├── .gitignore ├── .travis.yml ├── Kona.png ├── LICENSE ├── Makefile ├── README.md ├── bench ├── apl.k ├── inc.k ├── sum.k └── tak.k ├── misc ├── audit_use ├── audit_use_process_log ├── audit_use_uses └── audit_use_using ├── src ├── 0.c ├── 0.h ├── bswap.c ├── bswap.h ├── c.c ├── c.h ├── ckapi.txt ├── d.c ├── d.h ├── getline.c ├── getline.h ├── getline_android.c ├── incs.h ├── k-mode.el ├── k.c ├── k.h ├── kapi-test.c ├── kapi.c ├── kc.c ├── kc.h ├── kg.c ├── kg.h ├── km.c ├── km.h ├── kn.c ├── kn.h ├── ko.c ├── ko.h ├── kona.h ├── ks.c ├── ks.h ├── kx.c ├── kx.h ├── main.c ├── mt.c ├── mt.h ├── p.c ├── p.h ├── r.c ├── r.h ├── scalar.h ├── tests.c ├── tests.h ├── ts.h ├── v.c ├── v.h ├── va.c ├── va.h ├── vc.c ├── vc.h ├── vd.c ├── vd.h ├── vf.c ├── vf.h ├── vg.c ├── vg.h ├── vq.c ├── vq.h └── win │ ├── ansidecl.h │ ├── dlfcn.c │ ├── dlfcn.h │ ├── fnmatch.c │ ├── fnmatch.h │ ├── mman.c │ ├── mman.h │ ├── pread.c │ ├── safe-ctype.c │ ├── safe-ctype.h │ └── usleep.c └── verb ├── vt_dyad.c ├── vt_monad.c └── vtab.h /.gitignore: -------------------------------------------------------------------------------- 1 | a.out 2 | kbuild.h 3 | k 4 | k_test 5 | kona 6 | kona_test 7 | *.[oa] 8 | *.exe 9 | *.*~ 10 | *~ 11 | TAGS 12 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: cpp 2 | 3 | sudo: false 4 | 5 | compiler: 6 | - gcc 7 | - clang 8 | 9 | os: 10 | - linux 11 | - osx 12 | 13 | script: make 14 | 15 | after_script: echo '\\' | ./k_test 16 | -------------------------------------------------------------------------------- /Kona.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kevinlawler/kona/ac4e4c515faf586520454c266619ce1fea650554/Kona.png -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | ISC License 2 | 3 | Copyright (c) 2009-2015, Kevin Lawler 4 | 5 | Permission to use, copy, modify, and/or distribute this software for any 6 | purpose with or without fee is hereby granted, provided that the above 7 | copyright notice and this permission notice appear in all copies. 8 | 9 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PREFIX = /usr/local 2 | CFLAGS=-g 3 | PRODFLAGS = -O3 #-pg -g3 4 | LIB=libkona.a 5 | DEVFLAGS = -O0 -g3 -DDEBUG -Wall 6 | 7 | OS := $(shell uname -s | tr "[:upper:]" "[:lower:]") 8 | $(info OS="$(OS)") 9 | 10 | # Win-64 11 | ifeq (mingw64_nt-10.0-22000,$(OS)) 12 | CC=gcc -DWIN32=1 13 | PRODFLAGS += -D_FILE_OFFSET_BITS=64 14 | LDFLAGS = -lws2_32 -static -lpthread 15 | OBJS= src/win/mman.o src/win/dlfcn.o src/win/safe-ctype.o src/win/fnmatch.o \ 16 | src/win/pread.o src/win/usleep.o \ 17 | src/0.o src/bswap.o src/c.o src/getline.o src/mt.o src/p.o \ 18 | src/r.o src/k.o src/kc.o src/kx.o src/kg.o src/km.o src/kn.o src/ko.o \ 19 | src/ks.o src/v.o src/va.o src/vc.o src/vd.o src/vf.o src/vg.o src/vq.o 20 | endif 21 | 22 | # Win-32 23 | ifeq (mingw32_nt-10.0,$(OS)) 24 | CC=gcc -DWIN32=1 25 | LDFLAGS = -lws2_32 -static -lpthread 26 | OBJS= src/win/mman.o src/win/dlfcn.o src/win/safe-ctype.o src/win/fnmatch.o \ 27 | src/win/pread.o src/win/usleep.o \ 28 | src/0.o src/bswap.o src/c.o src/getline.o src/mt.o src/p.o \ 29 | src/r.o src/k.o src/kc.o src/kx.o src/kg.o src/km.o src/kn.o src/ko.o \ 30 | src/ks.o src/v.o src/va.o src/vc.o src/vd.o src/vf.o src/vg.o src/vq.o 31 | endif 32 | 33 | ifeq (android,$(OS)) 34 | CC=arm-linux-androideabi-gcc 35 | OBJS= src/0.o src/bswap.o src/c.o src/getline.o src/getline_android.o src/mt.o src/p.o \ 36 | src/r.o src/k.o src/kc.o src/kx.o src/kg.o src/km.o src/kn.o src/ko.o \ 37 | src/ks.o src/v.o src/va.o src/vc.o src/vd.o src/vf.o src/vg.o src/vq.o 38 | LDFLAGS = -Wl,--gc-sections -Wl,-z,nocopyreloc -lgcc -no-canonical-prefixes \ 39 | -Wl,--no-undefined -Wl,-z,noexecstack -Wl,-z,relro -Wl,-z,now -mthumb \ 40 | -lc -lm -ldl 41 | CFLAGS += -fPIE -fpic -ffunction-sections -funwind-tables -fstack-protector \ 42 | -no-canonical-prefixes -mtune=xscale -msoft-float -mthumb \ 43 | -fomit-frame-pointer -fno-strict-aliasing 44 | endif 45 | 46 | ifeq (linux,$(OS)) 47 | CFLAGS += -pthread 48 | OBJS= src/0.o src/bswap.o src/c.o src/getline.o src/mt.o src/p.o src/r.o \ 49 | src/k.o src/kc.o src/kx.o src/kg.o src/km.o src/kn.o src/ko.o src/ks.o \ 50 | src/v.o src/va.o src/vc.o src/vd.o src/vf.o src/vg.o src/vq.o 51 | LDFLAGS = -lm -ldl 52 | endif 53 | 54 | ifeq (freebsd,$(OS)) 55 | CFLAGS += -pthread 56 | LDFLAGS = -lm 57 | OBJS= src/0.o src/bswap.o src/c.o src/getline.o src/mt.o src/p.o src/r.o \ 58 | src/k.o src/kc.o src/kx.o src/kg.o src/km.o src/kn.o src/ko.o src/ks.o \ 59 | src/v.o src/va.o src/vc.o src/vd.o src/vf.o src/vg.o src/vq.o 60 | endif 61 | 62 | ifeq (openbsd,$(OS)) 63 | CFLAGS += -pthread 64 | LDFLAGS = -lm 65 | OBJS= src/0.o src/bswap.o src/c.o src/getline.o src/mt.o src/p.o src/r.o \ 66 | src/k.o src/kc.o src/kx.o src/kg.o src/km.o src/kn.o src/ko.o src/ks.o \ 67 | src/v.o src/va.o src/vc.o src/vd.o src/vf.o src/vg.o src/vq.o 68 | endif 69 | 70 | ifeq (netbsd,$(OS)) 71 | CFLAGS += -pthread 72 | LDFLAGS = -lm 73 | OBJS= src/0.o src/bswap.o src/c.o src/getline.o src/mt.o src/p.o src/r.o \ 74 | src/k.o src/kc.o src/kx.o src/kg.o src/km.o src/kn.o src/ko.o src/ks.o \ 75 | src/v.o src/va.o src/vc.o src/vd.o src/vf.o src/vg.o src/vq.o 76 | endif 77 | 78 | ifeq (darwin,$(OS)) 79 | LDFLAGS = -lm 80 | OBJS= src/0.o src/bswap.o src/c.o src/getline.o src/mt.o src/p.o src/r.o \ 81 | src/k.o src/kc.o src/kx.o src/kg.o src/km.o src/kn.o src/ko.o src/ks.o \ 82 | src/v.o src/va.o src/vc.o src/vd.o src/vf.o src/vg.o src/vq.o 83 | PRODFLAGS = -O3 84 | endif 85 | 86 | ifeq (cygwin_nt-6.3,$(OS)) 87 | OBJS= src/0.o src/bswap.o src/c.o src/getline.o src/mt.o src/p.o src/r.o \ 88 | src/k.o src/kc.o src/kx.o src/kg.o src/km.o src/kn.o src/ko.o src/ks.o \ 89 | src/v.o src/va.o src/vc.o src/vd.o src/vf.o src/vg.o src/vq.o 90 | LDFLAGS = -lm 91 | endif 92 | 93 | ifeq (sunos,$(OS)) 94 | LDFLAGS += -lsocket 95 | PRODFLAGS += -fast 96 | endif 97 | 98 | ifeq (haiku,$(OS)) 99 | OBJS= src/0.o src/bswap.o src/c.o src/getline.o src/mt.o src/p.o src/r.o \ 100 | src/k.o src/kc.o src/kx.o src/kg.o src/km.o src/kn.o src/ko.o src/ks.o \ 101 | src/v.o src/va.o src/vc.o src/vd.o src/vf.o src/vg.o src/vq.o 102 | LDFLAGS = -lm -lnetwork 103 | endif 104 | 105 | # k_test versions of OBJS 106 | OBJS_T= $(shell echo ${OBJS} | sed -e "s/\.o/.t.o/g") 107 | 108 | all: k k_test 109 | 110 | lib: $(LIB) 111 | 112 | $(LIB): $(OBJS) src/kapi.o 113 | $(AR) crv $@ $(OBJS) src/kapi.o 114 | 115 | kapi-test: src/kapi-test.o $(LIB) 116 | $(CC) ${CFLAGS} $^ -o $@ -L. -lkona $(LDFLAGS) 117 | 118 | k: CFLAGS += $(PRODFLAGS) 119 | k: src/kbuild.h $(OBJS) src/main.o 120 | $(CC) ${CFLAGS} $(OBJS) src/main.o -o $@ $(LDFLAGS) 121 | 122 | k_test: CFLAGS += $(DEVFLAGS) 123 | k_test: src/kbuild.h $(OBJS_T) src/main.t.o src/tests.t.o 124 | $(CC) ${CFLAGS} $(OBJS_T) src/main.t.o src/tests.t.o -o $@ $(LDFLAGS) 125 | 126 | k_dyn: CFLAGS += $(PRODFLAGS) 127 | k_dyn: src/kbuild.h $(OBJS) 128 | $(CC) ${CFLAGS} $(OBJS) -rdynamic -o $@ $(LDFLAGS) 129 | 130 | DATE_FMT = +%Y-%m-%d 131 | ifdef SOURCE_DATE_EPOCH 132 | BUILD_DATE := $(shell date -u -d "@$(SOURCE_DATE_EPOCH)" "$(DATE_FMT)" 2>/dev/null || date -u -r "$(SOURCE_DATE_EPOCH)" "$(DATE_FMT)" 2>/dev/null || date -u "$(DATE_FMT)") 133 | else 134 | BUILD_DATE := $(shell date "$(DATE_FMT)") 135 | endif 136 | 137 | src/kbuild.h: 138 | echo "#define KBUILD_DATE \"$(BUILD_DATE)\"" >$@ 139 | 140 | test: k_test 141 | 142 | install: 143 | install k $(PREFIX)/bin/k 144 | 145 | clean: 146 | $(RM) -r k k_test *.exe k.dSYM k_test.dSYM src/*.o src/win/*.o src/kbuild.h 147 | 148 | TAGS: *.c *.h 149 | etags *.[ch] 150 | 151 | %.t.o: %.c 152 | $(CC) $(CFLAGS) -c $(CPPFLAGS) -o $@ $< 153 | 154 | .PHONY: all clean install android-debug 155 | 156 | # Dependencies. 157 | ifeq (mingw64_nt-10.0,$(OS)) 158 | src/win/dlfcn.c: src/win/dlfcn.h 159 | src/win/mman.c: src/win/mman.h 160 | src/win/safe-ctype.c: src/win/safe-ctype.h 161 | src/win/fnmatch.c: src/win/fnmatch.h src/win/safe-ctype.h src/win/ansidecl.h 162 | src/*.o: src/incs.h src/ts.h Makefile src/k.h src/win/mman.h src/win/dlfcn.h 163 | endif 164 | 165 | ifeq (mingw32_nt-10.0,$(OS)) 166 | src/win/dlfcn.c: src/win/dlfcn.h 167 | src/win/mman.c: src/win/mman.h 168 | src/win/safe-ctype.c: src/win/safe-ctype.h 169 | src/sin/fnmatch.c: src/win/fnmatch.h src/win/safe-ctype.h src/win/ansidecl.h 170 | src/*.o: src/incs.h src/ts.h Makefile src/k.h src/win/mman.h src/win/dlfcn.h 171 | endif 172 | 173 | ifeq (linux,$(OS)) 174 | src/*.o: src/incs.h src/ts.h Makefile src/k.h 175 | endif 176 | 177 | ifeq (freebsd,$(OS)) 178 | src/*.o: src/incs.h src/ts.h Makefile src/k.h 179 | endif 180 | 181 | ifeq (openbsd,$(OS)) 182 | src/*.o: src/incs.h src/ts.h Makefile src/k.h 183 | endif 184 | 185 | ifeq (netbsd,$(OS)) 186 | src/*.o: src/incs.h src/ts.h Makefile src/k.h 187 | endif 188 | 189 | ifeq (darwin,$(OS)) 190 | src/*.o: src/incs.h src/ts.h Makefile src/k.h 191 | endif 192 | 193 | ifeq (sunos,$(OS)) 194 | src/*.o: src/incs.h src/ts.h Makefile src/k.h 195 | endif 196 | 197 | ifeq (haiku,$(OS)) 198 | src/*.o: src/incs.h src/ts.h Makefile src/k.h 199 | endif 200 | 201 | src/0.c: src/0.h src/km.h src/v.h src/vf.h 202 | src/c.c: src/c.h 203 | src/getline.c: src/0.h src/getline.h 204 | src/k.c: src/r.h src/kc.h src/kx.h src/kg.h src/km.h src/kn.h src/ko.h src/ks.h \ 205 | src/tests.h src/v.h src/va.h src/vc.h src/vd.h src/vf.h src/vg.h src/vq.h 206 | src/kc.c: src/kc.h 207 | src/kx.c: src/kx.h src/km.h 208 | src/kg.c: src/kg.h src/km.h 209 | src/km.c: src/km.h 210 | src/kn.c: src/kn.h 211 | src/ko.c: src/km.h src/ko.h 212 | src/ks.c: src/ks.h 213 | src/p.c: src/km.h src/p.h src/v.h src/vf.h 214 | src/r.c: src/r.h src/va.h src/vf.h src/vg.h 215 | src/tests.c: src/tests.h 216 | src/v.c: src/scalar.h src/km.h src/0.h src/v.h 217 | src/va.c: src/scalar.h src/r.h src/vc.h 218 | src/vc.c: src/scalar.h src/km.h src/ko.h src/vc.h 219 | src/vd.c: src/km.h src/p.h src/r.h src/v.h src/vd.h 220 | src/vf.c: src/km.h src/vf.h 221 | src/vg.c: src/kg.h src/km.h src/vg.h src/vc.h 222 | src/vq.c: src/r.h src/v.h src/vq.h 223 | src/kapi.c: src/kona.h 224 | 225 | # DO NOT DELETE 226 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # [Kona](http://kona.github.io/) [![Build Status](https://travis-ci.org/kevinlawler/kona.svg?branch=master)](https://travis-ci.org/kevinlawler/kona) 2 | 3 | ![Kona](https://raw.githubusercontent.com/kevinlawler/kona/master/Kona.png) 4 | 5 | What is Kona? 6 | ------------- 7 | 8 | Kona is the open-source implementation of the k3 programming language. k is a synthesis of APL and LISP. Although many of the capabilities come from APL, the fundamental data construct is quite different. In APL the construct is a multi-dimensional matrix-like array, where the dimension of the array can range from 0 to some maximum (often 9). In k, like LISP, the fundamental data construct is a list. Also, like LISP, the k language is ASCII-based, so you don't need a special keyboard. 9 | 10 | For many people, k was the preferred APL dialect. When it was available, it tended to be popular with investment bankers, the performance obsessed, and analysts dealing with lots of data. It is a demanding language. 11 | 12 | k was originally designed by Arthur Whitney and [Kx Systems](http://kx.com/). Praise for k should be taken to refer to Kx's k. Kx sells a popular database called KDB+. People can and do create networked trading platforms in hours. If your business needs production support, you can [evaluate KDB+ prior to purchasing from Kx](http://kx.com/software-download.php), or possibly speak with Kx consulting partner [First Derivatives](http://www.firstderivatives.com/). The 32-bit version of KDB+ is available for free. 13 | 14 | Kx's KDB+ uses the Q language, and is built on top of k4. Kx used to sell a database called KDB, which used the KSQL language, and was built on top of k3. Earlier, Kx sold k2 as its primary product. Before k2, UBS had a 5-year exclusive license to k1. To the confusion of all, these terms are used interchangeably. Kx's k3, k2 and k1 are basically no longer available. While you get k4 with KDB+, k4 is proprietary to Kx and no documentation is available. Kona is a reimplementation that targets k3 (which stopped being available about 20 years ago). Kona is unaffiliated with Kx. 15 | 16 | To get perspective on the various incarnations see https://ngn.bitbucket.io/k.html 17 | 18 | A note on the unusual style of C code: It attempts to replicate the style of Arthur Whitney. A striking original example is contained in file https://github.com/tavmem/buddy/blob/master/a/b.c. There are 2 versions of the buddy memory allocation system. The first is in 11 lines written by Whitney. The second is in well documented traditional C (almost 750 lines). 19 | 20 | Mailing Lists 21 | ------------- 22 | [kona-user](https://groups.google.com/forum/#!forum/kona-user) is about using the Kona programming language. 23 | 24 | [kona-dev](https://groups.google.com/forum/#!forum/kona-dev) is about developing the Kona language itself. 25 | 26 | Installation 27 | ------------ 28 | 29 | **Windows** 30 | 31 | You can find an executable version of Kona [here](https://github.com/kevinlawler/kona/releases). 32 | Download k.exe. Use Windows "Explorer" to move k.exe from the "Download" directory to another directory ... or not. Double click on k.exe in "Explorer" to start a Kona session. Alternatively, start a "cmd" console window, navigate to the directory containing k.exe, and key in "k". 33 | 34 | **macOS** 35 | 36 | If you have [Homebrew](https://brew.sh) installed, you can install Kona using `brew`: 37 | 38 | brew install kona 39 | 40 | **Build from source** 41 | 42 | For macOS, Linux, BSD, Cygwin and Android: 43 | Navigate to the directory you want to install Kona, then type: 44 | 45 | git clone https://github.com/kevinlawler/kona.git 46 | cd kona 47 | make #gmake on BSD 48 | 49 | Then, while in the "kona" directory, run: 50 | 51 | ./k #./k_test to run the test suite 52 | 53 | Android builds are similar, but you must set use this command when running `make`: 54 | 55 | make OS=android 56 | 57 | For Windows: 58 | Pretty much the same process, but you will need MinGW-w64 (Mingw-builds project package), and you will need MSYS (or MSYS2) for bash. You can start up Kona from MSYS, or from a native Windows "cmd" session. In MSYS, type "./k" or just type "k" when in the "kona" directory. When in "cmd" just type "k" as "./k" won't work. You can also double-click on k.exe from Windows Explorer. 59 | 60 | **Input Issues** 61 | 62 | If you experience input issues with the command-line interpreter, such as visible arrow keys, try the `rlwrap` utility and see if it solves your problem. 63 | 64 | Further Information 65 | ------------------- 66 | 67 | 68 | You can find further information about Kona at [the wiki](https://github.com/kevinlawler/kona/wiki). 69 | -------------------------------------------------------------------------------- /bench/apl.k: -------------------------------------------------------------------------------- 1 | / some classic APL benchmarks, from 2 | / 'Dyalog APL Arrives in the US' by Gregg Taylor 3 | / translated by isawdrones 4 | 5 | `0: "Generating test data...\n\n" 6 | 7 | / in paper, these values are used: 8 | / vs: 1000 9 | / pms: 50 100 10 | 11 | / more realistic values for modern hardware: 12 | vs: 10000 13 | ms: 500 10000 14 | 15 | cm: ms#cv: " ABCDEFGHIJ"@,/1?'vs#11 16 | im: ms#iv: ,/1?'vs#500 17 | fm: ms#fv: iv+0.01*1!iv 18 | bm: ms#bv: ,/1?'vs#2 19 | 20 | tests: (("int add\t" ; 20; "im+im+im+im+im") 21 | ("fp add\t" ; 20; "fm+fm+fm+fm+fm") 22 | ("int mult" ; 20; "im*im*im*im*im") 23 | ("fp mult\t" ; 20; "fm*fm*fm*fm*fm") 24 | ("index\t" ; 25; "(!#bv)@&bv" ) 25 | ("char compr" ; 20; "cv@&bv" ) 26 | ("int compr" ; 20; "iv@&bv" ) 27 | ("int + red" ; 20; "+/iv" ) 28 | ("int | red" ; 20; "|/iv" ) 29 | ("bool scan" ; 10; "(~=)\\bm" ) 30 | ("mat rotate" ; 10; "(!500)!\\:cm" ) 31 | ("char trans" ; 10; "+cm" ) 32 | ("int trans" ; 10; "+im" ) 33 | ("vec of vecs"; 20; ",:'cm" ) 34 | ("partition" ; 20; "aa:(&bv)_ cv" ) 35 | ("shape each" ; 20; "^:'aa" ) 36 | ("vec compar" ; 20; "&/cv=cv" ) 37 | ("int sort" ; 20; "iv@x;z 12 | _f[_f[x-1;y;z] 13 | _f[y-1;z;x] 14 | _f[z-1;x;y]]]} 15 | 16 | / tak[18;12;6] 17 | / TODO: \t 10000 tak[18;12]/6 18 | 19 | / FIXME: type error 20 | -------------------------------------------------------------------------------- /misc/audit_use: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | ls -1 *.h | sed -e "s/\.h//" | xargs -n1 misc/audit_use_uses 4 | -------------------------------------------------------------------------------- /misc/audit_use_process_log: -------------------------------------------------------------------------------- 1 | #!/usr/bin/awk -f 2 | 3 | { 4 | H = $1 5 | sub("\\.h", "", H) 6 | found = 0 7 | for (i=4; i<=NF; i++) { 8 | if ($i == (H ".c")) { found = 1; break; } 9 | } 10 | if (found == 0) printf("irrelevant: %s in %s\n", $2, $1) 11 | } 12 | 13 | NF == 3 { 14 | print("unused:", $0) 15 | } 16 | 17 | NF == 4 { 18 | H = $1 19 | C = $4 20 | sub("\\.h", "", H) 21 | sub("\\.c", "", C) 22 | if (H == C) 23 | print("private:", $0) 24 | else 25 | print("nonexistent:", $0) 26 | } 27 | -------------------------------------------------------------------------------- /misc/audit_use_uses: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | HEADER=$1 4 | awk ' 5 | # skip non-function defs 6 | /^#/ { next; } 7 | /^ / { next; } 8 | /^$/ { next; } 9 | /^\// { next; } 10 | /^extern/ { next; } 11 | /^typedef/ { next; } 12 | /^enum/ { next; } 13 | 14 | # print every function name 15 | { 16 | sub("\\*", ""); 17 | sub("\\(.*", ""); 18 | 19 | # delete prefix _ for e.g. _acos in r.c 20 | sub("^_", "", $2); 21 | print $2 22 | } 23 | ' $HEADER.h | 24 | xargs -n 1 -J _ misc/audit_use_using ${HEADER} _ 25 | -------------------------------------------------------------------------------- /misc/audit_use_using: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | FUNC_NAME=$2 4 | 5 | grep -l ${FUNC_NAME} *.c | 6 | env HEADER=$1 FUNC=$2 awk ' 7 | BEGIN { 8 | header = ENVIRON["HEADER"] 9 | func_name = ENVIRON["FUNC"] 10 | } 11 | { f[ct++] = $1 } 12 | END { 13 | printf("%s.h %s : ", header, func_name); 14 | for (i=0; i 4 | #include 5 | 6 | #include "bswap.h" 7 | 8 | #if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) 9 | #include 10 | #endif 11 | 12 | #if defined(__linux__) && defined(__GNUC__) 13 | #include 14 | #define bswap32 __bswap_32 15 | #define bswap64 __bswap_64 16 | #endif 17 | 18 | #ifdef _MSC_VER 19 | #include 20 | #define bswap32 _byteswap_ulong 21 | #define bswap64 _byteswap_uint64 22 | #endif 23 | 24 | #ifdef __APPLE__ 25 | #include 26 | #define bswap32 _OSSwapInt32 27 | #define bswap64 _OSSwapInt64 28 | #endif 29 | 30 | #ifndef bswap32 31 | uint32_t bswap32(uint32_t n) 32 | { 33 | UC d[4]; 34 | 35 | memcpy(d,&n,4); 36 | R ((uint32_t)(d[0])<<24)+((uint32_t)(d[1])<<16)+ 37 | ((uint32_t)(d[2])<< 8)+ (uint32_t)(d[3]); 38 | } 39 | 40 | uint64_t bswap64(uint64_t n) 41 | { 42 | UC d[8]; 43 | 44 | memcpy(d,&n,8); 45 | R ((uint64_t)(d[0])<<56)+((uint64_t)(d[1])<<48)+ 46 | ((uint64_t)(d[2])<<40)+((uint64_t)(d[3])<<32)+ 47 | ((uint64_t)(d[4])<<24)+((uint64_t)(d[5])<<16)+ 48 | ((uint64_t)(d[6])<< 8)+ (uint64_t)(d[7]); 49 | } 50 | #endif 51 | 52 | V membswp32(V d,V s,I n) 53 | { 54 | uint32_t *q=d,*p=s; 55 | I i; 56 | for(i=0;iC API 2 | 3 | Bakul Shah 4 | May 25, 2013 5 | 6 | 7 | Introduction 8 | ------------ 9 | Use of this API allows you to mix kona and C code. There are 10 | two uses for this API: 11 | 12 | a) when the kona library is linked with some C code to make a 13 | standalone application that can use K as an embedded language. 14 | b) when a C library is to be used from K code, either from 15 | a K script or standalone. 16 | 17 | In either case you can have C code calling K code calling C 18 | code etc. Attention must be paid to how Kona does reference 19 | counting to ensure that objects don't get released before 20 | their use has been finished or they stick around after their 21 | use is finished. In the first case the application will crash. 22 | In the second case the application may get a memory leak and 23 | over time run out of memory. 24 | 25 | 26 | Glossary 27 | -------- 28 | 29 | atom a scalar K object 30 | list a K list 31 | object an atom or list 32 | 33 | These may be preceded with type name to indicate a specific 34 | typed object. For example an integer object is either an 35 | integer atom or an integer list. 36 | 37 | 38 | Usage 39 | ----- 40 | 41 | C code using this API must include kona.h. 42 | 43 | a) Using K as an embedded language: link with the kona library 44 | with -lkona. If necessary, set -L to the directory where 45 | libkona.a resides. For example 46 | 47 | cc -I/usr/local/include mycode.c -L/usr/local/lib -lkona 48 | 49 | The API must be initialized by calling ksk("", 0) and ensuring 50 | it doesn't return an errror. 51 | 52 | b) Calling C code from K: Compile the C code as a shared library 53 | and then load it using the 2: function. For example, if the 54 | C code contains 55 | 56 | K bar(K num, K ints, K syms) { ... } 57 | 58 | Then to access this function from K one can do use 59 | the following in K code: 60 | 61 | foo:"mylib" 2: ("bar", 3) 62 | 63 | x:foo[1;2 3 4;`a`b`c] 64 | 65 | 66 | Types 67 | ------ 68 | 69 | In C, typedef K represents a k object. It is a pointer to a 70 | struct containing the following fields + content specific data: 71 | 72 | c ref count 73 | n number of items 74 | t type of the object 75 | 76 | These can be directly accessed from C code but should never be 77 | directly modified. Object content should only be accessed 78 | or modified through macros described below. 79 | 80 | A k object can be of the following types (the first column 81 | shows the value in t field). 82 | 83 | value Name 84 | -4 symbol list 85 | -3 char list 86 | -2 float list 87 | -1 integer list 88 | 0 general list 89 | 1 integer 90 | 2 float 91 | 3 char 92 | 4 symbol 93 | 5 dictionary 94 | 6 null 95 | 7 procedure 96 | 97 | The following C types are used in the construction of K 98 | objects. 99 | 100 | Type typedef C-type 101 | integer I long long int 102 | float F double 103 | char C char 104 | symbol S C* 105 | ptr V void* 106 | 107 | Support functions 108 | ----------------- 109 | 110 | S sp(S) 111 | Intern a given string. The same S value is returned as 112 | long as the argument to sp is the same string. 113 | 114 | Example: 115 | char x[4] = {'f','o','o', 0}; 116 | sp("foo") == sp(x) 117 | 118 | Accessor functions 119 | ------------------ 120 | 121 | Atoms 122 | 123 | C Kc(K) 124 | F Kf(K) 125 | I Ki(K) 126 | S Ks(K) 127 | Kc() returns a reference to a char, Kf() to a float, Ki to 128 | an int and Ks() to a symbol. They can be used to read or 129 | write the value. 130 | 131 | Examples: 132 | If objects c, f, i, s are existing atoms of type char, 133 | float, integer and symbol, then 134 | 135 | Kc(c) == 'A' 136 | Kf(f) = 1.2 137 | Ki(i) = 12 138 | Ks(s) = sp("abc"); // asign interned "abc" 139 | 140 | Lists 141 | 142 | C* KC(K) 143 | F* KF(K) 144 | I* KI(K) 145 | S* KS(K) 146 | KC() returns ptr to an array of chars, KF() an array of floats, 147 | KI() an array of integers, KS() an array of symbols. 148 | 149 | Examples: 150 | If objects c, f, i, s are existing lists of type char, 151 | float, integer and symbol, then 152 | 153 | KC(c)[0] == 'A' 154 | KF(f)[0] = 1.2 155 | KI(i)[0] = 12 156 | KS(s)[0] = sp("abc"); // asign interned "abc" 157 | 158 | K KK(K) 159 | KK() takes a general list and retuns a ptr to an array of 160 | objects. 161 | 162 | 163 | Generator functions 164 | ------------------- 165 | 166 | These functions return new objects. The returned value has a 167 | ref count of 1. These objects may be passed to K functions, 168 | stored in K or C data structures etc. 169 | 170 | Atoms 171 | 172 | K gc(C) 173 | K gf(F) 174 | K gi(I) 175 | K gs(S) 176 | K gn() 177 | gc() creates an atom from a char, gf() from a float, gi() 178 | from an integer, gs() from an interned string and gn() creates 179 | a null atom. 180 | 181 | Examples: 182 | K x = gc('A'); 183 | K y = gf(1.2); 184 | K z = gi(12); 185 | K w = gs(sp("abc")); // NB: the string must be interned with sp() 186 | K ls = gnk(4,x,y,z,w); 187 | 188 | Lists 189 | 190 | K gp(S) 191 | K gpn(S,I n) 192 | gs() creates a char list from a C string. gpn() creates a 193 | char list from the first n chars of a C string. 194 | 195 | Example: 196 | K s1 = gp("foo"); 197 | K s2 = gpn("food", 3); 198 | strncmp(KC(s1), KC(s2), 3) == 0 199 | 200 | K gtn(I t,I n) 201 | Create a list of type t and allocate space for n elements. 202 | These elements must be separately initialized with values 203 | appropriate to the type. t is in [-4 .. 0]. 204 | 205 | Example: 206 | K i = gtn(-1,2); // list of 2 ints; 207 | KI(i)[0] = 11; 208 | KI(i)[1] = 22; 209 | 210 | K gnk(I n,...) 211 | Create a general list of N elements from a variable list 212 | of objects 213 | 214 | Example: 215 | K x = gnk(5, gc('A'), gf(1.2), gi(333), gp("foo"), gs(sp("bar"))); 216 | Will yield K object ('A'; 1.2; 333; "foo", `bar) 217 | 218 | 219 | K gsk(S s, K k) 220 | Generate a triple: symbol from s, value k, attribute 221 | (none). Used for building dictionaries. 222 | 223 | Dictionaries can be generated with gtn(5, n) and may be 224 | treated as general list. They may be extended using kap 225 | with a list of triples. 226 | 227 | Example: 228 | K d = gtn(5,1); 229 | K t = gsk("foo", gi(12)); 230 | 231 | KK(d)[0] = gsk("foo", gi(12)); 232 | kap(&d, gsk("bar", gf(1.23))); 233 | 234 | K kap(K*x, V y) 235 | Append item y to list x. The actual type of y depends on 236 | the list type of x. Returns x if the append was 237 | successful. 238 | 239 | Refernce counts 240 | --------------- 241 | I cd(K) 242 | decrement reference count. When the C code doesn't need 243 | the k object any more, it must use cd() to allow freeing 244 | up memory. 245 | 246 | K ci(K) 247 | increment reference count. When the C code is handed a 248 | k object that it wants to save, it should use ci(). 249 | 250 | K from C 251 | -------- 252 | K ksk(S e, K a) [NYI] 253 | execute string e. Any arguments are provided in a. If e 254 | takes n arguments, a must be general list of n values. 255 | Return the result object or a null with error string 256 | as its content. 257 | 258 | Example: 259 | K ints = ksk("{!x}",gnk(1,gi(10))); 260 | 261 | C from K 262 | -------- 263 | 264 | K sfn(S s,(K(*f)(),I n) [NYI] 265 | Register a C function f to be called from K with the name 266 | s. It should take n arguments. Returns the function object. 267 | 268 | Example: 269 | K average(K a, K b) { return gi(Ki(a)+Ki(b)); } 270 | sfn("avg", (K(*)())average,2); 271 | 272 | sdf(I s,I(*fn)()) [NYI] 273 | Register a callback function for the given socket s. The 274 | first arg when positive records an accept callback. When 275 | negative records a read callback. These functions are 276 | called from k main loop. 277 | 278 | scd(I s) [NYI] 279 | Close the socket. This also tells the k main loop to 280 | stop looking for events on it. 281 | 282 | Conversions 283 | ----------- 284 | 285 | I dj(I j) 286 | given julian days return a date in the form yyyymmdd. 287 | julian day 0 maps to 20350101 288 | 289 | I jd(I d) 290 | given a date in the form yyyymmdd return julian days. 291 | 292 | 293 | Socket functions 294 | ---------------- 295 | 296 | General Notes 297 | ------------- 298 | 299 | When the C code finishes the use of a k object, 300 | -------------------------------------------------------------------------------- /src/d.c: -------------------------------------------------------------------------------- 1 | #include "d.h" 2 | 3 | K myadd (K x, K y){I a=*kI(x); I b=*kI(y); R Ki(a+b);} 4 | K f(K x,K y){R Ki(kI(x)[0]+ kI(y)[0]);} 5 | K g(K x){R Kf(kF(x)[0]+1);} 6 | K h(K a,K b,K c,K d,K e,K f,K g,K h){R Ki(123);} 7 | -------------------------------------------------------------------------------- /src/d.h: -------------------------------------------------------------------------------- 1 | //For libraries dynamically loaded by 2: dyadic 2 | #include 3 | typedef void* V; 4 | typedef long long I; 5 | typedef double F; 6 | typedef char C; 7 | typedef C* S; 8 | typedef unsigned char UC; 9 | typedef struct k0{I c,t,n;struct k0*k[1];}*K; 10 | #define ke(x) (((K)x)->k) 11 | #define kK(x) ((K*)ke(x)) 12 | #define kI(x) ((I*)ke(x)) 13 | #define kF(x) ((F*)ke(x)) 14 | #define kC(x) ((C*)ke(x)) 15 | #define kS(x) ((S*)ke(x)) 16 | #define O printf 17 | #define R return 18 | extern K Ki(I); 19 | extern K Kf(F); 20 | extern K newK(I t, I n); 21 | -------------------------------------------------------------------------------- /src/getline.c: -------------------------------------------------------------------------------- 1 | #include "incs.h" 2 | #include "0.h" 3 | #include "getline.h" 4 | 5 | //Based on BSD's getdelim.c - [BSD License] (c) 2009 David Schultz 6 | 7 | I expander(S *s, I n) //grow s? n - needs size 8 | { 9 | S t; I q; 10 | 11 | //XXX: these lines are deactivated since dlmalloc was removed. the q=n line bypasses (delete if reactivated) 12 | //this lightly assumes realloc is efficient (nlogn) for shrinking and appending (nice when true) 13 | //if(n <= malloc_usable_size(*s)) R 0; 14 | //q = rp2(n); 15 | q = n; 16 | // 17 | 18 | t = realloc(*s, MAX(1,q)); //if you want to mremap this still have to avoid malloc_useable_size above... actually, maybe better to not pass mmapped here 19 | if(!t){ME; R -1;} //mm/o - failed 20 | *s=t; 21 | R 0; 22 | } 23 | 24 | I appender(S *s, I *n, S t, I k) //concatenate t to s 25 | { 26 | if(expander(s,*n+k+1))R -1; //mm/o - failed 27 | memcpy(*s+*n,t,k); 28 | *n += k; 29 | (*s)[*n] = '\0'; 30 | R 0; 31 | } 32 | 33 | I getline_(S *s,I *n,FILE *f){R getdelim_(s,n,'\n',f);} 34 | 35 | I getdelim_(S *s,I *n,I d,FILE *f) 36 | { 37 | I m; S z;size_t o=*n; 38 | if(getdelim(s,&o,d,f)==-1){*n=0; R -1;} 39 | *n=o; 40 | m=strlenn(*s,*n); 41 | if(1_r <= 0 && __srefill(f)) 62 | { 63 | /* If f is at EOF already, we just need space for the NUL. */ 64 | if (__sferror(f) || expander(s, 1)) goto error; 65 | funlockfile(f); 66 | (*s)[0] = '\0'; 67 | R *n=-1; 68 | } 69 | 70 | while ((q = memchr(f->_p, d, f->_r)) == NULL) 71 | { 72 | if (appender(s, &w, (S) f->_p, f->_r)) goto error; 73 | if (__srefill(f)) 74 | { 75 | if (__sferror(f)) goto error; 76 | goto done; /* hit EOF */ 77 | } 78 | } 79 | q++; /* snarf the delimiter, too */ 80 | if (appender(s, &w, (S) f->_p, q - f->_p)) goto error; 81 | f->_r -= q - f->_p; 82 | f->_p = q; 83 | 84 | done: 85 | /* Invariant: *s has space for at least w+1 bytes. */ 86 | (*s)[w] = '\0'; 87 | funlockfile(f); 88 | R *n=w; 89 | 90 | error: 91 | f->_flags |= __SERR; 92 | funlockfile(f); 93 | R *n=-1; 94 | } 95 | #endif 96 | 97 | #ifdef WIN32 98 | size_t getline (S *s, size_t *n, FILE *f){ R getdelim(s,n,'\n',f);} 99 | size_t getdelim (S *s, size_t *n, int d, FILE *f){ //target, current capacity, delimiter, file 100 | #if 0 101 | // this code is MSVC runtime version specific 102 | char *q; I w=0; 103 | if (!s) {errno = EINVAL; goto error;} 104 | if (f->_cnt <= 0) { 105 | if (expander(s, 1)) goto error; 106 | (*s)[0] = '\0'; R *n=-1; 107 | } 108 | while ((q = memchr(f->_ptr, d, f->_cnt)) == NULL) { 109 | if (appender(s, &w, (S) f->_ptr, f->_cnt)) goto error; 110 | goto done; /* hit EOF */ 111 | } 112 | q++; /* snarf the delimiter, too */ 113 | if (appender(s, &w, (S) f->_ptr, q - f->_ptr)) goto error; 114 | f->_cnt -= q - f->_ptr; f->_ptr = q; 115 | #endif 116 | I w=0; 117 | if (!s) {errno = EINVAL; goto error;} 118 | for(;;) { 119 | C c=fgetc(f); 120 | if (EOF == c) R -1; 121 | if (appender(s, &w, (S)&c, 1)) goto error; 122 | if (d==c) break; 123 | } 124 | (*s)[w] = '\0'; R *n=w; 125 | error: R *n=-1; 126 | } 127 | #endif 128 | -------------------------------------------------------------------------------- /src/getline.h: -------------------------------------------------------------------------------- 1 | K _p(); 2 | S strdupn(S s,I k); 3 | I strlenn(S s,I k); 4 | I getdelim_(S *s,I *n,I d,FILE *f); 5 | I getline_(S *s,I *n,FILE *f); 6 | I appender(S *s,I *n,S t,I k); 7 | I expander(S *s,I n); 8 | 9 | #if defined(__MACH__) && __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1070 || \ 10 | defined(__ANDROID__) 11 | I getline(S *s,size_t * __restrict__ n,FILE *f); 12 | I getdelim(S *s,size_t * __restrict__ n,I d,FILE *f); 13 | #endif 14 | 15 | #if WIN32 16 | size_t getdelim (S *, size_t *, int, FILE *); 17 | #endif 18 | -------------------------------------------------------------------------------- /src/getline_android.c: -------------------------------------------------------------------------------- 1 | #include "incs.h" 2 | #include "0.h" 3 | #include "getline.h" 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | 12 | I getline(S *s,size_t*n, FILE *f){ R getdelim(s,n,'\n',f);} 13 | 14 | /* getdelim.c --- Implementation of replacement getdelim function. 15 | Copyright (C) 1994, 1996-1998, 2001, 2003, 2005-2012 Free Software 16 | Foundation, Inc. 17 | 18 | This program is free software; you can redistribute it and/or 19 | modify it under the terms of the GNU General Public License as 20 | published by the Free Software Foundation; either version 3, or (at 21 | your option) any later version. 22 | 23 | This program is distributed in the hope that it will be useful, but 24 | WITHOUT ANY WARRANTY; without even the implied warranty of 25 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 26 | General Public License for more details. 27 | 28 | You should have received a copy of the GNU General Public License 29 | along with this program; if not, see . */ 30 | 31 | /* Ported from glibc by Simon Josefsson. */ 32 | /* Slight modifications by Ryan Gonzalez. */ 33 | 34 | /* Don't use __attribute__ __nonnull__ in this compilation unit. Otherwise gcc 35 | optimizes away the lineptr == NULL || n == NULL || fp == NULL tests below. */ 36 | 37 | #ifndef SSIZE_MAX 38 | # define SSIZE_MAX ((ssize_t) (SIZE_MAX / 2)) 39 | #endif 40 | 41 | /* Read up to (and including) a DELIMITER from FP into *LINEPTR (and 42 | NUL-terminate it). *LINEPTR is a pointer returned from malloc (or 43 | NULL), pointing to *N characters of space. It is realloc'ed as 44 | necessary. Returns the number of characters read (not including 45 | the null terminator), or -1 on error or EOF. */ 46 | 47 | I getdelim (S *lineptr, size_t * __restrict__ n, I delimiter, FILE *fp) 48 | { 49 | ssize_t result; 50 | size_t cur_len = 0; 51 | 52 | if (lineptr == NULL || n == NULL || fp == NULL) 53 | { 54 | errno = EINVAL; 55 | return -1; 56 | } 57 | 58 | flockfile (fp); 59 | 60 | if (*lineptr == NULL || *n == 0) 61 | { 62 | char *new_lineptr; 63 | *n = 120; 64 | new_lineptr = (char *) realloc (*lineptr, *n); 65 | if (new_lineptr == NULL) 66 | { 67 | result = -1; 68 | goto unlock_return; 69 | } 70 | *lineptr = new_lineptr; 71 | } 72 | 73 | for (;;) 74 | { 75 | int i; 76 | 77 | i = getc(fp); 78 | if (i == EOF) 79 | { 80 | result = -1; 81 | break; 82 | } 83 | 84 | /* Make enough space for len+1 (for final NUL) bytes. */ 85 | if (cur_len + 1 >= *n) 86 | { 87 | size_t needed_max = 88 | SSIZE_MAX < SIZE_MAX ? (size_t) SSIZE_MAX + 1 : SIZE_MAX; 89 | size_t needed = 2 * *n + 1; /* Be generous. */ 90 | char *new_lineptr; 91 | 92 | if (needed_max < needed) 93 | needed = needed_max; 94 | if (cur_len + 1 >= needed) 95 | { 96 | result = -1; 97 | errno = EOVERFLOW; 98 | goto unlock_return; 99 | } 100 | 101 | new_lineptr = (char *) realloc (*lineptr, needed); 102 | if (new_lineptr == NULL) 103 | { 104 | result = -1; 105 | goto unlock_return; 106 | } 107 | 108 | *lineptr = new_lineptr; 109 | *n = needed; 110 | } 111 | 112 | (*lineptr)[cur_len] = i; 113 | cur_len++; 114 | 115 | if (i == delimiter) 116 | break; 117 | } 118 | (*lineptr)[cur_len] = '\0'; 119 | result = cur_len ? cur_len : result; 120 | 121 | unlock_return: 122 | funlockfile (fp); /* doesn't set errno */ 123 | 124 | R result; 125 | } 126 | -------------------------------------------------------------------------------- /src/incs.h: -------------------------------------------------------------------------------- 1 | #ifndef INCS_H 2 | #define INCS_H 3 | 4 | #ifdef WIN32 5 | #ifndef WIN32_LEAN_AND_MEAN 6 | #define WIN32_LEAN_AND_MEAN 7 | #endif 8 | #define _WIN32_WINNT 0x0501 9 | #include 10 | #include <_mingw.h> 11 | #include 12 | #include 13 | #include 14 | #include "win/dlfcn.h" 15 | #include "win/mman.h" //mmap 16 | #else 17 | #include 18 | #include 19 | #include 20 | #include //mmap 21 | #ifndef MAP_NORESERVE 22 | #define MAP_NORESERVE 0 23 | #endif 24 | #endif 25 | 26 | #include 27 | #include 28 | #include 29 | #include //M()/OOM_CD() 30 | #include 31 | #include 32 | #include 33 | #include 34 | #include 35 | #include 36 | 37 | #include //sbrk,sysconf 38 | #include //O_RDWR etc 39 | #define _TIMESPEC_DEFINED 40 | #include 41 | 42 | #include "ts.h" //data types + macros 43 | 44 | #define _exit __exit //stdlib.h already defines "_exit" but we need it for reserved r.c's _exit function 45 | 46 | extern I kreci; 47 | extern V krec[1000000]; 48 | extern K _ssr(K a,K b,K c); 49 | 50 | #endif 51 | -------------------------------------------------------------------------------- /src/k-mode.el: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; Copyright (c) 2011 Scott Vokes 3 | ;; 4 | ;; Permission to use, copy, modify, and/or distribute this software for any 5 | ;; purpose with or without fee is hereby granted, provided that the above 6 | ;; copyright notice and this permission notice appear in all copies. 7 | ;; 8 | ;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | ;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | ;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | ;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | ;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | ;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | ;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 16 | ;; 17 | ;; major-mode and a few utilities for working with kona (k). 18 | ;; Usage: 19 | ;; 20 | ;; (require 'k-mode) 21 | ;; 22 | ;; Bind switch-to-k to something convenient, e.g. 23 | ;; (global-set-key (kbd "C-c i k") 'switch-to-k) 24 | ;; and use that to start a connected k session. 25 | ;; 26 | ;; Use k-send (C-c C-e) to send the region (if any) or current line 27 | ;; or k-send-buffer (C-c C-b) to send blocks of code to it. 28 | ;; 29 | ;; TODO 30 | ;; * smart indentation 31 | ;; * syntax-table 32 | ;; * custom stuff? (I don't use it...) 33 | ;; 34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35 | 36 | (require 'comint) 37 | 38 | (defgroup k nil "K language editing mode." 39 | :group 'languages 40 | :prefix "k-") 41 | 42 | (defcustom k-program-name "k" "k executable name." 43 | :group 'k 44 | :type 'file) 45 | 46 | (defcustom k-prompt-string " " 47 | "String printed by interpreter to represent a ready prompt." 48 | :group 'k 49 | :type 'string) 50 | 51 | (defvar k-process nil "Current k comint process, if any.") 52 | 53 | (defvar k-mode-map 54 | (let ((m (make-sparse-keymap))) 55 | (define-key m (kbd "C-c C-e") 'k-send) ;eval region or line 56 | (define-key m (kbd "C-c C-z") 'switch-to-k) 57 | (define-key m (kbd "C-c C-b") 'k-send-buffer) 58 | ;(define-key m (kbd "C-c C-l") 'k-load-file) 59 | ;; (define-key m (kbd ")") 'k-electric-rparen) 60 | ;; (define-key m (kbd "]") 'k-electric-rbrace) 61 | ;; (define-key m (kbd "}") 'k-electric-rcurly) 62 | ;; (define-key m (kbd "\"") 'k-electric-quote) 63 | m) 64 | "Keymap for k mode.") 65 | 66 | 67 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 68 | ;; faces 69 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 70 | 71 | (defface k-normal-face 72 | '((t (:inherit nil))) 73 | "Font lock for text with no special highlighting.") 74 | 75 | (defface k-builtin-face 76 | '((t (:inherit font-lock-builtin-face))) 77 | "Font lock for builtins, such as _draw.") 78 | 79 | (defface k-number-face 80 | '((t (:inherit k-normal-face))) 81 | "Font lock for numbers.") 82 | 83 | (defface k-variable-face 84 | '((t (:inherit k-normal-face))) 85 | "Font lock for variables.") 86 | 87 | (defface k-variable-binding-face 88 | '((t (:inherit font-lock-variable-name-face))) 89 | "Font lock for variable bindings sites.") 90 | 91 | (defface k-verb-face 92 | '((t (:inherit k-normal-face))) 93 | "Font lock for verbs.") 94 | 95 | (defface k-string-face 96 | '((t (:inherit font-lock-string-face))) 97 | "Font lock for strings.") 98 | 99 | (defface k-symbol-face 100 | '((t (:inherit font-lock-constant-face))) 101 | "Font lock for symbols.") 102 | 103 | (defface k-adverb-face 104 | '((t (:weight bold :inherit font-lock-keyword-face))) 105 | "Font lock for adverbs.") 106 | 107 | (defface k-comment-delimeter-face 108 | '((t (:inherit font-lock-comment-delimeter-face))) 109 | "Font lock for comment marker.") 110 | 111 | (defface k-comment-face 112 | '((t (:inherit font-lock-comment-face))) 113 | "Font lock for comments.") 114 | 115 | (defface k-brace-face 116 | '((t (:inherit font-lock-function-name-face))) 117 | "Font lock for {}s.") 118 | 119 | (defface k-bracket-face 120 | '((t (:weight bold :inherit font-lock-normal-face))) 121 | "Font lock for []s.") 122 | 123 | 124 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 125 | ;; font-lock 126 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 127 | 128 | ;; FIXME: 129 | ;; * vars_with_underscores are highlighted wrong. 130 | ;; * other corner cases? 131 | 132 | (defun k-font-lock-keyword-maker () 133 | '(("^\\(/\\) \\([^\n]*\\)$" 134 | (1 'k-comment-delimeter-face) 135 | (2 'k-comment-face)) 136 | (" \\(/\\) \\([^\n]*\\)$" 137 | (1 'k-comment-delimeter-face) 138 | (2 'k-comment-face)) 139 | ("[/\\']:?" . 'k-adverb-face) 140 | ("`\"[^\"]*\"" . 'k-symbol-face) 141 | ("\"[^\"]*\"" . 'k-string-face) 142 | (";" . 'font-lock-keyword-face) 143 | ("_[a-zA-Z]+" . 'k-builtin-face) 144 | ("[a-zA-Z][a-zA-Z0-9]*:" . 'k-variable-binding-face) 145 | ("[a-zA-Z][a-zA-Z0-9]*" . 'k-variable-face) 146 | ("-?[0-9]+\\(\\.?[0-9]*\\)?\\([eE][+-]?[0-9]+\\)?" . 'k-number-face) 147 | ("\\(`\\)\\([a-zA-Z][a-zA-Z0-9_]*\\)" 148 | (1 'k-builtin-face) 149 | (2 'k-symbol-face)) 150 | ("[!#$%&*+,.;<=>?@^_|~-:]:?" . 'k-verb-face) 151 | ("[{}]" . 'k-brace-face) 152 | ("[][]" . 'k-bracket-face))) 153 | ; (setq k-font-lock-keywords (k-font-lock-keyword-maker)) 154 | 155 | (defvar k-font-lock-keywords 156 | (k-font-lock-keyword-maker) 157 | "Keyword highlighting specification for `k-mode'.") 158 | 159 | (defvar k-mode-hook nil "Hooks called when starting k-mode.") 160 | 161 | ;; (defvar k-mode-syntax-table 162 | ;; (let ((st (make-syntax-table))) 163 | ;; TODO 164 | ;; st)) 165 | 166 | 167 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 168 | ;; major-mode 169 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 170 | 171 | (define-derived-mode k-mode nil "k" 172 | "Major mode for k code. 173 | 174 | \\{k-mode-map} 175 | " 176 | ; :syntax-table k-mode-syntax-table 177 | (set (make-local-variable 'comment-start) "/ ") 178 | (set (make-local-variable 'comment-end) "") 179 | (use-local-map k-mode-map) 180 | (set (make-local-variable 'font-lock-defaults) '(k-font-lock-keywords))) 181 | 182 | (add-to-list 'auto-mode-alist '("\\.k$" . k-mode)) 183 | 184 | 185 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 186 | ;; comint 187 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 188 | 189 | (defun k-proc () 190 | "Get k process." 191 | (get-process k-program-name)) 192 | 193 | (defun k-proc-buffer () 194 | "Get k process's buffer." 195 | (get-buffer (concat "*" k-program-name "*"))) 196 | 197 | (defun k-proc-kill () 198 | "Kill the current K process, if any." 199 | (interactive) 200 | (let ((kp (k-proc))) 201 | (when kp (delete-process kp)))) 202 | 203 | (defun switch-to-k (uarg) 204 | "Switch to a k process, or spawn a new one if not running. 205 | Universal argument switches to it in another window." 206 | (interactive "P") 207 | (let* ((kproc (or (k-proc) 208 | (make-comint k-program-name k-program-name))) 209 | (kbuf (k-proc-buffer))) 210 | (when kbuf 211 | (with-current-buffer kbuf 212 | (add-hook 'comint-output-filter-functions 213 | 'k-comint-output-filter nil t)) 214 | (unless (equal (current-buffer) kbuf) 215 | (if uarg 216 | (switch-to-buffer-other-window kbuf) 217 | (switch-to-buffer kbuf)))) 218 | kproc)) 219 | 220 | (defun k-send-str (s) 221 | "Send string to the k process, if existing." 222 | ;; TODO: print comint result in minibuf? 223 | (let ((kproc (or (k-proc) (switch-to-k t))) 224 | (kbuf (k-proc-buffer))) 225 | (when (and kproc s) 226 | (comint-send-string kproc s)))) 227 | 228 | (defun k-buffer-is-visible () 229 | "Check if the k process buffer is currently visible." 230 | (let ((b (k-proc-buffer))) 231 | (when b 232 | (member b 233 | (mapcar (lambda (w) (window-buffer w)) 234 | (window-list)))))) 235 | 236 | (defun k-comint-output-filter (s) 237 | "Print output from code sent to k in the minibuffer." 238 | (unless (k-buffer-is-visible) 239 | (let ((drop (min (length s) 240 | (+ 1 (length k-prompt-string))))) 241 | (princ (substring s 0 (- drop)))))) 242 | 243 | (defun k-send-region (start end) 244 | "Send region to k process." 245 | (interactive "r") 246 | (let ((str (concat (buffer-substring start end) "\n"))) 247 | (k-send-str str))) 248 | 249 | (defun k-send-buffer () 250 | "Send whole buffer to k process." 251 | (interactive) 252 | (k-send-region (point-min) (point-max))) 253 | 254 | (defun k-send-line () 255 | "Send current line to k process." 256 | (interactive) 257 | (save-excursion 258 | (let ((bol (progn (beginning-of-line) (point))) 259 | (eol (progn (end-of-line) (point)))) 260 | (let ((str (concat (buffer-substring bol eol) "\n"))) 261 | (k-send-str str))))) 262 | 263 | (defun k-send () 264 | "Send current line or region to k process." 265 | (interactive) 266 | (if mark-active 267 | (k-send-region (region-beginning) (region-end)) 268 | (k-send-line))) 269 | 270 | (provide 'k-mode) 271 | -------------------------------------------------------------------------------- /src/k.h: -------------------------------------------------------------------------------- 1 | #if !defined(WIN32) 2 | #include 3 | #endif 4 | 5 | ; 6 | extern K KFIXED; 7 | K cd(K a); 8 | void finally(); 9 | extern I PG; 10 | extern I fError; 11 | extern __thread I fer; 12 | extern __thread I fer1; 13 | extern I fnci; 14 | extern S recur(S x); 15 | extern __thread K prnt; 16 | 17 | #if defined(DEBUG) 18 | extern V krec[1000000]; 19 | extern I kreci; 20 | void tf(N n); 21 | #endif 22 | 23 | I lsz(I k); 24 | I repool(V v,I r); 25 | I attend(); 26 | void boilerplate(); 27 | I kinit(); 28 | int main(int argc,S *argv); 29 | K show(K a); 30 | I check(); 31 | K _i(); 32 | void printAtDepth(V u,K a,I d,I x,I vdep,I b); 33 | K kapn(K *a,V v,I n); 34 | I args(int n,S *v); 35 | I prompt(I n); 36 | I VA(V p); 37 | I valence(V p); 38 | I adverbClass(V p); 39 | extern I vn_ct; 40 | I sva(V p); 41 | L charsAdverb(C c); 42 | L charsVerb(C c); 43 | I isCharVerb(C c); 44 | I charpos(S s,C c); 45 | I stringHasChar(S s,C c); 46 | extern S IFP[3]; 47 | extern S IFS[3]; 48 | extern V offsetSSR,offsetWhat,offsetAt,offsetDot,offsetColon; 49 | K _6d(K a,K b); 50 | K _5d(K x,K y); 51 | K _4d(K x,K y); 52 | K _3d(K x,K y); 53 | K _2d(K a,K b); 54 | K _1d(K x,K y); 55 | K _0d(K a,K b); 56 | K _6m(K x); 57 | K _5m(K x); 58 | K _4m(K x); 59 | K _3m(K x); 60 | K _2m(K a); 61 | K _1m(K x); 62 | K _0m(K a); 63 | K colon_dyadic(K a,K b); 64 | K dot(K a,K b); 65 | K dollar(K a,K b); 66 | K take_reshape(K a,K b); 67 | K join(K a,K b); 68 | K drop_cut(K a,K b); 69 | K what(K x,K y); 70 | K at(K x,K y); 71 | K match(K a,K b); 72 | K equals(K a,K b); 73 | K more(K a,K b); 74 | K less(K a,K b); 75 | K rotate_mod(K a,K b); 76 | K power(K a,K b); 77 | K min_and(K a,K b); 78 | K max_or(K a,K b); 79 | K divide(K a,K b); 80 | K times(K a,K b); 81 | K minus(K a,K b); 82 | K plus(K a,K b); 83 | K colon_monadic(K a); 84 | K dot_monadic(K x); 85 | K format(K a); 86 | K count(K a); 87 | K enlist(K x); 88 | K floor_verb(K a); 89 | K range(K a); 90 | K atom(K a); 91 | K not_attribute(K a); 92 | K group(K x); 93 | K grade_down(K a); 94 | K grade_up(K a); 95 | K enumerate(K a); 96 | K shape(K a); 97 | K where(K x); 98 | K reverse(K a); 99 | K reciprocal(K x); 100 | K first(K a); 101 | K negate(K x); 102 | K flip(K a); 103 | extern C vc[]; 104 | extern V adverbs[]; 105 | K eachpair(); 106 | K eachleft(); 107 | K eachright(); 108 | K each(); 109 | K scan(); 110 | K over(); 111 | extern C ac[]; 112 | I bk(V p); 113 | K end(); 114 | I simpleString(S a); 115 | F FF(F f); 116 | S CSK(K x); 117 | K KX(K x); 118 | K wd(S s,int n); 119 | K ex(K a); 120 | K X(S s); 121 | I miN(I a,I b); 122 | I maX(I a,I b); 123 | L DT_OFFSET(V v); 124 | extern C PPON; 125 | extern I PPMAX; 126 | extern I PP; 127 | extern S LS; 128 | extern K NIL; 129 | extern S IPC_PORT; 130 | extern S HTTP_PORT; 131 | extern S d_; 132 | extern I SEED; 133 | extern K KTREE; 134 | extern N SYMBOLS; 135 | K kerr(cS s); 136 | extern L DT_SIZE, DT_END_OFFSET, DT_ADVERB_OFFSET, DT_VERB_OFFSET, DT_SPECIAL_VERB_OFFSET; 137 | extern TR DT[]; 138 | extern L offsetOver, offsetScan, offsetEach, offsetEachright, offsetEachleft, offsetEachpair; 139 | K TABLE_END(); 140 | void nfinish(); 141 | I rc(K x); 142 | K _hash(K x); 143 | -------------------------------------------------------------------------------- /src/kapi-test.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "kona.h" 5 | 6 | 7 | Z int pass, fail; 8 | 9 | extern K KTREE; 10 | extern K X(S); 11 | extern K show(K); 12 | extern I attend(); 13 | extern void boilerplate(); 14 | 15 | #define tst(e) if(e){pass++;}else{fprintf(stderr, "Failed:%s\n", #e); fail++;} 16 | 17 | #define TEST(i,x,f) do { {i;} tst(x); {f;}} while(0) 18 | 19 | int 20 | main(int argc, char** argv) 21 | { 22 | F pi = atan(1.0)*4; 23 | K a = gi(2); 24 | K b = gi(3); 25 | K c = gi(4); 26 | K* v; 27 | 28 | cd(ksk("",0)); 29 | 30 | tst(Ki(a)==2); 31 | tst(Ki(b) + 1 == Ki(c)); 32 | cd(a); cd(b); cd(c); 33 | 34 | b = gf(1.0); c = gf(2); 35 | tst(Kf(b) + 1 == Kf(c)); 36 | cd(b); cd(c); 37 | 38 | a = gs(sp("foo")); 39 | b = ksk("`foo", 0); 40 | tst(Ks(a) == Ks(b)); 41 | cd(a); cd(b); 42 | 43 | a = ksk("2 + 3", 0); 44 | tst(Ki(a) == 5); 45 | cd(a); 46 | 47 | a = ksk("_ci 65", 0); 48 | tst(Kc(a) == 'A'); 49 | 50 | // XXX this should return type 1 uniform vector 51 | a=gnk(3,gi(11),gi(22),gi(33)); 52 | tst(a->t == 0); 53 | 54 | v = (K*)a->k; 55 | tst(Ki(v[0])+Ki(v[1])==Ki(v[2])); 56 | cd(a); 57 | 58 | 59 | { 60 | b = gsk("pi",gf(pi)); 61 | kap(&KTREE, &b); 62 | a = X(".pi"); 63 | tst(Kf(a) == pi); 64 | cd(a); 65 | } 66 | 67 | { 68 | K dir = gtn(5,0); 69 | K t; 70 | t = gsk("x",gi(1)); kap(&dir, &t); 71 | t = gsk("y",gi(2)); kap(&dir, &t); 72 | t = gsk("z",dir); kap(&KTREE, &t); 73 | a = X(".z.x"); 74 | tst(Ki(a) == 1); 75 | cd(a); 76 | a = X(".z.y"); 77 | tst(Ki(a) == 2); 78 | cd(a); 79 | } 80 | 81 | { 82 | I i; 83 | K d = gtn(5,0); 84 | K c0 = gtn(0,0); 85 | K c1 = gtn(-1,0); 86 | K t0, t1, e; 87 | t0 = gsk("a", c0); kap(&d,&t0); 88 | t1 = gsk("b", c1); kap(&d,&t1); 89 | e = gp("hello1"); kap(&c0,&e); 90 | e = gp("hello2"); kap(&c0,&e); 91 | KK(KK(d)[0])[1] = c0; 92 | i = 1; kap(&KK(KK(d)[1])[1], &i); 93 | i = 2; kap(&KK(KK(d)[1])[1], &i); 94 | //i = 1; kap(&c1, &i); 95 | //i = 2; kap(&c1, &i); 96 | //KK(KK(d)[1])[1] = c1; 97 | show(d); 98 | } 99 | 100 | 101 | //b = ksk("+/", a); 102 | //tst(Ki(b) == 66); 103 | 104 | //argc--;argv++; 105 | //DO(i, argc, {a=ksk(argv[i], 0); 106 | 107 | //ksk("`0:,/$!10;`0:,\"\n\"", 0); 108 | 109 | fprintf(stderr, "Pass:%4d, fail:%4d\n", pass, fail); 110 | if (argc > 1 && strcmp(argv[1], "-i") == 0) { 111 | boilerplate(); 112 | attend(); 113 | } 114 | } 115 | -------------------------------------------------------------------------------- /src/kapi.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "kona.h" 5 | 6 | extern K _jd(K); 7 | extern K wd(S s, I n); 8 | extern K dot(K,K); 9 | extern K newK(I t, I n); 10 | extern K newE(S s, K k); 11 | extern I jdn_from_date(I); 12 | extern I date_from_jdn(I); 13 | extern I kinit(); 14 | extern K X(S); 15 | extern K dv_ex(K, V*, K); 16 | extern K KTREE; 17 | extern K kap(K*, V); 18 | extern K* denameD(K*,S,I); 19 | extern K* denameS(S,S,I); 20 | extern S d_; 21 | #define NYI kerr("nyi") 22 | 23 | K gi(I x) {K z=newK(1,1); Ki(z)=x; R z;} 24 | K gf(F x) {K z=newK(2,1); Kf(z)=x; R z;} 25 | K gc(C x) {K z=newK(3,1); Kc(z)=x; R z;} 26 | K gs(S x) {K z=newK(4,1); Ks(z)=x; R z;} 27 | K gn() {K z=newK(6,1); R z;} 28 | 29 | K gtn(I t, I n) { R newK(t,n); } 30 | 31 | Z K gpn_(S s, I i) {K z=gtn(-3,i); memcpy(KC(z),s,i); R z; } 32 | K gpn(S s, I i) {I n=strlen(s); if(ik[i] = va_arg(v, K)); 50 | va_end(v); 51 | R z; 52 | } 53 | 54 | K ksk(S s, K x) 55 | { 56 | K z; 57 | K y; 58 | if (!*s) { kinit(); R 0; } 59 | y = X(s); 60 | if (!x) R y; 61 | //z = dv_ex(0, KV(z)[2], x) : z; 62 | R y; 63 | } 64 | -------------------------------------------------------------------------------- /src/kc.h: -------------------------------------------------------------------------------- 1 | void init_genrand64(unsigned long long seed); 2 | extern I SEED; 3 | extern C cdp[]; 4 | V alloc(size_t sz); 5 | K _dot_t(); 6 | K newE(S s,K k); 7 | K newEntry(S s); 8 | K Kd(); 9 | extern K KTREE; 10 | extern K KONA_WHO; 11 | extern K KONA_PORT; 12 | extern K KONA_GSET; 13 | extern K KONA_IDX; 14 | extern K KONA_CLIENT; 15 | K _n(); 16 | extern F mUsed; 17 | extern F mMax; 18 | extern F mAlloc; 19 | extern F mMap; 20 | extern I fWksp; 21 | extern __thread I fer; 22 | extern I fLoad; 23 | extern S lineA; 24 | extern S lineB; 25 | extern C errmsg[256]; 26 | I test(); 27 | extern S IFS[3]; 28 | extern S IFP[3]; 29 | extern S LS; 30 | extern S fnc; 31 | extern V fncp[128]; 32 | extern I fnci; 33 | extern I fom; 34 | extern I fam; 35 | extern I fll; 36 | extern __thread K cls; 37 | S sp(S k); 38 | extern S d_; 39 | K Kn(); 40 | extern K NIL; 41 | void seedPRNG(I s); 42 | N newN(); 43 | extern N SYMBOLS; 44 | extern V offsetSSR,offsetWhat,offsetAt,offsetDot,offsetColon,offsetJoin,offset3m; 45 | extern C vc[]; 46 | I charpos(S s,C c); 47 | extern V vd[]; 48 | extern V adverbs[]; 49 | extern V vt_[]; 50 | extern V vd_[]; 51 | extern V vm_[]; 52 | extern V vn_[]; 53 | void finally(); 54 | I kinit(); 55 | extern K KFIXED; 56 | K load(S s); 57 | I args(int n,S *v); 58 | I wipe_tape(I i); 59 | extern S IPC_PORT; 60 | extern S HTTP_PORT; 61 | I attend(); 62 | extern fd_set master; 63 | K wd(S s,int n); 64 | K ex(K a); 65 | I lines(FILE *f); 66 | K kap(K *a,V v); 67 | K cd(K a); 68 | void pdafree(PDA p); 69 | K newK(I t,I n); 70 | K kerr(cS s); 71 | K show(K a); 72 | I parsedepth(PDA p); 73 | I complete(S a,I n,PDA *q,I *marks); 74 | I appender(S *s,I *n,S t,I k); 75 | I wds(K *a,FILE*f); 76 | I wds_(K *a,FILE *f,I l); 77 | I prompt(I n); 78 | extern I adverb_ct; 79 | extern I vn_ct,vm_ct,vd_ct,vt_ct; 80 | 81 | #ifdef __FreeBSD__ 82 | extern ssize_t getline(S *lineptr, size_t *n, FILE *f); 83 | #endif 84 | 85 | K read_tape(I i,I j,I type); 86 | I line(FILE *f,S *a,I *n,PDA *p); 87 | K* denameS(S dir_string, S t, I create); 88 | I ninit(); 89 | extern M0 CP[FD_SETSIZE+1]; 90 | K _h(); 91 | K _host(K x); 92 | extern S HOST_IFACE; 93 | S spn(S s,I n); 94 | K Ks(S x); 95 | -------------------------------------------------------------------------------- /src/kg.c: -------------------------------------------------------------------------------- 1 | /* grading / sorting */ 2 | 3 | #include "incs.h" 4 | 5 | #include "k.h" 6 | #include "kg.h" 7 | #include "km.h" 8 | 9 | Z I gt=0; 10 | Z I mergerComparer(K a, I r, I i, I j); 11 | 12 | #define BITS_EM 0x7fffffffffffffffULL 13 | #define BITS_0i 0x7ff0000000000000ULL 14 | #define BITS_SUBN 0x0010000000000000ULL 15 | #define Inan(x) (BITS_0i<(BITS_EM&(x))) 16 | #define Isubn(x) (BITS_SUBN>(BITS_EM&(x))) 17 | 18 | I FC(F a, F b)//Floating-Point Compare 19 | { 20 | #ifdef REFERENCE_FC 21 | F E=0.00000000000000000001; //This value seems to work, might should be a different one though 22 | 23 | if(isnan(a))R isnan(b)?0:-1; 24 | if(isnan(b))R isnan(a)?0: 1; 25 | if(isinf(a)) { 26 | if (isinf(b)) { 27 | R (a<0 && b<0)?0:(a>0 && b>0)?0:(a<0 && b>0)?-1:1; 28 | } 29 | R a<0?-1:1; 30 | } 31 | else if (isinf(b)) { 32 | R b>0?-1:1; 33 | } 34 | 35 | if(ABS(a-b) <= E*MAX(ABS(a),ABS(b)))R 0; 36 | R a>44))<<1); 52 | if(adt, an=a->n, bt=b->t, bn=b->n; 63 | I A=ABS(at); 64 | 65 | if(atbt)R 1; 67 | if(3!=A){//since K2.6 lexicographic sorting of -3 68 | if(anbn)R 1; 70 | } 71 | 72 | I u,v;C c,d; 73 | if (7==A)R 0;//TODO: sort functions? 74 | else if(6==A)R 0; 75 | else if(5==A)R 0;//TODO: sort dictionaries? 76 | else if(4==A)DO(an, u=SC(kS(a)[i],kS(b)[i]); if(u) R u) 77 | else if(3==A)DO(MIN(an,bn)+1, c=kC(a)[i]; d=kC(b)[i]; if(cd) R 1) 78 | else if(2==A)DO(an, u=FC(kF(a)[i],kF(b)[i]); if(u)R u) 79 | else if(1==A)DO(an, u=kI(a)[i]; v=kI(b)[i]; if(uv) R 1) 80 | else if(0==A)DO(an, u=KC(kK(a)[i],kK(b)[i]); if(u) R u) 81 | if(3==A&&an!=bn)R ann, b=v-u+1, *c; 89 | K d=newK(-1,b);U(d) 90 | c=kI(d); //assumes # slots are set to 0 91 | K s=newK(-1,n); 92 | if(!s)GC; 93 | DO(n,c[kU(a)[i]-u]++) 94 | if(!r) DO(b-1,c[i+1]+=c[i]) //0==r: grade up 95 | else DO(b-1,c[_i-i-1]+=c[_i-i-0])//1==r: grade down 96 | DO(n, kI(s)[-1+c[kU(a)[n-i-1]-u]--]=n-i-1) 97 | cleanup: 98 | cd(d); 99 | R s; 100 | } 101 | K charGrade(K a, I r) 102 | {//Variation on Knuth Algorithm 5.2D Distribution counting 103 | I n=a->n,c[1+UCHAR_MAX]; //assumes # slots are set to 0 104 | memset(c,0,(1+UCHAR_MAX)*sizeof(I)); 105 | K s=newK(-1,n); 106 | DO(n,c[(UC)kC(a)[i]]++) 107 | if(!r) DO(UCHAR_MAX,c[i+1]+=c[i]) //0==r: grade up 108 | //else DO(UCHAR_MAX,c[_i-i-2]+=c[_i-i-1])//1==r: grade down 109 | else DO(UCHAR_MAX,c[_i-i-1]+=c[_i-i-0])//1==r: grade down 110 | DO(n, kI(s)[-1+c[(UC)kC(a)[n-i-1]]--]=n-i-1) 111 | R s; 112 | } 113 | Z I mergerComparer(K a, I r, I i, I j)//Could unroll this 114 | { 115 | I t=a->t; 116 | //-3 has its own sort, won't be merged 117 | if (-4==t && 0==r && 1>SC(kS(a)[i],kS(a)[j])) R 1; 118 | else if(-4==t && 1==r && -1FC(kF(a)[i],kF(a)[j])) R 1; 120 | else if(-2==t && 1==r && -1= kI(a)[j] ) R 1; 123 | else if( 0==t && 0==r && 1>KC(kK(a)[i],kK(a)[j])) R 1; 124 | else if( 0==t && 1==r && -1= t) R; //Faster: another sort when small |t-s| 155 | I m=s+(t-s)/2; //sic 156 | if(m-sn);M(x); 166 | DO(xn,K y=kK(a)[i];if(-3!=yt||yn>8){s=0;break;} 167 | k=StoU(kC(y),yn,yt);if(!k&&yn){s=0;break;} 168 | kU(x)[i]=k;h|=k) 169 | if(s)z=radixGrade(x,r,h); 170 | cd(x);R z; 171 | } 172 | K mergeGrade(K a, I r) 173 | { 174 | K x=0,y=0;I n=a->n; 175 | if(gt)O("mergeGrade"); 176 | if(0==a->t){ 177 | if((x=strGrade(a,r)))R x; 178 | } 179 | x=newK(-1,n);//Indices 180 | y=newK(-1,n);//Temporary storage 181 | M(x,y) 182 | DO(n, kI(x)[i]=i) 183 | doMergeGrade(a,r,x,y,0,n-1); 184 | cd(y); 185 | R x; 186 | } 187 | K insertGradeU(K a,I r) 188 | { 189 | if(gt)O("insertGrade"); 190 | uI *u=kU(a); 191 | I n=a->n,i,*c; 192 | K x=newK(-1,n);//Indices 193 | M(x) 194 | DO(n, kI(x)[i]=i) 195 | c=kI(x); 196 | 197 | if(!r) 198 | for(i=1;i<=n-1;i++){ 199 | I k=c[i],j=i; 200 | while(0u[k])){ 201 | c[j]=c[j-1]; j--; 202 | } 203 | c[j]=k; } 204 | else 205 | for(i=1;i<=n-1;i++){ 206 | I k=c[i],j=i; 207 | while(0>sa)]++) 225 | // if(!r) 226 | DO(N,c[i+1]+=c[i]) 227 | DO(n,I k=x[n-i-1]; y[-1+c[N&(a[n-i-1]>>sa)]--]=k) 228 | } 229 | Z void radixGradeI(uI*a,uI*w,I r,I*u,I*v,I*c,I n,uI h) 230 | { 231 | //trst(); 232 | if(r){DO(n,a[i]=~a[i]);r=0;} 233 | dGU(a,r,u,v,n,c,0); //elapsed(" grade0"); 234 | if(0x10000ULL>h)goto v2u; 235 | DO(n,w[i]=a[v[i]]); //elapsed(" order0"); 236 | c+=(1+N); 237 | dGU(w,r,v,u,n,c,1); //elapsed(" grade1"); 238 | if(0x100000000ULL>h)R; 239 | DO(n,w[i]=a[u[i]]); //elapsed(" order1"); 240 | c+=(1+N); 241 | dGU(w,r,u,v,n,c,2); //elapsed(" grade2"); 242 | if(0x1000000000000ULL>h)goto v2u; 243 | DO(n,w[i]=a[v[i]]); //elapsed(" order2"); 244 | c+=(1+N); 245 | dGU(w,r,v,u,n,c,3); //elapsed(" grade3"); 246 | R; 247 | v2u: 248 | memcpy(u,v,n*sizeof(I)); //elapsed(" v2u"); 249 | } 250 | K radixGrade(K a,I r,uI h) 251 | { 252 | if(gt)O("radixGrade"); 253 | I n=a->n; 254 | K x=newK(-1,n);//Indices 255 | K y=newK(-1,n);//Temporary storage 256 | K z=newK(-1,4*(1+N)); 257 | K w=newK(-1,n); 258 | M(x,y,z,w) 259 | DO(n, kI(x)[i]=i) 260 | radixGradeI(kU(a),kU(w),r,kI(x),kI(y),kI(z),n,h); 261 | cd(w);cd(z);cd(y); 262 | R x; 263 | } 264 | K symGrade(K x,I r) 265 | { 266 | K z=newK(-1,xn);M(x); 267 | setS(1,0);DO(xn,S s=kS(x)[i];SV(s,1)=SV(s,1)+1) 268 | //O("=== count\n");OS(SYMBOLS,1); 269 | if(!r) wleft(SYMBOLS,1,0); 270 | else wright(SYMBOLS,1,0); 271 | //O("=== mark\n");OS(SYMBOLS,1); 272 | DO(xn,S s=kS(x)[i];I y=SV(s,1);kI(z)[y++]=i;SV(s,1)=y) 273 | R z; 274 | } 275 | -------------------------------------------------------------------------------- /src/kg.h: -------------------------------------------------------------------------------- 1 | K mergeGrade(K a,I r); 2 | K charGrade(K a,I r); 3 | K cd(K a); 4 | K _i(); 5 | K newK(I t,I n); 6 | K distributionGrade(K a,I r,uI u,uI v); 7 | I SC(S a,S b); 8 | K at(K x,K y); 9 | I KC(K a,K b); 10 | I FC(F a,F b); 11 | K radixGrade(K a,I r,uI h); 12 | K insertGradeU(K a,I r); 13 | #define IGT 7 14 | void setS(int y,I z); 15 | I wleft(N x,I y,I z); 16 | I wright(N x,I y,I z); 17 | extern I feci; 18 | void OS(N x,I y); 19 | void trst(); 20 | void elapsed(S m); 21 | -------------------------------------------------------------------------------- /src/km.c: -------------------------------------------------------------------------------- 1 | /* memory management */ 2 | 3 | #if defined(__linux__) 4 | #define _GNU_SOURCE 1 5 | #endif 6 | 7 | #include "incs.h" 8 | 9 | #include "k.h" 10 | #include "km.h" 11 | 12 | 13 | //Notes on memory manager: seems like atoms (and small lists?) are not released 14 | //by K4 (see Skelton's remark: only contiguous arrays greater than 32MB are 15 | //returned to OS). Also: " Why do you think it is memory fragmentation? The 16 | //allocator in kdb+ is designed specifically to avoid that by using fixed size 17 | //buckets." 18 | // 19 | //Setting the minimum pool lane size to the width of a cache line can be a good idea 20 | //This increases the number of bytes in order to improve cache performance 21 | //See: https://github.com/ruby/ruby/pull/495 22 | //As of 2014.01.04 cache line size is often 64 bytes (or 2^6 giving KP_MIN==6) 23 | //There doesn't appear to be a programmatic/compiler way to determine this 24 | //Linux: cat /proc/cpuinfo | grep cache_alignment 25 | //OSX: sysctl -a | grep cache 26 | //Simple tests on Kona confirmed 6 is an improvement over 5 27 | #define KP_MIN 6 //2^x, must be at least ceil(lg(sizeof(V))) 28 | #define KP_MAX 26 //2^x, 26->64MB //TODO: base on available memory at startup (fixed percent? is 64M/2G a good percent?) 29 | V KP[KP_MAX+1]; //KPOOL 30 | I PG; //pagesize: size_t page_size = (size_t) sysconf (_SC_PAGESIZE); 31 | F mUsed=0.0, mAlloc=0.0, mMap=0.0, mMax=0.0; 32 | 33 | #if UINTPTR_MAX >= 0xffffffffffffffff //64 bit 34 | #define MAX_OBJECT_LENGTH (((unsigned long long)1) << 45) //for catching obviously incorrect allocations 35 | #else 36 | #define MAX_OBJECT_LENGTH (II - 1) //for catching obviously incorrect allocations 37 | #endif 38 | Z I kexpander(K *p,I n); 39 | Z K kapn_(K *a,V v,I n); 40 | Z V amem(I k,I r); 41 | Z V kalloc(I k,I*r); 42 | Z V unpool(I r); 43 | 44 | V alloc(size_t sz) { 45 | V r=malloc(sz);if(!r){fputs("out of memory\n",stderr);exit(1);} 46 | R r; } 47 | 48 | I OOM_CD(I g, ...) //out-of-memory count-decrement 49 | { va_list a; V v,o=(V)-1; 50 | va_start(a,g);while(o!=(v=va_arg(a,V)))if(!v)g=1; va_end(a); 51 | P(!g,1)//OK 52 | va_start(a,g);while(o!=(v=va_arg(a,V)))cd(v); va_end(a); 53 | R 0; 54 | } 55 | I rc(K x){R (x->_c)>>8;} 56 | Z K ic(K x){x->_c+=256;R x;} 57 | Z K dc(K x){x->_c-=256;R x;} 58 | Z I glsz(K x){R 255&(x->_c);} 59 | Z K slsz(K x,I r){x->_c&=~(uI)255;x->_c|=r;R x;} 60 | K mrc(K x,I c){I k=sz(xt,xn);I r=lsz(k);x->_c=(c<<8)|r;R x;} 61 | #define STAT(x) 62 | //Arthur says he doesn't use malloc or free. Andrei Moutchkine claims smallest unit is vm page (his truss says no malloc + add pages one at a time). 63 | //Arthur not using malloc is probably true. No strdup & related functions in binary's strings. Note: Skelton references "different allocator" not in \w report 64 | //This source would be improved by getting ridding of remaing malloc/calloc/realloc 65 | K cd(K x) 66 | { 67 | #ifdef DEBUG 68 | if(x && rc(x) <=0 ) { er(Tried to cd() already freed item) dd(tests) dd((L)x) dd(rc(x)) dd(x->t) dd(x->n) show(x); } 69 | #endif 70 | 71 | P(!x,0) 72 | dc(x); 73 | 74 | SW(xt) 75 | { 76 | CSR(5,) 77 | CS(0, STAT(trst()); DO(xn, cd(kK(x)[xn-i-1])); STAT(elapsed("cd"))) //repool in reverse, attempt to maintain order 78 | } 79 | 80 | if(x->_c > 255) R x; 81 | 82 | #ifdef DEBUG 83 | DO(kreci, if(x==krec[i]){krec[i]=0; break; }) 84 | #endif 85 | 86 | SW(xt) 87 | { 88 | CS(7, DO(-2+TYPE_SEVEN_SIZE,cd(kV(x)[2+i]))) //-4 special trick: don't recurse on V members. assumes sizeof S==K==V. (don't free CONTeXT or DEPTH) 89 | } 90 | 91 | #ifdef DEBUG 92 | if(0)R 0; //for viewing K that have been over-freed 93 | #endif 94 | //assumes seven_type x->k is < PG 95 | I o=((size_t)x)&(PG-1);//file-mapped? 1: 96 | I r=glsz(x); 97 | //assert file-maps have sizeof(V)==o and unpooled blocks never do (reasonable) 98 | //in 32-bit Linux: sizeof(V)==4 but file-maps have o==8 99 | //in 64-bit Linux: sizeof(V)==8 and file-maps have o==8 100 | if(o==8 || r>KP_MAX){ //(file-mapped or really big) do not go back into pool. 101 | I k=sz(xt,xn),s=k+o; 102 | I res=munmap(((V)x)-o,s); if(res)R UE; 103 | if(o==8)mMap-=s; 104 | else if(r>KP_MAX)mAlloc-=s; 105 | mUsed-=s; 106 | } 107 | else repool(x,r); 108 | R 0; 109 | } 110 | 111 | K ci(K x) 112 | { 113 | P(!x,0) 114 | ic(x); 115 | 116 | SW(xt) 117 | { 118 | CSR(5,) 119 | CS(0, DO(xn, ci(kK(x)[i]))) 120 | } 121 | 122 | R x; 123 | } 124 | 125 | I bp(I t) {SW(ABS(t)){CSR(1, R sizeof(I)) CSR(2, R sizeof(F)) CSR(3, R sizeof(C)) CD: R sizeof(V); } } //Default 0/+-4/5/6/7 (assumes sizeof(K)==sizeof(S)==...) 126 | I sz(I t,I n){R 3*sizeof(I)+(7==t?TYPE_SEVEN_SIZE:n)*bp(t)+(3==ABS(t));} //not recursive. assert sz() > 0: Everything gets valid block for simplified munmap/(free) 127 | 128 | Z I nearPG(I i){ I k=((size_t)i)&(PG-1);R k?i+PG-k:i;}//up 0,8,...,8,16,16,... 129 | 130 | //This is an untested idea for avoiding all that goes on in backing out of memory allocations when an error occurs inside a function before everything is done: 131 | //If you control the memory allocator one possibility is to work in "claimed" (sbreak) but "free" space and build the K data structure there. 132 | //Doing ci() or something similar on it marks the space "used". on error you do nothing and the space remains "free" (mutex) 133 | 134 | //Keyword "backingstore" in old k mailing list archives - extra KSWAP beyond regular swap space 135 | 136 | K newK(I t, I n) 137 | { 138 | K z; 139 | if(n>0 && n>MAX_OBJECT_LENGTH)R ME;//coarse (ignores bytes per type). but sz can overflow 140 | I k=sz(t,n),r; 141 | U(z=kalloc(k,&r)) 142 | //^^ relies on MAP_ANON being zero-filled for 0==t || 5==t (cd() the half-complete), 3==ABS(t) kC(z)[n]=0 (+-3 types emulate c-string) 143 | ic(slsz(z,r)); z->t=t; z->n=n; 144 | if(t==6)z->n=0; 145 | if(z->_c==0)z->_c=256; 146 | #ifdef DEBUG 147 | krec[kreci++]=z; 148 | #endif 149 | R z; 150 | } 151 | 152 | Z V kallocI(I k,I r) 153 | { 154 | if(r>KP_MAX)R amem(k,r);// allocate for objects of sz > 2^KP_MAX 155 | R unpool(r); 156 | } 157 | 158 | Z V kalloc(I k,I*r) //bytes. assumes k>0 159 | { 160 | *r=lsz(k);R kallocI(k,*r); 161 | } 162 | 163 | Z V amem(I k,I r) { 164 | K z; 165 | if(MAP_FAILED==(z=mmap(0,k,PROT_READ|PROT_WRITE,MAP_PRIVATE|MAP_ANON,-1,0)))R ME; 166 | mAlloc+=kKP_MAX){ mUsed+=k;if(mUsed>mMax)mMax=mUsed; } 168 | R z; 169 | } 170 | 171 | Z V unpool(I r) 172 | { 173 | V*z; 174 | V*L=((V*)KP)+r; 175 | I k= ((I)1)<*L) 180 | #endif 181 | { 182 | U(z=amem(k,r)) 183 | if(kmMax)mMax=mUsed; 192 | R z; 193 | } 194 | 195 | I cl2(I v) //optimized 64-bit ceil(log_2(I)) 196 | { 197 | if(!v)R -1;// no bits set 198 | I e = 0; 199 | if(v & (v - 1ULL))e=1; //round up if not a power of two 200 | #if UINTPTR_MAX >= 0xffffffffffffffff 201 | if(v & 0xFFFFFFFF00000000ULL){e+=32;v>>=32;} //64-bit or more only 202 | #endif 203 | if(v & 0x00000000FFFF0000ULL){e+=16;v>>=16;} 204 | //short CL2_LUT[1<<16]; DO(1<<16,if(i) CL2_LUT[i]=log2(i)); 205 | //to use lookup table: e+=CL2_LUT[v] and comment out below. 206 | if(v & 0x000000000000FF00ULL){e+=8; v>>=8; } 207 | if(v & 0x00000000000000F0ULL){e+=4; v>>=4; } 208 | if(v & 0x000000000000000CULL){e+=2; v>>=2; } 209 | if(v & 0x0000000000000002ULL){e+=1; v>>=1; } 210 | R e; 211 | } 212 | 213 | I lsz(I k){R k<=((I)1)<KP_MAX) //Large anonymous mmapped structure - (simulate mremap) 227 | { 228 | V v;I c=sz(a->t,a->n),d=sz(a->t,n),e=nearPG(c),f=d-e; 229 | if(f<=0) R 1; 230 | #if defined(__linux__) 231 | V*w=mremap(a,c,d,MREMAP_MAYMOVE); 232 | if(MAP_FAILED!=w) { 233 | mAlloc+=d-c;mUsed+=d-c;if(mUsed>mMax)mMax=mUsed; *p=(K)w;R 1;} 234 | #else 235 | F m=f/(F)PG; I n=m, g=1; if(m>n) n++; 236 | DO(n, if(-1==msync((V)a+e+PG*i,1,MS_ASYNC)) {if(errno!=ENOMEM) {g=0; break;}} 237 | else {g=0; break;}) 238 | if(g) if(MAP_FAILED!=mmap((V)a+e,f,PROT_READ|PROT_WRITE,MAP_PRIVATE|MAP_ANON|MAP_FIXED,-1,0)) { mAlloc+=f;mUsed+=f;if(mUsed>mMax)mMax=mUsed; R 1; } //Add pages to end 239 | #endif 240 | U(v=amem(d,r)) memcpy(v,a,c); *p=v; 241 | I res=munmap(a,c); if(res) { show(kerr("munmap")); R 0; } 242 | mAlloc-=c;mUsed-=c; 243 | R 1; //Couldn't add pages, copy to new space 244 | } 245 | I d=sz(a->t,n); 246 | //Standard pool object 247 | if(d<=(1<t,a->n); 251 | memcpy(x,a,c); 252 | *p=x; slsz(*p,s); 253 | repool(a,r); 254 | R 1; 255 | } 256 | 257 | Z K kap1_(K *a,V v)//at<=0 258 | { 259 | K k=*a; 260 | I t=k->t,m=k->n,p=m+1; 261 | if(!kexpander(&k,p))R 0; 262 | if(k!=*a) 263 | { 264 | #ifdef DEBUG 265 | DO(kreci, if(*a==krec[i]){krec[i]=0; break; }) 266 | #endif 267 | *a=k; 268 | } 269 | k->n=p; 270 | SW(-t) 271 | { 272 | CS(0, kK(k)[m]=ci(((K*)v)[0])); 273 | CS(1, kI(k)[m]=*(I*)v); 274 | CS(2, kF(k)[m]=*(F*)v); 275 | CS(3, kC(k)[m]=*(C*)v;kC(k)[p]=0); 276 | CS(4, kS(k)[m]=*(S*)v) 277 | CD: R 0; 278 | } 279 | R k; 280 | } 281 | 282 | Z K kapn_(K *a,V v,I n) 283 | { 284 | if(!a||!n)R 0; 285 | K k=*a; 286 | I t=k->t,m=k->n,p=m+n; 287 | if(6==t) 288 | { 289 | K z=newK(0,p);U(z) 290 | K *zv=kK(z); 291 | *zv++=_n(); DO(n, zv[i]=_n()); 292 | cd(k); 293 | *a=z; 294 | R z; 295 | } 296 | if(!kexpander(&k,p))R 0; 297 | if(k!=*a) 298 | { 299 | #ifdef DEBUG 300 | DO(kreci, if(*a==krec[i]){krec[i]=0; break; }) 301 | #endif 302 | *a=k; 303 | } 304 | k->n=p; 305 | SW(ABS(t)) 306 | { 307 | CSR(0,) CS(5, DO(n, kK(k)[i+m]=ci(((K*)v)[i]))); 308 | CS(1, memcpy(kI(k)+m,v,n*sizeof(I))); 309 | CS(2, memcpy(kF(k)+m,v,n*sizeof(F))); 310 | CS(3, strncpy(kC(k)+m,(S)v,n); kC(k)[p]=0); 311 | CS(4, memcpy(kS(k)+m,v,n*sizeof(S))) 312 | CD: R 0; 313 | } 314 | if(t>0&&t<5&&p>1)k->t*=-1; 315 | R *a; 316 | } 317 | 318 | extern K kapn(K *a,V v,I n){R kapn_(a,v,n);} 319 | 320 | extern K kap(K*a,V v){ if(!a)R 0; R (0<(*a)->t)?kapn_(a,v,1):kap1_(a,v); } 321 | //extern K kap(K*a,V v){R kapn_(a,v,1);} 322 | 323 | N newN(){R unpool(lsz(sizeof(Node)));} 324 | PDA newPDA(){PDA p=unpool(lsz(sizeof(Pda)));U(p) p->c=alloc(1); if(!p->c){ME;R 0;} R p;} 325 | I push(PDA p, C c){R appender(&p->c,&p->n,&c,1);} 326 | C peek(PDA p){I n=p->n; R n?p->c[n-1]:0;} 327 | C pop(PDA p){R p->n>0?p->c[--(p->n)]:0;} 328 | C bottom(PDA p){R p->n>0?p->c[0]:0;} 329 | void pdafree(PDA p){free(p->c); repool(p,lsz(sizeof(PDA)));} 330 | 331 | K Ki(I x){K z=newK(1,1);*kI(z)=x;R z;} 332 | K Kf(F x){K z=newK(2,1);*kF(z)=x;R z;} 333 | K Kc(C x){K z=newK(3,1);*kC(z)=x;R z;} 334 | K Ks(S x){U(x) K z=newK(4,1);*kS(z)=x;R z;}//KDB+ >= 2.4 tries interning [sp()] by default when generating sym atoms 335 | K Kd( ){R newK(5,0);} 336 | K Kn( ){R newK(6,1);}//Should n instead be 0? (Won't affect #:) in k3.2 yes //In K3.2 _n->n is overridden for error messages. 337 | K Kv( ){K z=newK(7,TYPE_SEVEN_SIZE);U(z) z->n=1;kV(z)[CONTeXT]=d_; M(z,kV(z)[PARAMS]=Kd(),kV(z)[LOCALS]=Kd()) R z;} //z->n == 0-wd 1-wordfunc 2-cfunc 3-charfunc 4-:[] 5-if[] 6-while[] 7-do[] 338 | //Optimization: It's better if Kv() doesn't set PARAMS and LOCALS. Only charfuncs should set params 339 | 340 | K newEntry(S s){R newE(s,_n());}//assumes s came from sp() 341 | K newE(S s, K k) //oom 342 | { 343 | K z=newK(0,3); U(z) 344 | kK(z)[0]=Ks(s); // be careful -- s must have come from sp() 345 | kK(z)[1]=k; 346 | kK(z)[2]=_n(); 347 | M(z,kK(z)[0],kK(z)[2]) //May want to redesign this function (& newEntry) to ci(k==kK(z)[1]) 348 | R z; 349 | } 350 | I rp2(I v){v--;v|=v>>1;v|=v>>2;v|=v>>4;v|=v>>8;v|=v>>16;if(sizeof(V)>=8)v|=v>>32;v++;R MAX(1,v);}//round up to integer power of 2 (fails on upper 1/4 signed) 351 | 352 | K mstat(){K ks=newK(-1,4);M(ks);I*s=kI(ks);s[0]=mUsed;s[1]=mAlloc;s[2]=mMap;s[3]=mMax;R ks;} 353 | -------------------------------------------------------------------------------- /src/km.h: -------------------------------------------------------------------------------- 1 | I rp2(I v); 2 | K newE(S s,K k); 3 | K newEntry(S s); 4 | extern S d_; 5 | K Kv(); 6 | K Kn(); 7 | K Kd(); 8 | K Ks(S x); 9 | K Kc(C x); 10 | K Kf(F x); 11 | K Ki(I x); 12 | void pdafree(PDA p); 13 | C bottom(PDA p); 14 | C pop(PDA p); 15 | C peek(PDA p); 16 | I appender(S *s,I *n,S t,I k); 17 | I push(PDA p,C c); 18 | PDA newPDA(); 19 | N newN(); 20 | K kap(K *a,V v); 21 | K kapn(K *a,V v,I n); 22 | K _n(); 23 | extern F testtime; 24 | K newK(I t,I n); 25 | I bp(I t); 26 | K ci(K a); 27 | I repool(V v,I r); 28 | I lsz(I k); 29 | I sz(I t,I n); 30 | #if defined(DEBUG) 31 | extern V krec[1000000]; 32 | extern I kreci; 33 | #endif 34 | K show(K a); 35 | extern I tests; 36 | K cd(K a); 37 | I OOM_CD(I g, ...); 38 | I cl2(I v); 39 | I rc(K x); 40 | K mrc(K x,I c); 41 | K mstat(void); 42 | void trst(); 43 | void elapsed(S m); 44 | -------------------------------------------------------------------------------- /src/kn.c: -------------------------------------------------------------------------------- 1 | /* networking */ 2 | 3 | #include "incs.h" 4 | #include "k.h" 5 | #include "km.h" 6 | #include "kn.h" 7 | 8 | #if defined(__OpenBSD__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__ANDROID__) 9 | #include 10 | #include 11 | #endif 12 | 13 | #ifndef WIN32 14 | #include //#include //#include 15 | #define closesocket close 16 | #endif 17 | M0 CP[FD_SETSIZE+1]; //Connection Pool (large array), last entry for Windows _4d 18 | 19 | Z I close_tape(I i,I sockfd); 20 | Z K modified_execute(K x); 21 | K KONA_WHO,KONA_PORT,KONA_CLIENT; 22 | 23 | void nfinish() 24 | { 25 | #ifdef WIN32 26 | extern I listener; 27 | if (IPC_PORT || HTTP_PORT) { 28 | closesocket(listener); listener=0; 29 | } 30 | WSACleanup(); 31 | #endif 32 | } 33 | 34 | I ninit() 35 | { 36 | static I _done = 0; 37 | 38 | if (!_done) { 39 | #ifdef WIN32 40 | WSADATA wsaData; 41 | int err = WSAStartup(MAKEWORD(2,2), &wsaData); 42 | if(err != 0) O("WSAStartup failed with error: %d\n",err); 43 | if(LOBYTE(wsaData.wVersion) != 2 || HIBYTE(wsaData.wVersion) != 2) 44 | { O("Could not find useable version of Winsock.dll\n"); exit(1); } 45 | atexit(nfinish); 46 | #endif 47 | _done = 1; 48 | } 49 | R _done; 50 | } 51 | 52 | 53 | void *get_in_addr(struct sockaddr *sa) { //get sockaddr, IPv4 or IPv6 54 | if (sa->sa_family == AF_INET) R &(((struct sockaddr_in*)sa)->sin_addr); 55 | R &(((struct sockaddr_in6*)sa)->sin6_addr); } 56 | 57 | Z I _oldw,_oldc; 58 | Z void mhbegin(I i){ 59 | _oldw=*kI(KONA_WHO); _oldc=*kI(KONA_CLIENT); 60 | *kI(KONA_WHO)=i; *kI(KONA_CLIENT)=CP[i].a; } 61 | Z void mhend(){ *kI(KONA_WHO)=_oldw; *kI(KONA_CLIENT)=_oldc; } 62 | 63 | I wipe_tape(I i) { I a=CP[i].a; if(CP[i].k)cd(CP[i].k); memset(&CP[i],0,sizeof(CP[0])); CP[i].a=a; R 0;} //safe to call >1 time 64 | Z I close_tape(I i,I sockfd) { 65 | #if !defined( __NetBSD__) && !defined(__OpenBSD__) 66 | mhbegin(i); 67 | #endif 68 | wipe_tape(i); CP[i].a=0; 69 | I r=closesocket(sockfd); if(r){show(kerr("file"));r=0;} 70 | FD_CLR(sockfd, &master); 71 | K x=*denameS(".",".m.c",0); 72 | if(6==xt){r=0; /*O("ct-D\n");*/ GC;} 73 | if(3!=ABS(xt)){r=1;O("type error");GC;} 74 | KX(x); 75 | cleanup: 76 | #if !defined(__NetBSD__) && !defined(__OpenBSD__) 77 | mhend(); 78 | #endif 79 | R r; } 80 | 81 | C bx[128]={0},by[128]={0}; 82 | 83 | Z K modified_execute(K x) //TODO: consider: this should be modified to use error trap. _4d should be modified to expect error trap output. 84 | { 85 | //K-Lite manual gives {:[4:x; .x; .[.;x]} as processing function 86 | if(pthread_mutex_lock(&execute_mutex)){ 87 | perror("Lock mutex in mod_ex()"); abort();} 88 | 89 | K a=(K)-1; 90 | if(4==xt || 3==ABS(xt)) a=X(CSK(x)); 91 | if(!xt && xn>0) a=vf_ex(offsetDot,x); 92 | 93 | if((K)-1!=a){ 94 | if(pthread_mutex_unlock(&execute_mutex)){ 95 | perror("Unlock mutex in mod_ex()"); abort();} 96 | R a; 97 | } 98 | R ci(x); 99 | } 100 | 101 | K read_tape(I i, I j, I type) { // type in {0,1} -> {select loop, 4: resp reader} 102 | I nbytes=0,n=0; C bz[128]={0},bn[1]={0}; 103 | if(HTTP_PORT) { 104 | if(bx[0]=='\0')nbytes=recv(j,bx,128,0); 105 | else if(by[0]=='\0')nbytes=recv(j,by,128,0); 106 | else nbytes=recv(j,bz,128,0); 107 | if(nbytes<=0){ 108 | if (nbytes==0)O("server: socket %lld hung up\n", j); 109 | else perror("recv"); 110 | GC; } 111 | K h=*denameS(".",".m.h",0); 112 | if(6==h->t){send(j,bx,nbytes,0); bx[0]='\0'; close_tape(i,j); R (K)0;} //echo back only if .m.h does not exist 113 | else { 114 | if(7!=h->t && 3!=h->n) { 115 | I n=snprintf(bx,128,"%s",".m.h is not type 7-3"); if(n>=128)R WE; 116 | send(j,bx,strlen(bx),0); bx[0]='\0'; close_tape(i,j); R (K)0;} 117 | else { //have .m.h of type 7-3 118 | S f=kC(kK(h)[CODE]); I ax=0,ay=0,az=0,sf=strlen(f); 119 | DO(sf, if(f[i]=='x')ax=1; else if(f[i]=='y')ay=1; else if(f[i]=='z')az=1;) I na=maX(1,ax+ay+az); 120 | if(na==3) { 121 | if(bz[0]=='\0'){ send(j,bn,1,0); close_tape(i,j); R (K)0; } 122 | else { 123 | for(n=0;n<128;++n){if(bx[n]=='\r' || bx[n]=='\0')break;} bx[n]='\0'; 124 | for(n=0;n<128;++n){if(by[n]=='\r' || by[n]=='\0')break;} by[n]='\0'; 125 | for(n=0;n<128;++n){if(bz[n]=='\r')break;} bz[n]='\0'; 126 | I sbx=strlen(bx); I sby=strlen(by); I sbz=strlen(bz); 127 | C c[13+sf+sbx+sby+sbz]; c[0]='{'; c[1+sf]='}'; c[2+sf]='['; c[11+sf+sbx+sby+sbz]=']'; 128 | c[3+sf]=c[4+sf+sbx]=c[6+sf+sbx]=c[7+sf+sbx+sby]=c[9+sf+sbx+sby]=c[10+sf+sbx+sby+sbz]='"'; 129 | c[5+sf+sbx]=c[8+sf+sbx+sby]=';'; c[12+sf+sbx+sby+sbz]='\0'; 130 | DO(sf,c[1+i]=f[i]) DO(sbx,c[4+sf+i]=bx[i]) DO(sby,c[7+sf+sbx+i]=by[i]) DO(sbz,c[10+sf+sbx+sby+i]=bz[i]) 131 | K r=X(c); I w=128; C bck[w]; 132 | switch(r->t) { 133 | CS(1, {n=snprintf(bck,w,"%lld",*kI(r)); if(n>=w){bck[w-4]=bck[w-3]=bck[w-2]='.';}}) 134 | CS(2, {n=snprintf(bck,w,"%f",*kF(r)); if(n>=w){bck[w-4]=bck[w-3]=bck[w-2]='.';}}) 135 | CS(3, {n=snprintf(bck,w,"%s",kC(r)); if(n>=w){bck[w-4]=bck[w-3]=bck[w-2]='.';}}) 136 | CS(-3,{n=snprintf(bck,w,"%s",kC(r)); if(n>=w){bck[w-4]=bck[w-3]=bck[w-2]='.';}}) 137 | default:{n=snprintf(bck,w,"%s","NYI: .m.h result of that type and count"); if(n>=w)R WE;} } 138 | send(j,bck,strlen(bck),0); bx[0]='\0'; by[0]='\0'; close_tape(i,j); R (K)0; } } 139 | if(na==2) { 140 | if(by[0]=='\0'){ send(j,bn,1,0); close_tape(i,j); R (K)0; } 141 | else { 142 | for(n=0;n<128;++n){if(bx[n]=='\r')break;} bx[n]='\0'; 143 | for(n=0;n<128;++n){if(by[n]=='\r')break;} by[n]='\0'; 144 | I sbx=strlen(bx); I sby=strlen(by); 145 | C c[10+sf+sbx+sby]; c[0]='{'; c[1+sf]='}'; c[2+sf]='['; c[8+sf+sbx+sby]=']'; 146 | c[3+sf]=c[4+sf+sbx]=c[6+sf+sbx]=c[7+sf+sbx+sby]='"'; 147 | c[5+sf+sbx]=';'; c[9+sf+sbx+sby]='\0'; 148 | DO(sf,c[1+i]=f[i]) DO(sbx,c[4+sf+i]=bx[i]) DO(sby,c[7+sf+sbx+i]=by[i]) 149 | K r=X(c); I w=128; C bck[w]; 150 | switch(r->t) { 151 | CS(1, {n=snprintf(bck,w,"%lld",*kI(r)); if(n>=w){bck[w-4]=bck[w-3]=bck[w-2]='.';}}) 152 | CS(2, {n=snprintf(bck,w,"%f",*kF(r)); if(n>=w){bck[w-4]=bck[w-3]=bck[w-2]='.';}}) 153 | CS(3, {n=snprintf(bck,w,"%s",kC(r)); if(n>=w){bck[w-4]=bck[w-3]=bck[w-2]='.';}}) 154 | CS(-3,{n=snprintf(bck,w,"%s",kC(r)); if(n>=w){bck[w-4]=bck[w-3]=bck[w-2]='.';}}) 155 | default:{n=snprintf(bck,w,"%s","NYI: .m.h result of that type and count"); if(n>=w)R WE;} } 156 | send(j,bck,strlen(bck),0); bx[0]='\0'; by[0]='\0'; close_tape(i,j); R (K)0; } } 157 | for(n=0;n<128;n++){if(bx[n]=='\r' || bx[n]=='\0')break;} 158 | bx[n]='\0'; I sbx=strlen(bx); 159 | C c[7+sf+sbx]; c[0]='{'; c[1+sf]='}'; c[2+sf]='['; c[5+sf+sbx]=']'; 160 | c[3+sf]=c[4+sf+sbx]='"'; c[6+sf+sbx]='\0'; 161 | DO(sf,c[1+i]=f[i]) DO(sbx,c[4+sf+i]=bx[i]) 162 | K r=X(c); if(strcmp(errmsg,"(nil)")){oerr();GC;} I w=128; C bck[w]; 163 | switch(r->t){ 164 | CS(1, {n=snprintf(bck,w,"%lld",*kI(r)); if(n>=w){bck[w-4]=bck[w-3]=bck[w-2]='.';}}) 165 | CS(2, {n=snprintf(bck,w,"%f",*kF(r)); if(n>=w){bck[w-4]=bck[w-3]=bck[w-2]='.';}}) 166 | CS(3, {n=snprintf(bck,w,"%s",kC(r)); if(n>=w){bck[w-4]=bck[w-3]=bck[w-2]='.';}}) 167 | CS(-3,{n=snprintf(bck,w,"%s",kC(r)); if(n>=w){bck[w-4]=bck[w-3]=bck[w-2]='.';}}) 168 | default:{n=snprintf(bck,w,"%s","NYI: .m.h result of that type and count"); if(n>=w)R WE;} } 169 | send(j,bck,strlen(bck),0); bx[0]='\0'; by[0]='\0'; close_tape(i,j); R (K)0; } } } 170 | I u=1;I a=*(S)&u; 171 | I c=CP[i].r, m=sizeof(M1),g; K z=0; 172 | S b = c 987654321) GC; //protect against too big? 186 | K k = newK(-3, m+CP[i].m1.n); 187 | if(!(CP[i].k=k))GC; 188 | memcpy(kC(k),&CP[i].m1,m); } //cpy data from our struct to the corresponding spot on the '_bd' object 189 | if(CP[i].r == m + CP[i].m1.n) { //the k for the _db is completed. perform modified execution, potentially respond 190 | //TODO: (here or in _db?) rearrange bytes based on little-endianness indicator CP[i].m1.a 191 | M1*p=(V)kC(CP[i].k); 192 | I msg_type = p->d; //p->d dissappears after wipe_tape 193 | K h = _db(CP[i].k); 194 | if(!h)GC; 195 | wipe_tape(i); 196 | 197 | //blocking read inside 4: receives response //response sent by server to client after a 4: request is not executed by client 198 | if(2==msg_type && 1==type){ 199 | // (0;x) or (1;"errmsg") 200 | if(h->t||2!=h->n)R NE; 201 | K s=kK(h)[0],r=kK(h)[1]; 202 | if(1!=s->t)R NE; 203 | if(*kI(s)) { 204 | if(3!=ABS(r->t))R NE; 205 | r=kerr(kC(r)); } 206 | else ci(r); 207 | cd(h); 208 | R r; } 209 | 210 | //Modified execution of received K value. First received transmission in a 3: or 4: 211 | K m=(2>msg_type)?*denameS(".",msg_type?".m.g":".m.s",0):0; 212 | if(!m||6==m->t)z=modified_execute(h);else{ mhbegin(i);z=at(m,h);mhend(); } 213 | if(msg_type){ 214 | K u=newK(0,2),s=Ki(0); 215 | M(u,s) 216 | if(!z){ 217 | *kI(s)=1; 218 | z=newK(-3,strlen(errmsg)); 219 | M(u,z); 220 | strcpy(kC(z),errmsg); 221 | kerr("(nil)"); } 222 | kK(u)[0]=s;kK(u)[1]=z;z=u; } 223 | else if(!z){ 224 | O("%s error\n",errmsg); 225 | kerr("(nil)"); } 226 | cd(h); 227 | //indicates received communication from 4: synchronous method which expects response 228 | if(z) if(1==msg_type && 0==type) ksender(j,z,2); 229 | cd(z); z=0; } 230 | R z; 231 | cleanup: 232 | close_tape(i,j); 233 | R (K)-1; 234 | } 235 | -------------------------------------------------------------------------------- /src/kn.h: -------------------------------------------------------------------------------- 1 | K ci(K a); 2 | K* denameS(S dir_string, S t, I create); 3 | K vf_ex(V q,K g); 4 | S CSK(K x); 5 | K X(S s); 6 | I ksender(I sockfd,K y,I t); 7 | K _db(K x); 8 | K newK(I t,I n); 9 | extern fd_set master; 10 | K cd(K a); 11 | I wipe_tape(I i); 12 | void *get_in_addr(struct sockaddr *sa); 13 | extern pthread_mutex_t execute_mutex; 14 | extern S HTTP_PORT; 15 | K _n(); 16 | extern C errmsg[256]; 17 | K Ki(I); 18 | I bswapI(I n); 19 | void dm1(S msg,M1*m); 20 | I oerr(); 21 | K read_tape(I i,I j,I type); 22 | extern M0 CP[FD_SETSIZE+1]; 23 | -------------------------------------------------------------------------------- /src/ko.c: -------------------------------------------------------------------------------- 1 | /* K object management */ 2 | 3 | #include "incs.h" 4 | 5 | #include "k.h" 6 | #include "km.h" 7 | #include "ko.h" 8 | 9 | Z I w=0; 10 | K _kclone(K a); 11 | K kcloneI(K a,cS f,int n){ 12 | if(w)O("kclone %s:%d ",f,n); 13 | R _kclone(a);} 14 | K _kclone(K a)//Deep copy -- eliminate where possible 15 | { 16 | if(!a) R 0; 17 | I t=a->t,n=a->n; 18 | K z= 7==t?Kv():newK(-5==t?-1:t,n);z->t=t; 19 | if (4==ABS(t)) DO(n, kS(z)[i]=kS(a)[i]) //memcpy everywhere is better 20 | else if(3==ABS(t)) DO(n, kC(z)[i]=kC(a)[i]) 21 | else if(2==ABS(t)) DO(n, kF(z)[i]=kF(a)[i]) 22 | else if(-5==t||1==ABS(t)) DO(n, kI(z)[i]=kI(a)[i]) 23 | else if(0== t ) DO(n, kK(z)[i]=_kclone(kK(a)[i])) 24 | else if(5== t ) DO(n, kK(z)[i]=_kclone(kK(a)[i])) 25 | else if(7== t ) 26 | { 27 | I k=0; 28 | 29 | z->t=a->t; 30 | I vt=z->n = a->n; 31 | K kv=0; 32 | 33 | V*v; 34 | SW(vt) 35 | { 36 | CS(1, k=((K)kV(a)[CODE])->n-1; 37 | M(z,kv=newK(-4,k+1)) 38 | v=(V*)kK(kv); 39 | //v[k]=0;//superfluous reminder 40 | DO(k, V w=kW(a)[i]; 41 | if(VA(w))v[i]=w; //TODO: is this ok for NAMES? see similar code in capture() 42 | else 43 | { 44 | K r=_kclone(*(K*)w); //oom 45 | V q=newE(LS,r); //oom 46 | kap((K*) kV(z)+LOCALS,&q);//oom 47 | cd(q);//kap does ci 48 | q=EVP(q); //oom free z etc. kap needs checking 49 | v[i]=q; 50 | } 51 | ) 52 | ) 53 | CS(2, M(z,kv=newK(-4,3)) 54 | v=(V*)kK(kv); 55 | memcpy(v,kW(a),sizeof(V)); 56 | ) 57 | CS(3,M(z,kv=_kclone((K)kV(a)[CODE]))) 58 | } 59 | kV(z)[CODE]=kv; 60 | kV(z)[DEPTH]=kV(a)[DEPTH]; 61 | kV(z)[CONTeXT]=kV(a)[CONTeXT]; 62 | cd(kV(z)[PARAMS]); kV(z)[PARAMS]=_kclone(kV(a)[PARAMS]); //oom ; fill instead of kclone? 63 | cd(kV(z)[LOCALS]); kV(z)[LOCALS]=_kclone(kV(a)[LOCALS]); //oom ; fill instead of kclone? 64 | kV(z)[CONJ]=_kclone(kV(a)[CONJ]); //oom 65 | } 66 | 67 | R z; 68 | } 69 | 70 | K collapse(K x) { //oom 71 | if(xt==1 && xn==1) R x; 72 | if(xt<0 && xn==1){xt=ABS(xt); R x;} 73 | K z; 74 | if(1==xn){ z=ci(*kK(x)); cd(x);} 75 | else z=demote(x); 76 | R z; 77 | } 78 | 79 | K delist(K x){K z=0,t=x; while(t->t==0 && t->n==1){z=*kK(t); t=z;} z=ci(t); cd(x); R z;} 80 | 81 | K demote(K a)//Attempt to force unnaturally occurring lists into vectors 82 | { // change: (0;1;2) -> 0 1 2 83 | // keep: (1;0.66667) //numerics are not reconciled as you might guess 84 | // change: (1) -> ,1 //doesn't solve parenthetical expressions offhand 85 | if(!a) R a; //dollar() uses this 86 | I t=a->t, n=a->n; 87 | if(0!=t || 1>n) R a; 88 | I p=kK(a)[0]->t; 89 | DO(n, if(p!=kK(a)[i]->t)p=0) 90 | if(!(1<=p && p <= 4))R a; 91 | K z=newK(-p,n); M(a,z) 92 | if (4==p)DO(n,kS(z)[i]=*kS(kK(a)[i])) //use memcpy instead 93 | else if(3==p)DO(n,kC(z)[i]=*kC(kK(a)[i])) 94 | else if(2==p)DO(n,kF(z)[i]=*kF(kK(a)[i])) 95 | else if(1==p)DO(n,kI(z)[i]=*kI(kK(a)[i])) 96 | cd(a); 97 | if(z->t==-1 && z->n==1) z->t=1; 98 | R z; 99 | } 100 | K promote(K a)//Identity on lists. Lists from vectors. Pseudo-enlist on atoms (always 0-lists). 101 | { //0 1 2 -> (0;1;2) 102 | I at=a->t; 103 | if(0==at) R ci(a); 104 | if(4< at) {K z=newK(0,1); U(z); *kK(z)=ci(a); R z;} 105 | K z=newK(0,a->n); U(z); 106 | K x; 107 | I v=ABS(at); 108 | if (4==v) DO(a->n, x=newK(v,1); M(x,z) *kS(x)=kS(a)[i]; kK(z)[i]=x ) 109 | else if(3==v) DO(a->n, x=newK(v,1); M(x,z) *kC(x)=kC(a)[i]; kK(z)[i]=x ) 110 | else if(2==v) DO(a->n, x=newK(v,1); M(x,z) *kF(x)=kF(a)[i]; kK(z)[i]=x ) 111 | else if(1==v) DO(a->n, x=newK(v,1); M(x,z) *kI(x)=kI(a)[i]; kK(z)[i]=x ) 112 | R z; 113 | } 114 | -------------------------------------------------------------------------------- /src/ko.h: -------------------------------------------------------------------------------- 1 | K at(K x,K y); 2 | K promote(K a); 3 | K demote(K a); 4 | K ci(K a); 5 | K collapse(K x); 6 | K delist(K x); 7 | K *EVP(K e); 8 | K cd(K a); 9 | K kap(K *a,V v); 10 | extern S LS; 11 | K newE(S s,K k); 12 | I VA(V p); 13 | K newK(I t,I n); 14 | K Kv(); 15 | K kcloneI(K a,const char*f,int n); 16 | #define kclone(a) kcloneI(a,__FILE__,__LINE__) 17 | -------------------------------------------------------------------------------- /src/kona.h: -------------------------------------------------------------------------------- 1 | #ifndef _KONA_H_ 2 | #define _KONA_H_ 3 | 4 | /* 5 | * Interface between C & K 6 | * atom functions/accessors: 7 | * list functions/accessors: 8 | * misc functions: ci, cd 9 | */ 10 | #ifdef __cplusplus 11 | extern "C" { 12 | #endif 13 | 14 | /* abbreviations */ 15 | #define O printf 16 | #define R return 17 | #define Z static 18 | 19 | /* types */ 20 | typedef void* V; 21 | typedef long long I; 22 | typedef double F; 23 | typedef char C; 24 | typedef C* S; 25 | typedef const C* cS; 26 | typedef unsigned char UC; 27 | typedef unsigned long UI; 28 | 29 | /* the main struct */ 30 | typedef struct k0{I c,t,n;struct k0*k[1];}*K; 31 | 32 | #define ke(x) (((K)x)->k) 33 | 34 | /* list accessors */ 35 | #define KI(x) ((I*)((x)->k)) 36 | #define KF(x) ((F*)((x)->k)) 37 | #define KC(x) ((UC*)((x)->k)) 38 | #define KS(x) ((S*)((x)->k)) 39 | #define KK(x) ((K*)((x)->k)) 40 | 41 | #define KV(x) ((V*)ke(x)) 42 | extern K kap(K*,V); 43 | 44 | /* atom accessors */ 45 | #define Ki(x) (*KI(x)) 46 | #define Kf(x) (*KF(x)) 47 | #define Kc(x) (*KC(x)) 48 | #define Ks(x) (*KS(x)) 49 | 50 | /* atom generators */ 51 | extern K gi(I); 52 | extern K gf(F); 53 | extern K gc(C); 54 | extern K gs(S); 55 | extern K gn(); 56 | 57 | /* list generators */ 58 | extern K gtn(I,I); 59 | extern K gsk(S,K); 60 | extern K gp(S); 61 | extern K gpn(S,I); 62 | extern K gnk(I,...); 63 | 64 | extern K kerr(S); 65 | 66 | /* Call k from c */ 67 | extern K ksk(S,K); 68 | extern I sfn(S,K(*)(),I); 69 | 70 | 71 | /* ref counting */ 72 | extern K ci(K); 73 | extern I cd(K); 74 | 75 | /* date conversion */ 76 | extern I jd(I); 77 | extern I dj(I); 78 | 79 | /* callbacks */ 80 | extern I sdf(I,I(*)()); 81 | extern I scd(I); 82 | 83 | extern S sp(S); 84 | 85 | #define DO(n,x) {I i,_n=(n);for(i=0;i<_n;++i){x;}} 86 | 87 | #ifdef __cplusplus 88 | } 89 | #endif 90 | 91 | #endif/*_KONA_H_*/ 92 | -------------------------------------------------------------------------------- /src/ks.c: -------------------------------------------------------------------------------- 1 | /* strings & string interning */ 2 | 3 | #include "incs.h" 4 | 5 | #include "k.h" 6 | #include "ks.h" 7 | 8 | Z I ns=0,sdd=0; 9 | // Z S sdup(S s){R strdupn(s,strlen(s));} //using this because "strdup" uses [used] dynamically linked malloc which fails with our static free 10 | Z S sdupI(S s){I k;S d=alloc(NSLOTS*sizeof(I)+(k=strlen(s))+1);if(!d)R 0;ns++;sdd=1;d+=NSLOTS*sizeof(I);d[k]=0;R memcpy(d,s,k);} 11 | S strdupn (S s,I k) {S d=alloc(k+1);if(!d)R 0;d[k]=0;R memcpy(d,s,k);} // mm/o (note: this can overallocate) 12 | //I SC0N(S a,S b,I n) {I x=memcmp(a,b,n); R x<0?-1:x>0?1:a[n]?1:0; }// non-standard way to compare aaa\0 vs aaa 13 | I strlenn(S s,I k){S t=memchr(s,'\0',k); R t?t-s:k;} 14 | 15 | I StoI(S s,I *n){S t; errno=0; *n=strtol(s,&t,10); R !(errno!=0||t==s||*t!=0);} 16 | 17 | I SC(S a,S b){I x=strcmp(a,b); R x<0?-1:x>0?1:0;}//String Compare: strcmp unfortunately does not draw from {-1,0,1} 18 | S sp(S k)//symbol from phrase: string interning, Ks(sp("aaa")). This should be called before introducing any sym to the instance 19 | { //We are using this to ensure any two 'character-identical' symbols are in fact represented by the same pointer S 20 | //See Knuth Algorithm 6.2.2T 21 | #define LINK(n,x) (n)->c[((x)+1)/2] // -1 => 0 , 1 => 1 22 | if(!k)R 0;//used in glue. used in _2m_4. used in parse. Probably a good argument to keep since it's exposed for libraries via 2: dyadic 23 | N t=SYMBOLS, s=t->c[1],p=s,q=p,r; I a,x; 24 | if(!s){s=t->c[1]=newN();P(!s,(S)ME);s->k=sdupI(k); if(!s->k){free(s);t->c[1]=0;ME;} R s->k;} // <-- strdup here and below 25 | while(q) 26 | { if(!(a=SC(k,p->k))){R p->k;}//In the usual tree put: p->k=k,p->v=v before returning 27 | if(!(q=LINK(p,a))){q=newN();P(!q,(S)ME);q->k=sdupI(k);if(!q->k){free(q);ME; R 0;} LINK(p,a)=q;break;}//Usual tree would q->v=v. mmo 28 | else if(q->b){t=p;s=q;} 29 | p=q; 30 | } 31 | a=0>SC(k,s->k)?-1:1; 32 | r=p=LINK(s,a); 33 | while(p!=q){x=SC(k,p->k); p->b=x;p=LINK(p,x);} 34 | if(!s->b){s->b=a;R p->k;} 35 | else if(s->b==-a){s->b=0; R p->k;} 36 | if(r->b==a){p=r; LINK(s,a)=LINK(r,-a); LINK(r,-a)=s; s->b=r->b=0;} 37 | else if(r->b==-a) 38 | { p=LINK(r,-a); LINK(r,-a)=LINK(p,a); 39 | LINK(p,a)=r; LINK(s,a)=LINK(p,-a); LINK(p,-a)=s; 40 | if (p->b== a){s->b=-a; r->b=0;} 41 | else if(p->b== 0){s->b= 0; r->b=0;} 42 | else if(p->b==-a){s->b= 0; r->b=a;} 43 | p->b=0; 44 | } 45 | t->c[s==t->c[1]?1:0]=p; 46 | R q->k; 47 | } 48 | 49 | //S spkC(K a){S u=strdupn(kC(a),a->n),v=sp(u);free(u);R v;} 50 | S spn(S s,I n){I k=0;while(kc[0],y,z); 55 | if(x->k&&SV(x->k,y)){I o=SV(x->k,y);SV(x->k,y)=z;z+=o;} 56 | R wleft(x->c[1],y,z); 57 | } 58 | I wright(N x,I y,I z) 59 | { 60 | if(!x)R z; 61 | z=wright(x->c[1],y,z); 62 | if(x->k&&SV(x->k,y)){I o=SV(x->k,y);SV(x->k,y)=z;z+=o;} 63 | R wright(x->c[0],y,z); 64 | } 65 | Z void ssI(N x,int y,I z){if(x){DO(2,ssI(x->c[i],y,z));if(x->k)SV(x->k,y)=z;}} 66 | void setS(int y,I z){ssI(SYMBOLS,y,z);} 67 | void OS(N x,I y) 68 | { 69 | if(!x)R; 70 | OS(x->c[0],y); 71 | if(x->k&&SV(x->k,y))O("%p: %lld\n",x->k,SV(x->k,y)); 72 | OS(x->c[1],y); 73 | } 74 | -------------------------------------------------------------------------------- /src/ks.h: -------------------------------------------------------------------------------- 1 | S spn(S s,I n); 2 | N newN(); 3 | extern N SYMBOLS; 4 | V alloc(size_t sz); 5 | S sp(S k); 6 | I SC(S a,S b); 7 | I StoI(S s,I *n); 8 | I strlenn(S s,I k); 9 | S strdupn(S s,I k); 10 | I gradeS(); 11 | K newK(I t,I n); 12 | K mergeGrade(K a,I r); 13 | void setS(int y,I z); 14 | I wleft(N x,I y,I z); 15 | I wright(N x,I y,I z); 16 | void OS(N x,I y); 17 | -------------------------------------------------------------------------------- /src/kx.h: -------------------------------------------------------------------------------- 1 | K of(K a,K b); 2 | K dot_tetradic_2(K *g,K b,K c,K y); 3 | extern S LS; 4 | K newE(S s,K k); 5 | extern V offsetSSR,offsetWhat,offsetAt,offsetDot,offsetColon,offset3m; 6 | extern I adverb_ct; 7 | extern V adverbs[]; 8 | extern S fBreak; 9 | extern I fCheck; 10 | K kap(K *a,V v); 11 | K itemAtIndex(K a,I i); 12 | K ex1(V *w,K k,I *i,I n,I f); 13 | K _n(); 14 | extern C errmsg[256]; 15 | I bk(V p); 16 | K wd_(S s,int n,K *dict,K func); 17 | K ex(K a); 18 | K DI(K d,I i); 19 | K kcloneI(K a,const char*f,int n); 20 | #define kclone(a) kcloneI(a,__FILE__,__LINE__) 21 | K Kv(); 22 | K dot_tetradic(K a,K b,K c,K y); 23 | K at_tetradic(K a,K b,K c,K y); 24 | K dot(K a,K b); 25 | K what_triadic(K a,K b,K c); 26 | K what(K x,K y); 27 | K eachpair(); 28 | K at(K x,K y); 29 | K demote(K a); 30 | K promote(K a); 31 | K eachleft(); 32 | K eachright(); 33 | K each(); 34 | K reverse(K a); 35 | K collapse(K x); 36 | K drop(K a,K b); 37 | I atomI(K a); 38 | K scan(); 39 | I matchI(K a,K b); 40 | K vf_ex(V q,K g); 41 | K cd(K a); 42 | I bp(I t); 43 | K newK(I t,I n); 44 | K first(K a); 45 | K Ki(I x); 46 | K Kf(F x); 47 | I VA(V p); 48 | K ci(K a); 49 | K enlist(K x); 50 | K join(K a,K b); 51 | K over(); 52 | I valence(V p); 53 | I sva(V p); 54 | I adverbClass(V p); 55 | K kerr(cS s); 56 | K last(K a); 57 | I kdefClass(I n); 58 | -------------------------------------------------------------------------------- /src/main.c: -------------------------------------------------------------------------------- 1 | #include "incs.h" 2 | #include "k.h" 3 | 4 | int main(int argc,S*argv) 5 | { 6 | kinit(); 7 | args(argc,argv); 8 | attend(); //loop on stdin/inet 9 | R 0; 10 | } 11 | -------------------------------------------------------------------------------- /src/mt.c: -------------------------------------------------------------------------------- 1 | #include "incs.h" 2 | 3 | //abridged. License BSD-style Takuji Nishimura & Makoto Matsumoto http://www.math.hiroshima-u.ac.jp/~m-mat/MT/emt.html 4 | //Before using, initialize the state by using init_genrand64(seed) 5 | //mt19937-64.c 6 | 7 | #define NN 312 8 | #define MM 156 9 | #define MATRIX_A 0xB5026F5AA96619E9ULL 10 | #define UM 0xFFFFFFFF80000000ULL // Most significant 33 bits 11 | #define LM 0x7FFFFFFFULL // Least significant 31 bits 12 | 13 | 14 | static unsigned long long mt[NN]; // The array for the state vector 15 | static int mti=NN+1; // mti==NN+1 means mt[NN] is not initialized 16 | 17 | void init_genrand64(unsigned long long seed) // initializes mt[NN] with a seed 18 | { 19 | mt[0] = seed; 20 | for (mti=1; mti> 62)) + mti); 22 | } 23 | 24 | // generates a random number on [0, 2^64-1]-interval 25 | unsigned long long genrand64_int64(void) 26 | { 27 | int i; 28 | unsigned long long x; 29 | static unsigned long long mag01[2]={0ULL, MATRIX_A}; 30 | 31 | if (mti >= NN) { // generate NN words at one time 32 | 33 | // if init_genrand64() has not been called, 34 | // a default initial seed is used 35 | if (mti == NN+1) 36 | init_genrand64(5489ULL); 37 | 38 | for (i=0;i>1) ^ mag01[(int)(x&1ULL)]; 41 | } 42 | for (;i>1) ^ mag01[(int)(x&1ULL)]; 45 | } 46 | x = (mt[NN-1]&UM)|(mt[0]&LM); 47 | mt[NN-1] = mt[MM-1] ^ (x>>1) ^ mag01[(int)(x&1ULL)]; 48 | 49 | mti = 0; 50 | } 51 | 52 | x = mt[mti++]; 53 | 54 | x ^= (x >> 29) & 0x5555555555555555ULL; 55 | x ^= (x << 17) & 0x71D67FFFEDA60000ULL; 56 | x ^= (x << 37) & 0xFFF7EEE000000000ULL; 57 | x ^= (x >> 43); 58 | 59 | return x; 60 | } 61 | 62 | // generates a random number on [0,1)-real-interval, 53-bit precision 63 | double genrand64_real2(void) { return (genrand64_int64() >> 11) * (1.0/9007199254740992.0); } 64 | 65 | 66 | 67 | -------------------------------------------------------------------------------- /src/mt.h: -------------------------------------------------------------------------------- 1 | double genrand64_real2(void); 2 | unsigned long long genrand64_int64(void); 3 | void init_genrand64(unsigned long long seed); 4 | -------------------------------------------------------------------------------- /src/p.h: -------------------------------------------------------------------------------- 1 | L charsAdverb(C c); 2 | extern V adverbs[]; 3 | extern I fbr; 4 | extern I feci; 5 | extern K sd_(K x,I f); 6 | extern K stopDict; 7 | extern I fStop; 8 | V alloc(size_t sz); 9 | L charsVerb(C c); 10 | I SC(S a,S b); 11 | K *denameS(S dir_string,S t,I create); 12 | K EV(K e); 13 | K newEntry(S s); 14 | extern V vn_[]; 15 | K _n(); 16 | extern S n_s; 17 | S sp(S k); 18 | K formKfCS(S s); 19 | K formKiCS(S s); 20 | S strdupn(S s,I k); 21 | extern S IFP[3]; 22 | K DE(K d,S b); 23 | K Kd(); 24 | K kerr(cS s); 25 | K *EVP(K e); 26 | K *EAP(K e); 27 | K DI(K d,I i); 28 | K kap(K *a,V v); 29 | K ci(K a); 30 | extern S LS; 31 | K newE(S s,K k); 32 | I sva(V p); 33 | I adverbClass(V p); 34 | I bk(V p); 35 | extern V offsetSSR,offsetWhat,offsetAt,offsetDot,offsetColon; 36 | extern S param_dfa; 37 | I sz(I t,I n); 38 | I lsz(I k); 39 | I capture(S s,I n,I k,I *m,V *w,I *d,K *locals,K *dict,K func); 40 | K Kv(); 41 | K cd(K a); 42 | void pdafree(PDA p); 43 | K newK(I t,I n); 44 | K backslash(S s,I n,K*dict); 45 | extern S d_; 46 | extern K KTREE; 47 | K *denameD(K *d,S t,I create); 48 | K wd_(S s,int n,K *dict,K func); 49 | K wd(S s,int n); 50 | I maX(I a,I b); 51 | I mark(I *m,I k,I t); 52 | enum mark_members {MARK_UNMARKED,MARK_IGNORE,MARK_BRACKET,MARK_END,MARK_PAREN,MARK_BRACE,MARK_QUOTE,MARK_SYMBOL, 53 | MARK_NAME,MARK_NUMBER,MARK_VERB,MARK_ADVERB,MARK_CONDITIONAL,MARK_COUNT}; 54 | typedef enum mark_members mark_members; 55 | #define EXPORT_INTERFACE 0 56 | I isCharVerb(C c); 57 | I stringHasChar(S s,C c); 58 | C bottom(PDA p); 59 | C pop(PDA p); 60 | C peek(PDA p); 61 | I push(PDA p,C c); 62 | PDA newPDA(); 63 | I complete(S a,I n,PDA *q,I *marks); 64 | I parsedepth(PDA p); 65 | extern S right; 66 | extern S left; 67 | extern S formed_dfa; 68 | I charpos(S s,C c); 69 | K lookupEntryOrCreate(K *p,S k); 70 | I oerr(); 71 | -------------------------------------------------------------------------------- /src/r.h: -------------------------------------------------------------------------------- 1 | V alloc(size_t sz); 2 | K _kona_exit(K x); 3 | K _dot_t(); 4 | double genrand64_real2(void); 5 | I KC(K a,K b); 6 | I FC(F a,F b); 7 | K _m(); 8 | K _k(); 9 | K _a(); 10 | K _u(); 11 | K _w(); 12 | K _p(); 13 | K _s(); 14 | K _f(); 15 | K _i(); 16 | K _v(); 17 | extern S d_; 18 | K _d(); 19 | K _h(); 20 | extern K NIL; 21 | K _T(); 22 | extern I k_epoch_offset; 23 | K _t(); 24 | K _c(); 25 | K _ss(K a,K b); 26 | K demote(K a); 27 | K promote(K a); 28 | K _sm(K a,K b); 29 | K _setenv(K a,K b); 30 | K _lsq(K a,K b); 31 | C bottom(PDA p); 32 | K take_reshape(K a,K b); 33 | void vitter(I *a,I n,I N); 34 | F RF(); 35 | K _draw(K a,K b); 36 | K _bin(K x,K y); 37 | K Kf(F x); 38 | K _size(K a); 39 | I stat_sz(S u,I *n); 40 | K _ltime(K a); 41 | K _lt(K a); 42 | K _jd(K a); 43 | K _ic(K a); 44 | K kerr(cS s); 45 | S sp(S k); 46 | K Ks(S x); 47 | K Ki(I x); 48 | K _host(K a); 49 | K _n(); 50 | S CSK(K x); 51 | K _getenv(K a); 52 | K _dj(K a); 53 | K rrep(V v,V aft,I *b,I y,I s); 54 | K _db(K x); 55 | K _ci(K a); 56 | K floor_ceil(K a,F(*g)(F)); 57 | K _ceiling(K a); 58 | I wrep(K x,V v,I y); 59 | K _bd(K x); 60 | I rep(K x,I y); 61 | I net(K x); 62 | K _abs(K a); 63 | extern V vn_[]; 64 | extern S n_s; 65 | K at(K x,K y); 66 | K math(F(*f)(F),K a); 67 | K ci(K a); 68 | F sqr(F x); 69 | K dot(K a,K b); 70 | K X(S s); 71 | #if defined(DEBUG) 72 | extern I kreci; 73 | #endif 74 | K vf_ex(V q,K g); 75 | K newK(I t,I n); 76 | K cd(K a); 77 | extern K KFIXED; 78 | extern K KONA_ARGS; 79 | extern K KONA_WHO; 80 | extern K KONA_PORT; 81 | extern K KONA_GSET; 82 | extern K KONA_IDX; 83 | extern K KONA_CLIENT; 84 | K kap(K *a,V v); 85 | K _acos(K x); 86 | K _asin(K x); 87 | K _atan(K x); 88 | K _ceil(K x); 89 | K _cos(K x); 90 | K _cosh(K x); 91 | K _exp(K x); 92 | K _floor(K x); 93 | K _log(K x); 94 | K _sin(K x); 95 | K _sinh(K x); 96 | K _sqr(K x); 97 | K _sqrt(K x); 98 | K _tan(K x); 99 | K _tanh(K x); 100 | K _gtime(K x); 101 | K _inv(K x); 102 | K _binl(K x,K y); 103 | K _di(K x,K y); 104 | K _dot(K x,K y); 105 | K _dv(K x,K y); 106 | K _dvl(K x,K y); 107 | K _hat(K x,K y); 108 | K _in(K x,K y); 109 | K _lin(K x,K y); 110 | K _mul(K x,K y); 111 | K _sv(K x,K y); 112 | K _vs(K x,K y); 113 | K _vsx(K x,K y); 114 | K mstat(void); 115 | -------------------------------------------------------------------------------- /src/scalar.h: -------------------------------------------------------------------------------- 1 | #ifndef SCALAR_H 2 | #define SCALAR_H 3 | 4 | /* Init vars for scalar dyad */ 5 | #define SCALAR_INIT(maxt) \ 6 | I at=a->t, an=a->n, bt=b->t, bn=b->n; \ 7 | I type = MAX(ABS(at),ABS(bt)); \ 8 | P(at <= 0 && bt <= 0 && an != bn, LE) \ 9 | P(type > maxt, TE ) /* > allowed types? */ \ 10 | I zt=type; /* Starting at worst known type */ \ 11 | if(MIN(at,bt) < 1) zt=-zt; /* Plural? */ \ 12 | if(!at || !bt) zt=0; /* Generic list trumps */ \ 13 | I zn=at>0?bn:an; 14 | 15 | /* Macro case: N:N, 1:N, N:1 implicit looping for op */ 16 | #define SCALAR_OP_CASE(op, cres, ca, cb) \ 17 | if (an==bn) { DO(zn,cres [i]= op (ca [i], cb [i])) } \ 18 | else if (an==1) { DO(zn,cres [i]= op (ca [0], cb [i])) } \ 19 | else /* bn==1 */ { DO(zn,cres [i]= op (ca [i], cb [0])) } 20 | 21 | /* Scalar operator macro, with proper float/int/array treatment */ 22 | #define SCALAR_OP(op,verb) \ 23 | if (2==ABS(at) && 2==ABS(bt)) { SCALAR_OP_CASE(op,kF(z),kF(a),kF(b)) } \ 24 | else if (2==ABS(at) && 1==ABS(bt)) { SCALAR_OP_CASE(op,kF(z),kF(a),kI(b)) } \ 25 | else if (1==ABS(at) && 2==ABS(bt)) { SCALAR_OP_CASE(op,kF(z),kI(a),kF(b)) } \ 26 | else if (1==ABS(at) && 1==ABS(bt)) { SCALAR_OP_CASE(op,kI(z),kI(a),kI(b)) } \ 27 | else if (0==at || 0==bt) { dp(&z,verb,a,b); } 28 | 29 | /* Macro case: N:N, 1:N, N:1 implicit looping for expression */ 30 | #define SCALAR_EXPR_CASE(expr, cres, ca, cb, vx, vy) \ 31 | if (an==bn) { DO(zn, vx=ca [i];vy=cb [i]; expr); } \ 32 | else if (an==1) { vx=ca [0]; DO(zn, vy=cb [i]; expr); } \ 33 | else /* bn==1 */ { vy=cb [0]; DO(zn, vx=ca [i]; expr); } 34 | 35 | /* Scalar expression macro, with proper float/int/array treatment */ 36 | #define SCALAR_EXPR(expr,verb,vx,vy) \ 37 | if (2==ABS(at) && 2==ABS(bt)) { SCALAR_EXPR_CASE(expr,kF(z),kF(a),kF(b),vx,vy) } \ 38 | else if (2==ABS(at) && 1==ABS(bt)) { SCALAR_EXPR_CASE(expr,kF(z),kF(a),kI(b),vx,vy) } \ 39 | else if (1==ABS(at) && 2==ABS(bt)) { SCALAR_EXPR_CASE(expr,kF(z),kI(a),kF(b),vx,vy) } \ 40 | else if (1==ABS(at) && 1==ABS(bt)) { SCALAR_EXPR_CASE(expr,kI(z),kI(a),kI(b),vx,vy) } \ 41 | else if (0==at || 0==bt) { dp(&z,verb,a,b); } 42 | 43 | /* Macro case: N:N, 1:N, N:1 implicit looping for fun call, w/ optional suffix */ 44 | #define SCALAR_EXPR_FUN(fun, cres, ca, cb, post) \ 45 | if (an==bn) { DO(zn, cres [i]= fun (ca [i], cb [i]) post) } \ 46 | else if (an==1) { DO(zn, cres [i]= fun (ca [0], cb [i]) post) } \ 47 | else /* bn==1 */ { DO(zn, cres [i]= fun (ca [i], cb [0]) post) } 48 | 49 | #endif 50 | -------------------------------------------------------------------------------- /src/tests.h: -------------------------------------------------------------------------------- 1 | K _ceiling(K a); 2 | K _size(K a); 3 | K _abs(K a); 4 | K _bin(K x,K y); 5 | K _bd(K x); 6 | K _db(K x); 7 | K _jd(K a); 8 | K _f(); 9 | K _n(); 10 | V alloc(size_t sz); 11 | I test(); 12 | K cd(K a); 13 | K show(K a); 14 | I matchI(K a,K b); 15 | K X(S s); 16 | K Kd(); 17 | extern K KTREE; 18 | I SC(S a,S b); 19 | extern F testtime; 20 | extern I tests; 21 | extern I passed; 22 | extern I test_print; 23 | extern S lineB; 24 | extern I fom; 25 | extern I fbr; 26 | extern I fll; 27 | extern I fdc; 28 | extern __thread K cls; 29 | extern I feci; 30 | extern C cdp[]; 31 | I tc(S a,S b); 32 | I tp(I x); 33 | S ts(I x); 34 | 35 | #if defined(DEBUG) 36 | extern V krec[1000000]; 37 | extern I kreci; 38 | #endif 39 | -------------------------------------------------------------------------------- /src/ts.h: -------------------------------------------------------------------------------- 1 | #ifndef TS_H 2 | #define TS_H 3 | 4 | #ifdef IN 5 | #define OLD_IN IN 6 | #undef IN 7 | #endif 8 | 9 | #ifndef LLONG_MIN 10 | #include 11 | #define LLONG_MIN INT64_MIN 12 | #define LLONG_MAX INT64_MAX 13 | #endif 14 | 15 | #ifdef __x86_64__ 16 | typedef long long L; 17 | typedef unsigned long long UI; 18 | #else 19 | typedef long L; 20 | typedef unsigned long UI; 21 | #endif 22 | 23 | typedef void* V; 24 | typedef long long I; //there are cases where casting pointer arithmetic to signed int will fail 25 | typedef unsigned long long uI; 26 | typedef double F; 27 | typedef char C; //Store +-3 type '\0' terminated 28 | typedef C* S; 29 | typedef const C* cS; 30 | typedef unsigned char UC; 31 | typedef I veci __attribute__ ((vector_size (16))); 32 | typedef struct k0{I _c,t,n;struct k0*k[1];}*K; //main K object 33 | typedef struct m1{char a,b,c[sizeof(I)-3],d;I n;} M1; //inet sent message header. m.a?little-:big-endian,m.b is type???, m.d in {0,1,2}->{3:,4:,response}, m.n is size of nested K struct in bytes. c unknown, inserted [5] for 64b alignment 34 | typedef struct m0{M1 m1;I r;K k;I a;} M0; //r=read so far. a=remote client. inet message reader. there is probably a more elegant way to do this 35 | enum TYPE_SEVEN_MEMBERS {CONTeXT,DEPTH,CODE,LOCALS,PARAMS,CONJ,CACHE_WD,CACHE_TREE,TYPE_SEVEN_SIZE}; //sp(), code in {-4, -4, -4[3], -3, -4,-4,-4,-4}, Kd(), Kd(), Kv()/0-List-w/-NULLs 36 | //Executable types: t-n is 7-n for n in {0,1,2,3,4,5,6,7}: 0: list of unexecuted types, 1: [derived] verb, 2: dynamically loaded function, 3: brace function{}, 4: ":[]", 5: if[], 6: while[], 7: do[] 37 | #define NSLOTS 2 38 | typedef struct node{V k;I b;struct node *c[2];}Node;typedef Node*N;//Knuth's AVL tree 39 | typedef struct pda{I i,s,n;S c;}Pda;typedef Pda*PDA; //holds parse state. pos in input, state, stacklength, stack 40 | typedef struct af{ V verb_over; V verb_scan; V verb_eachpair; } AF; //Alternative/Adverb Functions 41 | typedef struct tr{ I adverbClass; I arity; V func; S text; AF alt_funcs; } TR; //Table Row for Dispatch Table 42 | #define ke(x) (((K)x)->k) 43 | #define kK(x) ke(x) 44 | #define kI(x) ((I*)ke(x)) 45 | #define kU(x) ((uI*)ke(x)) 46 | #define kF(x) ((F*)ke(x)) 47 | #define kC(x) ((C*)ke(x))//Chars/Char-strings (+3/-3) must have a terminal '\0' (uncounted), but may also contain them 48 | #define kS(x) ((S*)ke(x))//Symbol pointers to interned strings ending at the first '\0' 49 | #define SV(x,y) (((I*)(x))[-(y)]) 50 | #define kV(x) ((V*)ke(x)) 51 | #define kVC(x) ((K)kV(x)[CODE]) 52 | #define kW(x) ((V*)kS(kVC(x))) 53 | #define II LLONG_MAX //I Infinity (Use -II for I Negative Infinity) 54 | #define IN LLONG_MIN //I Null (one less than -II) 55 | #define FI (1/0.) //IEEE should work everywhere 56 | #define FN (0/0.) //Alternate takes can be found in Arthur's "k.h" 57 | #define I2F(x) (II==(x)?FI:-II==(x)?-FI:IN==(x)?FN:(x)) 58 | #define Z static 59 | #define O printf 60 | #define R return 61 | #define xt x->t 62 | #define xn x->n 63 | #define yt y->t 64 | #define yn y->n 65 | #define DO(n,x) {I i=0,_i=(n);for(;i<_i;++i){x;}} 66 | #define DO2(n,x){I j=0,_j=(n);for(;j<_j;++j){x;}} 67 | #define DO3(n,x){I k=0,_k=(n);for(;k<_k;++k){x;}} 68 | #define CS(n,x) case n:x;break; 69 | #define CSR(n,x) case n:x; 70 | #define AE(x) (sizeof(x)/sizeof(x[0])) 71 | #define SW switch 72 | #define CD default 73 | #define diff(x,y) (((V*)(x)) - (V*)(y)) 74 | #define in(x,y) ((size_t)diff(x,y) < AE(y)) 75 | #define ABS(x) ((x) < 0 ? -(x) : (x)) 76 | #define SIGN(x) ((x) < 0 ? -(1) : (1)) 77 | 78 | #ifndef MAX 79 | #define MAX(a, b) (((a) > (b)) ? (a) : (b)) 80 | #endif 81 | 82 | #ifndef MIN 83 | #define MIN(a, b) (((a) < (b)) ? (a) : (b)) 84 | #endif 85 | 86 | #define _(...) X(#__VA_ARGS__) 87 | #define GC goto cleanup 88 | #define STDIN fileno(stdin) 89 | #define STDOUT fileno(stdout) 90 | 91 | #define P(x,y) {if(x)R(y);} 92 | #define U(x) P(!(x),0) 93 | #define M(...) U(OOM_CD(0,__VA_ARGS__,(V)-1)) //0 in (...)? cd(...), R 0; Alternative to "goto cleanup", precursor to oom-handler in memory-manager 94 | #define SE kerr(strerror(errno)) // not-reentrant, use strerror_r 95 | #define ME kerr("wsfull") //In general only directly allocating functions should call this 96 | #define TE kerr("type") //see http://kx.com/a/k/document/error.txt 97 | #define VE kerr("valence") 98 | #define PE kerr("parse") 99 | #define IE kerr("int") 100 | #define BE kerr("break") 101 | #define XE kerr("index") 102 | #define LE kerr("length") 103 | #define RE kerr("rank") 104 | #define NE kerr("nonce") 105 | #define FE kerr("file") 106 | #define UE kerr("munmap") 107 | #define WE kerr("write") 108 | #define DOE kerr("domain") 109 | #define SYE kerr("syntax") 110 | #define NYI kerr("nyi") 111 | #define LMT kerr("limit") 112 | #define VLE kerr("value") 113 | 114 | #define RTIME(d,...) {d=clock();{__VA_ARGS__;}d=(clock()-d)/CLOCKS_PER_SEC;} 115 | #define TIME(...) {F d; RTIME(d,__VA_ARGS__); O("Elapsed:%.7f\n",d);} 116 | #define dump(x, fmt) {fprintf(stderr, "%s:%u: %s=" fmt "\n", __FILE__, __LINE__, #x, x);} 117 | #define dd(x) dump((I)x,"%lld") 118 | #define er(x) {fprintf(stderr, "%s:%u: %s\n",__FILE__, __LINE__, #x);} 119 | 120 | #ifndef WIN32 121 | #define __thread 122 | #endif 123 | 124 | #endif 125 | -------------------------------------------------------------------------------- /src/v.h: -------------------------------------------------------------------------------- 1 | V alloc(size_t sz); //km.c 2 | K rotate(K x,K y); //vg.c 3 | K dot_tetradic(K x,K y,K z,K w); //vd.c 4 | K collapse(K x); //ko.c 5 | K of(K x, K y); //vd.c 6 | extern V offsetSSR,offsetWhat,offsetAt,offsetDot,offsetColon; //k.c 7 | extern K KTREE; //k.c 8 | K wd_(S s,int n,K*dict,K func); //p.c 9 | -------------------------------------------------------------------------------- /src/va.c: -------------------------------------------------------------------------------- 1 | #include "incs.h" 2 | #include "scalar.h" 3 | #include "k.h" 4 | #include "r.h" 5 | #include "vc.h" 6 | 7 | #include "va.h" 8 | 9 | /* scalar arithmetic verbs */ 10 | 11 | #ifdef K3_ARITH 12 | 13 | F kpow(F a,F b) 14 | { 15 | if(isnan(a))a=0.; 16 | if(isnan(b)){ 17 | if(FC(a,0.))R FN; 18 | b=0; 19 | }else if(isinf(b)&&!FC(a,1.))R FN; 20 | if(!FC(b,0.))R isinf(a)?FN:1.; 21 | else if(!FC(a,0.))R 0.; 22 | R pow(a,b); 23 | } 24 | 25 | #endif 26 | 27 | K power(K a, K b) 28 | { 29 | I at=a->t, an=a->n, bt=b->t, bn=b->n; 30 | I type = MAX(ABS(at),ABS(bt)); 31 | 32 | P(at <= 0 && bt <= 0 && an != bn, LE) 33 | P(type > 2, TE); 34 | 35 | I zt=type; 36 | if(MIN(at,bt) < 1) zt=-zt; 37 | if(!at || !bt) zt=0; 38 | if(1==zt*zt)zt*=2; 39 | I zn=at>0?bn:an; 40 | K z=newK(zt,zn); U(z) 41 | 42 | #ifndef K3_ARITH 43 | F x,y; 44 | //K3.2 silently yields 0n for -3^0.5 , even though some Kx documentation says domain error. 45 | #define FPOWER kF(z)[i]=(0==y)?1:(0==x)?0:pow(x,y); //x^0==1; 0^y==0 for y!=0; rest should be same as pow 46 | SCALAR_EXPR(FPOWER,power,x,y) 47 | #undef FPOWER 48 | #else 49 | #define KPOW_FI(x,y) kpow(x,I2F(y)) 50 | #define KPOW_IF(x,y) kpow(I2F(x),y) 51 | #define KPOW_II(x,y) kpow(I2F(x),I2F(y)) 52 | if(2==ABS(at)&&2==ABS(bt)){ SCALAR_OP_CASE(kpow,kF(z),kF(a),kF(b)) } 53 | else if(2==ABS(at)&&1==ABS(bt)){ SCALAR_OP_CASE(KPOW_FI,kF(z),kF(a),kI(b)) } 54 | else if(1==ABS(at)&&2==ABS(bt)){ SCALAR_OP_CASE(KPOW_IF,kF(z),kI(a),kF(b)) } 55 | else if(1==ABS(at)&&1==ABS(bt)){ SCALAR_OP_CASE(KPOW_II,kF(z),kI(a),kI(b)) } 56 | else if(0==at||0==bt){ dp(&z,power,a,b); } 57 | #endif 58 | R z; 59 | } 60 | 61 | K plus(K a, K b) //compare plus() to times() or minus() 62 | { 63 | SCALAR_INIT(2) 64 | K z=newK(zt,zn);U(z) //Finally, we know what we're going to make 65 | 66 | #define PLUS(x, y) ((x) + (y)) 67 | #ifndef K3_ARITH 68 | SCALAR_OP(PLUS,plus) 69 | #else 70 | #define PLUS_FI(x, y) ((x) + I2F(y)) 71 | #define PLUS_IF(x, y) (I2F(x) + (y)) 72 | if(2==ABS(at)&&2==ABS(bt)){ SCALAR_OP_CASE(PLUS,kF(z),kF(a),kF(b)) } 73 | else if(2==ABS(at)&&1==ABS(bt)){ SCALAR_OP_CASE(PLUS_FI,kF(z),kF(a),kI(b)) } 74 | else if(1==ABS(at)&&2==ABS(bt)){ SCALAR_OP_CASE(PLUS_IF,kF(z),kI(a),kF(b)) } 75 | else if(1==ABS(at)&&1==ABS(bt)){ SCALAR_OP_CASE(PLUS,kI(z),kI(a),kI(b)) } 76 | else if(0==at||0==bt){ dp(&z,plus,a,b); } 77 | #undef PLUS_FI 78 | #undef PLUS_IF 79 | #endif 80 | #undef PLUS 81 | 82 | R z; 83 | } 84 | 85 | K times(K a, K b)//TODO: Float results will respect intermediate OI or Oi. Other functions too. (& casts.) 86 | { 87 | SCALAR_INIT(2) 88 | K z=newK(zt,zn);U(z) 89 | 90 | #define TIMES(x, y) ((x) * (y)) 91 | #ifndef K3_ARITH 92 | SCALAR_OP(TIMES,times) 93 | #else 94 | #define TIMES_FI(x, y) ((x) * I2F(y)) 95 | #define TIMES_IF(x, y) (I2F(x) * (y)) 96 | if(2==ABS(at)&&2==ABS(bt)){ SCALAR_OP_CASE(TIMES, kF(z),kF(a),kF(b)) } 97 | else if(2==ABS(at)&&1==ABS(bt)){ SCALAR_OP_CASE(TIMES_FI,kF(z),kF(a),kI(b)) } 98 | else if(1==ABS(at)&&2==ABS(bt)){ SCALAR_OP_CASE(TIMES_IF,kF(z),kI(a),kF(b)) } 99 | else if(1==ABS(at)&&1==ABS(bt)){ SCALAR_OP_CASE(TIMES, kI(z),kI(a),kI(b)) } 100 | else if(0==at||0==bt){ dp(&z,times,a,b); } 101 | #undef TIMES_FI 102 | #undef TIMES_IF 103 | #endif 104 | #undef TIMES 105 | 106 | R z; 107 | } 108 | 109 | K _dot(K a,K b) 110 | { 111 | SCALAR_INIT(2); 112 | I A=ABS(at),B=ABS(bt); 113 | I accI=0;F accF=0.0; 114 | #define DOT_F accF+=x*y 115 | #define DOT_FI accF+=x*I2F(y) 116 | #define DOT_IF accF+=I2F(x)*y 117 | #define DOT_I accI+=x*y 118 | if(2==A&&2==B){ F x,y; SCALAR_EXPR_CASE(DOT_F, F,kF(a),kF(b),x,y) } 119 | else if(2==A&&1==B){ F x;I y; SCALAR_EXPR_CASE(DOT_FI,F,kF(a),kI(b),x,y) } 120 | else if(1==A&&2==B){ I x;F y; SCALAR_EXPR_CASE(DOT_IF,F,kI(a),kF(b),x,y) } 121 | else if(1==A&&1==B){ I x,y; SCALAR_EXPR_CASE(DOT_I, I,kI(a),kI(b),x,y) } 122 | else if(0==A||0==B){ 123 | V p[]={0,(V)0x16}; 124 | K x,y=overDyad(0,p+2,(x=times(a,b))); cd(x); 125 | R y; 126 | } 127 | R 1==ABS(zt)?Ki(accI):Kf(accF); 128 | } 129 | 130 | K mod(K a, K b) //In K4: {x-y*x div y} 131 | { 132 | I at=a->t, an=a->n, bt=b->t; 133 | P(ABS(at) > 2,TE) 134 | //Know bt in 1,2 and at in -2,-1,0,1,2 135 | I t=(0==at)?0:MAX(ABS(at),ABS(bt))*(at>0?1:-1); 136 | 137 | K z=newK(t,an); U(z) 138 | I c,d,e; F f,g,h; 139 | #if __INT_MAX__ == 2147483647 140 | F ct=1e-13; // Comparison tolerance for 32 bit 141 | #else 142 | F ct=0; // Not needed for 64 bit 143 | #endif 144 | #define FMOD h=g?f-g*floor(ct+f/g):f; kF(z)[i]=(ABS(h)>ct)?h:0; 145 | if (2==ABS(at) && 2==bt) { g=*kF(b); DO(an, f=kF(a)[i]; FMOD) } 146 | else if(2==ABS(at) && 1==bt) { g=*kI(b); DO(an, f=kF(a)[i]; FMOD) } 147 | else if(1==ABS(at) && 2==bt) { g=*kF(b); DO(an, f=kI(a)[i]; FMOD) } 148 | else if(1==ABS(at) && 1==bt) 149 | { 150 | g=d=*kI(b); 151 | // K 2.91, K 3.2: the sign of result = sign of b 152 | DO(an, c=kI(a)[i]; e=d?c-d*floor(c/g):c; kI(z)[i]=e) 153 | // if(d>0) DO(an, c=kI(a)[i]; e=d?c-d*(c%d):c; kI(z)[i]=e) 154 | // else DO(an, c=kI(a)[i]; e=d?c-d*floor(c/(F)d):c; kI(z)[i]=e) //TODO: casting to F is slow/wrong for big#. NB: floor does not equal truncate for negatives 155 | 156 | } 157 | else if(0==at) DO(an, if(!(kK(z)[i]=mod(kK(a)[i],b))){cd(z);R 0;}) 158 | R z; 159 | } 160 | 161 | K minus(K a, K b) 162 | { 163 | SCALAR_INIT(2) 164 | K z=newK(zt,zn);U(z) 165 | 166 | #define MINUS(x, y) ((x) - (y)) 167 | #ifndef K3_ARITH 168 | SCALAR_OP(MINUS,minus) 169 | #else 170 | #define MINUS_FI(x, y) ((x) - I2F(y)) 171 | #define MINUS_IF(x, y) (I2F(x) - (y)) 172 | if(2==ABS(at)&&2==ABS(bt)){ SCALAR_OP_CASE(MINUS,kF(z),kF(a),kF(b)) } 173 | else if(2==ABS(at)&&1==ABS(bt)){ SCALAR_OP_CASE(MINUS_FI,kF(z),kF(a),kI(b)) } 174 | else if(1==ABS(at)&&2==ABS(bt)){ SCALAR_OP_CASE(MINUS_IF,kF(z),kI(a),kF(b)) } 175 | else if(1==ABS(at)&&1==ABS(bt)){ SCALAR_OP_CASE(MINUS,kI(z),kI(a),kI(b)) } 176 | else if(0==at||0==bt){ dp(&z,minus,a,b); } 177 | #undef MINUS_FI 178 | #undef MINUS_IF 179 | #endif 180 | #undef MINUS 181 | 182 | R z; 183 | } 184 | 185 | K negate(K x){K y,z; U(y=Ki(0)) z=minus(y,x); cd(y); R z;} //TODO: probably implemented using negation vector operations 186 | 187 | K divide(K a, K b)//NB: Integral values promoted to float 188 | { 189 | SCALAR_INIT(2) 190 | //if(1==zt*zt)zt*=2;//don't do because I%I is now I 191 | //if(zt==1)zt=2; 192 | K z=newK(zt,zn);U(z) 193 | 194 | F u,d,y=FI;//nUmerator, Denominator, infinitY 195 | //TODO:nulls;is it necessary to check for inf? IEEE may handle it already everywhere 196 | //TODO: ensure that 1/inf==0 and 1/-inf ==0 197 | 198 | I s,t,w=II; 199 | if(1==ABS(at) && 1==ABS(bt))//save I from being cast to F for greater accuracy 200 | { if (an==bn) { DO(zn,s= kI(a)[i];t=kI(b)[i];kI(z)[i]=!t?!s?IN:s>0?w:-w:s/t)} 201 | else if (an==1) { DO(zn,s= kI(a)[0];t=kI(b)[i];kI(z)[i]=!t?!s?IN:s>0?w:-w:s/t)} 202 | else /* bn==1 */ { DO(zn,s= kI(a)[i];t=kI(b)[0];kI(z)[i]=!t?!s?IN:s>0?w:-w:s/t)} 203 | R z; } 204 | 205 | #define FDIVIDE kF(z)[i]=!d?!u?FN:u>0?y:-y:u/d //0/0=FN, 1/0=oo, -1/0=-oo, 1/2=0.5 206 | SCALAR_EXPR(FDIVIDE,divide,u,d) 207 | 208 | R z; 209 | } 210 | 211 | K reciprocal(K x){K y,z; U(y=Kf(1)) z=divide(y,x); cd(y); R z;} 212 | 213 | K min_and(K a, K b) 214 | { 215 | SCALAR_INIT(2) 216 | K z=newK(zt,zn);U(z) 217 | SCALAR_OP(MIN,min_and) 218 | R z; 219 | } 220 | 221 | K max_or(K a, K b) 222 | { 223 | SCALAR_INIT(2) 224 | K z=newK(zt,zn);U(z) 225 | 226 | SCALAR_OP(MAX,max_or) 227 | 228 | R z; 229 | } 230 | 231 | K floor_ceil(K a, F(*g)(F)) 232 | { 233 | if(strcmp(errmsg,"(nil)"))R (K)0; 234 | I at=a->t, an=a->n; 235 | F(*h)(F)=g==ceil?floor:ceil; 236 | P(2t),TE) 237 | if(1==ABS(at))R ci(a); 238 | 239 | //TODO: oom 240 | K z=newK(at?SIGN(at):0,an);//Compress F {-2,2} into I {-1,1} 241 | F e,f;I r; 242 | if(2==ABS(at))DO(an, e=kF(a)[i]; if(isnan(e))r=IN;else if(isinf(e)||e<=-II||e>=II)r=e<0?-II:II;else {f=FF(e); r=(f>0&&!FC(f,1))||(f<0&&!FC(f,0))?h(e):g(e);} kI(z)[i]=r) 243 | else if(!at) DO(an, kK(z)[i]=floor_ceil(kK(a)[i],g)) 244 | R z; 245 | } 246 | 247 | K floor_verb(K a){R floor_ceil(a,floor);}//K3.2 "_ -5 + 1.0 * 1 + -OI" yields -0I not Domain Error 248 | -------------------------------------------------------------------------------- /src/va.h: -------------------------------------------------------------------------------- 1 | K floor_verb(K a); 2 | I FC(F a,F b); 3 | F FF(F f); 4 | K ci(K a); 5 | K floor_ceil(K a,F(*g)(F)); 6 | K max_or(K a,K b); 7 | K min_and(K a,K b); 8 | K Kf(F x); 9 | K reciprocal(K x); 10 | K divide(K a,K b); 11 | K Ki(I x); 12 | K negate(K x); 13 | K minus(K a,K b); 14 | K cd(K a); 15 | K mod(K a,K b); 16 | K times(K a,K b); 17 | K plus(K a,K b); 18 | K newK(I t,I n); 19 | K at(K x,K y); 20 | K power(K a,K b); 21 | K overDyad(K a,V*p,K b); 22 | extern C errmsg[256]; 23 | -------------------------------------------------------------------------------- /src/vc.c: -------------------------------------------------------------------------------- 1 | #include "incs.h" 2 | #include "scalar.h" 3 | #include "k.h" 4 | #include "km.h" 5 | #include "ko.h" 6 | #include "vc.h" 7 | 8 | /* FC utility */ 9 | I FC_IF(I a,F b){ R FC(I2F(a),b); } 10 | I FC_FI(F a,I b){ R FC(a,I2F(b)); } 11 | 12 | /* comparison verbs */ 13 | 14 | Z K lessmore(K a,K b,I x); 15 | 16 | K dp(K*z,K(*f)(K,K),K x,K y) //dyad promote 17 | { 18 | x=promote(x); y=promote(y); 19 | M(x,y,*z) 20 | DO((*z)->n, if(!(kK(*z)[i]=f(kK(x)[i%xn],kK(y)[i%y->n]))){cd(*z);*z=TE;break;}) //TODO: optimization: remove these modulo % operations 21 | cd(x);cd(y); 22 | R 0; 23 | } 24 | 25 | K equals(K a, K b) 26 | { 27 | I at=a->t, an=a->n, bt=b->t, bn=b->n; 28 | if(at <=0 && bt <= 0 && an != bn) R LE; 29 | I AT=ABS(at), BT=ABS(bt); 30 | if(4=AT && 2>=BT) && !(3==AT && 3==BT) && !(4==AT && 4==BT) ) R TE; 33 | I t= (!at||!bt)?0:MIN(at,bt)<0?-1:1;//Any 0-list? Zero. Any vector? -1. Both atoms? 1. 34 | I zn=at>0?bn:an; 35 | K z=newK(t,zn); //oom 36 | #define EQ(x, y) (x) == (y) 37 | if (2==AT && 2==BT) { SCALAR_EXPR_FUN(FC, kI(z), kF(a), kF(b), ?0:1) 38 | DO(zn, if(kF(a)[i]!=kF(a)[i] && kF(b)[i]!=kF(b)[i]) kI(z)[i]=1)} 39 | else if(2==AT && 1==BT) SCALAR_EXPR_FUN(FC_FI, kI(z), kF(a), kI(b), ?0:1) 40 | else if(1==AT && 2==BT) SCALAR_EXPR_FUN(FC_IF, kI(z), kI(a), kF(b), ?0:1) 41 | else if(1==AT && 1==BT) SCALAR_OP_CASE(EQ, kI(z), kI(a), kI(b)) 42 | else if(3==AT && 3==BT) SCALAR_OP_CASE(EQ, kI(z), kC(a), kC(b)) 43 | else if(4==AT && 4==BT) SCALAR_OP_CASE(EQ, kI(z), kS(a), kS(b)) //works because of interning 44 | else if(0==at || 0==bt) dp(&z,equals,a,b); 45 | #undef EQ 46 | R z; 47 | } 48 | 49 | I matchI(K a, K b) 50 | { 51 | if(!a||!b)R 0;//Using this in over adverb type stuff 52 | I at=a->t, an=a->n, bt=b->t, bn=b->n; 53 | I AT=ABS(at), BT=ABS(bt); 54 | K *c,*d; 55 | //if(an!=bn || (at!=bt && !(1==AT && 2==BT) && !(2==AT && 1==BT)))R 0; // 0 ~ 1.0 ~ 1 56 | if(an!=bn || at!=bt) R 0; 57 | if(4==AT)DO(an, if(kS(a)[i]!=kS(b)[i]) R 0 ) 58 | if(3==AT)DO(an, if(kC(a)[i]!=kC(b)[i]) R 0 ) 59 | if(2==AT && 2==BT)DO(an, if(FC(kF(a)[i],kF(b)[i])) R 0 ) 60 | //if(2==AT && 1==BT)DO(an, if(FC(kF(a)[i],kI(b)[i])) R 0 ) 61 | //if(1==AT && 2==BT)DO(an, if(FC(kI(a)[i],kF(b)[i])) R 0 ) 62 | if(1==AT && 1==BT)DO(an, if(kI(a)[i]!=kI(b)[i]) R 0 ) 63 | if(0==AT || 5==AT)DO(an, if(!matchI(kK(a)[i],kK(b)[i]))R 0)//Dictionary keys are ordered sets 64 | if(7==AT) 65 | { 66 | if(a->n!=b->n) R 0; 67 | 68 | switch(a->n) 69 | { 70 | CS(1, 71 | an=kVC(a)->n-1; 72 | bn=kVC(b)->n-1; 73 | if(an!=bn) R 0; 74 | DO(an, c=kW(a)[i];d=kW(b)[i]; if(VA(c)||VA(d)){if(c!=d) R 0;} else if(!matchI(*c,*d)) R 0) //TODO: Projection (up above?) 75 | ) 76 | CS(2, )//TODO 77 | CS(3, if(kV(a)[CONTeXT] != kV(b)[CONTeXT])R 0; R matchI(kV(a)[CODE],kV(b)[CODE])) //TODO: Projection (up above?) 78 | } 79 | } 80 | R 1; 81 | } 82 | 83 | K match(K a, K b){R Ki(matchI(a,b));} 84 | 85 | Z K lessmore(K a, K b, I x) 86 | { 87 | if(!x && 0!=b->t){K c=a;a=b;b=c;} 88 | //NB: If primitives modify a but not b (or vice-versa. e.g. reuse of refcount 1 objects) 89 | //this should be reviewed. in q it can effect dicts (borror). see backup for unfactored ver. 90 | I at=a->t, an=a->n, bt=b->t, bn=b->n; 91 | if(at <=0 && bt <= 0 && an != bn) R LE; 92 | I AT=ABS(at), BT=ABS(bt); 93 | if(4=AT && 2>=BT) && !(3==AT && 3==BT) && !(4==AT && 4==BT) ) R TE; 96 | I t= (!at||!bt)?0:MIN(at,bt)<0?-1:1;//Any 0-list? Zero. Any vector? -1. Both atoms? 1. 97 | I zn=at>0?bn:an; 98 | K z=newK(t,zn); 99 | U(z) 100 | I*h=kI(z); 101 | 102 | if(0==at || 0==bt) 103 | { 104 | a=promote(a); b=promote(b); //copy-pasted from dp() 105 | M(a,b,z); 106 | DO(zn, if(!(kK(z)[i]=lessmore(kK(a)[i%an],kK(b)[i%b->n],x))){cd(z);z=ME;break;}) 107 | cd(a);cd(b); 108 | } 109 | else 110 | { 111 | #define GT(x, y) (x) > (y) 112 | if (2==AT && 2==BT) SCALAR_EXPR_FUN(FC, h, kF(a), kF(b), >0) 113 | else if(2==AT && 1==BT) SCALAR_EXPR_FUN(FC_FI, h, kF(a), kI(b), >0) 114 | else if(1==AT && 2==BT) SCALAR_EXPR_FUN(FC_IF, h, kI(a), kF(b), >0) 115 | else if(1==AT && 1==BT) SCALAR_OP_CASE(GT, kI(z), kI(a), kI(b)) 116 | else if(3==AT && 3==BT) SCALAR_OP_CASE(GT, kI(z), kC(a), kC(b)) 117 | else if(4==AT && 4==BT) {SCALAR_EXPR_FUN(SC, h, kS(a), kS(b), >0)} 118 | #undef GT 119 | } 120 | 121 | R z; 122 | } 123 | 124 | K less(K a, K b){R lessmore(a,b,0);} 125 | K more(K a, K b){R lessmore(a,b,1);} 126 | -------------------------------------------------------------------------------- /src/vc.h: -------------------------------------------------------------------------------- 1 | K dp(K*z,K(*f)(K,K),K x,K y); 2 | K more(K a,K b); 3 | K less(K a,K b); 4 | I SC(S a,S b); 5 | K Ki(I x); 6 | K match(K a,K b); 7 | I VA(V p); 8 | I matchI(K a,K b); 9 | I FC(F a,F b); 10 | K newK(I t,I n); 11 | K at(K x,K y); 12 | K equals(K a,K b); 13 | K cd(K a); 14 | K promote(K a); 15 | -------------------------------------------------------------------------------- /src/vd.c: -------------------------------------------------------------------------------- 1 | #include "incs.h" 2 | 3 | #include "k.h" 4 | #include "km.h" 5 | #include "p.h" 6 | #include "r.h" 7 | #include "v.h" 8 | #include "vd.h" 9 | 10 | /* dot monadic, dyadic, triadic, tetradic */ 11 | 12 | Z K dot_ref(K *p,K *x,K *z,I s,K c,K y); 13 | Z K makeable(K a); 14 | 15 | Z K of2(K d, K *x, K *y, I s) 16 | { 17 | K f=*x; if(!f) R NYI; 18 | I dt=d->t, dn=d->n, ft=f->t, fn=f->n; 19 | 20 | if(0>=s)R at_verb(d,f); //Is it at_verb or at()... ? 21 | 22 | K z; 23 | if(0==ft) 24 | { 25 | U(z=newK(0,fn)) 26 | DO(fn, M(z,kK(z)[i]=of2(d,&kK(f)[i],y,s))) 27 | } 28 | else if(1==ABS(ft)) 29 | { 30 | if(dt!=0)R 0;//TODO: Error - must be 0 if s!=0 ... ? 31 | I k; 32 | DO(fn, k=kI(f)[i]; P(k<0 || k>=dn,XE)) 33 | if(1==ft) R of2(kK(d)[*kI(f)], y, 1+y, s-1);//Don't increase depth, just move on 34 | U(z=newK(0,fn)) 35 | DO(fn, M(z,kK(z)[i]=of2(kK(d)[kI(f)[i]], y, 1+y, s-1))) 36 | } 37 | else if(4==ABS(ft)) 38 | { 39 | if(dt!=5)R 0;//TODO: Error - must be 0 if s!=0 ... ? 40 | if(4==ft) R of2(lookup(d,*kS(f)), y,1+y,s-1);//Don't increase depth ; mm/o lookups 41 | U(z=newK(0,fn)) 42 | DO(fn, M(z,kK(z)[i]=of2(lookup(d,kS(f)[i]), y, 1+y, s-1))) 43 | } 44 | else if(6==ft) 45 | { 46 | if (0==dt){U(z=newK(0,dn)) DO(dn,M(z,kK(z)[i]=of2(kK(d)[i],y,1+y,s-1))) } 47 | else if(5==dt){U(z=newK(0,dn)) DO(dn,M(z,kK(z)[i]=of2(kK(kK(d)[i])[1],y,1+y,s-1))) } 48 | else R RE; 49 | } 50 | else R TE; 51 | if(z)z=demote(z); 52 | R z; 53 | } 54 | 55 | K of(K a, K b) //TODO: oom all (see of2() for M(z,kK(z)[i]=...) pattern ) 56 | { 57 | 58 | //TODO: must implement Value/Execute '`k.b@"a+1"' same as '.(`k.b;"a+1")' 59 | 60 | I at=a->t, an=a->n, bt=b->t, bn=b->n; 61 | if(0==b->t && 0==b->n) R ci(a);//Empty list is identity 62 | 63 | K z=0; 64 | if(at==4 && bt==0) { 65 | C s[256]; strcpy(s,d_); strcat(s,"."); strcat(s,*kS(a)); 66 | S ss=*kS(a); I i; for(i=0;i0?1+f:0,bn-1); 71 | } 72 | 73 | if(at==4 && bt==1){ 74 | C s[256]; strcpy(s,d_); strcat(s,"."); strcat(s,*kS(a)); 75 | K *aa=denameD(&KTREE,(S)sp(s),1); 76 | R of(*aa,b); 77 | } 78 | 79 | P(0=at) z=ci(a); 95 | //Getting to here with a symbol atom for a is tricky. "x:`sym; `x . _n => rank error" 96 | else R RE;// a->t necessarily in {1,2,3,4} 97 | } 98 | else if(0>bt && 0==bn && -3!=bt)z=ci(a); 99 | else if(5==at || 0==at) 100 | {//Can't have bn==0 here 101 | if(0==bt){K *f=&kK(b)[0]; z=of2(a,f,bn>0?1+f:0,bn-1);} 102 | else if(-1==bt || -4==bt){K k=promote(b); K *f=&kK(k)[0]; z=of2(a,f,1+f,bn-1); cd(k); } //mmo U(k) ? //This line added to fix test for (5 2.14;"abc") . 1 2 --- doesn't give me great confidence in the code 103 | else z=at_verb(a,b); 104 | } 105 | else if(0 >at) 106 | { 107 | if(-1==bt&&1==bn){ 108 | K f=newK(1,1); *kI(f)=*kI(b); z=at_verb(a,f); cd(f); } 109 | else if(1==ABS(bt)) z=at_verb(a,b); 110 | else if(0==bt){K k; z=newK(0,bn);DO(bn,k=at_verb(a,kK(b)[i]); M(k,z) kK(z)[i]=k) z=collapse(z);} 111 | else R TE; 112 | } 113 | R z; 114 | } 115 | 116 | K dot(K a, K b) //NB: b can be a cheating 0-type with NULLs .. ? 117 | { 118 | //TODO: create dename without path-creation effect. will lookup correct handle or return a _n to use ... but won't create path. K at() also needs this. 119 | //if(4==a->t)a=retrieveByHandle(a); 120 | 121 | if(4==a->t && 4==b->t) 122 | { S s=(S)malloc(2+strlen(*kS(a))+strlen(*kS(b))); 123 | s=strcpy(s,*kS(a)); strcat(s,"."); strcat(s,*kS(b)); 124 | R ci(*inKtree(&kK((kK(KTREE))[0])[1],s,0)); } 125 | if(7==a->t) R vf_ex(&a,b); //Verb: "Apply" //TODO: my guess is this fails everywhere vf_ex does (derived verbs?) (|+) . (0;1) ??? 126 | R of(a,b); //TODO: vf_ex might/could implement this itself ? 127 | } 128 | 129 | //TODO: Is this a stable thing if my function mucks with the tree above me? No, but find 'reference error' 130 | //TODO: Does this do the right thing for functions/nouns with valence > 2 ? 131 | //TODO: k-tree elements with subelements whose refcount is >1 will bork???? 132 | //TODO: catch oom errors etc. 133 | K dot_ref(K *p, K *x, K *z, I s, K c, K y) 134 | { 135 | K d=*p, f=x?*x:0; 136 | I dt=d->t, dn=countI(d), ft=999, fn, yn0=0; 137 | 138 | if(f) {ft=f->t; fn=countI(f);} 139 | else R NYI; 140 | if(y) {yn0=countI(y);} 141 | 142 | if(-1==s && 0==fn && -3!=ft) 143 | { 144 | I argc = y?2:1; 145 | K args=newK(0,argc);U(args)//Cheating 0-type w/ NULLs 146 | kK(args)[0]=ci(*p); 147 | if(argc > 1) kK(args)[1] = ci(y); 148 | K r = specialAmendDot(c,args); 149 | cd(args); 150 | U(r) 151 | cd(*p); 152 | // XXX: it seems silly to me to make a klone() of a value 153 | // which has been computed just above, but it crashes Kona 154 | // at several places if I remove this... 155 | if (5==r->t || 0==r->t) 156 | { 157 | *p=kclone(r); 158 | cd(r); 159 | } 160 | else 161 | *p=r; 162 | R NULL; 163 | } 164 | //these may turn out to be the "ELSE" case 165 | if((1 <= dt && dt <= 4) || 7==dt || 7==ft) R RE; 166 | else if(6==dt && (0 >= ft) && -4 != ft) R XE; 167 | else if(6==dt && 6 != ft && 4 != ABS(ft)) R TE; 168 | if(5==dt && 123 == ft) R NULL; //TODO: Fill in dict errors 169 | //TODO: full error chart. at_ref will account for some of it 170 | 171 | if(0>=s) at_ref(p,f,c,y); //what errors will this take care of ? 172 | else if(0==ft) 173 | { 174 | if(!atomI(f) && y && !atomI(y) && fn != yn0) R LE; 175 | I n = (atomI(f) && y)?yn0:fn; 176 | if(y) U(y=promote(y)) 177 | DO(n, dot_ref(p, kK(f)+(i%fn), z, s, c, kK(y)[i%yn0])) 178 | cd(y); 179 | } 180 | else if(1==ABS(ft)) 181 | { 182 | if(f && !atomI(f) && y && !atomI(y) && fn != yn0) R LE; 183 | if( 1==ft && dt > 0) R TE; // (5,6) 184 | 185 | if(y && yt != 0 && f && !atomI(f)) U(y = promote(y)) 186 | else ci(y); 187 | 188 | //TODO: .[.,(`a;2);0 0;*:] -> identity. (0->type err, 0 0 0-> rank err) 189 | if(dt != 0) R RE; 190 | 191 | if(f) DO(fn, I e=kI(f)[i]; if( e < 0 || dn <= e ) R XE; )//check is in advance 192 | if(f) DO(fn, 193 | K py=0; 194 | if(y) py=atomI(f)?y:kK(y)[i%yn0]; 195 | dot_ref(kK(d)+(kI(f)[i]),z,z+1,s-1,c,py); 196 | ) 197 | cd(y); 198 | } 199 | else if(4==ABS(ft)) 200 | { 201 | if(!atomI(f) && y && !atomI(y) && fn != yn0) R LE; 202 | if( 4==ft && 0 >= dt) R TE; 203 | if(-4==ft && 0 >= dt) R IE; 204 | if(y && yt != 0 && !atomI(f)) U(y = promote(y)) 205 | else ci(y); 206 | 207 | //Only 6/4, 5/4, 5/-4 at this point 208 | DO(fn, 209 | K py = 0; 210 | if(y) py=atomI(f)?y:kK(y)[i%yn0]; //trying promote here instead of itemAtIndex like in at_ref 211 | S u = kS(f)[i]; 212 | dot_ref(lookupEVOrCreate(p,u),z,z+1,s-1,c,py); //oom, cd(y), ??? 213 | ) 214 | cd(y); 215 | } 216 | else if(6==ft) 217 | { 218 | if(6==dt) R NULL; //identity 219 | if(y && !atomI(y) && yn0 != d->n) R LE; 220 | if(y) U(y=promote(y)) 221 | if(5==dt) DO(d->n, dot_ref(EVP(DI(d,i)),z,z+1,s-1,c,y?kK(y)[i%yn0]:0)) 222 | if(0>=dt) { K k=Ki(0); M(k,y?y:k); DO(countI(d), *kI(k)=i; dot_ref(p,&k,z,s,c,y?kK(y)[i%yn0]:0)) cd(k); } 223 | cd(y); 224 | } 225 | R 0; 226 | } 227 | 228 | K dot_tetradic_2(K *g, K b, K c, K y) 229 | { 230 | if(c->t==7 && kK(c)[CODE]->t==-4) 231 | { V q=kV(kS(c)[CODE])[0]; 232 | if(q>(V)500)R SYE; 233 | fnc=DT[(L)q].text; 234 | if(fnci<127){ fncp[fnci]=q; fnci++; } } 235 | 236 | I bt=b->t, bn=countI(b); 237 | 238 | if(0==bn || 6==bt) 239 | { 240 | dot_ref(g,&b,0,bn-1,c,y); //could factor further by promoting everything... 241 | } 242 | else if(0==bt || 1==ABS(bt) || 4==ABS(bt)) 243 | { 244 | b=promote(b); bt=0; bn=countI(b); //oom 245 | K *f=kK(b); dot_ref(g,f,bn>0?1+f:0,bn-1,c,y); //bn!=0 ???? copy/paste comment 246 | cd(b); 247 | } 248 | else R TE; //Type Error 7,5,+-3,+-2 TODO: Move inside if possible... ? 249 | 250 | R *g; 251 | } 252 | 253 | //TODO: All this must be rewritten to handle function-local-dictionaries and global 254 | K dot_tetradic(K a, K b, K c, K y)//Handles triadic and tetradic case 255 | { 256 | if(isColonDyadic(c) && !y && !kV(c)[CONJ]) //'Error Trap' 257 | { 258 | K d = newK(0,2); 259 | K i = Ki(0); 260 | M(d,i) 261 | kK(d)[0] = i; 262 | K z = vf_ex(&a,b); 263 | kK(d)[1]=z; 264 | if(!z) 265 | { 266 | *kI(i)=1; 267 | K e=newK(-3,strlen(errmsg)); 268 | M(d,e); 269 | strcpy(kC(e),errmsg); 270 | kK(d)[1]=e; 271 | } 272 | fer=-1; 273 | R demote(d); 274 | } 275 | 276 | if(KONA_GSET&&(a!=KONA_GSET)) {ci(a);cd(KONA_GSET);KONA_GSET=a;} 277 | if(KONA_IDX&&(b!=KONA_IDX)) {ci(b);cd(KONA_IDX);KONA_IDX=b;} 278 | 279 | K q=0, *p=0; 280 | 281 | //TODO: Index/Of claims to accept handles as sub-elements....is this true??? for Of and for DOT_TETRADIC etc... 282 | if(a->t == 4) 283 | { 284 | //TODO: reference error <- d.e.f:123;\d .k.d.e; .[`.k;`d;:;1] 285 | //TODO: ^^ note, whoever handles reference error will need to know about Context of the Parsed value being Executed 286 | // because it doesn't matter if the \d directory changes in the middle: 287 | // d.e.f:123;\d .k.d.e;\n\n\n a:1;."\\d .";.[`.k;`d;:;1];a:2 -> reference error (and then afterwards _d is `) 288 | 289 | //triadic & tetradic create dict path if not existing (even on errors). dyadic/monadic create nothing 290 | 291 | p = denameS(d_,*kS(a),1); 292 | U(p) //oom 293 | // if(1 (1;"rank") 303 | // @[_n;1 2;:] -> (0; 1 2) 304 | 305 | R q?q:ci(a);// sym not *p 306 | } 307 | 308 | //make dict, monadic .((`foo;1 2 3);) variant. Assumes makeable() is true. 309 | //dicts are currently implemented as an association array (i.e., linear search), should change soon. 310 | K make(K a) 311 | { 312 | //TODO: this will need to set reference counts on all dictionary entries, etc. 313 | P(!makeable(a), RE) 314 | I n=a->n; 315 | K x,y; 316 | K z=newK(5,n); 317 | DO(n, kK(z)[i]=newK(0,3);) 318 | DO(n, x=kK(z)[i]; y=kK(a)[i]; DO2(y->n,kK(x)[j]=y->t?Ks(kS(y)[j]):ci(kK(y)[j])) if(y->n<3)kK(x)[2]=_n()) //oom 319 | R z; 320 | } 321 | Z K unmake(K a){K z=kclone(a); z->t=0; R z;}//TODO: deep clone inefficient 322 | Z K makeable(K a) //TODO: this has to be reworked. can't hang out raw in dot_monadic as it is currently 323 | { 324 | I t=a->t, n=a->n; 325 | //All this was moved here from make(). not sure how to handle error checking when it's outside like this 326 | P(0!=t, 0) 327 | K x; 328 | //NB: .(`a`b;`c`d) is also a valid dictionary (sym vectors) 329 | DO(n, x=kK(a)[i]; if( (0!=x->t && -4!=x->t) || x->n < 2 || 3 < x->n || (-4==x->t && x->n != 2) )R 0) 330 | DO(n, x=kK(a)[i]; if(0==x->t) if( 4 != kK(x)[0]->t || (3==x->n && 5!=kK(x)[2]->t && 6!=kK(x)[2]->t)) R 0) 331 | R (K)1; 332 | } 333 | 334 | K dot_monadic(K x) { 335 | P(xt==0 && x->n==1 && kK(x)[0]->t==-3,VE) 336 | if(3==ABS(xt)){ 337 | R KX(x); } 338 | if(4==xt) { 339 | K *p = denameS(d_,*kS(x),0); 340 | if(!p) R DOE; 341 | R ci(*p); } 342 | if(5==xt)R unmake(x); 343 | if(makeable(x))R make(x); 344 | R vf_ex(offsetDot,x); } 345 | -------------------------------------------------------------------------------- /src/vd.h: -------------------------------------------------------------------------------- 1 | K KX(K x); 2 | K dot_monadic(K x); 3 | K Ks(S x); 4 | K make(K a); 5 | K kcloneI(K a,const char*f,int n); 6 | #define kclone(a) kcloneI(a,__FILE__,__LINE__) 7 | extern S d_; 8 | extern K*inKtree(K*d, S t, I create); 9 | extern K *denameS(S dir_string,S t,I create); 10 | extern C errmsg[256]; 11 | I isColonDyadic(K x); 12 | K dot_tetradic(K a,K b,K c,K y); 13 | K dot_tetradic_2(K *g,K b,K c,K y); 14 | K Ki(I x); 15 | K DI(K d,I i); 16 | K *EVP(K e); 17 | K *lookupEVOrCreate(K *p,S k); 18 | I atomI(K a); 19 | K at_ref(K *p,K b,K c,K y); 20 | I args(int n,S *v); 21 | extern K specialAmendDot(K c,K args); 22 | I countI(K a); 23 | K vf_ex(V q,K g); 24 | K dot(K a,K b); 25 | K collapse(K x); 26 | K cd(K a); 27 | K promote(K a); 28 | K _n(); 29 | K ci(K a); 30 | K at(K x,K y); 31 | K of(K a,K b); 32 | K demote(K a); 33 | K lookup(K a,S b); 34 | K newK(I t,I n); 35 | K at_verb(K a,K b); 36 | extern S fnc; 37 | extern V fncp[128]; 38 | extern I fnci; 39 | extern __thread I fer; 40 | extern K KONA_GSET; 41 | extern K KONA_IDX; 42 | -------------------------------------------------------------------------------- /src/vf.c: -------------------------------------------------------------------------------- 1 | #include "incs.h" 2 | #include "k.h" 3 | #include "km.h" 4 | #include "vf.h" 5 | 6 | /* format */ 7 | 8 | Z I TNI(I p,C h); 9 | Z I parseNI(S s,I n); 10 | 11 | S CSK(K x){ R !x?0:4==xt?*kS(x):3==ABS(xt)?kC(x):0;}//non-allocating CSTRING from K. assumes +4,+-3 types are null-terminated 12 | 13 | Z K formKsCS(S s) 14 | { 15 | //Could remove this function. It's equivalent to Ks(sp(s)) 16 | S t=sp(s); 17 | if(!t)R 0; //oom 18 | K z=Ks(t); //oom 19 | if(!z)R 0; 20 | R z; 21 | } 22 | 23 | K formKiCS(S s) // 0 $ "123\000456\000" is 123 ('\0' char) 24 | { 25 | C *p,q=0; 26 | I r=IN; 27 | 28 | I w=parseNI(s,strlen(s)); 29 | if(w) r=NI[w]; 30 | else if(*s) 31 | { 32 | r=strtoll(s,&p,10); 33 | errno=0; //is this ok to do? 34 | q=*p; 35 | if(IN==r)r=-II;//if r < -0I then r=-0I 36 | } 37 | P(q && !isblank(q),(K)0) 38 | R Ki(r);//oom 39 | } 40 | 41 | K formKfCS(S s) // 0.0 $ "123\000456\000" is 123 ('\0' char) 42 | { 43 | C *p,q=0; 44 | F r=FN; 45 | 46 | I w=parseNI(s,strlen(s)); 47 | if(w) r=ni[w]; 48 | else if(*s) 49 | { 50 | r=strtod(s,&p); 51 | errno=0;//is this ok to do? 52 | q=*p; 53 | if(isnan(r))r=-FI; //'r==FN' does not work 54 | } 55 | P(q && !isblank(q),(K)0) 56 | R Kf(r); //oom 57 | } 58 | 59 | Z K formatFn(K a){ V *v=kW(a),p; I i,k,n,r=0; K z=0; C t[256]=""; S s=(C*)t; 60 | SW(a->n){ 61 | CS(1,for(i=0;(p=v[i]);i++){ L q=(L)p; 62 | if(q=DT_SPECIAL_VERB_OFFSET){S u=DT[q].text; n=strlen(u); strcpy(s+r,u); r+=n;} 63 | else if((k=adverbClass(p))){t[r]=adverbsChar(p); if(k!=1)t[r+1]=':'; r++;} 64 | else if((k=sva(p))){t[r]=verbsChar(p); if(k!=2)t[r+1]=':'; r++;} 65 | else;} 66 | n=strlen(s); z=newK(-3,n); memcpy(kC(z),s,n+1);) 67 | CS(2,) 68 | CS(3,{S f=kC(kV(a)[CODE]); I n=strlen(f); z=newK(-3,n+2); 69 | kC(z)[0]='{';memcpy(kC(z)+1,f,n); kC(z)[n+1]='}'; kC(z)[n+2]=0;})} 70 | R z;} 71 | 72 | Z K formatS(S x) 73 | { I n=strlen(x); 74 | K z=newK(-3,n); 75 | if(z)sprintf(kC(z),"%s",x); //OK since 3/-3 is null-terminated 76 | R z; 77 | } 78 | Z K formatF(F x, I y, I c) 79 | { 80 | Z C buf[32]; 81 | int k=y; 82 | S b= 0==c?"%.*g":1==c?"%.*f":"%.*e";// %#.*g ?? 83 | sprintf(buf,b,k,x);I n=strlen(buf); 84 | K z=newK(-3,n); 85 | if(z)memcpy(kC(z),buf,n); 86 | R z; 87 | } 88 | Z K formatI(I x) 89 | { 90 | Z C buf[72]; 91 | sprintf(buf,"%lld",x);I n=strlen(buf); 92 | K z=newK(-3,n); 93 | if(z)memcpy(kC(z),buf,n); 94 | R z; 95 | } 96 | K format(K a) 97 | { 98 | I at=a->t, an=a->n; 99 | K z; 100 | if(3==ABS(at)){z=kclone(a); z->t=-3; R z;} 101 | else if(7==at)R formatFn(a); 102 | else if(6==at)R newK(-3,0); 103 | else if(5==at)R formatS(sp(".(..)"));//Beats me -- this has a similar signature to a _hash 104 | else if(4==at)R formatS(*kS(a)); 105 | else if(2==at)R formatF(*kF(a),PP,0); 106 | else if(1==at)R formatI(*kI(a)); 107 | z=newK(0,an); 108 | if ( 0==at)DO(an, kK(z)[i]=format (kK(a)[i])) 109 | else if(-1==at)DO(an, kK(z)[i]=formatI(kI(a)[i])) 110 | else if(-2==at)DO(an, kK(z)[i]=formatF(kF(a)[i],PP,0)) 111 | else if(-4==at)DO(an, kK(z)[i]=formatS(kS(a)[i])) 112 | R z; 113 | } 114 | 115 | I NI[]={0,IN,-II,II,II,-II,II}; //0N,-0I,0I,0n,-0i,0i maps to I 116 | F ni[]={0,FN,-FI,FI,FN,-FI,FI}; //maps to F 117 | Z I TNI(I p,C h) //transition function for parsing 0N -0I 0I 0n ... 118 | { 119 | I c=isblank(h)?0:charpos(" -0NIni",h); //character classes 120 | if(0==c && 7>=p) R p; 121 | if(1==c && (0==p || 7==p))R 7-p; 122 | if(2==c && 0==p) R 9; 123 | if(2==c && 7==p) R 8; 124 | if(3==c && (8==p || 9==p))R 1; 125 | if(4==c && (8==p || 9==p))R p-6; 126 | if(5==c && (8==p || 9==p))R 4; 127 | if(6==c && (8==p || 9==p))R p-3; 128 | R 10; 129 | } 130 | 131 | Z I parseNI(S s,I n){I i=0,p=0; while(i0&&!FC(d,1))||(d<0&&!FC(d,0))?ceil(f):floor(f);} 133 | 134 | //TODO: Really weird: run '`g $ 99' run '. _d' see entry '(`s4;99;) in the `.k K-Tree 135 | // also run '`s $ 1.0' -> domain error 136 | //TODO: oom all 137 | K dollar(K a, K b) //form/format_dyadic 138 | { 139 | I at=a->t, an=a->n, bt=b->t, bn=b->n; 140 | K z=0; 141 | I x = (at <=0 && -3 != at), y = (bt <=0 && -3 != bt); 142 | P(x && y && an!=bn,LE) 143 | 144 | if(x || y) 145 | { 146 | a=x?promote(a):ci(a); //-3 147 | b=y?promote(b):ci(b); //-3 148 | z=a&&b?newK(0,x?a->n:b->n):0; 149 | if(z)DO(z->n, K q=dollar(x?kK(a)[i]:a,y?kK(b)[i]:b); M(q,z,a,b) kK(z)[i]=q) 150 | cd(a);cd(b); 151 | R demote(z); 152 | } 153 | 154 | if(1==at && *kI(a)) //"Format (Dyadic)" 155 | { 156 | K c; 157 | U(c=format(b)) 158 | I m=*kI(a); 159 | z=newK(-3,ABS(m));M(c,z) 160 | if(z->n < c->n) DO(z->n, kC(z)[i]='*')//K3.2 161 | else 162 | { 163 | I k=m>0?m-c->n:0; 164 | DO(z->n,kC(z)[i]=' '); 165 | DO(c->n,kC(z)[i+k]=kC(c)[i]) 166 | } 167 | cd(c); 168 | R z; 169 | } 170 | 171 | if(2==at) //"Format (Dyadic)" 172 | { 173 | F f=*kF(a); 174 | if(2==bt || 1==bt) 175 | { 176 | K c,d; 177 | U(c=Ki(f)) 178 | d=formatF(2==bt?*kF(b):*kI(b), ((I)tround(fabs(f)*10))%10, signbit(f)?2:1); 179 | if(d)z=dollar(c,d); 180 | cd(c);cd(d); 181 | R z; 182 | } 183 | } 184 | 185 | if(3==ABS(bt)) //"Form" 186 | { 187 | if(3==bt) b=enlist(b);//mm/o 188 | 189 | if(4==at && !strlen(*kS(a))) R formKsCS(CSK(b)); 190 | if(3==ABS(at)) R ci(b); 191 | if(2==at) R formKfCS(CSK(b)); //Had '&& 0.0 == *kF(a)' here but the manual is wrong 192 | if(1==at && !*kI(a)) R formKiCS(CSK(b)); 193 | //if(5<=at) 194 | R 0;//TODO: Else parse-execute (6,7, looks like for 5, maybe 4 too???) 195 | } 196 | 197 | R TE; 198 | } 199 | -------------------------------------------------------------------------------- /src/vf.h: -------------------------------------------------------------------------------- 1 | K enlist(K x); 2 | K demote(K a); 3 | K cd(K a); 4 | K ci(K a); 5 | K promote(K a); 6 | K dollar(K a,K b); 7 | I FC(F a,F b); 8 | F FF(F f); 9 | I charpos(S s,C c); 10 | extern I PP; 11 | K kcloneI(K a,const char*f,int n); 12 | #define kclone(a) kcloneI(a,__FILE__,__LINE__) 13 | K at(K x,K y); 14 | K format(K a); 15 | K newK(I t,I n); 16 | K Kf(F x); 17 | extern F ni[]; 18 | K formKfCS(S s); 19 | K Ki(I x); 20 | extern I NI[]; 21 | K formKiCS(S s); 22 | K Ks(S x); 23 | S sp(S k); 24 | S CSK(K x); 25 | C verbsChar(V p); 26 | C adverbsChar(V p); 27 | -------------------------------------------------------------------------------- /src/vg.h: -------------------------------------------------------------------------------- 1 | K promote(K a); 2 | I bk(V p); 3 | K join(K a,K b); 4 | K count(K a); 5 | I countI(K a); 6 | K demote(K x); 7 | K reverse(K a); 8 | K where(K x); 9 | K drop_cut(K a,K b); 10 | K cut(K a,K b); 11 | K drop(K a,K b); 12 | K rotate(K a,K b); 13 | K _i(); 14 | K shape(K a); 15 | K take_reshape(K a,K b); 16 | K take(K a,K b); 17 | K reshape(K a,K b); 18 | K _n(); 19 | K Ki(I x); 20 | K Kf(F x); 21 | K Kc(C x); 22 | extern S LS; 23 | K Ks(S x); 24 | K first(K a); 25 | K itemAtIndex(K a,I i); 26 | K flip(K a); 27 | I VAT(I i); 28 | K group(K x); 29 | K cd(K a); 30 | I matchI(K a,K b); 31 | I FC(F a,F b); 32 | K range(K a); 33 | K ci(K a); 34 | K newK(I t,I n); 35 | K enlist(K x); 36 | K grade_down(K a); 37 | K grade_up(K a); 38 | K mergeGrade(K a,I r); 39 | K distributionGrade(K a,I r,uI u,uI v); 40 | K radixGrade(K a,I r,uI h); 41 | K charGrade(K a,I r); 42 | K at(K x,K y); 43 | void trst(); 44 | void elapsed(S); 45 | V alloc(size_t); 46 | K symGrade(K a,I r); 47 | I cl2(I v); 48 | K last(K a); 49 | -------------------------------------------------------------------------------- /src/vq.c: -------------------------------------------------------------------------------- 1 | #include "incs.h" 2 | 3 | #include "km.h" 4 | #include "r.h" 5 | #include "v.h" 6 | #include "vq.h" 7 | 8 | /* question mark - find/function_inverse - what dyadic triadic */ 9 | 10 | K find(K a, K b) 11 | { 12 | I at=a->t, an=a->n, bt=b->t; 13 | P(at>0,DOE) 14 | if(-4==at && 4==bt)DO(an, if(kS(a)[i]==*kS(b))R Ki(i)) 15 | if(-3==at && 3==bt)DO(an, if(kC(a)[i]==*kC(b))R Ki(i)) 16 | if(-2==at && 2==bt)DO(an, if(!FC(kF(a)[i],*kF(b)))R Ki(i)) 17 | if(-2==at && 1==bt){F fb=I2F(*kI(b));DO(an, if(!FC(kF(a)[i],fb))R Ki(i));} 18 | if(-1==at && 2==bt)DO(an, if(!FC(I2F(kI(a)[i]),*kF(b)))R Ki(i)) 19 | if(-1==at && 1==bt)DO(an, if(kI(a)[i]==*kI(b))R Ki(i)) 20 | if(!at){ 21 | if(2==an&&-5==kK(a)[1]->t)R hash_find(a,b); 22 | DO(an, if(matchI(kK(a)[i],b))R Ki(i)) 23 | } 24 | R Ki(an); 25 | } 26 | 27 | Z F num_ex(K a, F x)//f-> monadic, numeric in&out 28 | { 29 | F y=0; 30 | K b,g; 31 | P(!(b=Kf(x)),FN) //err 32 | 33 | if(!(g=newK(0,1))){cd(b); R FN;}//err 34 | *kK(g)=ci(b); 35 | K k=vf_ex(&a,g); 36 | 37 | if(!k || (k->t!=1 && k->t!=2))y=FN; //err 38 | else if(k->t==1) y=(F)*kI(k); 39 | else y=*kF(k); 40 | 41 | cd(b); 42 | cd(k); 43 | cd(g); 44 | R y; 45 | } 46 | 47 | Z I isShallowNumeric(K k) 48 | { 49 | if(ABS(k->t) > 2) R 0; 50 | if(0==k->t) DO(k->n, I t=kK(k)[i]->t; if(t!=1 && t!=2) R 0) 51 | R 1; 52 | } 53 | 54 | Z F ithFloat(K k, I i) //made specific for what_triadic 55 | { 56 | if(!k) R 0; 57 | I n=k->n; 58 | if(!k->t) {k=kK(k)[i%n]; i=0;} 59 | if(1==ABS(k->t)) R (F) kI(k)[i%n]; 60 | R kF(k)[i%n]; 61 | } 62 | 63 | Z F inverter(K a, K b, K c, I index)//secant method 64 | { 65 | F y = ithFloat(b,index); 66 | 67 | I i,m=20;//max iterations 68 | F x[m+2], f[m+2]; 69 | x[0]=0.9998; 70 | x[1]=0.9999; 71 | 72 | if(c) 73 | { 74 | F r=ithFloat(c,index); 75 | //TODO: r== 0n 0i etc ?? 76 | x[0]=0.9999*r; 77 | x[1]=r; 78 | } 79 | 80 | DO(2, f[i]=num_ex(a,x[i])-y); //oom/err FN ?? how to catch 81 | F d, e=y?y*0.000001:0.000001;//y*1e-6 82 | 83 | for(i=0;i=m){ kerr("limit"); R 0;} 90 | R x[i+2]; 91 | } 92 | 93 | K what_triadic(K a, K b, K c)//TODO: 0i -0i 0n 94 | { 95 | //TODO: {1}?1 -> 0n ?? 96 | I bt=b->t, bn=b->n; 97 | if(!isShallowNumeric(b) || (c && !isShallowNumeric(c))) R TE; 98 | if((!bt && !bn) || (c && !c->t && !c->n)) R newK(0,0); 99 | if(0==bn || (c && 0==c->n)) R newK(-2,0); 100 | if(c && c->t < 1 && bt < 1 && c->n != b->n) R LE; 101 | 102 | I zn=bn, zt=2; 103 | if(bt<1 || (c && c->t < 1)) zt = -2; 104 | if(c) zn=MAX(zn,c->n); 105 | K z = newK(zt,zn); 106 | U(z) 107 | DO(zn, kF(z)[i] = inverter(a,b,c,i)) 108 | R z; 109 | } 110 | 111 | Z K qrand(K a,K b) 112 | { 113 | I at=a->t,bt=b->t; 114 | K y; 115 | P(1!=ABS(at)||(1!=bt&&2!=bt),IE) 116 | I c=*kI(a),n=ABS(c); 117 | P(1==bt && c<0 && *kI(b) < -c,LE) 118 | P(1==bt && *kI(b)<0,DOE) 119 | 120 | I j=0,k,s; 121 | U(y=newK(1==bt?-1:-2,n)) 122 | 123 | if(2==bt){F f=*kF(b);DO(n,kF(y)[i]=RF()*f) R y;} 124 | I d=*kI(b); 125 | if(c>=0)DO(n,kI(y)[i]=d*RF()) //this could be better (small numerical error) 126 | else //deal 127 | { 128 | vitter(kI(y),y->n,d); //Vitter's algorithm 129 | for(j=n-1;j>0;j--){k=(1+j)*RF();s=kI(y)[j];kI(y)[j]=kI(y)[k];kI(y)[k]=s;} //Knuth Algorithm 3.4.2P 130 | } 131 | R y; 132 | } 133 | 134 | K sample(K x,K y) 135 | { 136 | K a,b,z; 137 | if(!y->n) R take(x,y); 138 | U(b=Ki(countI(y))) 139 | a=qrand(x,b); 140 | M(a,b) cd(b); 141 | z=at_verb(y,a); 142 | cd(a); 143 | R z; 144 | } 145 | 146 | K what(K x, K y) 147 | { 148 | P(1==xt,DOE) 149 | if(7==xt)R what_triadic(x,y,0); 150 | if(1==xt) R atomI(y)?qrand(x,y):sample(x,y); 151 | R find(x,y); 152 | } 153 | -------------------------------------------------------------------------------- /src/vq.h: -------------------------------------------------------------------------------- 1 | I atomI(K a); 2 | K what(K x,K y); 3 | K at_verb(K a,K b); 4 | I countI(K a); 5 | K take(K a,K b); 6 | K sample(K x,K y); 7 | void vitter(I *a,I n,I N); 8 | F RF(); 9 | K what_triadic(K a,K b,K c); 10 | K kerr(cS s); 11 | K vf_ex(V q,K g); 12 | K ci(K a); 13 | K cd(K a); 14 | K newK(I t,I n); 15 | K Kf(F x); 16 | I matchI(K a,K b); 17 | I FC(F a,F b); 18 | K Ki(I x); 19 | K at(K x,K y); 20 | K find(K a,K b); 21 | K hash_find(K a,K b); 22 | -------------------------------------------------------------------------------- /src/win/ansidecl.h: -------------------------------------------------------------------------------- 1 | /* ANSI and traditional C compatability macros 2 | Copyright 1991, 1992, 1996 Free Software Foundation, Inc. 3 | This file is part of the GNU C Library. 4 | 5 | This program is free software; you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation; either version 2 of the License, or 8 | (at your option) any later version. 9 | 10 | This program is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program; if not, write to the Free Software 17 | Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ 18 | 19 | /* ANSI and traditional C compatibility macros 20 | 21 | ANSI C is assumed if __STDC__ is #defined. 22 | 23 | Macro ANSI C definition Traditional C definition 24 | ----- ---- - ---------- ----------- - ---------- 25 | PTR `void *' `char *' 26 | LONG_DOUBLE `long double' `double' 27 | VOLATILE `volatile' `' 28 | SIGNED `signed' `' 29 | PTRCONST `void *const' `char *' 30 | ANSI_PROTOTYPES 1 not defined 31 | 32 | CONST is also defined, but is obsolete. Just use const. 33 | 34 | obsolete -- DEFUN (name, arglist, args) 35 | 36 | Defines function NAME. 37 | 38 | ARGLIST lists the arguments, separated by commas and enclosed in 39 | parentheses. ARGLIST becomes the argument list in traditional C. 40 | 41 | ARGS list the arguments with their types. It becomes a prototype in 42 | ANSI C, and the type declarations in traditional C. Arguments should 43 | be separated with `AND'. For functions with a variable number of 44 | arguments, the last thing listed should be `DOTS'. 45 | 46 | obsolete -- DEFUN_VOID (name) 47 | 48 | Defines a function NAME, which takes no arguments. 49 | 50 | obsolete -- EXFUN (name, (prototype)) -- obsolete. 51 | 52 | Replaced by PARAMS. Do not use; will disappear someday soon. 53 | Was used in external function declarations. 54 | In ANSI C it is `NAME PROTOTYPE' (so PROTOTYPE should be enclosed in 55 | parentheses). In traditional C it is `NAME()'. 56 | For a function that takes no arguments, PROTOTYPE should be `(void)'. 57 | 58 | obsolete -- PROTO (type, name, (prototype) -- obsolete. 59 | 60 | This one has also been replaced by PARAMS. Do not use. 61 | 62 | PARAMS ((args)) 63 | 64 | We could use the EXFUN macro to handle prototype declarations, but 65 | the name is misleading and the result is ugly. So we just define a 66 | simple macro to handle the parameter lists, as in: 67 | 68 | static int foo PARAMS ((int, char)); 69 | 70 | This produces: `static int foo();' or `static int foo (int, char);' 71 | 72 | EXFUN would have done it like this: 73 | 74 | static int EXFUN (foo, (int, char)); 75 | 76 | but the function is not external...and it's hard to visually parse 77 | the function name out of the mess. EXFUN should be considered 78 | obsolete; new code should be written to use PARAMS. 79 | 80 | DOTS is also obsolete. 81 | 82 | Examples: 83 | 84 | extern int printf PARAMS ((const char *format, ...)); 85 | */ 86 | 87 | #ifndef _ANSIDECL_H 88 | 89 | #define _ANSIDECL_H 1 90 | 91 | 92 | /* Every source file includes this file, 93 | so they will all get the switch for lint. */ 94 | /* LINTLIBRARY */ 95 | 96 | 97 | #if defined (__STDC__) || defined (_AIX) || (defined (__mips) && defined (_SYSTYPE_SVR4)) || defined(_WIN32) 98 | /* All known AIX compilers implement these things (but don't always 99 | define __STDC__). The RISC/OS MIPS compiler defines these things 100 | in SVR4 mode, but does not define __STDC__. */ 101 | 102 | #define PTR void * 103 | #define PTRCONST void *CONST 104 | #define LONG_DOUBLE long double 105 | 106 | #ifndef IN_GCC 107 | #define AND , 108 | #define NOARGS void 109 | #define VOLATILE volatile 110 | #define SIGNED signed 111 | #endif /* ! IN_GCC */ 112 | 113 | #define PARAMS(paramlist) paramlist 114 | #define ANSI_PROTOTYPES 1 115 | 116 | #define VPARAMS(ARGS) ARGS 117 | #define VA_START(va_list,var) va_start(va_list,var) 118 | 119 | /* These are obsolete. Do not use. */ 120 | #ifndef IN_GCC 121 | #define CONST const 122 | #define DOTS , ... 123 | #define PROTO(type, name, arglist) type name arglist 124 | #define EXFUN(name, proto) name proto 125 | #define DEFUN(name, arglist, args) name(args) 126 | #define DEFUN_VOID(name) name(void) 127 | #endif /* ! IN_GCC */ 128 | 129 | #else /* Not ANSI C. */ 130 | 131 | #define PTR char * 132 | #define PTRCONST PTR 133 | #define LONG_DOUBLE double 134 | 135 | #ifndef IN_GCC 136 | #define AND ; 137 | #define NOARGS 138 | #define VOLATILE 139 | #define SIGNED 140 | #endif /* !IN_GCC */ 141 | 142 | #ifndef const /* some systems define it in header files for non-ansi mode */ 143 | #define const 144 | #endif 145 | 146 | #define PARAMS(paramlist) () 147 | 148 | #define VPARAMS(ARGS) (va_alist) va_dcl 149 | #define VA_START(va_list,var) va_start(va_list) 150 | 151 | /* These are obsolete. Do not use. */ 152 | #ifndef IN_GCC 153 | #define CONST 154 | #define DOTS 155 | #define PROTO(type, name, arglist) type name () 156 | #define EXFUN(name, proto) name() 157 | #define DEFUN(name, arglist, args) name arglist args; 158 | #define DEFUN_VOID(name) name() 159 | #endif /* ! IN_GCC */ 160 | 161 | #endif /* ANSI C. */ 162 | 163 | #endif /* ansidecl.h */ 164 | 165 | -------------------------------------------------------------------------------- /src/win/dlfcn.c: -------------------------------------------------------------------------------- 1 | /* 2 | * dlfcn-win32 3 | * Copyright (c) 2007 Ramiro Polla 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version. 9 | * 10 | * This library is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | * Lesser General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU Lesser General Public 16 | * License along with this library; if not, write to the Free Software 17 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | */ 19 | 20 | #include 21 | #include 22 | 23 | #include "dlfcn.h" 24 | 25 | /* Note: 26 | * MSDN says these functions are not thread-safe. We make no efforts to have 27 | * any kind of thread safety. 28 | */ 29 | 30 | typedef struct global_object { 31 | HMODULE hModule; 32 | struct global_object *previous; 33 | struct global_object *next; 34 | } global_object; 35 | 36 | static global_object first_object; 37 | 38 | /* These functions implement a double linked list for the global objects. */ 39 | static global_object *global_search( HMODULE hModule ) 40 | { 41 | global_object *pobject; 42 | 43 | if( hModule == NULL ) 44 | return NULL; 45 | 46 | for( pobject = &first_object; pobject ; pobject = pobject->next ) 47 | if( pobject->hModule == hModule ) 48 | return pobject; 49 | 50 | return NULL; 51 | } 52 | 53 | static void global_add( HMODULE hModule ) 54 | { 55 | global_object *pobject; 56 | global_object *nobject; 57 | 58 | if( hModule == NULL ) 59 | return; 60 | 61 | pobject = global_search( hModule ); 62 | 63 | /* Do not add object again if it's already on the list */ 64 | if( pobject ) 65 | return; 66 | 67 | for( pobject = &first_object; pobject->next ; pobject = pobject->next ); 68 | 69 | nobject = malloc( sizeof(global_object) ); 70 | 71 | /* Should this be enough to fail global_add, and therefore also fail 72 | * dlopen? 73 | */ 74 | if( !nobject ) 75 | return; 76 | 77 | pobject->next = nobject; 78 | nobject->next = NULL; 79 | nobject->previous = pobject; 80 | nobject->hModule = hModule; 81 | } 82 | 83 | static void global_rem( HMODULE hModule ) 84 | { 85 | global_object *pobject; 86 | 87 | if( hModule == NULL ) 88 | return; 89 | 90 | pobject = global_search( hModule ); 91 | 92 | if( !pobject ) 93 | return; 94 | 95 | if( pobject->next ) 96 | pobject->next->previous = pobject->previous; 97 | if( pobject->previous ) 98 | pobject->previous->next = pobject->next; 99 | 100 | free( pobject ); 101 | } 102 | 103 | /* POSIX says dlerror( ) doesn't have to be thread-safe, so we use one 104 | * static buffer. 105 | * MSDN says the buffer cannot be larger than 64K bytes, so we set it to 106 | * the limit. 107 | */ 108 | static char error_buffer[65535]; 109 | static char *current_error; 110 | 111 | static int copy_string( char *dest, int dest_size, const char *src ) 112 | { 113 | int i = 0; 114 | 115 | /* gcc should optimize this out */ 116 | if( !src && !dest ) 117 | return 0; 118 | 119 | for( i = 0 ; i < dest_size-1 ; i++ ) 120 | { 121 | if( !src[i] ) 122 | break; 123 | else 124 | dest[i] = src[i]; 125 | } 126 | dest[i] = '\0'; 127 | 128 | return i; 129 | } 130 | 131 | static void save_err_str( const char *str ) 132 | { 133 | DWORD dwMessageId; 134 | DWORD pos; 135 | 136 | dwMessageId = GetLastError( ); 137 | 138 | if( dwMessageId == 0 ) 139 | return; 140 | 141 | /* Format error message to: 142 | * "": 143 | */ 144 | pos = copy_string( error_buffer, sizeof(error_buffer), "\"" ); 145 | pos += copy_string( error_buffer+pos, sizeof(error_buffer)-pos, str ); 146 | pos += copy_string( error_buffer+pos, sizeof(error_buffer)-pos, "\": " ); 147 | pos += FormatMessage( FORMAT_MESSAGE_FROM_SYSTEM, NULL, dwMessageId, 148 | MAKELANGID( LANG_NEUTRAL, SUBLANG_DEFAULT ), 149 | error_buffer+pos, sizeof(error_buffer)-pos, NULL ); 150 | 151 | if( pos > 1 ) 152 | { 153 | /* POSIX says the string must not have trailing */ 154 | if( error_buffer[pos-2] == '\r' && error_buffer[pos-1] == '\n' ) 155 | error_buffer[pos-2] = '\0'; 156 | } 157 | 158 | current_error = error_buffer; 159 | } 160 | 161 | static void save_err_ptr_str( const void *ptr ) 162 | { 163 | char ptr_buf[19]; /* 0x up to 64 bits. */ 164 | 165 | sprintf( ptr_buf, "0x%p", ptr ); 166 | 167 | save_err_str( ptr_buf ); 168 | } 169 | 170 | void *dlopen( const char *file, int mode ) 171 | { 172 | HMODULE hModule; 173 | UINT uMode; 174 | 175 | current_error = NULL; 176 | 177 | /* Do not let Windows display the critical-error-handler message box */ 178 | uMode = SetErrorMode( SEM_FAILCRITICALERRORS ); 179 | 180 | if( file == 0 ) 181 | { 182 | /* POSIX says that if the value of file is 0, a handle on a global 183 | * symbol object must be provided. That object must be able to access 184 | * all symbols from the original program file, and any objects loaded 185 | * with the RTLD_GLOBAL flag. 186 | * The return value from GetModuleHandle( ) allows us to retrieve 187 | * symbols only from the original program file. For objects loaded with 188 | * the RTLD_GLOBAL flag, we create our own list later on. 189 | */ 190 | hModule = GetModuleHandle( NULL ); 191 | 192 | if( !hModule ) 193 | save_err_ptr_str( file ); 194 | } 195 | else 196 | { 197 | char lpFileName[MAX_PATH]; 198 | int i; 199 | 200 | /* MSDN says backslashes *must* be used instead of forward slashes. */ 201 | for( i = 0 ; i < sizeof(lpFileName)-1 ; i++ ) 202 | { 203 | if( !file[i] ) 204 | break; 205 | else if( file[i] == '/' ) 206 | lpFileName[i] = '\\'; 207 | else 208 | lpFileName[i] = file[i]; 209 | } 210 | lpFileName[i] = '\0'; 211 | 212 | /* POSIX says the search path is implementation-defined. 213 | * LOAD_WITH_ALTERED_SEARCH_PATH is used to make it behave more closely 214 | * to UNIX's search paths (start with system folders instead of current 215 | * folder). 216 | */ 217 | hModule = LoadLibraryEx( (LPSTR) lpFileName, NULL, 218 | LOAD_WITH_ALTERED_SEARCH_PATH ); 219 | 220 | /* If the object was loaded with RTLD_GLOBAL, add it to list of global 221 | * objects, so that its symbols may be retrieved even if the handle for 222 | * the original program file is passed. POSIX says that if the same 223 | * file is specified in multiple invocations, and any of them are 224 | * RTLD_GLOBAL, even if any further invocations use RTLD_LOCAL, the 225 | * symbols will remain global. 226 | */ 227 | if( !hModule ) 228 | save_err_str( lpFileName ); 229 | else if( (mode & RTLD_GLOBAL) ) 230 | global_add( hModule ); 231 | } 232 | 233 | /* Return to previous state of the error-mode bit flags. */ 234 | SetErrorMode( uMode ); 235 | 236 | return (void *) hModule; 237 | } 238 | 239 | int dlclose( void *handle ) 240 | { 241 | HMODULE hModule = (HMODULE) handle; 242 | BOOL ret; 243 | 244 | current_error = NULL; 245 | 246 | ret = FreeLibrary( hModule ); 247 | 248 | /* If the object was loaded with RTLD_GLOBAL, remove it from list of global 249 | * objects. 250 | */ 251 | if( ret ) 252 | global_rem( hModule ); 253 | else 254 | save_err_ptr_str( handle ); 255 | 256 | /* dlclose's return value in inverted in relation to FreeLibrary's. */ 257 | ret = !ret; 258 | 259 | return (int) ret; 260 | } 261 | 262 | void *dlsym( void *handle, const char *name ) 263 | { 264 | FARPROC symbol; 265 | 266 | current_error = NULL; 267 | 268 | symbol = GetProcAddress( handle, name ); 269 | 270 | if( symbol == NULL ) 271 | { 272 | HMODULE hModule; 273 | 274 | /* If the handle for the original program file is passed, also search 275 | * in all globally loaded objects. 276 | */ 277 | 278 | hModule = GetModuleHandle( NULL ); 279 | 280 | if( hModule == handle ) 281 | { 282 | global_object *pobject; 283 | 284 | for( pobject = &first_object; pobject ; pobject = pobject->next ) 285 | { 286 | if( pobject->hModule ) 287 | { 288 | symbol = GetProcAddress( pobject->hModule, name ); 289 | if( symbol != NULL ) 290 | break; 291 | } 292 | } 293 | } 294 | 295 | CloseHandle( hModule ); 296 | } 297 | 298 | if( symbol == NULL ) 299 | save_err_str( name ); 300 | 301 | return (void*) symbol; 302 | } 303 | 304 | char *dlerror( void ) 305 | { 306 | char *error_pointer = current_error; 307 | 308 | /* POSIX says that invoking dlerror( ) a second time, immediately following 309 | * a prior invocation, shall result in NULL being returned. 310 | */ 311 | current_error = NULL; 312 | 313 | return error_pointer; 314 | } 315 | -------------------------------------------------------------------------------- /src/win/dlfcn.h: -------------------------------------------------------------------------------- 1 | /* 2 | * dlfcn-win32 3 | * Copyright (c) 2007 Ramiro Polla 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version. 9 | * 10 | * This library is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | * Lesser General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU Lesser General Public 16 | * License along with this library; if not, write to the Free Software 17 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 | */ 19 | 20 | #ifndef DLFCN_H 21 | #define DLFCN_H 22 | 23 | /* POSIX says these are implementation-defined. 24 | * To simplify use with Windows API, we treat them the same way. 25 | */ 26 | 27 | #define RTLD_LAZY 0 28 | #define RTLD_NOW 0 29 | 30 | #define RTLD_GLOBAL (1 << 1) 31 | #define RTLD_LOCAL (1 << 2) 32 | 33 | /* These two were added in The Open Group Base Specifications Issue 6. 34 | * Note: All other RTLD_* flags in any dlfcn.h are not standard compliant. 35 | */ 36 | 37 | #define RTLD_DEFAULT 0 38 | #define RTLD_NEXT 0 39 | 40 | void *dlopen ( const char *file, int mode ); 41 | int dlclose( void *handle ); 42 | void *dlsym ( void *handle, const char *name ); 43 | char *dlerror( void ); 44 | 45 | #endif /* DLFCN_H */ 46 | -------------------------------------------------------------------------------- /src/win/fnmatch.c: -------------------------------------------------------------------------------- 1 | /* Copyright (C) 1991, 1992, 1993 Free Software Foundation, Inc. 2 | 3 | NOTE: This source is derived from an old version taken from the GNU C 4 | Library (glibc). 5 | 6 | This program is free software; you can redistribute it and/or modify it 7 | under the terms of the GNU General Public License as published by the 8 | Free Software Foundation; either version 2, or (at your option) any 9 | later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program; if not, write to the Free Software 18 | Foundation, 59 Temple Place - Suite 330, 19 | Boston, MA 02111-1307, USA. */ 20 | 21 | #ifdef HAVE_CONFIG_H 22 | #if defined (CONFIG_BROKETS) 23 | /* We use instead of "config.h" so that a compilation 24 | using -I. -I$srcdir will use ./config.h rather than $srcdir/config.h 25 | (which it would do because it found this file in $srcdir). */ 26 | #include 27 | #else 28 | #include "config.h" 29 | #endif 30 | #endif 31 | 32 | 33 | #ifndef _GNU_SOURCE 34 | #define _GNU_SOURCE 35 | #endif 36 | 37 | /* This code to undef const added in libiberty. */ 38 | #ifndef __STDC__ 39 | /* This is a separate conditional since some stdc systems 40 | reject `defined (const)'. */ 41 | #ifndef const 42 | #define const 43 | #endif 44 | #endif 45 | 46 | #include 47 | #include "fnmatch.h" 48 | #include "safe-ctype.h" 49 | 50 | /* Comment out all this code if we are using the GNU C Library, and are not 51 | actually compiling the library itself. This code is part of the GNU C 52 | Library, but also included in many other GNU distributions. Compiling 53 | and linking in this code is a waste when using the GNU C library 54 | (especially if it is a shared library). Rather than having every GNU 55 | program understand `configure --with-gnu-libc' and omit the object files, 56 | it is simpler to just do this in the source for each such file. */ 57 | 58 | #if defined (_LIBC) || !defined (__GNU_LIBRARY__) 59 | 60 | /* Match STRING against the filename pattern PATTERN, returning zero if 61 | it matches, nonzero if not. */ 62 | int 63 | fnmatch (pattern, string, flags) 64 | const char *pattern; 65 | const char *string; 66 | int flags; 67 | { 68 | register const char *p = pattern, *n = string; 69 | register unsigned char c; 70 | 71 | #define FOLD(c) ((flags & FNM_CASEFOLD) ? TOLOWER (c) : (c)) 72 | 73 | while ((c = *p++) != '\0') 74 | { 75 | c = FOLD (c); 76 | 77 | switch (c) 78 | { 79 | case '?': 80 | if (*n == '\0') 81 | return FNM_NOMATCH; 82 | else if ((flags & FNM_FILE_NAME) && *n == '/') 83 | return FNM_NOMATCH; 84 | else if ((flags & FNM_PERIOD) && *n == '.' && 85 | (n == string || ((flags & FNM_FILE_NAME) && n[-1] == '/'))) 86 | return FNM_NOMATCH; 87 | break; 88 | 89 | case '\\': 90 | if (!(flags & FNM_NOESCAPE)) 91 | { 92 | c = *p++; 93 | c = FOLD (c); 94 | } 95 | if (FOLD ((unsigned char)*n) != c) 96 | return FNM_NOMATCH; 97 | break; 98 | 99 | case '*': 100 | if ((flags & FNM_PERIOD) && *n == '.' && 101 | (n == string || ((flags & FNM_FILE_NAME) && n[-1] == '/'))) 102 | return FNM_NOMATCH; 103 | 104 | for (c = *p++; c == '?' || c == '*'; c = *p++, ++n) 105 | if (((flags & FNM_FILE_NAME) && *n == '/') || 106 | (c == '?' && *n == '\0')) 107 | return FNM_NOMATCH; 108 | 109 | if (c == '\0') 110 | return 0; 111 | 112 | { 113 | unsigned char c1 = (!(flags & FNM_NOESCAPE) && c == '\\') ? *p : c; 114 | c1 = FOLD (c1); 115 | for (--p; *n != '\0'; ++n) 116 | if ((c == '[' || FOLD ((unsigned char)*n) == c1) && 117 | fnmatch (p, n, flags & ~FNM_PERIOD) == 0) 118 | return 0; 119 | return FNM_NOMATCH; 120 | } 121 | 122 | case '[': 123 | { 124 | /* Nonzero if the sense of the character class is inverted. */ 125 | register int not; 126 | 127 | if (*n == '\0') 128 | return FNM_NOMATCH; 129 | 130 | if ((flags & FNM_PERIOD) && *n == '.' && 131 | (n == string || ((flags & FNM_FILE_NAME) && n[-1] == '/'))) 132 | return FNM_NOMATCH; 133 | 134 | not = (*p == '!' || *p == '^'); 135 | if (not) 136 | ++p; 137 | 138 | c = *p++; 139 | for (;;) 140 | { 141 | register unsigned char cstart = c, cend = c; 142 | 143 | if (!(flags & FNM_NOESCAPE) && c == '\\') 144 | cstart = cend = *p++; 145 | 146 | cstart = cend = FOLD (cstart); 147 | 148 | if (c == '\0') 149 | /* [ (unterminated) loses. */ 150 | return FNM_NOMATCH; 151 | 152 | c = *p++; 153 | c = FOLD (c); 154 | 155 | if ((flags & FNM_FILE_NAME) && c == '/') 156 | /* [/] can never match. */ 157 | return FNM_NOMATCH; 158 | 159 | if (c == '-' && *p != ']') 160 | { 161 | cend = *p++; 162 | if (!(flags & FNM_NOESCAPE) && cend == '\\') 163 | cend = *p++; 164 | if (cend == '\0') 165 | return FNM_NOMATCH; 166 | cend = FOLD (cend); 167 | 168 | c = *p++; 169 | } 170 | 171 | if (FOLD ((unsigned char)*n) >= cstart 172 | && FOLD ((unsigned char)*n) <= cend) 173 | goto matched; 174 | 175 | if (c == ']') 176 | break; 177 | } 178 | if (!not) 179 | return FNM_NOMATCH; 180 | break; 181 | 182 | matched:; 183 | /* Skip the rest of the [...] that already matched. */ 184 | while (c != ']') 185 | { 186 | if (c == '\0') 187 | /* [... (unterminated) loses. */ 188 | return FNM_NOMATCH; 189 | 190 | c = *p++; 191 | if (!(flags & FNM_NOESCAPE) && c == '\\') 192 | /* XXX 1003.2d11 is unclear if this is right. */ 193 | ++p; 194 | } 195 | if (not) 196 | return FNM_NOMATCH; 197 | } 198 | break; 199 | 200 | default: 201 | if (c != FOLD ((unsigned char)*n)) 202 | return FNM_NOMATCH; 203 | } 204 | 205 | ++n; 206 | } 207 | 208 | if (*n == '\0') 209 | return 0; 210 | 211 | if ((flags & FNM_LEADING_DIR) && *n == '/') 212 | /* The FNM_LEADING_DIR flag says that "foo*" matches "foobar/frobozz". */ 213 | return 0; 214 | 215 | return FNM_NOMATCH; 216 | } 217 | 218 | #endif /* _LIBC or not __GNU_LIBRARY__. */ 219 | -------------------------------------------------------------------------------- /src/win/fnmatch.h: -------------------------------------------------------------------------------- 1 | /* Copyright 1991, 1992, 1993, 1996 Free Software Foundation, Inc. 2 | 3 | NOTE: The canonical source of this file is maintained with the GNU C Library. 4 | Bugs can be reported to bug-glibc@prep.ai.mit.edu. 5 | 6 | This program is free software; you can redistribute it and/or modify it 7 | under the terms of the GNU General Public License as published by the 8 | Free Software Foundation; either version 2, or (at your option) any 9 | later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program; if not, write to the Free Software 18 | Foundation, 59 Temple Place - Suite 330, 19 | Boston, MA 02111-1307, USA. */ 20 | 21 | #ifndef _FNMATCH_H 22 | 23 | #define _FNMATCH_H 1 24 | 25 | #ifdef __cplusplus 26 | extern "C" { 27 | #endif 28 | 29 | #if defined (__cplusplus) || (defined (__STDC__) && __STDC__) 30 | #undef __P 31 | #define __P(args) args 32 | #else /* Not C++ or ANSI C. */ 33 | #undef __P 34 | #define __P(args) () 35 | /* We can get away without defining `const' here only because in this file 36 | it is used only inside the prototype for `fnmatch', which is elided in 37 | non-ANSI C where `const' is problematical. */ 38 | #endif /* C++ or ANSI C. */ 39 | 40 | 41 | /* We #undef these before defining them because some losing systems 42 | (HP-UX A.08.07 for example) define these in . */ 43 | #undef FNM_PATHNAME 44 | #undef FNM_NOESCAPE 45 | #undef FNM_PERIOD 46 | 47 | /* Bits set in the FLAGS argument to `fnmatch'. */ 48 | #define FNM_PATHNAME (1 << 0) /* No wildcard can ever match `/'. */ 49 | #define FNM_NOESCAPE (1 << 1) /* Backslashes don't quote special chars. */ 50 | #define FNM_PERIOD (1 << 2) /* Leading `.' is matched only explicitly. */ 51 | 52 | #if !defined (_POSIX_C_SOURCE) || _POSIX_C_SOURCE < 2 || defined (_GNU_SOURCE) 53 | #define FNM_FILE_NAME FNM_PATHNAME /* Preferred GNU name. */ 54 | #define FNM_LEADING_DIR (1 << 3) /* Ignore `/...' after a match. */ 55 | #define FNM_CASEFOLD (1 << 4) /* Compare without regard to case. */ 56 | #endif 57 | 58 | /* Value returned by `fnmatch' if STRING does not match PATTERN. */ 59 | #define FNM_NOMATCH 1 60 | 61 | /* Match STRING against the filename pattern PATTERN, 62 | returning zero if it matches, FNM_NOMATCH if not. */ 63 | extern int fnmatch __P ((const char *__pattern, const char *__string, 64 | int __flags)); 65 | 66 | #ifdef __cplusplus 67 | } 68 | #endif 69 | 70 | #endif /* fnmatch.h */ 71 | -------------------------------------------------------------------------------- /src/win/mman.c: -------------------------------------------------------------------------------- 1 | 2 | #include 3 | #include 4 | #include 5 | 6 | #include "mman.h" 7 | 8 | #ifndef FILE_MAP_EXECUTE 9 | #define FILE_MAP_EXECUTE 0x0020 10 | #endif /* FILE_MAP_EXECUTE */ 11 | 12 | static int map_mman_error(const DWORD err, const int deferr) 13 | { 14 | if (err == 0) 15 | return 0; 16 | //TODO: implement 17 | return err; 18 | } 19 | 20 | static DWORD map_mmap_prot_page(const int prot) 21 | { 22 | DWORD protect = 0; 23 | 24 | if (prot == PROT_NONE) 25 | return protect; 26 | 27 | if ((prot & PROT_EXEC) != 0) 28 | { 29 | protect = ((prot & PROT_WRITE) != 0) ? 30 | PAGE_EXECUTE_READWRITE : PAGE_EXECUTE_READ; 31 | } 32 | else 33 | { 34 | protect = ((prot & PROT_WRITE) != 0) ? 35 | PAGE_READWRITE : PAGE_READONLY; 36 | } 37 | 38 | return protect; 39 | } 40 | 41 | static DWORD map_mmap_prot_file(const int prot) 42 | { 43 | DWORD desiredAccess = 0; 44 | 45 | if (prot == PROT_NONE) 46 | return desiredAccess; 47 | 48 | if ((prot & PROT_READ) != 0) 49 | desiredAccess |= FILE_MAP_READ; 50 | if ((prot & PROT_WRITE) != 0) 51 | desiredAccess |= FILE_MAP_WRITE; 52 | if ((prot & PROT_EXEC) != 0) 53 | desiredAccess |= FILE_MAP_EXECUTE; 54 | 55 | return desiredAccess; 56 | } 57 | 58 | void* mmap(void *addr, size_t len, int prot, int flags, int fildes, off_t off) 59 | { 60 | HANDLE fm, h; 61 | 62 | void * map = MAP_FAILED; 63 | 64 | #ifdef _MSC_VER 65 | #pragma warning(push) 66 | #pragma warning(disable: 4293) 67 | #endif 68 | 69 | const DWORD dwFileOffsetLow = (sizeof(off_t) <= sizeof(DWORD)) ? 70 | (DWORD)off : (DWORD)(off & 0xFFFFFFFFL); 71 | const DWORD dwFileOffsetHigh = (sizeof(off_t) <= sizeof(DWORD)) ? 72 | (DWORD)0 : (DWORD)((off >> 32) & 0xFFFFFFFFL); 73 | const DWORD protect = map_mmap_prot_page(prot); 74 | const DWORD desiredAccess = map_mmap_prot_file(prot); 75 | 76 | const off_t maxSize = off + (off_t)len; 77 | 78 | const DWORD dwMaxSizeLow = (sizeof(off_t) <= sizeof(DWORD)) ? 79 | (DWORD)maxSize : (DWORD)(maxSize & 0xFFFFFFFFL); 80 | const DWORD dwMaxSizeHigh = (sizeof(off_t) <= sizeof(DWORD)) ? 81 | (DWORD)0 : (DWORD)((maxSize >> 32) & 0xFFFFFFFFL); 82 | 83 | #ifdef _MSC_VER 84 | #pragma warning(pop) 85 | #endif 86 | 87 | errno = 0; 88 | 89 | if (len == 0 90 | /* Unsupported flag combinations */ 91 | || (flags & MAP_FIXED) != 0 92 | /* Usupported protection combinations */ 93 | || prot == PROT_EXEC) 94 | { 95 | errno = EINVAL; 96 | return MAP_FAILED; 97 | } 98 | 99 | h = ((flags & MAP_ANONYMOUS) == 0) ? 100 | (HANDLE)_get_osfhandle(fildes) : INVALID_HANDLE_VALUE; 101 | 102 | if ((flags & MAP_ANONYMOUS) == 0 && h == INVALID_HANDLE_VALUE) 103 | { 104 | errno = EBADF; 105 | return MAP_FAILED; 106 | } 107 | 108 | fm = CreateFileMapping(h, NULL, protect, dwMaxSizeHigh, dwMaxSizeLow, NULL); 109 | 110 | if (fm == NULL) 111 | { 112 | errno = map_mman_error(GetLastError(), EPERM); 113 | return MAP_FAILED; 114 | } 115 | 116 | map = MapViewOfFile(fm, desiredAccess, dwFileOffsetHigh, dwFileOffsetLow, len); 117 | 118 | CloseHandle(fm); 119 | 120 | if (map == NULL) 121 | { 122 | errno = map_mman_error(GetLastError(), EPERM); 123 | return MAP_FAILED; 124 | } 125 | 126 | return map; 127 | } 128 | 129 | int munmap(void *addr, size_t len) 130 | { 131 | if (UnmapViewOfFile(addr)) 132 | return 0; 133 | 134 | errno = map_mman_error(GetLastError(), EPERM); 135 | 136 | return -1; 137 | } 138 | 139 | int mprotect(void *addr, size_t len, int prot) 140 | { 141 | DWORD newProtect = map_mmap_prot_page(prot); 142 | DWORD oldProtect = 0; 143 | 144 | if (VirtualProtect(addr, len, newProtect, &oldProtect)) 145 | return 0; 146 | 147 | errno = map_mman_error(GetLastError(), EPERM); 148 | 149 | return -1; 150 | } 151 | 152 | int msync(void *addr, size_t len, int flags) 153 | { 154 | if (FlushViewOfFile(addr, len)) 155 | return 0; 156 | 157 | errno = map_mman_error(GetLastError(), EPERM); 158 | 159 | return -1; 160 | } 161 | 162 | int mlock(const void *addr, size_t len) 163 | { 164 | if (VirtualLock((LPVOID)addr, len)) 165 | return 0; 166 | 167 | errno = map_mman_error(GetLastError(), EPERM); 168 | 169 | return -1; 170 | } 171 | 172 | int munlock(const void *addr, size_t len) 173 | { 174 | if (VirtualUnlock((LPVOID)addr, len)) 175 | return 0; 176 | 177 | errno = map_mman_error(GetLastError(), EPERM); 178 | 179 | return -1; 180 | } 181 | -------------------------------------------------------------------------------- /src/win/mman.h: -------------------------------------------------------------------------------- 1 | /* 2 | * sys/mman.h 3 | * mman-win32 4 | */ 5 | 6 | #ifndef _SYS_MMAN_H_ 7 | #define _SYS_MMAN_H_ 8 | 9 | #ifndef _WIN32_WINNT // Allow use of features specific to Windows XP or later. 10 | #define _WIN32_WINNT 0x0501 // Change this to the appropriate value to target other versions of Windows. 11 | #endif 12 | 13 | /* All the headers include this file. */ 14 | #ifndef _MSC_VER 15 | #include <_mingw.h> 16 | #endif 17 | 18 | #include 19 | 20 | #ifdef __cplusplus 21 | extern "C" { 22 | #endif 23 | 24 | #define PROT_NONE 0 25 | #define PROT_READ 1 26 | #define PROT_WRITE 2 27 | #define PROT_EXEC 4 28 | 29 | #define MAP_FILE 0 30 | #define MAP_SHARED 1 31 | #define MAP_PRIVATE 2 32 | #define MAP_TYPE 0xf 33 | #define MAP_FIXED 0x10 34 | #define MAP_ANONYMOUS 0x20 35 | #define MAP_ANON MAP_ANONYMOUS 36 | #define MAP_NORESERVE 0 37 | 38 | #define MAP_FAILED ((void *)-1) 39 | 40 | /* Flags for msync. */ 41 | #define MS_ASYNC 1 42 | #define MS_SYNC 2 43 | #define MS_INVALIDATE 4 44 | 45 | void* mmap(void *addr, size_t len, int prot, int flags, int fildes, off_t off); 46 | int munmap(void *addr, size_t len); 47 | int mprotect(void *addr, size_t len, int prot); 48 | int msync(void *addr, size_t len, int flags); 49 | int mlock(const void *addr, size_t len); 50 | int munlock(const void *addr, size_t len); 51 | 52 | #ifdef __cplusplus 53 | }; 54 | #endif 55 | 56 | #endif /* _SYS_MMAN_H_ */ 57 | -------------------------------------------------------------------------------- /src/win/pread.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | 6 | ssize_t pread(int __fd,void* __buf,size_t __nbytes,off_t __offset) 7 | { 8 | ssize_t ret; 9 | off_t old = lseek(__fd,0,SEEK_CUR); 10 | if(old==(off_t)-1)return -1; 11 | if(-1==lseek(__fd,__offset,SEEK_SET))return -1; 12 | ret=read(__fd,__buf,__nbytes); 13 | lseek(__fd,old,SEEK_SET); 14 | return ret; 15 | } 16 | -------------------------------------------------------------------------------- /src/win/safe-ctype.c: -------------------------------------------------------------------------------- 1 | /* replacement macros. 2 | 3 | Copyright (C) 2000 Free Software Foundation, Inc. 4 | Contributed by Zack Weinberg . 5 | 6 | This file is part of the libiberty library. 7 | Libiberty is free software; you can redistribute it and/or 8 | modify it under the terms of the GNU Library General Public 9 | License as published by the Free Software Foundation; either 10 | version 2 of the License, or (at your option) any later version. 11 | 12 | Libiberty is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | Library General Public License for more details. 16 | 17 | You should have received a copy of the GNU Library General Public 18 | License along with libiberty; see the file COPYING.LIB. If 19 | not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, 20 | Boston, MA 02111-1307, USA. */ 21 | 22 | /* This is a compatible replacement of the standard C library's 23 | with the following properties: 24 | 25 | - Implements all isxxx() macros required by C99. 26 | - Also implements some character classes useful when 27 | parsing C-like languages. 28 | - Does not change behavior depending on the current locale. 29 | - Behaves properly for all values in the range of a signed or 30 | unsigned char. */ 31 | 32 | #include "ansidecl.h" 33 | #include "safe-ctype.h" 34 | #include /* for EOF */ 35 | 36 | /* Shorthand */ 37 | #define bl _sch_isblank 38 | #define cn _sch_iscntrl 39 | #define di _sch_isdigit 40 | #define is _sch_isidst 41 | #define lo _sch_islower 42 | #define nv _sch_isnvsp 43 | #define pn _sch_ispunct 44 | #define pr _sch_isprint 45 | #define sp _sch_isspace 46 | #define up _sch_isupper 47 | #define vs _sch_isvsp 48 | #define xd _sch_isxdigit 49 | 50 | /* Masks. */ 51 | #define L (const unsigned short) (lo|is |pr) /* lower case letter */ 52 | #define XL (const unsigned short) (lo|is|xd|pr) /* lowercase hex digit */ 53 | #define U (const unsigned short) (up|is |pr) /* upper case letter */ 54 | #define XU (const unsigned short) (up|is|xd|pr) /* uppercase hex digit */ 55 | #define D (const unsigned short) (di |xd|pr) /* decimal digit */ 56 | #define P (const unsigned short) (pn |pr) /* punctuation */ 57 | #define _ (const unsigned short) (pn|is |pr) /* underscore */ 58 | 59 | #define C (const unsigned short) ( cn) /* control character */ 60 | #define Z (const unsigned short) (nv |cn) /* NUL */ 61 | #define M (const unsigned short) (nv|sp |cn) /* cursor movement: \f \v */ 62 | #define V (const unsigned short) (vs|sp |cn) /* vertical space: \r \n */ 63 | #define T (const unsigned short) (nv|sp|bl|cn) /* tab */ 64 | #define S (const unsigned short) (nv|sp|bl|pr) /* space */ 65 | 66 | /* Are we ASCII? */ 67 | #if '\n' == 0x0A && ' ' == 0x20 && '0' == 0x30 \ 68 | && 'A' == 0x41 && 'a' == 0x61 && '!' == 0x21 \ 69 | && EOF == -1 70 | 71 | const unsigned short _sch_istable[256] = 72 | { 73 | Z, C, C, C, C, C, C, C, /* NUL SOH STX ETX EOT ENQ ACK BEL */ 74 | C, T, V, M, M, V, C, C, /* BS HT LF VT FF CR SO SI */ 75 | C, C, C, C, C, C, C, C, /* DLE DC1 DC2 DC3 DC4 NAK SYN ETB */ 76 | C, C, C, C, C, C, C, C, /* CAN EM SUB ESC FS GS RS US */ 77 | S, P, P, P, P, P, P, P, /* SP ! " # $ % & ' */ 78 | P, P, P, P, P, P, P, P, /* ( ) * + , - . / */ 79 | D, D, D, D, D, D, D, D, /* 0 1 2 3 4 5 6 7 */ 80 | D, D, P, P, P, P, P, P, /* 8 9 : ; < = > ? */ 81 | P, XU, XU, XU, XU, XU, XU, U, /* @ A B C D E F G */ 82 | U, U, U, U, U, U, U, U, /* H I J K L M N O */ 83 | U, U, U, U, U, U, U, U, /* P Q R S T U V W */ 84 | U, U, U, P, P, P, P, _, /* X Y Z [ \ ] ^ _ */ 85 | P, XL, XL, XL, XL, XL, XL, L, /* ` a b c d e f g */ 86 | L, L, L, L, L, L, L, L, /* h i j k l m n o */ 87 | L, L, L, L, L, L, L, L, /* p q r s t u v w */ 88 | L, L, L, P, P, P, P, C, /* x y z { | } ~ DEL */ 89 | 90 | /* high half of unsigned char is locale-specific, so all tests are 91 | false in "C" locale */ 92 | 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93 | 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 94 | 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 95 | 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 96 | 97 | 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 98 | 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 99 | 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 100 | 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 101 | }; 102 | 103 | const unsigned char _sch_tolower[256] = 104 | { 105 | 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 106 | 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 107 | 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 108 | 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 109 | 64, 110 | 111 | 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 112 | 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', 113 | 114 | 91, 92, 93, 94, 95, 96, 115 | 116 | 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 117 | 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', 118 | 119 | 123,124,125,126,127, 120 | 121 | 128,129,130,131, 132,133,134,135, 136,137,138,139, 140,141,142,143, 122 | 144,145,146,147, 148,149,150,151, 152,153,154,155, 156,157,158,159, 123 | 160,161,162,163, 164,165,166,167, 168,169,170,171, 172,173,174,175, 124 | 176,177,178,179, 180,181,182,183, 184,185,186,187, 188,189,190,191, 125 | 126 | 192,193,194,195, 196,197,198,199, 200,201,202,203, 204,205,206,207, 127 | 208,209,210,211, 212,213,214,215, 216,217,218,219, 220,221,222,223, 128 | 224,225,226,227, 228,229,230,231, 232,233,234,235, 236,237,238,239, 129 | 240,241,242,243, 244,245,246,247, 248,249,250,251, 252,253,254,255, 130 | }; 131 | 132 | const unsigned char _sch_toupper[256] = 133 | { 134 | 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 135 | 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 136 | 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 137 | 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 138 | 64, 139 | 140 | 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 141 | 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 142 | 143 | 91, 92, 93, 94, 95, 96, 144 | 145 | 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 146 | 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 147 | 148 | 123,124,125,126,127, 149 | 150 | 128,129,130,131, 132,133,134,135, 136,137,138,139, 140,141,142,143, 151 | 144,145,146,147, 148,149,150,151, 152,153,154,155, 156,157,158,159, 152 | 160,161,162,163, 164,165,166,167, 168,169,170,171, 172,173,174,175, 153 | 176,177,178,179, 180,181,182,183, 184,185,186,187, 188,189,190,191, 154 | 155 | 192,193,194,195, 196,197,198,199, 200,201,202,203, 204,205,206,207, 156 | 208,209,210,211, 212,213,214,215, 216,217,218,219, 220,221,222,223, 157 | 224,225,226,227, 228,229,230,231, 232,233,234,235, 236,237,238,239, 158 | 240,241,242,243, 244,245,246,247, 248,249,250,251, 252,253,254,255, 159 | }; 160 | 161 | #else 162 | #error "Unsupported host character set" 163 | #endif /* not ASCII */ 164 | -------------------------------------------------------------------------------- /src/win/safe-ctype.h: -------------------------------------------------------------------------------- 1 | /* replacement macros. 2 | 3 | Copyright (C) 2000, 2001 Free Software Foundation, Inc. 4 | Contributed by Zack Weinberg . 5 | 6 | This file is part of the libiberty library. 7 | Libiberty is free software; you can redistribute it and/or 8 | modify it under the terms of the GNU Library General Public 9 | License as published by the Free Software Foundation; either 10 | version 2 of the License, or (at your option) any later version. 11 | 12 | Libiberty is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | Library General Public License for more details. 16 | 17 | You should have received a copy of the GNU Library General Public 18 | License along with libiberty; see the file COPYING.LIB. If 19 | not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, 20 | Boston, MA 02111-1307, USA. */ 21 | 22 | /* This is a compatible replacement of the standard C library's 23 | with the following properties: 24 | 25 | - Implements all isxxx() macros required by C99. 26 | - Also implements some character classes useful when 27 | parsing C-like languages. 28 | - Does not change behavior depending on the current locale. 29 | - Behaves properly for all values in the range of a signed or 30 | unsigned char. 31 | 32 | To avoid conflicts, this header defines the isxxx functions in upper 33 | case, e.g. ISALPHA not isalpha. */ 34 | 35 | #ifndef SAFE_CTYPE_H 36 | #define SAFE_CTYPE_H 37 | 38 | // #ifdef isalpha 39 | // #error "safe-ctype.h and ctype.h may not be used simultaneously" 40 | // #else 41 | 42 | /* Categories. */ 43 | 44 | enum { 45 | /* In C99 */ 46 | _sch_isblank = 0x0001, /* space \t */ 47 | _sch_iscntrl = 0x0002, /* nonprinting characters */ 48 | _sch_isdigit = 0x0004, /* 0-9 */ 49 | _sch_islower = 0x0008, /* a-z */ 50 | _sch_isprint = 0x0010, /* any printing character including ' ' */ 51 | _sch_ispunct = 0x0020, /* all punctuation */ 52 | _sch_isspace = 0x0040, /* space \t \n \r \f \v */ 53 | _sch_isupper = 0x0080, /* A-Z */ 54 | _sch_isxdigit = 0x0100, /* 0-9A-Fa-f */ 55 | 56 | /* Extra categories useful to cpplib. */ 57 | _sch_isidst = 0x0200, /* A-Za-z_ */ 58 | _sch_isvsp = 0x0400, /* \n \r */ 59 | _sch_isnvsp = 0x0800, /* space \t \f \v \0 */ 60 | 61 | /* Combinations of the above. */ 62 | _sch_isalpha = _sch_isupper|_sch_islower, /* A-Za-z */ 63 | _sch_isalnum = _sch_isalpha|_sch_isdigit, /* A-Za-z0-9 */ 64 | _sch_isidnum = _sch_isidst|_sch_isdigit, /* A-Za-z0-9_ */ 65 | _sch_isgraph = _sch_isalnum|_sch_ispunct, /* isprint and not space */ 66 | _sch_iscppsp = _sch_isvsp|_sch_isnvsp, /* isspace + \0 */ 67 | _sch_isbasic = _sch_isprint|_sch_iscppsp /* basic charset of ISO C 68 | (plus ` and @) */ 69 | }; 70 | 71 | /* Character classification. */ 72 | extern const unsigned short _sch_istable[256]; 73 | 74 | #define _sch_test(c, bit) (_sch_istable[(c) & 0xff] & (unsigned short)(bit)) 75 | 76 | #define ISALPHA(c) _sch_test(c, _sch_isalpha) 77 | #define ISALNUM(c) _sch_test(c, _sch_isalnum) 78 | #define ISBLANK(c) _sch_test(c, _sch_isblank) 79 | #define ISCNTRL(c) _sch_test(c, _sch_iscntrl) 80 | #define ISDIGIT(c) _sch_test(c, _sch_isdigit) 81 | #define ISGRAPH(c) _sch_test(c, _sch_isgraph) 82 | #define ISLOWER(c) _sch_test(c, _sch_islower) 83 | #define ISPRINT(c) _sch_test(c, _sch_isprint) 84 | #define ISPUNCT(c) _sch_test(c, _sch_ispunct) 85 | #define ISSPACE(c) _sch_test(c, _sch_isspace) 86 | #define ISUPPER(c) _sch_test(c, _sch_isupper) 87 | #define ISXDIGIT(c) _sch_test(c, _sch_isxdigit) 88 | 89 | #define ISIDNUM(c) _sch_test(c, _sch_isidnum) 90 | #define ISIDST(c) _sch_test(c, _sch_isidst) 91 | #define IS_ISOBASIC(c) _sch_test(c, _sch_isbasic) 92 | #define IS_VSPACE(c) _sch_test(c, _sch_isvsp) 93 | #define IS_NVSPACE(c) _sch_test(c, _sch_isnvsp) 94 | #define IS_SPACE_OR_NUL(c) _sch_test(c, _sch_iscppsp) 95 | 96 | /* Character transformation. */ 97 | extern const unsigned char _sch_toupper[256]; 98 | extern const unsigned char _sch_tolower[256]; 99 | #define TOUPPER(c) _sch_toupper[(c) & 0xff] 100 | #define TOLOWER(c) _sch_tolower[(c) & 0xff] 101 | 102 | // #endif /* no ctype.h */ 103 | #endif /* SAFE_CTYPE_H */ 104 | -------------------------------------------------------------------------------- /src/win/usleep.c: -------------------------------------------------------------------------------- 1 | #define WIN32_LEAN_AND_MEAN 1 2 | #include 3 | 4 | /* forum post by cyi823 5oct2005 at c-plusplus.net */ 5 | void win_usleep(unsigned int usec) 6 | { 7 | HANDLE timer; 8 | LARGE_INTEGER due; 9 | 10 | due.QuadPart = -(10 * (__int64)usec); 11 | timer = CreateWaitableTimer(NULL, TRUE, NULL); 12 | SetWaitableTimer(timer, &due, 0, NULL, NULL, 0); 13 | WaitForSingleObject(timer, INFINITE); 14 | CloseHandle(timer); 15 | } 16 | -------------------------------------------------------------------------------- /verb/vt_dyad.c: -------------------------------------------------------------------------------- 1 | /* dyadic verbs */ 2 | 3 | #include "vtab.h" 4 | 5 | /* These are just notes so far, for brainstorming about optimizations. Not 6 | * actually compiled, yet. Eventually, this may drive verb dispatch. 7 | * 8 | * Also, note that projection over lists is not explicitly noted here, 9 | * e.g. for 1 + (1 2 3; 4 5 6; 7 8 9) there aren't explict (TI, TL), (TF, TL), 10 | * (TL, TI), ... cases. That may be simpler to handle in the dispatcher. 11 | * Either way, anything marked SCALAR should project. (right?) 12 | */ 13 | 14 | 15 | /* Tags: 16 | * ATOM: atom / list distinction is significant 17 | * BOOL: special case for boolean vectors 18 | */ 19 | 20 | /* poss. type signatures for dyads: 21 | * 22 | * basic: 23 | * K *foo(K *a, K *b) 24 | * 25 | * pass in return pointer, when b can be modified in place: 26 | * K *foo(K *a, K *b, K *z) 27 | * 28 | * pass in value vectors & counts, for scalars that don't need to access 29 | * other parts of the K (so that one thread could handle the first (ct) 30 | * values, another would get an offset pointer and handle the next (ct), 31 | * etc.): 32 | * K *foo(V *a, I na, V *b, I nb, V *z) 33 | * 34 | * Variant for 1:N and N:1 cases (e.g. 1+1 2 3): 35 | * K *foo(V *a, I na, V b, V *z) 36 | * K *foo(V a, V *b, I nb, V *z) 37 | * 38 | * Others? Not all dyadic funs should need the same type signature. 39 | */ 40 | 41 | 42 | /********** 43 | * Macros * 44 | **********/ 45 | 46 | #define d_table(name) static const struct dispatch_dyad name [] 47 | 48 | /* sentinel. If reached during dispatch, throw type error. */ 49 | #define EOV {0, 0, 0, 0, 0} 50 | 51 | #define SCALAR(fname, flags) \ 52 | { TI, TI, fname ## II, TI, flags }, \ 53 | { TI, TF, fname ## IF, TF, flags }, \ 54 | { TF, TI, fname ## FI, TF, flags }, \ 55 | { TF, TF, fname ## FF, TF, flags } 56 | 57 | /********* 58 | * Verbs * 59 | *********/ 60 | 61 | d_table(d_plus) = { 62 | SCALAR(plus, VF_SAME_SIZE), 63 | EOV 64 | }; 65 | 66 | d_table(d_minus) = { 67 | SCALAR(minus, VF_SAME_SIZE), 68 | EOV 69 | }; 70 | 71 | 72 | d_table(d_asterisk) = { 73 | SCALAR(times, VF_SAME_SIZE), 74 | EOV 75 | }; 76 | 77 | 78 | d_table(d_percent) = { 79 | SCALAR(div, VF_SAME_SIZE), 80 | EOV 81 | }; 82 | 83 | 84 | d_table(d_pipe) = { 85 | SCALAR(max_or, VF_SAME_SIZE), 86 | EOV 87 | }; 88 | 89 | 90 | d_table(d_ampersand) = { 91 | SCALAR(min_and, VF_SAME_SIZE), 92 | EOV 93 | }; 94 | 95 | 96 | d_table(d_caret) = { 97 | SCALAR(power, VF_SAME_SIZE), 98 | EOV 99 | }; 100 | 101 | /* 2!1 2 3 4 5 is rotate, 1 2 3 4 5!2 is mod. One of few cases where the 102 | * ATOM / list distinction actually impacts results. */ 103 | d_table(d_excl) = { /* ATOM */ 104 | { TIA, TAny, rotate, TAny, VF_SAME_SIZE | VF_REARRANGE}, 105 | { TI, TIA, modII, TI, VF_SAME_SIZE /*as left*/}, 106 | { TF, TIA, modFI, TI, VF_SAME_SIZE /*as left*/}, 107 | { TI, TF, mod, TI, VF_SAME_SIZE}, 108 | EOV 109 | }; 110 | 111 | d_table(d_lt) = { /* Could also return BOOL */ 112 | { TI, TI, ltII, TI, VF_SAME_SIZE}, 113 | { TI, TF, ltIF, TI, VF_SAME_SIZE}, 114 | { TF, TI, ltFI, TI, VF_SAME_SIZE}, 115 | { TF, TF, ltFF, TI, VF_SAME_SIZE}, 116 | { TC, TC, ltCC, TI, VF_SAME_SIZE}, 117 | { TS, TS, ltSS, TI, VF_SAME_SIZE}, 118 | EOV 119 | }; 120 | 121 | d_table(d_gt) = { 122 | { TI, TI, gtII, TI, VF_SAME_SIZE}, 123 | { TI, TF, gtIF, TI, VF_SAME_SIZE}, 124 | { TF, TI, gtFI, TI, VF_SAME_SIZE}, 125 | { TF, TF, gtFF, TI, VF_SAME_SIZE}, 126 | { TC, TC, gtCC, TI, VF_SAME_SIZE}, 127 | { TS, TS, gtSS, TI, VF_SAME_SIZE}, 128 | EOV 129 | }; 130 | 131 | d_table(d_eq) = { 132 | { TI, TI, eqII, TI, VF_SAME_SIZE}, 133 | { TI, TF, eqIF, TI, VF_SAME_SIZE}, 134 | { TF, TI, eqFI, TI, VF_SAME_SIZE}, 135 | { TF, TF, eqFF, TI, VF_SAME_SIZE}, 136 | { TC, TC, eqCC, TI, VF_SAME_SIZE}, 137 | { TS, TS, eqSS, TI, VF_SAME_SIZE}, 138 | EOV 139 | }; 140 | 141 | /* Unlike eq, returns 0 or 1 for whole structure, not atoms. */ 142 | d_table(d_tilde) = { 143 | { TL, TL, matchLL, TI, VF_REDUCER}, 144 | { TI, TI, matchII, TI, VF_REDUCER}, 145 | { TI, TF, matchIF, TI, VF_REDUCER}, 146 | { TF, TI, matchFI, TI, VF_REDUCER}, 147 | { TF, TF, matchFF, TI, VF_REDUCER}, 148 | { TC, TC, matchCC, TI, VF_REDUCER}, 149 | { TS, TS, matchSS, TI, VF_REDUCER}, 150 | { TD, TD, matchDD, TI, VF_REDUCER}, /* DICT */ 151 | /* all other comparisons fail, just return 0 */ 152 | { TAny, TAny, return0, TI, VF_REDUCER}, 153 | EOV 154 | }; 155 | 156 | d_table(d_at) = { 157 | { TFun, TAny, dot, TAny, VF_NONE}, /* enlist right arg & apply function */ 158 | { TS, TAny, nyi, TAny, NF_NYI}, 159 | { TAny, TI, at_verbI, TAny, NF_NONE}, /* vector lookup */ 160 | { TD, TS, at_verbDS, TAny, NF_NONE}, /* DICT lookup */ 161 | { TAny, TN, identity, TAny, NF_SAME_SIZE}, /* a[] or a@_n -> a */ 162 | EOV 163 | }; 164 | 165 | d_table(d_question) = { 166 | { TFun, TAny, what_triadic, TAny, VF_NONE}, /* find function inverse, secant method */ 167 | /* 10?30 = 10 random ints 0<=n<30; -10?30 is w/out replacement (all distinct) */ 168 | { TI, TI, qrandI, TI, VF_EXPANDER}, 169 | /* same as above, but random floats; 2?1.0 -> 0.2953862 0.2792765 */ 170 | { TI, TF, qrandF, TF, VF_EXPANDER}, 171 | EOV 172 | }; 173 | 174 | d_table(d_underscore) = { 175 | { TIA, TAny, drop, TAny, VF_REDUCER}, /* 3_!5 -> 3 4; -3_!5 -> 0 1 */ 176 | { TI, TAny, cut, TAny, VF_REARRANGE}, /* 3 6_!10 -> (3 4 5; 6 7 8 9) */ 177 | EOV 178 | }; 179 | 180 | d_table(d_comma) = { /* missing any? */ 181 | { TL, TL, joinLL, TL, VF_EXPANDER}, 182 | { TI, TI, joinII, TI, VF_EXPANDER}, 183 | { TF, TF, joinFF, TF, VF_EXPANDER}, 184 | { TC, TC, joinCC, TC, VF_EXPANDER}, 185 | { TS, TS, joinSS, TS, VF_EXPANDER}, 186 | EOV 187 | }; 188 | 189 | d_table(d_pound) = { 190 | /* reduces when a < b->n, "overtaking" loops b to fill */ 191 | { TIA, TAny, take, TAny, VF_NONE}, 192 | { TI, TAny, reshape, TAny, VF_NONE}, /* num dimensions = #a */ 193 | EOV 194 | }; 195 | 196 | d_table(d_dollar) = { /* "format", convert to char */ 197 | { TI, TAny, formatI, TAny /*TC or TL*/, VF_NONE}, 198 | { TF, TI, formatFI, TAny /*TC or TL*/, VF_NONE}, 199 | { TF, TF, formatFF, TAny /*TC or TL*/, VF_NONE}, 200 | { TC, TC, identity, TC, VF_SAME_SIZE}, /* a is ignored, why? */ 201 | { TSA, TC, char_to_symbol, TS, VF_REDUCER}, /* `$"foo" -> `foo */ 202 | EOV 203 | }; 204 | 205 | d_table(d_dot) = { /* TODO */ 206 | EOV 207 | }; 208 | 209 | d_table(d_colon) = { /* TODO */ 210 | EOV 211 | }; 212 | -------------------------------------------------------------------------------- /verb/vt_monad.c: -------------------------------------------------------------------------------- 1 | /* monadic verbs */ 2 | 3 | #include "vtab.h" 4 | 5 | /* These are just notes so far, for brainstorming about optimizations. Not 6 | * actually compiled, yet. Eventually, this may drive verb dispatch. */ 7 | 8 | 9 | /* Tags: 10 | * ATOM: atom / list distinction is significant 11 | * BOOL: special case for boolean vectors 12 | */ 13 | 14 | /********** 15 | * Macros * 16 | **********/ 17 | 18 | /* These are really repetitive, but may still be worth spelling them out 19 | * explicitly if we generate docs from this. 20 | */ 21 | 22 | /* macro for all 'a -> 'a monadic verbs */ 23 | #define eachL1(fname, flags) \ 24 | { TL, fname ## L, TL, flags }, \ 25 | { TI, fname ## I, TI, flags }, \ 26 | { TF, fname ## F, TF, flags }, \ 27 | { TC, fname ## C, TC, flags }, \ 28 | { TS, fname ## S, TS, flags } 29 | 30 | /* macro for all 'a -> 'a monadic verbs, same fun */ 31 | #define eachL1Same(fname, flags) \ 32 | { TL, fname, TL, flags }, \ 33 | { TI, fname, TI, flags }, \ 34 | { TF, fname, TF, flags }, \ 35 | { TC, fname, TC, flags }, \ 36 | { TS, fname, TS, flags } 37 | 38 | /* macro for all 'a -> TI monadic verbs */ 39 | #define eachL1I(fname, flags) \ 40 | { TL, fname ## L, TI, flags }, \ 41 | { TI, fname ## I, TI, flags }, \ 42 | { TF, fname ## F, TI, flags }, \ 43 | { TC, fname ## C, TI, flags }, \ 44 | { TS, fname ## S, TI, flags } 45 | 46 | 47 | #define m_table(name) static const struct dispatch_monad name [] 48 | 49 | /* sentinel. If reached during dispatch, throw type error. */ 50 | #define EOV {0, 0, 0, 0} 51 | 52 | /********* 53 | * Verbs * 54 | *********/ 55 | 56 | m_table(m_plus) = { 57 | { TL, flip, TL, VF_TYPE }, /* NB: shadows TL */ 58 | eachL1(identify, VF_TYPE), 59 | EOV 60 | }; 61 | 62 | m_table(m_minus) = { 63 | { TI, negI, TI, 0 }, 64 | { TF, negF, TF, 0 }, 65 | EOV 66 | }; 67 | 68 | 69 | m_table(m_asterisk) = { 70 | eachL1(first, VF_SIZE | VF_REDUCER), 71 | EOV 72 | }; 73 | 74 | 75 | m_table(m_percent) = { 76 | { TI, recipI, TI, VF_SAME_SIZE }, 77 | { TF, recipF, TF, VF_SAME_SIZE }, 78 | EOV 79 | }; 80 | 81 | 82 | m_table(m_pipe) = { 83 | eachL1(reverse, VF_SIZE | VF_REARRANGE), 84 | EOV 85 | }; 86 | 87 | 88 | /* & can either reduce or grow, though is often used to reduce 89 | * implicitly boolean vectors. A distinct BOOL type would make this clearer, 90 | * but converting to/from bools elsewhere could also be messy. */ 91 | m_table(m_ampersand) = { 92 | { TI, where, TI, VF_REDUCER }, /* doesn't always reduce... */ 93 | EOV 94 | }; 95 | 96 | 97 | m_table(m_caret) = { 98 | { TL, shape, TI, 0 }, /* all share same implementation */ 99 | { TI, shape, TI, 0 }, 100 | { TF, shape, TI, 0 }, 101 | { TC, shape, TI, 0 }, 102 | { TS, shape, TI, 0 }, 103 | { TD, shape, TI, 0 }, /* DICT */ 104 | { TN, shape, TI, 0 }, 105 | { TF, shape, TI, 0 }, 106 | EOV 107 | }; 108 | 109 | /* ATOM, length ~= 1 for arg is currently unused */ 110 | m_table(m_excl) = { 111 | { TIA, enumerate, TI, 0 }, 112 | { TFA, enumerate, TI, 0 }, 113 | { TCA, ls_directory, TL, 0 }, /* currently called "enumerate_charvec" */ 114 | /* NYI { TS, enumerate dictionary of sym on k-tree, TL, 0 }, */ 115 | { TD, keys, TS, 0 }, /* DICT */ 116 | { TN, enumerateN, TD, 0 }, 117 | // { TF, funcname, Tr, 0 }, 118 | EOV 119 | }; 120 | 121 | m_table(m_lt) = { 122 | eachL1I(gradeup, VF_SAME_SIZE), 123 | EOV 124 | }; 125 | 126 | m_table(m_gt) = { 127 | eachL1I(gradedown, VF_SAME_SIZE), 128 | EOV 129 | }; 130 | 131 | m_table(m_eq) = { 132 | eachL1I(group, 0), 133 | EOV 134 | }; 135 | 136 | m_table(m_tilde) = { 137 | { TL, not_attr_project, TL, 0 }, 138 | { TI, notI, TI, VF_SAME_SIZE }, /* 0 0 1 0 -> 1 1 0 1, BOOL */ 139 | { TF, notF, TI, 0 }, /* 0.0 0.1 3.4 0.0 5.0 -> 1 0 0 1 0, BOOL */ 140 | { TS, notsp, TS, 0 }, /* this adds . to a symbol. use case? */ 141 | EOV 142 | }; 143 | 144 | m_table(m_at) = { 145 | eachL1Same(atom, VF_REDUCER, VF_SIZE), 146 | { TD, atom, TI, VF_REDUCER, VF_SIZE }, /* DICT */ 147 | { TN, atom, TI, VF_REDUCER, VF_SIZE }, 148 | { TF, atom, TI, VF_REDUCER, VF_SIZE }, 149 | EOV 150 | }; 151 | 152 | m_table(m_question) = { 153 | eachL1(range, VF_REDUCER), 154 | EOV 155 | }; 156 | 157 | m_table(m_underscore) = { 158 | { TL, floorL, TL, 0 }, 159 | { TI, identity, TI, 0 }, 160 | { TF, floorF, TF, 0 }, 161 | EOV 162 | }; 163 | 164 | m_table(m_comma) = { /* FIXME atom vs list */ 165 | eachL1(enlist, 0), 166 | EOV 167 | }; 168 | 169 | m_table(m_pound) = { 170 | eachL1Same(count, VF_REDUCER | VF_SIZE), 171 | EOV 172 | }; 173 | 174 | m_table(m_dollar) = { /* ATOM/list affects return type, C or L-of-C */ 175 | { TIA, formatI, TC, 0 }, 176 | { TFA, formatF, TC, 0 }, 177 | { TCA, identity, TC, 0 }, 178 | { TSA, formatS, TC, 0 }, 179 | { TL, formatL, TL, 0 }, 180 | { TI, formatI, TL, 0 }, 181 | { TF, formatF, TL, 0 }, 182 | { TC, identity, TL, 0 }, 183 | { TS, formatS, TL, 0 }, 184 | { TD, funcname, Tr, 0 }, /* FIXME "Beats me -- this has a similar signature to a _hash" DICT */ 185 | EOV 186 | }; 187 | 188 | m_table(m_dot) = { /* are these correct? */ 189 | { TL, make_dict, TD, 0 }, /* DICT */ 190 | { TC, eval, TAny, 0 }, 191 | { TS, dump_tree, TD, 0 }, /* DICT */ 192 | { TD, unmake_dict, TL, 0 }, /* DICT */ 193 | EOV 194 | }; 195 | 196 | m_table(m_colon) = { /* FIXME. Just calls ci(a). Use? */ 197 | // { TL, funcname, Tr, 0 }, 198 | // { TI, funcname, Tr, 0 }, 199 | // { TF, funcname, Tr, 0 }, 200 | // { TC, funcname, Tr, 0 }, 201 | // { TS, funcname, Tr, 0 }, 202 | // { TD, funcname, Tr, 0 }, 203 | // { TN, funcname, Tr, 0 }, 204 | // { TF, funcname, Tr, 0 }, 205 | EOV 206 | }; 207 | -------------------------------------------------------------------------------- /verb/vtab.h: -------------------------------------------------------------------------------- 1 | #ifndef VTAB_H 2 | #define VTAB_H 3 | 4 | /* verb tables */ 5 | 6 | /* Verb types. Where atoms and lists are handled distinctly, use TIA etc. */ 7 | typedef enum { TL, TI, TF, TC, TS, TD, TN, TFun, TAny, 8 | TIA = -1, TFA = -2, TCA = -3, TSA = -4, 9 | } TV; 10 | 11 | typedef enum verb_flags { 12 | VF_NONE, 13 | VF_SIZE, /* return size known before running */ 14 | VF_SAME_SIZE, /* same return size as larger argument, implies VF_SIZE */ 15 | VF_EXPANDER, /* tends to expand input */ 16 | VF_REDUCER, /* tends to reduce input */ 17 | VF_REARRANGE, /* rearranges input (same size) */ 18 | VF_MUTATES, /* modifies input in place */ 19 | VF_NYI, /* not yet implemented */ 20 | /* other attributes? */ 21 | } verb_flags; 22 | 23 | struct dispatch_nilad { 24 | K (*f)(K z), 25 | TV rt, 26 | verb_flags flags 27 | }; 28 | 29 | 30 | /* Type signature for monadic verbs could be f(K a), f(K a, K z), 31 | * f(void *a, I n), f(void *a, I n, K z), etc. 32 | * Are there any monadic cases where the argument could be mutated 33 | * in-place (w/ refcount of 1)? Most of those are dyadic. 34 | * Passing in a void * and count would allow different ranges of 35 | * the argument to be handled in parallel. 36 | * While void *s would be used, each verb function is already 37 | * made type-specific at compile-time, i.e., floorF or firstI. 38 | */ 39 | struct dispatch_monad { 40 | int at, 41 | K (*f)(K a, K z), 42 | TV rt, 43 | verb_flags flags 44 | }; 45 | 46 | 47 | /* Same issues as dispatch_monad, except most scalars would clearly 48 | * benefit from type f(void *a, I an, void *b, I bn, K z); if b has 49 | * the expected return type and length and b's refcount is 1, z's 50 | * vector should point at b (mutate in-place), otherwise alloc a 51 | * new K for the result. 52 | */ 53 | struct dispatch_dyad { 54 | int at, 55 | int bt, 56 | K (*f)(K a, K b, K z), 57 | TV rt, 58 | verb_flags flags 59 | }; 60 | 61 | /* Are there any cases for triad or tetrad where the dyadic 62 | * optimizations apply? 63 | */ 64 | struct dispatch_triad { 65 | int at, 66 | int bt, 67 | int ct, 68 | K (*f)(K a, K b, K c, K z), 69 | TV rt, 70 | verb_flags flags 71 | }; 72 | 73 | struct dispatch_tetrad { 74 | int at, 75 | int bt, 76 | int ct, 77 | int dt, 78 | K (*f)(K a, K b, K c, K d, K z), 79 | TV rt, 80 | verb_flags flags 81 | }; 82 | 83 | #define VF_SCALAR (VF_SAME_SIZE) 84 | 85 | #endif 86 | --------------------------------------------------------------------------------