├── .gitignore ├── LICENSE ├── Makefile ├── Makefile.macosx ├── README.md ├── aliases.scm ├── ascii-mona-lisa ├── ascii-mona-lisa-2 ├── attic ├── s.c ├── scrap.c └── scrap.lsp ├── bootstrap.sh ├── builtins.c ├── compiler.lsp ├── cvalues.c ├── equal.c ├── equalhash.c ├── equalhash.h ├── examples ├── bq.scm ├── cps.lsp ├── dict.lsp └── rule30.lsp ├── flisp.boot ├── flisp.c ├── flisp.h ├── flmain.c ├── iostream.c ├── lib ├── lazy.scm ├── psyntax-expanded.ss ├── psyntax.ss └── sort.scm ├── llt ├── Makefile ├── Makefile.macosx ├── UTF8.txt ├── bitvector-ops.c ├── bitvector.c ├── bitvector.h ├── dirpath.c ├── dirpath.h ├── dtypes.h ├── dump.c ├── hashing.c ├── hashing.h ├── htable.c ├── htable.h ├── htable.inc ├── htableh.inc ├── ieee754.h ├── int2str.c ├── ios.c ├── ios.h ├── llt.h ├── lltinit.c ├── lookup3.c ├── mt19937ar.c ├── ptrhash.c ├── ptrhash.h ├── random.c ├── random.h ├── socket.c ├── socket.h ├── timefuncs.c ├── timefuncs.h ├── utf8.c ├── utf8.h ├── utils.h └── wcwidth.c ├── mkboot0.lsp ├── mkboot1.lsp ├── opaque_type_template.c ├── opcodes.h ├── operators.c ├── print.c ├── read.c ├── string.c ├── system.lsp ├── table.c ├── tests ├── 100x100.lsp ├── argv.lsp ├── ast │ ├── asttools.lsp │ ├── datetimeR.lsp │ ├── match.lsp │ ├── match.scm │ ├── rpasses-out.lsp │ └── rpasses.lsp ├── color.lsp ├── equal.scm ├── err.lsp ├── hashtest.lsp ├── perf.lsp ├── pisum.lsp ├── printcases.lsp ├── tcolor.lsp ├── test.lsp ├── tme.lsp ├── torture.scm ├── torus.lsp ├── unittest.lsp └── wt.lsp ├── tiny ├── Makefile ├── eval1 ├── eval2 ├── evalt ├── flutils.c ├── lisp-nontail.c ├── lisp.c ├── lisp2.c ├── lispf.c └── system.lsp ├── todo ├── todo-scrap └── types.c /.gitignore: -------------------------------------------------------------------------------- 1 | /*.o 2 | /*.do 3 | /*.a 4 | /*.da 5 | /flisp 6 | /llt/*.o 7 | /llt/*.a 8 | /flisp.boot.bak 9 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2008 Jeff Bezanson 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright notice, 9 | this list of conditions and the following disclaimer. 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | * Neither the author nor the names of any contributors may be used to 14 | endorse or promote products derived from this software without specific 15 | prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 19 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 21 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 22 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 23 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 24 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | FREEBSD-GE-10 = $(shell test `uname` = FreeBSD -a `uname -r | cut -d. -f1` -ge 10 && echo YES) 2 | CC = $(if $(FREEBSD-GE-10),clang,gcc) 3 | 4 | NAME = flisp 5 | SRCS = $(NAME).c builtins.c string.c equalhash.c table.c iostream.c 6 | OBJS = $(SRCS:%.c=%.o) 7 | DOBJS = $(SRCS:%.c=%.do) 8 | EXENAME = $(NAME) 9 | LIBTARGET = lib$(NAME) 10 | LLTDIR = llt 11 | LLT = $(LLTDIR)/libllt.a 12 | 13 | FLAGS = -falign-functions -Wall -Wno-strict-aliasing -I$(LLTDIR) $(CFLAGS) -DUSE_COMPUTED_GOTO 14 | LIBFILES = $(LLT) 15 | LIBS = $(LIBFILES) -lm 16 | 17 | DEBUGFLAGS = -g -DDEBUG $(FLAGS) 18 | SHIPFLAGS = -O2 -DNDEBUG $(FLAGS) 19 | 20 | default: release test 21 | 22 | test: 23 | cd tests && ../flisp unittest.lsp 24 | 25 | %.o: %.c 26 | $(CC) $(SHIPFLAGS) -c $< -o $@ 27 | %.do: %.c 28 | $(CC) $(DEBUGFLAGS) -c $< -o $@ 29 | 30 | flisp.o: flisp.c cvalues.c operators.c types.c flisp.h print.c read.c equal.c 31 | flisp.do: flisp.c cvalues.c operators.c types.c flisp.h print.c read.c equal.c 32 | flmain.o: flmain.c flisp.h 33 | flmain.do: flmain.c flisp.h 34 | 35 | $(LLT): 36 | cd $(LLTDIR) && $(MAKE) 37 | 38 | $(LIBTARGET).da: $(DOBJS) 39 | rm -rf $@ 40 | ar rs $@ $(DOBJS) 41 | 42 | $(LIBTARGET).a: $(OBJS) 43 | rm -rf $@ 44 | ar rs $@ $(OBJS) 45 | 46 | debug: $(DOBJS) $(LIBFILES) $(LIBTARGET).da flmain.do 47 | $(CC) $(DEBUGFLAGS) $(DOBJS) flmain.do -o $(EXENAME) $(LIBS) $(LIBTARGET).da 48 | $(MAKE) test 49 | 50 | release: $(OBJS) $(LIBFILES) $(LIBTARGET).a flmain.o 51 | $(CC) $(SHIPFLAGS) $(OBJS) flmain.o -o $(EXENAME) $(LIBS) $(LIBTARGET).a 52 | 53 | clean: 54 | rm -f *.o 55 | rm -f *.do 56 | rm -f $(EXENAME) 57 | rm -f $(LIBTARGET).a 58 | rm -f $(LIBTARGET).da 59 | -------------------------------------------------------------------------------- /Makefile.macosx: -------------------------------------------------------------------------------- 1 | CC ?= gcc 2 | CARBON_HEADERS ?= "/Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX10.7.sdk/Developer/Headers" 3 | 4 | NAME = flisp 5 | SRCS = $(NAME).c builtins.c string.c equalhash.c table.c iostream.c 6 | OBJS = $(SRCS:%.c=%.o) 7 | DOBJS = $(SRCS:%.c=%.do) 8 | EXENAME = $(NAME) 9 | LIBTARGET = lib$(NAME) 10 | LLTDIR = llt 11 | LLT = $(LLTDIR)/libllt.a 12 | 13 | CONFIG = -DBITS64 -D__CPU__=686 -I$(CARBON_HEADERS) 14 | FLAGS = -falign-functions -Wall -Wno-strict-aliasing -I$(LLTDIR) $(CFLAGS) -DUSE_COMPUTED_GOTO $(CONFIG) 15 | LIBFILES = $(LLT) 16 | LIBS = $(LIBFILES) -lm -framework ApplicationServices 17 | 18 | DEBUGFLAGS = -g -DDEBUG $(FLAGS) 19 | SHIPFLAGS = -O2 -DNDEBUG $(FLAGS) 20 | 21 | default: release test 22 | 23 | test: 24 | cd tests && ../flisp unittest.lsp 25 | 26 | %.o: %.c 27 | $(CC) $(SHIPFLAGS) -c $< -o $@ 28 | %.do: %.c 29 | $(CC) $(DEBUGFLAGS) -c $< -o $@ 30 | 31 | flisp.o: flisp.c cvalues.c types.c flisp.h print.c read.c equal.c 32 | flisp.do: flisp.c cvalues.c types.c flisp.h print.c read.c equal.c 33 | flmain.o: flmain.c flisp.h 34 | flmain.do: flmain.c flisp.h 35 | 36 | $(LLT): 37 | cd $(LLTDIR) && make -f Makefile.macosx 38 | 39 | $(LIBTARGET).da: $(DOBJS) 40 | rm -rf $@ 41 | ar rs $@ $(DOBJS) 42 | 43 | $(LIBTARGET).a: $(OBJS) 44 | rm -rf $@ 45 | ar rs $@ $(OBJS) 46 | 47 | debug: $(DOBJS) $(LIBFILES) $(LIBTARGET).da flmain.do 48 | $(CC) $(DEBUGFLAGS) $(DOBJS) flmain.do -o $(EXENAME) $(LIBS) $(LIBTARGET).da 49 | make test 50 | 51 | release: $(OBJS) $(LIBFILES) $(LIBTARGET).a flmain.o 52 | $(CC) $(SHIPFLAGS) $(OBJS) flmain.o -o $(EXENAME) $(LIBS) $(LIBTARGET).a 53 | 54 | clean: 55 | rm -f *.o 56 | rm -f *.do 57 | rm -f $(EXENAME) 58 | rm -f $(LIBTARGET).a 59 | rm -f $(LIBTARGET).da 60 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Join the chat at https://gitter.im/FemtoLisp/flisp](https://badges.gitter.im/FemtoLisp/flisp.svg)](https://gitter.im/FemtoLisp/flisp) 2 | 3 | ## ...a purely symbolic gesture... 4 | 5 | This project began with an attempt to write the fastest lisp interpreter I could in under 1000 lines of C. It snowballed from there as I kept trying to see if I could add powerful features with minimal code. At the same time I assembled a library of some of my favorite C code (by myself and others) to use as a base for a standard library. This includes `ios`, a replacement for parts of C's stdio that adds more flexible features. 6 | 7 | Before you say "oh no, another lisp", consider the following: femtolisp is about 150kb, is very self-contained, and has the following features: 8 | 9 | * vectors, strings, gensyms 10 | * backquote 11 | * exceptions 12 | * printing and reading circular/shared structure 13 | * all values can be printed readably 14 | * prettyprinting 15 | * hash tables 16 | * support for directly using C data types ala Python's ctypes 17 | * `equal` and ordered comparison predicates that work on circular structure 18 | * proper tail recursion 19 | * io and memory streams with utf8 support 20 | * highly compatible with Scheme, including some `R6RS` features 21 | * simple, well-organized, powerful API with as few functions as possible 22 | * compacting GC 23 | * and... 24 | 25 | ...it is fast, ranking among the fastest non-native-compiled Scheme implementations. It achieves this level of speed even though many primitives (e.g. `filter` and `for-each`) are written in the language instead of C. femtolisp uses a bytecode compiler and VM, with the compiler written in femtolisp. Bytecode is first-class, can be printed and read, and is "human readable" (the representation is a string of normal low-ASCII characters). 26 | 27 | femtolisp is a simple, elegant Scheme dialect. It is a lisp-1 with lexical scope. The core is 12 builtin special forms and 33 builtin functions. 28 | 29 | A primary design goal is to keep the code concise and interesting. I strive to have each concept implemented in just one place, so the system is easy to understand and modify. The result is high reliability, because there are fewer places for bugs to hide. You want a small core of generically useful features that work _really well_ (for example, see `torture.scm`). 30 | 31 | Almost everybody has their own lisp implementation. Some programmers' dogs and cats probably have _their_ own lisp implementations as well. This is great, but too often I see people omit some of the obscure but critical features that make lisp uniquely wonderful. These include read macros like `#.` and backreferences, gensyms, and properly escaped symbol names. If you're going to waste everybody's time with yet another lisp, at least do it right damnit. 32 | 33 | Another design goal is to avoid spurious novelties. Many others offering their own "shiny new" lisp dialects get carried away and change anything that strikes their fancy. These changes have no effect except incompatibility, and often make the language worse because the new design was not as carefully thought out and has not stood the test of time. For example, how does it help to remove backquote? One design changes the syntax of `quote`. Some systems disallow dotted lists. (I've seen all three of these.) What's the point? Implementers wave the banner of "simplicity", yet wedge in all kinds of weird implicit behaviors and extra evaluation rules. 34 | 35 | Lately a surprising amount of FUD has been spread about proper tail recursion. I agree that not every language needs it, but I would like to refute the idea that it makes interpreters slow. Look at the "tiny" subdirectory or the "interpreter" branch to see a pure s-expr interpreter with efficient proper tail calls. All you have to do is keep track of whether you're in tail position, which can be done very cheaply. These interpreters are difficult to beat for speed, yet they have lexical scope and proper tail calls. 36 | 37 | This project is mostly a matter of style. Look at the code and you'll understand. 38 | 39 | This is what I do for fun, because it is the _exact opposite_ of the kind of thing people will pay for: an obscure implementation of a programming language everybody hates. 40 | -------------------------------------------------------------------------------- /aliases.scm: -------------------------------------------------------------------------------- 1 | ; definitions of standard scheme procedures in terms of femtolisp procedures 2 | ; sufficient to run the R5RS version of psyntax 3 | 4 | (define top-level-bound? bound?) 5 | (define (eval-core x) (eval x)) 6 | (define (symbol-value s) (top-level-value s)) 7 | (define (set-symbol-value! s v) (set-top-level-value! s v)) 8 | (define (eval x) 9 | ((compile-thunk (expand 10 | (if (and (pair? x) 11 | (equal? (car x) "noexpand")) 12 | (cadr x) 13 | x))))) 14 | (define (command-line) *argv*) 15 | 16 | (define gensym 17 | (let (($gensym gensym)) 18 | (lambda ((x #f)) ($gensym)))) 19 | 20 | (define-macro (begin0 first . rest) 21 | `(prog1 ,first ,@rest)) 22 | 23 | (define vector-ref aref) 24 | (define vector-set! aset!) 25 | (define vector-length length) 26 | (define make-vector vector.alloc) 27 | (define (vector-fill! v f) 28 | (for 0 (- (length v) 1) 29 | (lambda (i) (aset! v i f))) 30 | #t) 31 | (define (vector-map f v) (vector.map f v)) 32 | 33 | (define array-ref aref) 34 | (define (array-set! a obj i0 . idxs) 35 | (if (null? idxs) 36 | (aset! a i0 obj) 37 | (error "array-set!: multiple dimensions not yet implemented"))) 38 | 39 | (define (array-dimensions a) 40 | (list (length a))) 41 | 42 | (define (complex? x) #f) 43 | (define (real? x) (number? x)) 44 | (define (rational? x) (integer? x)) 45 | (define (exact? x) (integer? x)) 46 | (define (inexact? x) (not (exact? x))) 47 | (define (flonum? x) (not (exact? x))) 48 | (define quotient div0) 49 | (define remainder mod0) 50 | (define (inexact x) x) 51 | (define (exact x) 52 | (if (exact? x) x 53 | (error "exact real numbers not supported"))) 54 | (define (exact->inexact x) (double x)) 55 | (define (inexact->exact x) 56 | (if (integer-valued? x) 57 | (truncate x) 58 | (error "exact real numbers not supported"))) 59 | (define (floor x) (if (< x 0) (truncate (- x 0.5)) (truncate x))) 60 | (define (ceiling x) (if (< x 0) (truncate x) (truncate (+ x 0.5)))) 61 | (define (finite? x) (and (< x +inf.0) (> x -inf.0))) 62 | (define (infinite? x) (or (equal? x +inf.0) (equal? x -inf.0))) 63 | 64 | (define (char->integer c) (fixnum c)) 65 | (define (integer->char i) (wchar i)) 66 | (define char-upcase char.upcase) 67 | (define char-downcase char.downcase) 68 | (define char=? eqv?) 69 | (define char? >) 71 | (define char<=? <=) 72 | (define char>=? >=) 73 | (define (char-whitespace? c) (not (not (string.find *whitespace* c)))) 74 | (define (char-numeric? c) (not (not (string.find "0123456789" c)))) 75 | 76 | (define string=? eqv?) 77 | (define string? >) 79 | (define string<=? <=) 80 | (define string>=? >=) 81 | (define string-copy copy) 82 | (define string-append string) 83 | (define string-length string.count) 84 | (define string->symbol symbol) 85 | (define (symbol->string s) (string s)) 86 | (define symbol=? eq?) 87 | (define (make-string k (fill #\space)) 88 | (string.rep fill k)) 89 | 90 | (define (string-ref s i) 91 | (string.char s (string.inc s 0 i))) 92 | 93 | (define (list->string l) (apply string l)) 94 | (define (string->list s) 95 | (do ((i (sizeof s) i) 96 | (l '() (cons (string.char s i) l))) 97 | ((= i 0) l) 98 | (set! i (string.dec s i)))) 99 | 100 | (define (substring s start end) 101 | (string.sub s (string.inc s 0 start) (string.inc s 0 end))) 102 | 103 | (define (input-port? x) (iostream? x)) 104 | (define (output-port? x) (iostream? x)) 105 | (define (port? x) (iostream? x)) 106 | (define close-input-port io.close) 107 | (define close-output-port io.close) 108 | (define (read-char (s *input-stream*)) (io.getc s)) 109 | (define (peek-char (s *input-stream*)) (io.peekc s)) 110 | (define (write-char c (s *output-stream*)) (io.putc s c)) 111 | ; TODO: unread-char 112 | (define (port-eof? p) (io.eof? p)) 113 | (define (open-input-string str) 114 | (let ((b (buffer))) 115 | (io.write b str) 116 | (io.seek b 0) 117 | b)) 118 | (define (open-output-string) (buffer)) 119 | (define (open-string-output-port) 120 | (let ((b (buffer))) 121 | (values b (lambda () (io.tostring! b))))) 122 | 123 | (define (get-output-string b) 124 | (let ((p (io.pos b))) 125 | (io.seek b 0) 126 | (let ((s (io.readall b))) 127 | (io.seek b p) 128 | (if (eof-object? s) "" s)))) 129 | 130 | (define (open-input-file name) (file name :read)) 131 | (define (open-output-file name) (file name :write :create)) 132 | 133 | (define (current-input-port (p *input-stream*)) 134 | (set! *input-stream* p)) 135 | (define (current-output-port (p *output-stream*)) 136 | (set! *output-stream* p)) 137 | 138 | (define (input-port-line p) 139 | ; TODO 140 | 1) 141 | 142 | (define get-datum read) 143 | (define (put-datum port x) 144 | (with-bindings ((*print-readably* #t)) 145 | (write x port))) 146 | 147 | (define (put-u8 port o) (io.write port (uint8 o))) 148 | (define (put-string port s (start 0) (count #f)) 149 | (let* ((start (string.inc s 0 start)) 150 | (end (if count 151 | (string.inc s start count) 152 | (sizeof s)))) 153 | (io.write port s start (- end start)))) 154 | 155 | (define (io.skipws s) 156 | (let ((c (io.peekc s))) 157 | (if (and (not (eof-object? c)) (char-whitespace? c)) 158 | (begin (io.getc s) 159 | (io.skipws s))))) 160 | 161 | (define (with-output-to-file name thunk) 162 | (let ((f (file name :write :create :truncate))) 163 | (unwind-protect 164 | (with-output-to f (thunk)) 165 | (io.close f)))) 166 | 167 | (define (with-input-from-file name thunk) 168 | (let ((f (file name :read))) 169 | (unwind-protect 170 | (with-input-from f (thunk)) 171 | (io.close f)))) 172 | 173 | (define (call-with-input-file name proc) 174 | (let ((f (open-input-file name))) 175 | (prog1 (proc f) 176 | (io.close f)))) 177 | 178 | (define (call-with-output-file name proc) 179 | (let ((f (open-output-file name))) 180 | (prog1 (proc f) 181 | (io.close f)))) 182 | 183 | (define (file-exists? f) (path.exists? f)) 184 | (define (delete-file name) (void)) ; TODO 185 | 186 | (define (display x (port *output-stream*)) 187 | (with-output-to port (princ x)) 188 | #t) 189 | 190 | (define assertion-violation 191 | (lambda args 192 | (display 'assertion-violation) 193 | (newline) 194 | (display args) 195 | (newline) 196 | (car #f))) 197 | 198 | (define pretty-print write) 199 | 200 | (define (memp proc ls) 201 | (cond ((null? ls) #f) 202 | ((pair? ls) (if (proc (car ls)) 203 | ls 204 | (memp proc (cdr ls)))) 205 | (else (assertion-violation 'memp "Invalid argument" ls)))) 206 | 207 | (define (assp pred lst) 208 | (cond ((atom? lst) #f) 209 | ((pred (caar lst)) (car lst)) 210 | (else (assp pred (cdr lst))))) 211 | 212 | (define (for-all proc l . ls) 213 | (or (null? l) 214 | (and (apply proc (car l) (map car ls)) 215 | (apply for-all proc (cdr l) (map cdr ls))))) 216 | (define andmap for-all) 217 | 218 | (define (exists proc l . ls) 219 | (and (not (null? l)) 220 | (or (apply proc (car l) (map car ls)) 221 | (apply exists proc (cdr l) (map cdr ls))))) 222 | (define ormap exists) 223 | 224 | (define cons* list*) 225 | 226 | (define (fold-left f zero lst) 227 | (if (null? lst) zero 228 | (fold-left f (f zero (car lst)) (cdr lst)))) 229 | 230 | (define fold-right foldr) 231 | 232 | (define (partition pred lst) 233 | (let ((s (separate pred lst))) 234 | (values (car s) (cdr s)))) 235 | 236 | (define (dynamic-wind before thunk after) 237 | (before) 238 | (unwind-protect (thunk) 239 | (after))) 240 | 241 | (let ((*properties* (table))) 242 | (set! putprop 243 | (lambda (sym key val) 244 | (let ((sp (get *properties* sym #f))) 245 | (if (not sp) 246 | (let ((t (table))) 247 | (put! *properties* sym t) 248 | (set! sp t))) 249 | (put! sp key val)))) 250 | 251 | (set! getprop 252 | (lambda (sym key) 253 | (let ((sp (get *properties* sym #f))) 254 | (and sp (get sp key #f))))) 255 | 256 | (set! remprop 257 | (lambda (sym key) 258 | (let ((sp (get *properties* sym #f))) 259 | (and sp (has? sp key) (del! sp key)))))) 260 | 261 | ; --- gambit 262 | 263 | (define arithmetic-shift ash) 264 | (define bitwise-and logand) 265 | (define bitwise-or logior) 266 | (define bitwise-not lognot) 267 | (define bitwise-xor logxor) 268 | 269 | (define (include f) (load f)) 270 | (define (with-exception-catcher hand thk) 271 | (trycatch (thk) 272 | (lambda (e) (hand e)))) 273 | 274 | (define (current-exception-handler) 275 | ; close enough 276 | (lambda (e) (raise e))) 277 | 278 | (define make-table table) 279 | (define table-ref get) 280 | (define table-set! put!) 281 | (define (read-line (s *input-stream*)) 282 | (io.flush *output-stream*) 283 | (io.discardbuffer s) 284 | (io.readline s)) 285 | (define (shell-command s) 1) 286 | (define (error-exception-message e) (cadr e)) 287 | (define (error-exception-parameters e) (cddr e)) 288 | 289 | (define (with-output-to-string nada thunk) 290 | (let ((b (buffer))) 291 | (with-output-to b (thunk)) 292 | (io.tostring! b))) 293 | 294 | (define (read-u8) (io.read *input-stream* 'uint8)) 295 | (define modulo mod) 296 | -------------------------------------------------------------------------------- /ascii-mona-lisa: -------------------------------------------------------------------------------- 1 | iIYVVVVXVVVVVVVVVYVYVYYVYYYYIIIIYYYIYVVVYYYYYYYYYVVYVVVVXVVVVVYI+. 2 | tYVXXXXXXVXXXXVVVYVVVVVVVVVVVVYVVVVVVVVVVVVVVVVVXXXXXVXXXXXXXVVYi. 3 | iYXRXRRRXXXXXXXXXXXVVXVXVVVVVVVVXXXVXVVXXXXXXXXXXXXXXRRRRRRRRRXVi. 4 | tVRRRRRRRRRRRRRRRXRXXXXXXXXXXXXXXRRXXXXRRRRXXXXXXXRRRRRRRRRRRRXV+. 5 | tVRRBBBRMBRRRRRRRRRXXRRRRRXt=+;;;;;==iVXRRRRXXXXRRRRRRRRMMBRRRRXi, 6 | tVRRBMBBMMBBBBBMBBRBBBRBX++=++;;;;;;:;;;IRRRRXXRRRBBBBBBMMBBBRRXi, 7 | iVRMMMMMMMMMMMMMMBRBBMMV==iIVYIi=;;;;:::;;XRRRRRRBBMMMMMMMMBBRRXi. 8 | iVRMMMMMMMMMMMMMMMMMMMY;IBWWWWMMXYi=;:::::;RBBBMMMMMMMMMMMMMMBBXi, 9 | +VRMMRBMMMMMMMMMMMMMMY+;VMMMMMMMRXIi=;:::::=VVXXXRRRMMMMMMMMBBMXi; 10 | =tYYVVVXRRRXXRBMMMMMV+;=RBBMMMXVXXVYt;::::::ttYYVYVVRMMMMMMBXXVI+= 11 | ;=tIYYVYYYYYYVVVMMMBt=;;+i=IBi+t==;;i;::::::+iitIIttYRMMMMMRXVVI=; 12 | ;=IIIIYYYIIIIttIYItIt;;=VVYXBIVRXVVXI;::::::;+iitttttVMMBRRRVVVI+, 13 | ;+++tttIttttiiii+i++==;;RMMMBXXMMMXI+;::::::;+ittttitYVXVYYIYVIi;; 14 | ;===iiittiiIitiii++;;;;:IVRVi=iBXVIi;::::::::;==+++++iiittii+++=;; 15 | ;;==+iiiiiiiiii+++=;;;;;;VYVIiiiVVt+;::::::::;++++++++++iti++++=;; 16 | ;;=++iiii+i+++++iii==;;;::tXYIIYIi+=;:::::,::;+++++++++++++++++=;; 17 | ;;;+==+ii+++++iiiiit=;;:::::=====;;;::::::::::+++i+++++++++i+++;;; 18 | ;;;==+=+iiiiitttIIII+;;;:,::,;;;;:;=;;;::,::::=++++++++==++++++;;; 19 | :;====+tittiiittttti+;;::::,:=Ytiiiiti=;:::::,:;;==ii+ittItii+==;; 20 | ;;+iiittIti+ii;;===;;:;::::;+IVXVVVVVVt;;;;;::::;;===;+IIiiti=;;;; 21 | ;=++++iIti+ii+=;;;=;:::;;+VXBMMBBBBBBXY=;=;;:::::;=iYVIIttii++;;;; 22 | ;;++iiiItttIi+++=;;:::;=iBMMMMMMMMMMMXI==;;,::;;:;;=+itIttIIti+;;; 23 | ;=+++++i+tYIIiii;:,::;itXMMMMMMMMMMMBXti==;:;++=;:::::;=+iittti+;; 24 | ;;+ii+ii+iitiIi;::::;iXBMMMMMWWWWWMMBXti+ii=;::::,,,,:::=;==+tI+;; 25 | ;;iiiitItttti;:::;::=+itYXXMWWWWWWMBYt+;;::,,,,,,,,,,,,,:==;==;;;; 26 | :;=iIIIttIt+:;:::;;;==;+=+iiittttti+;;:,:,,,,::,,,,,,,,:::;=;==::; 27 | ;::=+ittiii=;:::::;;;:;:;=++==;;==;:,,,,,,:;::::,,,,,,,,::;==;;::; 28 | :::;+iiiii=;::::,:;:::::;;:;;::;:::,,,,,,,:::;=;;;:,,,,,:::;;::::; 29 | :;;iIIIIII=;:::,:::::::,::::,:::,,,,,,,,,,,:;;=;:,,,,,,::::;=;:::; 30 | :;==++ii+;;;:::::::::::,,,,,,::,,,,,,,,,,,::::,,,,,,,,,,:,:::::::; 31 | ::;;=+=;;;:::;;::,,,,,,,,,,,,,,,,,,,,,,,,,:,,,,,,,,,,,,,,,,,:::::; 32 | ::;=;;;:;:::;;;;::,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,::,,::::; 33 | :;;:;::::::,::,,:,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,:::; 34 | :::::::::::;;;:,,,,,,,,,,,,,...,...,,,.,,,,,,,,,,,,.,,,,,,,,,,,,:; 35 | ::::::::;=;;;;;::,,,,,,,,,,,.......,...,,,,,,,,,,,,.,,,,,,,,,,,,,; 36 | :::::,,:;=;;;;;;;iVXXXVt+:,,....,,,,....,.,,,,,,,.,.....,,,,,,,,:; 37 | :,,::,,:::;;;;;;=IVVVXXXXVXVt:,,,,,..,..,,,,.,,,,,..,.,,,,,,,,,,,; 38 | ::,::,,,:,:::::,::;=iIYVXVVVVIYIi;,,.,.,,,::,,,,,,,,,,,,,,,,,,,,,. 39 | :,,,,,,,,,,,,,,,,::;+itIIIIIIi:;;i++=;;;;;;;;;::,,,...,,..,,,,,,,. 40 | :,,,,,,,,,,,,,,=iitVYi++iitt==it;;:;;;;::;;::::,,,......,,,,,,,::. 41 | ::,,,,,,,,,,,,,++iiIVIi=;;=;+i;:;+:::,,,,,,,,,,,,,.....,,,,,,,,::, 42 | ,,,,,,,,,,,,,,,;=+it=:::,,,,,,,,,,.,......,,.,..........,,,,,,,,:: 43 | :,,,,,,,,,,,,,,,,:=:,,,,,,,,,,,,,,......................,.,,.,.,,: 44 | :,,,,,,,,,,,,,,,,,:,,,,,,,,,,..,........................,..,...,,: 45 | ,,,,,,,,,,,,,,,,,,,.....................................,.......,, 46 | ,,,,,,,,,.,,,,,,,...............................................,, 47 | itittiiiii+=++=;;=iiiiiiittiiiiii+iii===;++iiitiiiiiii+=====+ii=+i 48 | -------------------------------------------------------------------------------- /ascii-mona-lisa-2: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 3 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!>'''''' !!!!! 26 | !!!!! ?$$$$$$$$$$$$??$c`$$$$$$$$$$$?>' `!!!! 27 | !!!!! `?$$$$$$I7?"" ,$$$$$$$$$?>>' !!!! 28 | !!!!!. <>'' `!!! 29 | !!!!!! '' `!!! 30 | !!!!!! $$$hccccccccc= cc$$$$$$$>>' !!! 31 | !!!!! `?$$$$$$F"""" `"$$$$$>>>'' `!! 32 | !!!!! "?$$$$$cccccc$$$$??>>>>' !! 33 | !!!!> "$$$$$$$$$$$$$F>>>>'' `! 34 | !!!!! "$$$$$$$$???>''' ! 35 | !!!!!> `""""" ` 36 | !!!!!!; . ` 37 | !!!!!!! ?h. 38 | !!!!!!!! $$c, 39 | !!!!!!!!> ?$$$h. .,c 40 | !!!!!!!!! $$$$$$$$$hc,.,,cc$$$$$ 41 | !!!!!!!!! .,zcc$$$$$$$$$$$$$$$$$$$$$$ 42 | !!!!!!!!! .z$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 43 | !!!!!!!!! ,d$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ . 44 | !!!!!!!!! ,d$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ !! 45 | !!!!!!!!! ,d$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ ,!' 46 | !!!!!!!!> c$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$. !' 47 | !!!!!!'' ,d$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$> ' 48 | !!!'' z$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$> 49 | !' ,$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$> .. 50 | z$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$' ;!!!!''` 51 | $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$F ,;;!'`' .'' 52 | <$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$> ,;'`' ,; 53 | `$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$F -' ,;!!' 54 | "?$$$$$$$$$$?$$$$$$$$$$$$$$$$$$$$$$$$$$F . ""??$$$?C3$$$$$$$$$$$$$$$$$$$$$$$$"" ;!''' !!! 56 | ;!!!!;, `"''""????$$$$$$$$$$$$$$$$"" ,;-'' ',! 57 | ;!!!!;,;, .. ' . ' ' 59 | !!' ,;!!! ;'`!!!!!!!!;!!!!!; . >' .'' ; 60 | !!' ;!!'!';! !! !!!!!!!!!!!!! ' -' 61 | ;! ;> 68 | !' ; !! ' 69 | ' ;! > ! ' 70 | ' 71 | by Allen Mullen 72 | -------------------------------------------------------------------------------- /attic/s.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | struct _b { 4 | char a; 5 | short b:9; 6 | }; 7 | 8 | struct _bb { 9 | char a; 10 | int :0; 11 | int b:10; 12 | int :0; 13 | int b0:10; 14 | int :0; 15 | int b1:10; 16 | int :0; 17 | int b2:10; 18 | int :0; 19 | int b4:30; 20 | char c; 21 | }; 22 | 23 | union _cc { 24 | struct { 25 | char a; 26 | int b:1; // bit 8 27 | int b1:1; // bit 9 28 | int b2:24; // bits 32..55 29 | char c; 30 | }; 31 | unsigned long long ull; 32 | }; 33 | 34 | union _cc2 { 35 | struct { 36 | char a; 37 | int b:24; // bit 8 38 | int b1:1; 39 | int b2:1; 40 | char c; 41 | }; 42 | unsigned long long ull; 43 | }; 44 | 45 | union _dd { 46 | struct { 47 | int a0:10; 48 | int a1:10; 49 | int a2:10; 50 | int a3:10; 51 | int a4:10; 52 | }; 53 | struct { 54 | unsigned long long ull; 55 | }; 56 | }; 57 | 58 | struct _ee { 59 | short s:9; 60 | short j:9; 61 | char c; 62 | }; 63 | 64 | typedef long long int int64_t; 65 | typedef unsigned long long int uint64_t; 66 | typedef int int32_t; 67 | typedef unsigned int uint32_t; 68 | typedef short int16_t; 69 | typedef unsigned short uint16_t; 70 | typedef char int8_t; 71 | typedef unsigned char uint8_t; 72 | 73 | #define lomask(type,n) (type)((((type)1)<<(n))-1) 74 | 75 | uint64_t get_u_bitfield(char *ptr, int typesz, int boffs, int blen) 76 | { 77 | uint64_t i8; 78 | uint32_t i4; 79 | uint16_t i2; 80 | uint8_t i1; 81 | 82 | switch (typesz) { 83 | case 8: 84 | i8 = *(uint64_t*)ptr; 85 | return (i8>>boffs) & lomask(uint64_t,blen); 86 | case 4: 87 | i4 = *(uint32_t*)ptr; 88 | return (i4>>boffs) & lomask(uint32_t,blen); 89 | case 2: 90 | i2 = *(uint16_t*)ptr; 91 | return (i2>>boffs) & lomask(uint16_t,blen); 92 | case 1: 93 | i1 = *(uint8_t*)ptr; 94 | return (i1>>boffs) & lomask(uint8_t,blen); 95 | } 96 | //error 97 | return 0; 98 | } 99 | 100 | int64_t get_s_bitfield(char *ptr, int typesz, int boffs, int blen) 101 | { 102 | int64_t i8; 103 | int32_t i4; 104 | int16_t i2; 105 | int8_t i1; 106 | 107 | switch (typesz) { 108 | case 8: 109 | i8 = *(int64_t*)ptr; 110 | return (i8<<(64-boffs-blen))>>(64-blen); 111 | case 4: 112 | i4 = *(int32_t*)ptr; 113 | return (i4<<(32-boffs-blen))>>(32-blen); 114 | case 2: 115 | i2 = *(int16_t*)ptr; 116 | return (i2<<(16-boffs-blen))>>(16-blen); 117 | case 1: 118 | i1 = *(int8_t*)ptr; 119 | return (i1<<(8-boffs-blen))>>(8-blen); 120 | } 121 | //error 122 | return 0; 123 | } 124 | 125 | void set_bitfield(char *ptr, int typesz, int boffs, int blen, uint64_t v) 126 | { 127 | uint64_t i8, m8; 128 | uint32_t i4, m4; 129 | uint16_t i2, m2; 130 | uint8_t i1, m1; 131 | 132 | switch (typesz) { 133 | case 8: 134 | m8 = lomask(uint64_t,blen)<\n"); 52 | } 53 | 54 | #else 55 | PUSH(NIL); 56 | PUSH(NIL); 57 | value_t *rest = &Stack[SP-1]; 58 | // build list of rest arguments 59 | // we have to build it forwards, which is tricky 60 | while (iscons(v)) { 61 | v = eval(car_(v)); 62 | PUSH(v); 63 | v = cons_(&Stack[SP-1], &NIL); 64 | POP(); 65 | if (iscons(*rest)) 66 | cdr_(*rest) = v; 67 | else 68 | Stack[SP-2] = v; 69 | *rest = v; 70 | v = Stack[saveSP] = cdr_(Stack[saveSP]); 71 | } 72 | POP(); 73 | #endif 74 | // this version uses collective allocation. about 7-10% 75 | // faster for lists with > 2 elements, but uses more 76 | // stack space 77 | i = SP; 78 | while (iscons(v)) { 79 | v = eval(car_(v)); 80 | PUSH(v); 81 | v = Stack[saveSP] = cdr_(Stack[saveSP]); 82 | } 83 | if ((int)SP==i) { 84 | PUSH(NIL); 85 | } 86 | else { 87 | e = v = cons_reserve(nargs=(SP-i)); 88 | for(; i < (int)SP; i++) { 89 | car_(v) = Stack[i]; 90 | v = cdr_(v); 91 | } 92 | POPN(nargs); 93 | PUSH(e); 94 | } 95 | 96 | value_t list_to_vector(value_t l) 97 | { 98 | value_t v; 99 | size_t n = llength(l), i=0; 100 | v = alloc_vector(n, 0); 101 | while (iscons(l)) { 102 | vector_elt(v,i) = car_(l); 103 | i++; 104 | l = cdr_(l); 105 | } 106 | return v; 107 | } 108 | -------------------------------------------------------------------------------- /attic/scrap.lsp: -------------------------------------------------------------------------------- 1 | ; -*- scheme -*- 2 | ; (try expr 3 | ; (catch (type-error e) . exprs) 4 | ; (catch (io-error e) . exprs) 5 | ; (catch (e) . exprs) 6 | ; (finally . exprs)) 7 | (define-macro (try expr . forms) 8 | (let* ((e (gensym)) 9 | (reraised (gensym)) 10 | (final (f-body (cdr (or (assq 'finally forms) '(()))))) 11 | (catches (filter (lambda (f) (eq (car f) 'catch)) forms)) 12 | (catchblock `(cond 13 | ,.(map (lambda (catc) 14 | (let* ((specific (cdr (cadr catc))) 15 | (extype (caadr catc)) 16 | (var (if specific (car specific) 17 | extype)) 18 | (todo (cddr catc))) 19 | `(,(if specific 20 | ; exception matching logic 21 | `(or (eq ,e ',extype) 22 | (and (pair? ,e) 23 | (eq (car ,e) 24 | ',extype))) 25 | #t); (catch (e) ...), match anything 26 | (let ((,var ,e)) (begin ,@todo))))) 27 | catches) 28 | (#t (raise ,e))))) ; no matches, reraise 29 | (if final 30 | (if catches 31 | ; form with both catch and finally 32 | `(prog1 (trycatch ,expr 33 | (lambda (,e) 34 | (trycatch ,catchblock 35 | (lambda (,reraised) 36 | (begin ,final 37 | (raise ,reraised)))))) 38 | ,final) 39 | ; finally only; same as unwind-protect 40 | `(prog1 (trycatch ,expr (lambda (,e) 41 | (begin ,final (raise ,e)))) 42 | ,final)) 43 | ; catch, no finally 44 | `(trycatch ,expr (lambda (,e) ,catchblock))))) 45 | 46 | ; setf 47 | ; expands (setf (place x ...) v) to (mutator (f x ...) v) 48 | ; (mutator (identity x ...) v) is interpreted as (mutator x ... v) 49 | (set! *setf-place-list* 50 | ; place mutator f 51 | '((car rplaca identity) 52 | (cdr rplacd identity) 53 | (caar rplaca car) 54 | (cadr rplaca cdr) 55 | (cdar rplacd car) 56 | (cddr rplacd cdr) 57 | (caaar rplaca caar) 58 | (caadr rplaca cadr) 59 | (cadar rplaca cdar) 60 | (caddr rplaca cddr) 61 | (cdaar rplacd caar) 62 | (cdadr rplacd cadr) 63 | (cddar rplacd cdar) 64 | (cdddr rplacd cddr) 65 | (list-ref rplaca nthcdr) 66 | (get put! identity) 67 | (aref aset! identity) 68 | (symbol-syntax set-syntax! identity))) 69 | 70 | (define (setf-place-mutator place val) 71 | (if (symbol? place) 72 | (list 'set! place val) 73 | (let ((mutator (assq (car place) *setf-place-list*))) 74 | (if (null? mutator) 75 | (error "setf: unknown place " (car place)) 76 | (if (eq (caddr mutator) 'identity) 77 | (cons (cadr mutator) (append (cdr place) (list val))) 78 | (list (cadr mutator) 79 | (cons (caddr mutator) (cdr place)) 80 | val)))))) 81 | 82 | (define-macro (setf . args) 83 | (f-body 84 | ((label setf- 85 | (lambda (args) 86 | (if (null? args) 87 | () 88 | (cons (setf-place-mutator (car args) (cadr args)) 89 | (setf- (cddr args)))))) 90 | args))) 91 | 92 | (define-macro (labels binds . body) 93 | (cons (list 'lambda (map car binds) 94 | (f-body 95 | (nconc (map (lambda (b) 96 | (list 'set! (car b) (cons 'lambda (cdr b)))) 97 | binds) 98 | body))) 99 | (map (lambda (x) #f) binds))) 100 | 101 | (define (evalhead e env) 102 | (if (and (symbol? e) 103 | (or (constant? e) 104 | (and (not (memq e env)) 105 | (bound? e) 106 | (builtin? (eval e))))) 107 | (eval e) 108 | e)) 109 | -------------------------------------------------------------------------------- /bootstrap.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | cp flisp.boot flisp.boot.bak 4 | 5 | echo "Creating stage 0 boot file..." 6 | #../../branches/interpreter/femtolisp/flisp mkboot0.lsp system.lsp compiler.lsp > flisp.boot.new 7 | ./flisp mkboot0.lsp system.lsp compiler.lsp > flisp.boot.new 8 | mv flisp.boot.new flisp.boot 9 | 10 | echo "Creating stage 1 boot file..." 11 | ./flisp mkboot1.lsp 12 | 13 | echo "Testing..." 14 | make test 15 | -------------------------------------------------------------------------------- /equalhash.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | #include "llt.h" 9 | #include "flisp.h" 10 | #include "equalhash.h" 11 | 12 | #include "htable.inc" 13 | 14 | #define _equal_lispvalue_(x,y) equal_lispvalue((value_t)(x),(value_t)(y)) 15 | 16 | HTIMPL(equalhash, hash_lispvalue, _equal_lispvalue_) 17 | -------------------------------------------------------------------------------- /equalhash.h: -------------------------------------------------------------------------------- 1 | #ifndef EQUALHASH_H 2 | #define EQUALHASH_H 3 | 4 | #include "htableh.inc" 5 | 6 | HTPROT(equalhash) 7 | 8 | #endif 9 | -------------------------------------------------------------------------------- /examples/bq.scm: -------------------------------------------------------------------------------- 1 | (define (bq-process2 x d) 2 | (define (splice-form? x) 3 | (or (and (pair? x) (or (eq? (car x) 'unquote-splicing) 4 | (eq? (car x) 'unquote-nsplicing) 5 | (and (eq? (car x) 'unquote) 6 | (length> x 2)))) 7 | (eq? x 'unquote))) 8 | ;; bracket without splicing 9 | (define (bq-bracket1 x) 10 | (if (and (pair? x) (eq? (car x) 'unquote)) 11 | (if (= d 0) 12 | (cadr x) 13 | (list cons ''unquote 14 | (bq-process2 (cdr x) (- d 1)))) 15 | (bq-process2 x d))) 16 | (define (bq-bracket x) 17 | (cond ((atom? x) (list list (bq-process2 x d))) 18 | ((eq? (car x) 'unquote) 19 | (if (= d 0) 20 | (cons list (cdr x)) 21 | (list list (list cons ''unquote 22 | (bq-process2 (cdr x) (- d 1)))))) 23 | ((eq? (car x) 'unquote-splicing) 24 | (if (= d 0) 25 | (list 'copy-list (cadr x)) 26 | (list list (list list ''unquote-splicing 27 | (bq-process2 (cadr x) (- d 1)))))) 28 | ((eq? (car x) 'unquote-nsplicing) 29 | (if (= d 0) 30 | (cadr x) 31 | (list list (list list ''unquote-nsplicing 32 | (bq-process2 (cadr x) (- d 1)))))) 33 | (else (list list (bq-process2 x d))))) 34 | (cond ((symbol? x) (list 'quote x)) 35 | ((vector? x) 36 | (let ((body (bq-process2 (vector->list x) d))) 37 | (if (eq? (car body) list) 38 | (cons vector (cdr body)) 39 | (list apply vector body)))) 40 | ((atom? x) x) 41 | ((eq? (car x) 'quasiquote) 42 | (list list ''quasiquote (bq-process2 (cadr x) (+ d 1)))) 43 | ((eq? (car x) 'unquote) 44 | (if (and (= d 0) (length= x 2)) 45 | (cadr x) 46 | (list cons ''unquote (bq-process2 (cdr x) (- d 1))))) 47 | ((or (> d 0) (not (any splice-form? x))) 48 | (let ((lc (lastcdr x)) 49 | (forms (map bq-bracket1 x))) 50 | (if (null? lc) 51 | (cons list forms) 52 | (if (null? (cdr forms)) 53 | (list cons (car forms) (bq-process2 lc d)) 54 | (nconc (cons list* forms) (list (bq-process2 lc d))))))) 55 | (else 56 | (let loop ((p x) (q ())) 57 | (cond ((null? p) ;; proper list 58 | (cons 'nconc (reverse! q))) 59 | ((pair? p) 60 | (cond ((eq? (car p) 'unquote) 61 | ;; (... . ,x) 62 | (cons 'nconc 63 | (nreconc q 64 | (if (= d 0) 65 | (cdr p) 66 | (list (list list ''unquote) 67 | (bq-process2 (cdr p) 68 | (- d 1))))))) 69 | (else 70 | (loop (cdr p) (cons (bq-bracket (car p)) q))))) 71 | (else 72 | ;; (... . x) 73 | (cons 'nconc (reverse! (cons (bq-process2 p d) q))))))))) 74 | 75 | #| 76 | tests 77 | 78 | > ``(,a ,,a ,b ,@b ,,@b) 79 | `(,a ,1 ,b ,@b (unquote 2 3)) 80 | > `(,a ,1 ,b ,@b (unquote 2 3)) 81 | (1 1 (2 3) 2 3 2 3) 82 | 83 | (define a 1) 84 | 85 | (bq-process2 '`(,a (unquote unquote a)) 0) 86 | 87 | (define b '(unquote a)) 88 | (define unquote 88) 89 | (bq-process2 '``(,a ,,,@b) 0) 90 | ; etc. => (1 88 1) 91 | 92 | (define b '(a a)) 93 | (bq-process2 '``(,a ,,,@b) 0) 94 | ; etc. => (1 1 1) 95 | |# 96 | 97 | ;; minimal version with no optimizations, vectors, or dotted lists 98 | (define (bq-process0 x d) 99 | (define (bq-bracket x) 100 | (cond ((and (pair? x) (eq? (car x) 'unquote)) 101 | (if (= d 0) 102 | (cons list (cdr x)) 103 | (list list (list cons ''unquote 104 | (bq-process0 (cdr x) (- d 1)))))) 105 | ((and (pair? x) (eq? (car x) 'unquote-splicing)) 106 | (if (= d 0) 107 | (list 'copy-list (cadr x)) 108 | (list list (list list ''unquote-splicing 109 | (bq-process0 (cadr x) (- d 1)))))) 110 | (else (list list (bq-process0 x d))))) 111 | (cond ((symbol? x) (list 'quote x)) 112 | ((atom? x) x) 113 | ((eq? (car x) 'quasiquote) 114 | (list list ''quasiquote (bq-process0 (cadr x) (+ d 1)))) 115 | ((eq? (car x) 'unquote) 116 | (if (and (= d 0) (length= x 2)) 117 | (cadr x) 118 | (list cons ''unquote (bq-process0 (cdr x) (- d 1))))) 119 | (else 120 | (cons 'nconc (map bq-bracket x))))) 121 | 122 | #t 123 | -------------------------------------------------------------------------------- /examples/dict.lsp: -------------------------------------------------------------------------------- 1 | ; dictionary as binary tree 2 | 3 | (defun dict () ()) 4 | 5 | ; node representation ((k . v) L R) 6 | (defun dict-peek (d key nf) 7 | (if (null d) nf 8 | (let ((c (compare key (caar d)))) 9 | (cond ((= c 0) (cdar d)) 10 | ((< c 0) (dict-peek (cadr d) key nf)) 11 | (T (dict-peek (caddr d) key nf)))))) 12 | 13 | (defun dict-get (d key) (dict-peek d key nil)) 14 | 15 | (defun dict-put (d key v) 16 | (if (null d) (list (cons key v) (dict) (dict)) 17 | (let ((c (compare key (caar d)))) 18 | (cond ((= c 0) (list (cons key v) (cadr d) (caddr d))) 19 | ((< c 0) (list (car d) 20 | (dict-put (cadr d) key v) 21 | (caddr d))) 22 | (T (list (car d) 23 | (cadr d) 24 | (dict-put (caddr d) key v))))))) 25 | 26 | ; mutable dictionary 27 | (defun dict-nput (d key v) 28 | (if (null d) (list (cons key v) (dict) (dict)) 29 | (let ((c (compare key (caar d)))) 30 | (cond ((= c 0) (rplacd (car d) v)) 31 | ((< c 0) (setf (cadr d) (dict-nput (cadr d) key v))) 32 | (T (setf (caddr d) (dict-nput (caddr d) key v)))) 33 | d))) 34 | 35 | (defun dict-collect (f d) 36 | (if (null d) () 37 | (cons (f (caar d) (cdar d)) (nconc (dict-collect f (cadr d)) 38 | (dict-collect f (caddr d)))))) 39 | 40 | (defun dict-keys (d) (dict-collect K d)) 41 | (defun dict-pairs (d) (dict-collect cons d)) 42 | 43 | (defun dict-each (f d) 44 | (if (null d) () 45 | (progn (f (caar d) (cdar d)) 46 | (dict-each f (cadr d)) 47 | (dict-each f (caddr d))))) 48 | 49 | (defun alist-to-dict (a) 50 | (foldl (lambda (p d) (dict-put d (car p) (cdr p))) 51 | (dict) a)) 52 | -------------------------------------------------------------------------------- /examples/rule30.lsp: -------------------------------------------------------------------------------- 1 | ; -*- scheme -*- 2 | 3 | (define (rule30-step b) 4 | (let ((L (ash b -1)) 5 | (R (ash b 1))) 6 | (let ((~b (lognot b)) 7 | (~L (lognot L)) 8 | (~R (lognot R))) 9 | (logior (logand L ~b ~R) 10 | (logand ~L b R) 11 | (logand ~L b ~R) 12 | (logand ~L ~b R))))) 13 | 14 | (define (bin-draw s) 15 | (string.map (lambda (c) (case c 16 | (#\1 #\#) 17 | (#\0 #\ ) 18 | (else c))) 19 | s)) 20 | 21 | (for-each (lambda (n) 22 | (begin 23 | (princ (bin-draw (string.lpad (number->string n 2) 63 #\0))) 24 | (newline))) 25 | (nestlist rule30-step (uint64 0x0000000080000000) 32)) 26 | -------------------------------------------------------------------------------- /flmain.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "llt.h" 5 | #include "flisp.h" 6 | 7 | static value_t argv_list(int argc, char *argv[]) 8 | { 9 | int i; 10 | value_t lst=FL_NIL, temp; 11 | fl_gc_handle(&lst); 12 | fl_gc_handle(&temp); 13 | for(i=argc-1; i >= 0; i--) { 14 | temp = cvalue_static_cstring(argv[i]); 15 | lst = fl_cons(temp, lst); 16 | } 17 | fl_free_gc_handles(2); 18 | return lst; 19 | } 20 | 21 | extern value_t fl_file(value_t *args, uint32_t nargs); 22 | 23 | int main(int argc, char *argv[]) 24 | { 25 | char fname_buf[1024]; 26 | 27 | fl_init(512*1024); 28 | 29 | fname_buf[0] = '\0'; 30 | #ifdef INITFILE 31 | strcat(fname_buf, INITFILE); 32 | #else 33 | value_t str = symbol_value(symbol("*install-dir*")); 34 | char *exedir = (str == UNBOUND ? NULL : cvalue_data(str)); 35 | if (exedir != NULL) { 36 | strcat(fname_buf, exedir); 37 | strcat(fname_buf, PATHSEPSTRING); 38 | } 39 | strcat(fname_buf, "flisp.boot"); 40 | #endif 41 | 42 | value_t args[2]; 43 | fl_gc_handle(&args[0]); 44 | fl_gc_handle(&args[1]); 45 | FL_TRY_EXTERN { 46 | args[0] = cvalue_static_cstring(fname_buf); 47 | args[1] = symbol(":read"); 48 | value_t f = fl_file(&args[0], 2); 49 | fl_free_gc_handles(2); 50 | 51 | if (fl_load_system_image(f)) 52 | return 1; 53 | 54 | (void)fl_applyn(1, symbol_value(symbol("__start")), 55 | argv_list(argc, argv)); 56 | } 57 | FL_CATCH_EXTERN { 58 | ios_puts("fatal error:\n", ios_stderr); 59 | fl_print(ios_stderr, fl_lasterror); 60 | ios_putc('\n', ios_stderr); 61 | return 1; 62 | } 63 | return 0; 64 | } 65 | -------------------------------------------------------------------------------- /lib/lazy.scm: -------------------------------------------------------------------------------- 1 | ; SRFI 45: Primitives for Expressing Iterative Lazy Algorithms 2 | ; by André van Tonder 3 | ;========================================================================= 4 | ; Boxes 5 | 6 | (define (box x) (list x)) 7 | (define unbox car) 8 | (define set-box! set-car!) 9 | 10 | ;========================================================================= 11 | ; Primitives for lazy evaluation: 12 | 13 | (define (eager x) 14 | (box (cons 'eager x))) 15 | 16 | #| 17 | (define-syntax lazy 18 | (syntax-rules () 19 | ((lazy exp) 20 | (box (cons 'lazy (lambda () exp)))))) 21 | 22 | (define-syntax delay 23 | (syntax-rules () 24 | ((delay exp) (lazy (eager exp))))) 25 | |# 26 | 27 | (define-macro (lazy exp) 28 | `(box (cons 'lazy (lambda () ,exp)))) 29 | 30 | (define-macro (delay exp) 31 | `(lazy (eager ,exp))) 32 | 33 | (define (force promise) 34 | (let ((content (unbox promise))) 35 | (case (car content) 36 | ((eager) (cdr content)) 37 | ((lazy) (let* ((promise* ((cdr content))) 38 | (content (unbox promise))) ; * 39 | (if (not (eqv? (car content) 'eager)) ; * 40 | (begin (set-car! content (car (unbox promise*))) 41 | (set-cdr! content (cdr (unbox promise*))) 42 | (set-box! promise* content))) 43 | (force promise)))))) 44 | 45 | ; (*) These two lines re-fetch and check the original promise in case 46 | ; the first line of the let* caused it to be forced. For an example 47 | ; where this happens, see reentrancy test 3 below. 48 | -------------------------------------------------------------------------------- /lib/sort.scm: -------------------------------------------------------------------------------- 1 | ;;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort! 2 | ;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren) 3 | ;;; 4 | ;;; This code is in the public domain. 5 | 6 | ;;; Updated: 11 June 1991 7 | ;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991 8 | ;;; Updated: 19 June 1995 9 | ;;; (sort, sort!, sorted?): Generalized to strings by jaffer: 2003-09-09 10 | ;;; (sort, sort!, sorted?): Generalized to arrays by jaffer: 2003-10-04 11 | ;;; jaffer: 2006-10-08: 12 | ;;; (sort, sort!, sorted?, merge, merge!): Added optional KEY argument. 13 | ;;; jaffer: 2006-11-05: 14 | ;;; (sorted?, merge, merge!, sort, sort!): Call KEY arg at most once 15 | ;;; per element. 16 | 17 | ;(require 'array) 18 | 19 | ;;; (sorted? sequence less?) 20 | ;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm) 21 | ;;; such that for all 1 <= i <= m, 22 | ;;; (not (less? (list-ref list i) (list-ref list (- i 1)))). 23 | ;@ 24 | (define (sorted? seq less? . opt-key) 25 | (define key (if (null? opt-key) identity (car opt-key))) 26 | (cond ((null? seq) #t) 27 | ((array? seq) 28 | (let ((dimax (+ -1 (car (array-dimensions seq))))) 29 | (or (<= dimax 1) 30 | (let loop ((idx (+ -1 dimax)) 31 | (last (key (array-ref seq dimax)))) 32 | (or (negative? idx) 33 | (let ((nxt (key (array-ref seq idx)))) 34 | (and (less? nxt last) 35 | (loop (+ -1 idx) nxt)))))))) 36 | ((null? (cdr seq)) #t) 37 | (else 38 | (let loop ((last (key (car seq))) 39 | (next (cdr seq))) 40 | (or (null? next) 41 | (let ((nxt (key (car next)))) 42 | (and (not (less? nxt last)) 43 | (loop nxt (cdr next))))))))) 44 | 45 | ;;; (merge a b less?) 46 | ;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?) 47 | ;;; and returns a new list in which the elements of a and b have been stably 48 | ;;; interleaved so that (sorted? (merge a b less?) less?). 49 | ;;; Note: this does _not_ accept arrays. See below. 50 | ;@ 51 | (define (merge a b less? . opt-key) 52 | (define key (if (null? opt-key) identity (car opt-key))) 53 | (cond ((null? a) b) 54 | ((null? b) a) 55 | (else 56 | (let loop ((x (car a)) (kx (key (car a))) (a (cdr a)) 57 | (y (car b)) (ky (key (car b))) (b (cdr b))) 58 | ;; The loop handles the merging of non-empty lists. It has 59 | ;; been written this way to save testing and car/cdring. 60 | (if (less? ky kx) 61 | (if (null? b) 62 | (cons y (cons x a)) 63 | (cons y (loop x kx a (car b) (key (car b)) (cdr b)))) 64 | ;; x <= y 65 | (if (null? a) 66 | (cons x (cons y b)) 67 | (cons x (loop (car a) (key (car a)) (cdr a) y ky b)))))))) 68 | 69 | (define (sort:merge! a b less? key) 70 | (define (loop r a kcara b kcarb) 71 | (cond ((less? kcarb kcara) 72 | (set-cdr! r b) 73 | (if (null? (cdr b)) 74 | (set-cdr! b a) 75 | (loop b a kcara (cdr b) (key (cadr b))))) 76 | (else ; (car a) <= (car b) 77 | (set-cdr! r a) 78 | (if (null? (cdr a)) 79 | (set-cdr! a b) 80 | (loop a (cdr a) (key (cadr a)) b kcarb))))) 81 | (cond ((null? a) b) 82 | ((null? b) a) 83 | (else 84 | (let ((kcara (key (car a))) 85 | (kcarb (key (car b)))) 86 | (cond 87 | ((less? kcarb kcara) 88 | (if (null? (cdr b)) 89 | (set-cdr! b a) 90 | (loop b a kcara (cdr b) (key (cadr b)))) 91 | b) 92 | (else ; (car a) <= (car b) 93 | (if (null? (cdr a)) 94 | (set-cdr! a b) 95 | (loop a (cdr a) (key (cadr a)) b kcarb)) 96 | a)))))) 97 | 98 | ;;; takes two sorted lists a and b and smashes their cdr fields to form a 99 | ;;; single sorted list including the elements of both. 100 | ;;; Note: this does _not_ accept arrays. 101 | ;@ 102 | (define (merge! a b less? . opt-key) 103 | (sort:merge! a b less? (if (null? opt-key) identity (car opt-key)))) 104 | 105 | (define (sort:sort-list! seq less? key) 106 | (define keyer (if key car identity)) 107 | (define (step n) 108 | (cond ((> n 2) (let* ((j (quotient n 2)) 109 | (a (step j)) 110 | (k (- n j)) 111 | (b (step k))) 112 | (sort:merge! a b less? keyer))) 113 | ((= n 2) (let ((x (car seq)) 114 | (y (cadr seq)) 115 | (p seq)) 116 | (set! seq (cddr seq)) 117 | (cond ((less? (keyer y) (keyer x)) 118 | (set-car! p y) 119 | (set-car! (cdr p) x))) 120 | (set-cdr! (cdr p) '()) 121 | p)) 122 | ((= n 1) (let ((p seq)) 123 | (set! seq (cdr seq)) 124 | (set-cdr! p '()) 125 | p)) 126 | (else '()))) 127 | (define (key-wrap! lst) 128 | (cond ((null? lst)) 129 | (else (set-car! lst (cons (key (car lst)) (car lst))) 130 | (key-wrap! (cdr lst))))) 131 | (define (key-unwrap! lst) 132 | (cond ((null? lst)) 133 | (else (set-car! lst (cdar lst)) 134 | (key-unwrap! (cdr lst))))) 135 | (cond (key 136 | (key-wrap! seq) 137 | (set! seq (step (length seq))) 138 | (key-unwrap! seq) 139 | seq) 140 | (else 141 | (step (length seq))))) 142 | 143 | (define (rank-1-array->list array) 144 | (define dimensions (array-dimensions array)) 145 | (do ((idx (+ -1 (car dimensions)) (+ -1 idx)) 146 | (lst '() (cons (array-ref array idx) lst))) 147 | ((< idx 0) lst))) 148 | 149 | ;;; (sort! sequence less?) 150 | ;;; sorts the list, array, or string sequence destructively. It uses 151 | ;;; a version of merge-sort invented, to the best of my knowledge, by 152 | ;;; David H. D. Warren, and first used in the DEC-10 Prolog system. 153 | ;;; R. A. O'Keefe adapted it to work destructively in Scheme. 154 | ;;; A. Jaffer modified to always return the original list. 155 | ;@ 156 | (define (sort! seq less? . opt-key) 157 | (define key (if (null? opt-key) #f (car opt-key))) 158 | (cond ((array? seq) 159 | (let ((dims (array-dimensions seq))) 160 | (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key) 161 | (cdr sorted)) 162 | (i 0 (+ i 1))) 163 | ((null? sorted) seq) 164 | (array-set! seq (car sorted) i)))) 165 | (else ; otherwise, assume it is a list 166 | (let ((ret (sort:sort-list! seq less? key))) 167 | (if (not (eq? ret seq)) 168 | (do ((crt ret (cdr crt))) 169 | ((eq? (cdr crt) seq) 170 | (set-cdr! crt ret) 171 | (let ((scar (car seq)) (scdr (cdr seq))) 172 | (set-car! seq (car ret)) (set-cdr! seq (cdr ret)) 173 | (set-car! ret scar) (set-cdr! ret scdr))))) 174 | seq)))) 175 | 176 | ;;; (sort sequence less?) 177 | ;;; sorts a array, string, or list non-destructively. It does this 178 | ;;; by sorting a copy of the sequence. My understanding is that the 179 | ;;; Standard says that the result of append is always "newly 180 | ;;; allocated" except for sharing structure with "the last argument", 181 | ;;; so (append x '()) ought to be a standard way of copying a list x. 182 | ;@ 183 | (define (sort seq less? . opt-key) 184 | (define key (if (null? opt-key) #f (car opt-key))) 185 | (cond ((array? seq) 186 | (let ((dims (array-dimensions seq))) 187 | (define newra (apply make-array seq dims)) 188 | (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key) 189 | (cdr sorted)) 190 | (i 0 (+ i 1))) 191 | ((null? sorted) newra) 192 | (array-set! newra (car sorted) i)))) 193 | (else (sort:sort-list! (append seq '()) less? key)))) 194 | -------------------------------------------------------------------------------- /llt/Makefile: -------------------------------------------------------------------------------- 1 | FREEBSD-GE-10 = $(shell test `uname` = FreeBSD -a `uname -r | cut -d. -f1` -ge 10 && echo YES) 2 | CC = $(if $(FREEBSD-GE-10),clang,gcc) 3 | 4 | SRCS = bitvector.c hashing.c socket.c timefuncs.c ptrhash.c utf8.c ios.c \ 5 | dirpath.c htable.c bitvector-ops.c int2str.c dump.c random.c \ 6 | lltinit.c 7 | OBJS = $(SRCS:%.c=%.o) 8 | DOBJS = $(SRCS:%.c=%.do) 9 | TARGET = libllt.a 10 | 11 | FLAGS = -Wall -Wno-strict-aliasing $(CFLAGS) 12 | LIBS = 13 | 14 | DEBUGFLAGS = -g -DDEBUG $(FLAGS) 15 | SHIPFLAGS = -O3 -DNDEBUG $(FLAGS) 16 | 17 | default: release 18 | 19 | %.o: %.c 20 | $(CC) $(SHIPFLAGS) -c $< -o $@ 21 | %.do: %.c 22 | $(CC) $(DEBUGFLAGS) -c $< -o $@ 23 | 24 | debug: $(DOBJS) 25 | rm -rf $(TARGET) 26 | ar rs $(TARGET) $(DOBJS) 27 | 28 | release: $(OBJS) 29 | rm -rf $(TARGET) 30 | ar rs $(TARGET) $(OBJS) 31 | 32 | clean: 33 | rm -f *.o 34 | rm -f *.do 35 | rm -f *~ 36 | rm -f core* 37 | rm -f $(TARGET) 38 | -------------------------------------------------------------------------------- /llt/Makefile.macosx: -------------------------------------------------------------------------------- 1 | CC = gcc 2 | 3 | SRCS = bitvector.c hashing.c socket.c timefuncs.c ptrhash.c utf8.c ios.c \ 4 | dirpath.c htable.c bitvector-ops.c int2str.c dump.c random.c \ 5 | lltinit.c 6 | OBJS = $(SRCS:%.c=%.o) 7 | DOBJS = $(SRCS:%.c=%.do) 8 | TARGET = libllt.a 9 | 10 | # OS flags: LINUX, WIN32, MACOSX 11 | # architecture flags: __CPU__=xxx, BITS64, ARCH_X86, ARCH_X86_64 12 | CONFIG = -DBITS64 -D__CPU__=686 13 | FLAGS = -Wall -Wno-strict-aliasing $(CFLAGS) $(CONFIG) 14 | LIBS = 15 | 16 | DEBUGFLAGS = -g -DDEBUG $(FLAGS) 17 | SHIPFLAGS = -O3 -DNDEBUG $(FLAGS) 18 | 19 | default: release 20 | 21 | %.o: %.c 22 | $(CC) $(SHIPFLAGS) -c $< -o $@ 23 | %.do: %.c 24 | $(CC) $(DEBUGFLAGS) -c $< -o $@ 25 | 26 | debug: $(DOBJS) 27 | rm -rf $(TARGET) 28 | ar rs $(TARGET) $(DOBJS) 29 | 30 | release: $(OBJS) 31 | rm -rf $(TARGET) 32 | ar rs $(TARGET) $(OBJS) 33 | 34 | clean: 35 | rm -f *.o 36 | rm -f *.do 37 | rm -f *~ 38 | rm -f core* 39 | rm -f $(TARGET) 40 | -------------------------------------------------------------------------------- /llt/UTF8.txt: -------------------------------------------------------------------------------- 1 | 2 | UTF-8 encoded sample plain-text file 3 | ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ 4 | 5 | Markus Kuhn [ˈmaʳkʊs kuːn] — 2002-07-25 6 | 7 | 8 | The ASCII compatible UTF-8 encoding used in this plain-text file 9 | is defined in Unicode, ISO 10646-1, and RFC 2279. 10 | 11 | 12 | Using Unicode/UTF-8, you can write in emails and source code things such as 13 | 14 | Mathematics and sciences: 15 | 16 | ∮ E⋅da = Q, n → ∞, ∑ f(i) = ∏ g(i), ⎧⎡⎛┌─────┐⎞⎤⎫ 17 | ⎪⎢⎜│a²+b³ ⎟⎥⎪ 18 | ∀x∈ℝ: ⌈x⌉ = −⌊−x⌋, α ∧ ¬β = ¬(¬α ∨ β), ⎪⎢⎜│───── ⎟⎥⎪ 19 | ⎪⎢⎜⎷ c₈ ⎟⎥⎪ 20 | ℕ ⊆ ℕ₀ ⊂ ℤ ⊂ ℚ ⊂ ℝ ⊂ ℂ, ⎨⎢⎜ ⎟⎥⎬ 21 | ⎪⎢⎜ ∞ ⎟⎥⎪ 22 | ⊥ < a ≠ b ≡ c ≤ d ≪ ⊤ ⇒ (⟦A⟧ ⇔ ⟪B⟫), ⎪⎢⎜ ⎲ ⎟⎥⎪ 23 | ⎪⎢⎜ ⎳aⁱ-bⁱ⎟⎥⎪ 24 | 2H₂ + O₂ ⇌ 2H₂O, R = 4.7 kΩ, ⌀ 200 mm ⎩⎣⎝i=1 ⎠⎦⎭ 25 | 26 | Linguistics and dictionaries: 27 | 28 | ði ıntəˈnæʃənəl fəˈnɛtık əsoʊsiˈeıʃn 29 | Y [ˈʏpsilɔn], Yen [jɛn], Yoga [ˈjoːgɑ] 30 | 31 | APL: 32 | 33 | ((V⍳V)=⍳⍴V)/V←,V ⌷←⍳→⍴∆∇⊃‾⍎⍕⌈ 34 | 35 | Nicer typography in plain text files: 36 | 37 | ╔══════════════════════════════════════════╗ 38 | ║ ║ 39 | ║ • ‘single’ and “double” quotes ║ 40 | ║ ║ 41 | ║ • Curly apostrophes: “We’ve been here” ║ 42 | ║ ║ 43 | ║ • Latin-1 apostrophe and accents: '´` ║ 44 | ║ ║ 45 | ║ • ‚deutsche‘ „Anführungszeichen“ ║ 46 | ║ ║ 47 | ║ • †, ‡, ‰, •, 3–4, —, −5/+5, ™, … ║ 48 | ║ ║ 49 | ║ • ASCII safety test: 1lI|, 0OD, 8B ║ 50 | ║ ╭─────────╮ ║ 51 | ║ • the euro symbol: │ 14.95 € │ ║ 52 | ║ ╰─────────╯ ║ 53 | ╚══════════════════════════════════════════╝ 54 | 55 | Combining characters: 56 | 57 | STARGΛ̊TE SG-1, a = v̇ = r̈, a⃑ ⊥ b⃑ 58 | 59 | Greek (in Polytonic): 60 | 61 | The Greek anthem: 62 | 63 | Σὲ γνωρίζω ἀπὸ τὴν κόψη 64 | τοῦ σπαθιοῦ τὴν τρομερή, 65 | σὲ γνωρίζω ἀπὸ τὴν ὄψη 66 | ποὺ μὲ βία μετράει τὴ γῆ. 67 | 68 | ᾿Απ᾿ τὰ κόκκαλα βγαλμένη 69 | τῶν ῾Ελλήνων τὰ ἱερά 70 | καὶ σὰν πρῶτα ἀνδρειωμένη 71 | χαῖρε, ὦ χαῖρε, ᾿Ελευθεριά! 72 | 73 | From a speech of Demosthenes in the 4th century BC: 74 | 75 | Οὐχὶ ταὐτὰ παρίσταταί μοι γιγνώσκειν, ὦ ἄνδρες ᾿Αθηναῖοι, 76 | ὅταν τ᾿ εἰς τὰ πράγματα ἀποβλέψω καὶ ὅταν πρὸς τοὺς 77 | λόγους οὓς ἀκούω· τοὺς μὲν γὰρ λόγους περὶ τοῦ 78 | τιμωρήσασθαι Φίλιππον ὁρῶ γιγνομένους, τὰ δὲ πράγματ᾿ 79 | εἰς τοῦτο προήκοντα, ὥσθ᾿ ὅπως μὴ πεισόμεθ᾿ αὐτοὶ 80 | πρότερον κακῶς σκέψασθαι δέον. οὐδέν οὖν ἄλλο μοι δοκοῦσιν 81 | οἱ τὰ τοιαῦτα λέγοντες ἢ τὴν ὑπόθεσιν, περὶ ἧς βουλεύεσθαι, 82 | οὐχὶ τὴν οὖσαν παριστάντες ὑμῖν ἁμαρτάνειν. ἐγὼ δέ, ὅτι μέν 83 | ποτ᾿ ἐξῆν τῇ πόλει καὶ τὰ αὑτῆς ἔχειν ἀσφαλῶς καὶ Φίλιππον 84 | τιμωρήσασθαι, καὶ μάλ᾿ ἀκριβῶς οἶδα· ἐπ᾿ ἐμοῦ γάρ, οὐ πάλαι 85 | γέγονεν ταῦτ᾿ ἀμφότερα· νῦν μέντοι πέπεισμαι τοῦθ᾿ ἱκανὸν 86 | προλαβεῖν ἡμῖν εἶναι τὴν πρώτην, ὅπως τοὺς συμμάχους 87 | σώσομεν. ἐὰν γὰρ τοῦτο βεβαίως ὑπάρξῃ, τότε καὶ περὶ τοῦ 88 | τίνα τιμωρήσεταί τις καὶ ὃν τρόπον ἐξέσται σκοπεῖν· πρὶν δὲ 89 | τὴν ἀρχὴν ὀρθῶς ὑποθέσθαι, μάταιον ἡγοῦμαι περὶ τῆς 90 | τελευτῆς ὁντινοῦν ποιεῖσθαι λόγον. 91 | 92 | Δημοσθένους, Γ´ ᾿Ολυνθιακὸς 93 | 94 | Georgian: 95 | 96 | From a Unicode conference invitation: 97 | 98 | გთხოვთ ახლავე გაიაროთ რეგისტრაცია Unicode-ის მეათე საერთაშორისო 99 | კონფერენციაზე დასასწრებად, რომელიც გაიმართება 10-12 მარტს, 100 | ქ. მაინცში, გერმანიაში. კონფერენცია შეჰკრებს ერთად მსოფლიოს 101 | ექსპერტებს ისეთ დარგებში როგორიცაა ინტერნეტი და Unicode-ი, 102 | ინტერნაციონალიზაცია და ლოკალიზაცია, Unicode-ის გამოყენება 103 | ოპერაციულ სისტემებსა, და გამოყენებით პროგრამებში, შრიფტებში, 104 | ტექსტების დამუშავებასა და მრავალენოვან კომპიუტერულ სისტემებში. 105 | 106 | Russian: 107 | 108 | From a Unicode conference invitation: 109 | 110 | Зарегистрируйтесь сейчас на Десятую Международную Конференцию по 111 | Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии. 112 | Конференция соберет широкий круг экспертов по вопросам глобального 113 | Интернета и Unicode, локализации и интернационализации, воплощению и 114 | применению Unicode в различных операционных системах и программных 115 | приложениях, шрифтах, верстке и многоязычных компьютерных системах. 116 | 117 | Thai (UCS Level 2): 118 | 119 | Excerpt from a poetry on The Romance of The Three Kingdoms (a Chinese 120 | classic 'San Gua'): 121 | 122 | [----------------------------|------------------------] 123 | ๏ แผ่นดินฮั่นเสื่อมโทรมแสนสังเวช พระปกเกศกองบู๊กู้ขึ้นใหม่ 124 | สิบสองกษัตริย์ก่อนหน้าแลถัดไป สององค์ไซร้โง่เขลาเบาปัญญา 125 | ทรงนับถือขันทีเป็นที่พึ่ง บ้านเมืองจึงวิปริตเป็นนักหนา 126 | โฮจิ๋นเรียกทัพทั่วหัวเมืองมา หมายจะฆ่ามดชั่วตัวสำคัญ 127 | เหมือนขับไสไล่เสือจากเคหา รับหมาป่าเข้ามาเลยอาสัญ 128 | ฝ่ายอ้องอุ้นยุแยกให้แตกกัน ใช้สาวนั้นเป็นชนวนชื่นชวนใจ 129 | พลันลิฉุยกุยกีกลับก่อเหตุ ช่างอาเพศจริงหนาฟ้าร้องไห้ 130 | ต้องรบราฆ่าฟันจนบรรลัย ฤๅหาใครค้ำชูกู้บรรลังก์ ฯ 131 | 132 | (The above is a two-column text. If combining characters are handled 133 | correctly, the lines of the second column should be aligned with the 134 | | character above.) 135 | 136 | Ethiopian: 137 | 138 | Proverbs in the Amharic language: 139 | 140 | ሰማይ አይታረስ ንጉሥ አይከሰስ። 141 | ብላ ካለኝ እንደአባቴ በቆመጠኝ። 142 | ጌጥ ያለቤቱ ቁምጥና ነው። 143 | ደሀ በሕልሙ ቅቤ ባይጠጣ ንጣት በገደለው። 144 | የአፍ ወለምታ በቅቤ አይታሽም። 145 | አይጥ በበላ ዳዋ ተመታ። 146 | ሲተረጉሙ ይደረግሙ። 147 | ቀስ በቀስ፥ ዕንቁላል በእግሩ ይሄዳል። 148 | ድር ቢያብር አንበሳ ያስር። 149 | ሰው እንደቤቱ እንጅ እንደ ጉረቤቱ አይተዳደርም። 150 | እግዜር የከፈተውን ጉሮሮ ሳይዘጋው አይድርም። 151 | የጎረቤት ሌባ፥ ቢያዩት ይስቅ ባያዩት ያጠልቅ። 152 | ሥራ ከመፍታት ልጄን ላፋታት። 153 | ዓባይ ማደሪያ የለው፥ ግንድ ይዞ ይዞራል። 154 | የእስላም አገሩ መካ የአሞራ አገሩ ዋርካ። 155 | ተንጋሎ ቢተፉ ተመልሶ ባፉ። 156 | ወዳጅህ ማር ቢሆን ጨርስህ አትላሰው። 157 | እግርህን በፍራሽህ ልክ ዘርጋ። 158 | 159 | Runes: 160 | 161 | ᚻᛖ ᚳᚹᚫᚦ ᚦᚫᛏ ᚻᛖ ᛒᚢᛞᛖ ᚩᚾ ᚦᚫᛗ ᛚᚪᚾᛞᛖ ᚾᚩᚱᚦᚹᛖᚪᚱᛞᚢᛗ ᚹᛁᚦ ᚦᚪ ᚹᛖᛥᚫ 162 | 163 | (Old English, which transcribed into Latin reads 'He cwaeth that he 164 | bude thaem lande northweardum with tha Westsae.' and means 'He said 165 | that he lived in the northern land near the Western Sea.') 166 | 167 | Braille: 168 | 169 | ⡌⠁⠧⠑ ⠼⠁⠒ ⡍⠜⠇⠑⠹⠰⠎ ⡣⠕⠌ 170 | 171 | ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠙⠑⠁⠙⠒ ⠞⠕ ⠃⠑⠛⠔ ⠺⠊⠹⠲ ⡹⠻⠑ ⠊⠎ ⠝⠕ ⠙⠳⠃⠞ 172 | ⠱⠁⠞⠑⠧⠻ ⠁⠃⠳⠞ ⠹⠁⠞⠲ ⡹⠑ ⠗⠑⠛⠊⠌⠻ ⠕⠋ ⠙⠊⠎ ⠃⠥⠗⠊⠁⠇ ⠺⠁⠎ 173 | ⠎⠊⠛⠝⠫ ⠃⠹ ⠹⠑ ⠊⠇⠻⠛⠹⠍⠁⠝⠂ ⠹⠑ ⠊⠇⠻⠅⠂ ⠹⠑ ⠥⠝⠙⠻⠞⠁⠅⠻⠂ 174 | ⠁⠝⠙ ⠹⠑ ⠡⠊⠑⠋ ⠍⠳⠗⠝⠻⠲ ⡎⠊⠗⠕⠕⠛⠑ ⠎⠊⠛⠝⠫ ⠊⠞⠲ ⡁⠝⠙ 175 | ⡎⠊⠗⠕⠕⠛⠑⠰⠎ ⠝⠁⠍⠑ ⠺⠁⠎ ⠛⠕⠕⠙ ⠥⠏⠕⠝ ⠰⡡⠁⠝⠛⠑⠂ ⠋⠕⠗ ⠁⠝⠹⠹⠔⠛ ⠙⠑ 176 | ⠡⠕⠎⠑ ⠞⠕ ⠏⠥⠞ ⠙⠊⠎ ⠙⠁⠝⠙ ⠞⠕⠲ 177 | 178 | ⡕⠇⠙ ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲ 179 | 180 | ⡍⠔⠙⠖ ⡊ ⠙⠕⠝⠰⠞ ⠍⠑⠁⠝ ⠞⠕ ⠎⠁⠹ ⠹⠁⠞ ⡊ ⠅⠝⠪⠂ ⠕⠋ ⠍⠹ 181 | ⠪⠝ ⠅⠝⠪⠇⠫⠛⠑⠂ ⠱⠁⠞ ⠹⠻⠑ ⠊⠎ ⠏⠜⠞⠊⠊⠥⠇⠜⠇⠹ ⠙⠑⠁⠙ ⠁⠃⠳⠞ 182 | ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲ ⡊ ⠍⠊⠣⠞ ⠙⠁⠧⠑ ⠃⠑⠲ ⠔⠊⠇⠔⠫⠂ ⠍⠹⠎⠑⠇⠋⠂ ⠞⠕ 183 | ⠗⠑⠛⠜⠙ ⠁ ⠊⠕⠋⠋⠔⠤⠝⠁⠊⠇ ⠁⠎ ⠹⠑ ⠙⠑⠁⠙⠑⠌ ⠏⠊⠑⠊⠑ ⠕⠋ ⠊⠗⠕⠝⠍⠕⠝⠛⠻⠹ 184 | ⠔ ⠹⠑ ⠞⠗⠁⠙⠑⠲ ⡃⠥⠞ ⠹⠑ ⠺⠊⠎⠙⠕⠍ ⠕⠋ ⠳⠗ ⠁⠝⠊⠑⠌⠕⠗⠎ 185 | ⠊⠎ ⠔ ⠹⠑ ⠎⠊⠍⠊⠇⠑⠆ ⠁⠝⠙ ⠍⠹ ⠥⠝⠙⠁⠇⠇⠪⠫ ⠙⠁⠝⠙⠎ 186 | ⠩⠁⠇⠇ ⠝⠕⠞ ⠙⠊⠌⠥⠗⠃ ⠊⠞⠂ ⠕⠗ ⠹⠑ ⡊⠳⠝⠞⠗⠹⠰⠎ ⠙⠕⠝⠑ ⠋⠕⠗⠲ ⡹⠳ 187 | ⠺⠊⠇⠇ ⠹⠻⠑⠋⠕⠗⠑ ⠏⠻⠍⠊⠞ ⠍⠑ ⠞⠕ ⠗⠑⠏⠑⠁⠞⠂ ⠑⠍⠏⠙⠁⠞⠊⠊⠁⠇⠇⠹⠂ ⠹⠁⠞ 188 | ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲ 189 | 190 | (The first couple of paragraphs of "A Christmas Carol" by Dickens) 191 | 192 | Compact font selection example text: 193 | 194 | ABCDEFGHIJKLMNOPQRSTUVWXYZ /0123456789 195 | abcdefghijklmnopqrstuvwxyz £©µÀÆÖÞßéöÿ 196 | –—‘“”„†•…‰™œŠŸž€ ΑΒΓΔΩαβγδω АБВГДабвгд 197 | ∀∂∈ℝ∧∪≡∞ ↑↗↨↻⇣ ┐┼╔╘░►☺♀ fi�⑀₂ἠḂӥẄɐː⍎אԱა 198 | 199 | Greetings in various languages: 200 | 201 | Hello world, Καλημέρα κόσμε, コンニチハ 202 | 203 | Box drawing alignment tests: █ 204 | ▉ 205 | ╔══╦══╗ ┌──┬──┐ ╭──┬──╮ ╭──┬──╮ ┏━━┳━━┓ ┎┒┏┑ ╷ ╻ ┏┯┓ ┌┰┐ ▊ ╱╲╱╲╳╳╳ 206 | ║┌─╨─┐║ │╔═╧═╗│ │╒═╪═╕│ │╓─╁─╖│ ┃┌─╂─┐┃ ┗╃╄┙ ╶┼╴╺╋╸┠┼┨ ┝╋┥ ▋ ╲╱╲╱╳╳╳ 207 | ║│╲ ╱│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╿ │┃ ┍╅╆┓ ╵ ╹ ┗┷┛ └┸┘ ▌ ╱╲╱╲╳╳╳ 208 | ╠╡ ╳ ╞╣ ├╢ ╟┤ ├┼─┼─┼┤ ├╫─╂─╫┤ ┣┿╾┼╼┿┫ ┕┛┖┚ ┌┄┄┐ ╎ ┏┅┅┓ ┋ ▍ ╲╱╲╱╳╳╳ 209 | ║│╱ ╲│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╽ │┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▎ 210 | ║└─╥─┘║ │╚═╤═╝│ │╘═╪═╛│ │╙─╀─╜│ ┃└─╂─┘┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▏ 211 | ╚══╩══╝ └──┴──┘ ╰──┴──╯ ╰──┴──╯ ┗━━┻━━┛ ▗▄▖▛▀▜ └╌╌┘ ╎ ┗╍╍┛ ┋ ▁▂▃▄▅▆▇█ 212 | ▝▀▘▙▄▟ 213 | -------------------------------------------------------------------------------- /llt/bitvector.c: -------------------------------------------------------------------------------- 1 | /* 2 | bit vector primitives 3 | 4 | todo: 5 | * reverse 6 | * nreverse 7 | (- rotate left/right) 8 | * shl_to 9 | * not 10 | - shr_row, shl_row 11 | 12 | These routines are the back end supporting bit matrices. Many operations 13 | on bit matrices are slow (such as accessing or setting a single element!) 14 | but certain operations are privileged and lend themselves to extremely 15 | efficient implementation due to the bit-vector nature of machine integers. 16 | These are: 17 | done: 18 | & | $ ~ copy reverse fill sum prod 19 | todo: 20 | shift trans rowswap 21 | would be nice: 22 | channel interleave 23 | 24 | Important note: 25 | Out-of-place functions always assume dest and source have the same amount 26 | of space available. 27 | 28 | shr_to, shl_to, not_to, and reverse_to assume source and dest don't overlap 29 | and_to, or_to, and xor_to allow overlap. 30 | */ 31 | 32 | #include 33 | #include 34 | #include 35 | 36 | #include "dtypes.h" 37 | #include "bitvector.h" 38 | 39 | #ifdef WIN32 40 | #include 41 | #endif 42 | 43 | u_int32_t *bitvector_resize(u_int32_t *b, uint64_t oldsz, uint64_t newsz, 44 | int initzero) 45 | { 46 | u_int32_t *p; 47 | size_t sz = ((newsz+31)>>5) * sizeof(uint32_t); 48 | p = LLT_REALLOC(b, sz); 49 | if (p == NULL) return NULL; 50 | if (initzero && newsz>oldsz) { 51 | size_t osz = ((oldsz+31)>>5) * sizeof(uint32_t); 52 | memset(&p[osz/sizeof(uint32_t)], 0, sz-osz); 53 | } 54 | return p; 55 | } 56 | 57 | u_int32_t *bitvector_new(u_int64_t n, int initzero) 58 | { 59 | return bitvector_resize(NULL, 0, n, initzero); 60 | } 61 | 62 | size_t bitvector_nwords(u_int64_t nbits) 63 | { 64 | return ((nbits+31)>>5); 65 | } 66 | 67 | void bitvector_set(u_int32_t *b, u_int64_t n, u_int32_t c) 68 | { 69 | if (c) 70 | b[n>>5] |= (1<<(n&31)); 71 | else 72 | b[n>>5] &= ~(1<<(n&31)); 73 | } 74 | 75 | u_int32_t bitvector_get(u_int32_t *b, u_int64_t n) 76 | { 77 | return b[n>>5] & (1<<(n&31)); 78 | } 79 | 80 | static int ntz(uint32_t x) 81 | { 82 | int n; 83 | 84 | if (x == 0) return 32; 85 | n = 1; 86 | if ((x & 0x0000FFFF) == 0) {n = n +16; x = x >>16;} 87 | if ((x & 0x000000FF) == 0) {n = n + 8; x = x >> 8;} 88 | if ((x & 0x0000000F) == 0) {n = n + 4; x = x >> 4;} 89 | if ((x & 0x00000003) == 0) {n = n + 2; x = x >> 2;} 90 | return n - (x & 1); 91 | } 92 | 93 | // given a bitvector of n bits, starting at bit n0 find the next 94 | // set bit, including n0. 95 | // returns n if no set bits. 96 | uint32_t bitvector_next(uint32_t *b, uint64_t n0, uint64_t n) 97 | { 98 | if (n0 >= n) return n; 99 | 100 | uint32_t i = n0>>5; 101 | uint32_t nb = n0&31; 102 | uint32_t nw = (n+31)>>5; 103 | uint32_t w; 104 | 105 | if (i < nw-1 || (n&31)==0) 106 | w = b[i]>>nb; 107 | else 108 | w = (b[i]&lomask(n&31))>>nb; 109 | if (w != 0) 110 | return ntz(w)+n0; 111 | if (i == nw-1) 112 | return n; 113 | i++; 114 | while (i < nw-1) { 115 | w = b[i]; 116 | if (w != 0) { 117 | return ntz(w) + (i<<5); 118 | } 119 | i++; 120 | } 121 | w = b[i]; 122 | nb = n&31; 123 | i = ntz(w); 124 | if (nb == 0) 125 | return i + (n-32); 126 | if (i >= nb) 127 | return n; 128 | return i + (n-nb); 129 | } 130 | -------------------------------------------------------------------------------- /llt/bitvector.h: -------------------------------------------------------------------------------- 1 | #ifndef __BITVECTOR_H_ 2 | #define __BITVECTOR_H_ 3 | 4 | // a mask with n set lo or hi bits 5 | #define lomask(n) (u_int32_t)((((u_int32_t)1)<<(n))-1) 6 | #define himask(n) (~lomask(32-n)) 7 | #define ONES32 ((u_int32_t)0xffffffff) 8 | 9 | #ifdef __INTEL_COMPILER 10 | #define count_bits(b) _popcnt32(b) 11 | #else 12 | static inline u_int32_t count_bits(u_int32_t b) 13 | { 14 | b = b - ((b>>1)&0x55555555); 15 | b = ((b>>2)&0x33333333) + (b&0x33333333); 16 | b = ((b>>4)+b)&0x0f0f0f0f; 17 | b += (b>>8); 18 | b += (b>>16); 19 | return b & 0x3f; 20 | // here is the non-optimized version, for clarity: 21 | /* 22 | b = ((b>> 1)&0x55555555) + (b&0x55555555); 23 | b = ((b>> 2)&0x33333333) + (b&0x33333333); 24 | b = ((b>> 4)&0x0f0f0f0f) + (b&0x0f0f0f0f); 25 | b = ((b>> 8)&0x00ff00ff) + (b&0x00ff00ff); 26 | b = ((b>>16)&0x0000ffff) + (b&0x0000ffff); 27 | return b & 0x3f; 28 | */ 29 | } 30 | #endif 31 | 32 | u_int32_t bitreverse(u_int32_t x); 33 | 34 | u_int32_t *bitvector_new(u_int64_t n, int initzero); 35 | u_int32_t *bitvector_resize(u_int32_t *b, uint64_t oldsz, uint64_t newsz, 36 | int initzero); 37 | size_t bitvector_nwords(u_int64_t nbits); 38 | void bitvector_set(u_int32_t *b, u_int64_t n, u_int32_t c); 39 | u_int32_t bitvector_get(u_int32_t *b, u_int64_t n); 40 | 41 | uint32_t bitvector_next(uint32_t *b, uint64_t n0, uint64_t n); 42 | 43 | void bitvector_shr(u_int32_t *b, size_t n, u_int32_t s); 44 | void bitvector_shr_to(u_int32_t *dest, u_int32_t *b, size_t n, u_int32_t s); 45 | void bitvector_shl(u_int32_t *b, size_t n, u_int32_t s); 46 | void bitvector_shl_to(u_int32_t *dest, u_int32_t *b, size_t n, u_int32_t s, 47 | bool_t scrap); 48 | void bitvector_fill(u_int32_t *b,u_int32_t offs, u_int32_t c, u_int32_t nbits); 49 | void bitvector_copy(u_int32_t *dest, u_int32_t doffs, 50 | u_int32_t *a, u_int32_t aoffs, u_int32_t nbits); 51 | void bitvector_not(u_int32_t *b, u_int32_t offs, u_int32_t nbits); 52 | void bitvector_not_to(u_int32_t *dest, u_int32_t doffs, 53 | u_int32_t *a, u_int32_t aoffs, u_int32_t nbits); 54 | void bitvector_reverse(u_int32_t *b, u_int32_t offs, u_int32_t nbits); 55 | void bitvector_reverse_to(u_int32_t *dest, u_int32_t *src, u_int32_t soffs, 56 | u_int32_t nbits); 57 | void bitvector_and_to(u_int32_t *dest, u_int32_t doffs, 58 | u_int32_t *a, u_int32_t aoffs, 59 | u_int32_t *b, u_int32_t boffs, u_int32_t nbits); 60 | void bitvector_or_to(u_int32_t *dest, u_int32_t doffs, 61 | u_int32_t *a, u_int32_t aoffs, 62 | u_int32_t *b, u_int32_t boffs, u_int32_t nbits); 63 | void bitvector_xor_to(u_int32_t *dest, u_int32_t doffs, 64 | u_int32_t *a, u_int32_t aoffs, 65 | u_int32_t *b, u_int32_t boffs, u_int32_t nbits); 66 | u_int64_t bitvector_count(u_int32_t *b, u_int32_t offs, u_int64_t nbits); 67 | u_int32_t bitvector_any0(u_int32_t *b, u_int32_t offs, u_int32_t nbits); 68 | u_int32_t bitvector_any1(u_int32_t *b, u_int32_t offs, u_int32_t nbits); 69 | 70 | #endif 71 | -------------------------------------------------------------------------------- /llt/dirpath.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | 11 | #include "dtypes.h" 12 | 13 | #ifdef WIN32 14 | #include 15 | #include 16 | #include 17 | #undef NO_ERROR 18 | #undef MOD_SHIFT 19 | #undef TRUE 20 | #undef FALSE 21 | #undef VOID 22 | #else 23 | #include 24 | #include 25 | #include 26 | #endif 27 | 28 | #include "dirpath.h" 29 | 30 | void get_cwd(char *buf, size_t size) 31 | { 32 | #ifndef WIN32 33 | getcwd(buf, size); 34 | #else 35 | GetCurrentDirectory(size, buf); 36 | #endif 37 | } 38 | 39 | int set_cwd(char *buf) 40 | { 41 | #ifndef WIN32 42 | if (chdir(buf) == -1) 43 | return 1; 44 | #else 45 | if (SetCurrentDirectory(buf) == 0) 46 | return 1; 47 | #endif 48 | return 0; 49 | } 50 | 51 | // destructively convert path to directory part 52 | void path_to_dirname(char *path) 53 | { 54 | char *sep = strrchr(path, PATHSEP); 55 | if (sep != NULL) { 56 | *sep = '\0'; 57 | } 58 | else { 59 | path[0] = '\0'; 60 | } 61 | } 62 | 63 | #ifdef LINUX 64 | char *get_exename(char *buf, size_t size) 65 | { 66 | char linkname[64]; /* /proc//exe */ 67 | pid_t pid; 68 | ssize_t ret; 69 | 70 | /* Get our PID and build the name of the link in /proc */ 71 | pid = getpid(); 72 | 73 | if (snprintf(linkname, sizeof(linkname), "/proc/%i/exe", pid) < 0) 74 | return NULL; 75 | 76 | /* Now read the symbolic link */ 77 | ret = readlink(linkname, buf, size); 78 | 79 | /* In case of an error, leave the handling up to the caller */ 80 | if (ret == -1) 81 | return NULL; 82 | 83 | /* Report insufficient buffer size */ 84 | if ((size_t)ret >= size) 85 | return NULL; 86 | 87 | /* Ensure proper NUL termination */ 88 | buf[ret] = 0; 89 | 90 | return buf; 91 | } 92 | #elif defined(OPENBSD) 93 | #include 94 | #include 95 | 96 | char *get_exename(char *buf, size_t size) 97 | { 98 | int mib[4]; 99 | pid_t pid; 100 | size_t len, plen; 101 | char **argv, **argv2; 102 | char *p, *path, *pathcpy, filename[PATH_MAX]; 103 | struct stat sbuf; 104 | 105 | pid = getpid(); 106 | 107 | mib[0] = CTL_KERN; 108 | mib[1] = KERN_PROC_ARGS; 109 | mib[2] = pid; 110 | mib[3] = KERN_PROC_ARGV; 111 | 112 | buf = NULL; 113 | argv = NULL; 114 | len = 128; 115 | 116 | // Now, play The Guessing Game with sysctl(3) as to how big argv 117 | // is supposed to be. (It's loads of fun for the whole family!) 118 | 119 | while (len < SIZE_MAX / 2) { 120 | len *= 2; 121 | if ((argv2 = realloc(argv, len)) == NULL) 122 | break; 123 | argv = argv2; 124 | if (sysctl(mib, 4, argv, &len, NULL, 0) == -1) { 125 | if (errno == ENOMEM) 126 | continue; // Go back and realloc more memory. 127 | break; // Bail for some other error in sysctl(3). 128 | } 129 | // If you made it here, congrats! You guessed right! 130 | if (*argv != NULL) 131 | buf = strdup(*argv); 132 | break; 133 | } 134 | free(argv); 135 | 136 | // If no error occurred in the sysctl(3) KERN_PROC_ARGV call 137 | // above, then buf at this point contains some kind of pathname. 138 | 139 | if (buf != NULL) { 140 | if (strchr(buf, '/') == NULL) { 141 | // buf contains a `basename`-style pathname (i.e. "foo", 142 | // as opposed to "../foo" or "/usr/bin/foo"); search the 143 | // PATH for its location. (BTW the setgid(2), setuid(2) 144 | // calls are a pre-condition for the access(2) call 145 | // later.) 146 | 147 | if ( (path = getenv("PATH")) != NULL && 148 | !setgid(getegid()) && !setuid(geteuid()) ) { 149 | 150 | // The strdup(3) call below, if successful, will 151 | // allocate memory for the PATH string returned by 152 | // getenv(3) above. This is necessary because the man 153 | // page of getenv(3) says that its return value 154 | // "should be considered read-only"; however, the 155 | // strsep(3) call below is going to be destructively 156 | // modifying that value. ("Hulk smash!") 157 | 158 | if ((path = strdup(path)) != NULL) { 159 | pathcpy = path; 160 | len = strlen(buf); 161 | while ((p = strsep(&pathcpy, ":")) != NULL) { 162 | if (*p == '\0') p = "."; 163 | plen = strlen(p); 164 | 165 | // strip trailing '/' 166 | while (p[plen-1] == '/') p[--plen] = '\0'; 167 | 168 | if (plen + 1 + len < sizeof(filename)) { 169 | snprintf(filename, sizeof(filename), "%s/%s", p, buf); 170 | if ( (stat(filename, &sbuf) == 0) && 171 | S_ISREG(sbuf.st_mode) && 172 | access(filename, X_OK) == 0 ) { 173 | buf = strdup(filename); 174 | break; 175 | } 176 | } 177 | } 178 | free(path); // free the strdup(3) memory allocation. 179 | } 180 | } 181 | else buf = NULL; // call to getenv(3) or [sg]ete?[ug]id(2) failed. 182 | } 183 | if ( buf != NULL && *buf != '/' ) { 184 | // buf contains a relative pathname (e.g. "../foo"); 185 | // resolve this to an absolute pathname. 186 | if ( strlcpy(filename, buf, sizeof(filename)) >= sizeof(filename) || 187 | realpath(filename, buf) == NULL ) 188 | buf = NULL; 189 | } 190 | } 191 | 192 | return buf; 193 | } 194 | #elif defined(FREEBSD) 195 | #include 196 | #include 197 | 198 | char *get_exename(char *buf, size_t size) 199 | { 200 | int mib[4]; 201 | mib[0] = CTL_KERN; 202 | mib[1] = KERN_PROC; 203 | mib[2] = KERN_PROC_PATHNAME; 204 | mib[3] = -1; 205 | sysctl(mib, 4, buf, &size, NULL, 0); 206 | 207 | return buf; 208 | } 209 | #elif defined(WIN32) 210 | char *get_exename(char *buf, size_t size) 211 | { 212 | if (GetModuleFileName(NULL, buf, size) == 0) 213 | return NULL; 214 | 215 | return buf; 216 | } 217 | #elif defined(MACOSX) 218 | #include 219 | char *get_exename(char *buf, size_t size) 220 | { 221 | uint32_t bufsize = (uint32_t)size; 222 | if (_NSGetExecutablePath(buf, &bufsize)) 223 | return NULL; 224 | return buf; 225 | } 226 | #endif 227 | -------------------------------------------------------------------------------- /llt/dirpath.h: -------------------------------------------------------------------------------- 1 | #ifndef __DIRPATH_H_ 2 | #define __DIRPATH_H_ 3 | 4 | #ifdef WIN32 5 | #define PATHSEP '\\' 6 | #define PATHSEPSTRING "\\" 7 | #define PATHLISTSEP ';' 8 | #define PATHLISTSEPSTRING ";" 9 | #define ISPATHSEP(c) ((c)=='/' || (c)=='\\') 10 | #define MAXPATHLEN 1024 11 | #else 12 | #define PATHSEP '/' 13 | #define PATHSEPSTRING "/" 14 | #define PATHLISTSEP ':' 15 | #define PATHLISTSEPSTRING ":" 16 | #define ISPATHSEP(c) ((c)=='/') 17 | #endif 18 | 19 | void get_cwd(char *buf, size_t size); 20 | int set_cwd(char *buf); 21 | char *get_exename(char *buf, size_t size); 22 | void path_to_dirname(char *path); 23 | 24 | #endif 25 | -------------------------------------------------------------------------------- /llt/dtypes.h: -------------------------------------------------------------------------------- 1 | #ifndef __DTYPES_H_ 2 | #define __DTYPES_H_ 3 | 4 | /* 5 | This file defines sane integer types for our target platforms. This 6 | library only runs on machines with the following characteristics: 7 | 8 | - supports integer word sizes of 8, 16, 32, and 64 bits 9 | - uses unsigned and signed 2's complement representations 10 | - all pointer types are the same size 11 | - there is an integer type with the same size as a pointer 12 | 13 | Some features require: 14 | - IEEE 754 single- and double-precision floating point 15 | 16 | We assume the LP64 convention for 64-bit platforms. 17 | */ 18 | 19 | 20 | #if defined(__gnu_linux__) 21 | # define LINUX 22 | #elif defined(__APPLE__) && defined(__MACH__) 23 | # define MACOSX 24 | #elif defined(__OpenBSD__) 25 | # define OPENBSD 26 | #elif defined(__FreeBSD__) 27 | # define FREEBSD 28 | #elif defined(_WIN32) 29 | # define WIN32 30 | #else 31 | # error "unknown platform" 32 | #endif 33 | 34 | #if defined(OPENBSD) || defined(FREEBSD) 35 | #if defined(__x86_64__) 36 | # define __SIZEOF_POINTER__ 8 37 | #else 38 | # define __SIZEOF_POINTER__ 4 39 | #endif 40 | #endif 41 | 42 | #if !defined (BITS32) && !defined (BITS64) 43 | #ifndef __SIZEOF_POINTER__ 44 | # error "__SIZEOF_POINTER__ undefined" 45 | #endif 46 | #if( 8 == __SIZEOF_POINTER__ ) 47 | # define BITS64 48 | #elif( 4 == __SIZEOF_POINTER__ ) 49 | # define BITS32 50 | #else 51 | # error "this is one weird machine" 52 | #endif 53 | #endif 54 | 55 | 56 | #if defined(WIN32) 57 | # define STDCALL __stdcall 58 | # if defined(IMPORT_EXPORTS) 59 | # define DLLEXPORT __declspec(dllimport) 60 | # else 61 | # define DLLEXPORT __declspec(dllexport) 62 | # endif 63 | #else 64 | # define STDCALL 65 | # define DLLEXPORT __attribute__ ((visibility("default"))) 66 | #endif 67 | 68 | #if defined(LINUX) 69 | # include 70 | # include 71 | # define LITTLE_ENDIAN __LITTLE_ENDIAN 72 | # define BIG_ENDIAN __BIG_ENDIAN 73 | # define PDP_ENDIAN __PDP_ENDIAN 74 | # define BYTE_ORDER __BYTE_ORDER 75 | #elif defined(MACOSX) || defined(OPENBSD) || defined(FREEBSD) 76 | # include 77 | # define __LITTLE_ENDIAN LITTLE_ENDIAN 78 | # define __BIG_ENDIAN BIG_ENDIAN 79 | # define __PDP_ENDIAN PDP_ENDIAN 80 | # define __BYTE_ORDER BYTE_ORDER 81 | #elif defined(WIN32) 82 | # define __LITTLE_ENDIAN 1234 83 | # define __BIG_ENDIAN 4321 84 | # define __PDP_ENDIAN 3412 85 | # define __BYTE_ORDER __LITTLE_ENDIAN 86 | # define __FLOAT_WORD_ORDER __LITTLE_ENDIAN 87 | # define LITTLE_ENDIAN __LITTLE_ENDIAN 88 | # define BIG_ENDIAN __BIG_ENDIAN 89 | # define PDP_ENDIAN __PDP_ENDIAN 90 | # define BYTE_ORDER __BYTE_ORDER 91 | #else 92 | # error "unknown platform" 93 | #endif 94 | 95 | 96 | #ifdef BOEHM_GC 97 | // boehm GC allocator 98 | #include 99 | #define LLT_ALLOC(n) GC_MALLOC(n) 100 | #define LLT_REALLOC(p,n) GC_REALLOC((p),(n)) 101 | #define LLT_FREE(x) ((void)(x)) 102 | #else 103 | // standard allocator 104 | #define LLT_ALLOC(n) malloc(n) 105 | #define LLT_REALLOC(p,n) realloc((p),(n)) 106 | #define LLT_FREE(x) free(x) 107 | #endif 108 | 109 | typedef int bool_t; 110 | 111 | #if defined(__INTEL_COMPILER) && defined(WIN32) 112 | # define STATIC_INLINE static 113 | # define INLINE 114 | # ifdef BITS64 115 | typedef unsigned long size_t; 116 | # else 117 | typedef unsigned int size_t; 118 | # endif 119 | #else 120 | # define STATIC_INLINE static inline 121 | # define INLINE inline 122 | #endif 123 | 124 | typedef unsigned char byte_t; /* 1 byte */ 125 | #if defined(WIN32) 126 | typedef short int16_t; 127 | typedef int int32_t; 128 | typedef long long int64_t; 129 | typedef unsigned char u_int8_t; 130 | typedef unsigned short u_int16_t; 131 | typedef unsigned int u_int32_t; 132 | #ifdef BITS64 133 | typedef unsigned long u_int64_t; 134 | #else 135 | typedef unsigned long long u_int64_t; 136 | #endif 137 | #ifdef __INTEL_COMPILER 138 | typedef signed char int8_t; 139 | typedef short int16_t; 140 | typedef int int32_t; 141 | #endif 142 | #else 143 | #include 144 | #endif 145 | 146 | #ifdef BITS64 147 | #define TOP_BIT 0x8000000000000000 148 | #define NBITS 64 149 | typedef unsigned long uint_t; // preferred int type on platform 150 | typedef long int_t; 151 | typedef int64_t offset_t; 152 | typedef u_int64_t index_t; 153 | typedef int64_t ptrint_t; // pointer-size int 154 | typedef u_int64_t u_ptrint_t; 155 | #else 156 | #define TOP_BIT 0x80000000 157 | #define NBITS 32 158 | typedef unsigned long uint_t; 159 | typedef long int_t; 160 | typedef int32_t offset_t; 161 | typedef u_int32_t index_t; 162 | typedef int32_t ptrint_t; 163 | typedef u_int32_t u_ptrint_t; 164 | #endif 165 | 166 | typedef u_int8_t uint8_t; 167 | typedef u_int16_t uint16_t; 168 | typedef u_int32_t uint32_t; 169 | typedef u_int64_t uint64_t; 170 | typedef u_ptrint_t uptrint_t; 171 | 172 | #define LLT_ALIGN(x, sz) (((x) + (sz-1)) & (-sz)) 173 | 174 | // branch prediction annotations 175 | #ifdef __GNUC__ 176 | #define __unlikely(x) __builtin_expect(!!(x), 0) 177 | #define __likely(x) __builtin_expect(!!(x), 1) 178 | #else 179 | #define __unlikely(x) (x) 180 | #define __likely(x) (x) 181 | #endif 182 | 183 | #define DBL_MAXINT 9007199254740992LL 184 | #define FLT_MAXINT 16777216 185 | #define U64_MAX 18446744073709551615ULL 186 | #define S64_MAX 9223372036854775807LL 187 | #define S64_MIN (-S64_MAX - 1LL) 188 | #define BIT63 0x8000000000000000LL 189 | #define U32_MAX 4294967295L 190 | #define S32_MAX 2147483647L 191 | #define S32_MIN (-S32_MAX - 1L) 192 | #define BIT31 0x80000000 193 | 194 | #define DBL_EPSILON 2.2204460492503131e-16 195 | #define FLT_EPSILON 1.192092896e-7 196 | #define DBL_MAX 1.7976931348623157e+308 197 | #define DBL_MIN 2.2250738585072014e-308 198 | #define FLT_MAX 3.402823466e+38 199 | #define FLT_MIN 1.175494351e-38 200 | #define LOG2_10 3.3219280948873626 201 | #define rel_zero(a, b) (fabs((a)/(b)) < DBL_EPSILON) 202 | #define sign_bit(r) ((*(int64_t*)&(r)) & BIT63) 203 | #define LABS(n) (((n)^((n)>>(NBITS-1))) - ((n)>>(NBITS-1))) 204 | #define NBABS(n,nb) (((n)^((n)>>((nb)-1))) - ((n)>>((nb)-1))) 205 | #define DFINITE(d) (((*(int64_t*)&(d))&0x7ff0000000000000LL)!=0x7ff0000000000000LL) 206 | #define DNAN(d) ((d)!=(d)) 207 | 208 | extern double D_PNAN; 209 | extern double D_NNAN; 210 | extern double D_PINF; 211 | extern double D_NINF; 212 | extern float F_PNAN; 213 | extern float F_NNAN; 214 | extern float F_PINF; 215 | extern float F_NINF; 216 | 217 | #endif 218 | -------------------------------------------------------------------------------- /llt/dump.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "dtypes.h" 3 | #include "ios.h" 4 | #include "utils.h" 5 | 6 | static char hexdig[] = "0123456789abcdef"; 7 | 8 | /* 9 | display a given number of bytes from a buffer, with the first 10 | address label being startoffs 11 | */ 12 | void hexdump(ios_t *dest, const char *buffer, size_t len, size_t startoffs) 13 | { 14 | size_t offs=0; 15 | size_t i, pos; 16 | char ch, linebuffer[16]; 17 | char hexc[4]; 18 | static char *spc50 = " "; 19 | 20 | hexc[2] = hexc[3] = ' '; 21 | do { 22 | ios_printf(dest, "%.8x ", offs+startoffs); 23 | pos = 10; 24 | for(i=0; i < 16 && offs < len; i++, offs++) { 25 | ch = buffer[offs]; 26 | linebuffer[i] = (ch<32 || ch>=0x7f) ? '.' : ch; 27 | hexc[0] = hexdig[((unsigned char)ch)>>4]; 28 | hexc[1] = hexdig[ch&0x0f]; 29 | pos += ios_write(dest, hexc, (i==7 || i==15) ? 4 : 3); 30 | } 31 | for(; i < 16; i++) 32 | linebuffer[i] = ' '; 33 | ios_write(dest, spc50, 60-pos); 34 | ios_putc('|', dest); 35 | ios_write(dest, linebuffer, 16); 36 | ios_write(dest, "|\n", 2); 37 | } while (offs < len); 38 | } 39 | -------------------------------------------------------------------------------- /llt/hashing.c: -------------------------------------------------------------------------------- 1 | /* 2 | Hashing 3 | */ 4 | #include 5 | #include 6 | #include 7 | #include "dtypes.h" 8 | #include "utils.h" 9 | #include "hashing.h" 10 | #include "timefuncs.h" 11 | #include "ios.h" 12 | #include "random.h" 13 | 14 | uint_t nextipow2(uint_t i) 15 | { 16 | if (i==0) return 1; 17 | if ((i&(i-1))==0) return i; 18 | if (i&TOP_BIT) return TOP_BIT; 19 | 20 | // repeatedly clear bottom bit 21 | while (i&(i-1)) 22 | i = i&(i-1); 23 | 24 | return i<<1; 25 | } 26 | 27 | u_int32_t int32hash(u_int32_t a) 28 | { 29 | a = (a+0x7ed55d16) + (a<<12); 30 | a = (a^0xc761c23c) ^ (a>>19); 31 | a = (a+0x165667b1) + (a<<5); 32 | a = (a+0xd3a2646c) ^ (a<<9); 33 | a = (a+0xfd7046c5) + (a<<3); 34 | a = (a^0xb55a4f09) ^ (a>>16); 35 | return a; 36 | } 37 | 38 | u_int64_t int64hash(u_int64_t key) 39 | { 40 | key = (~key) + (key << 21); // key = (key << 21) - key - 1; 41 | key = key ^ (key >> 24); 42 | key = (key + (key << 3)) + (key << 8); // key * 265 43 | key = key ^ (key >> 14); 44 | key = (key + (key << 2)) + (key << 4); // key * 21 45 | key = key ^ (key >> 28); 46 | key = key + (key << 31); 47 | return key; 48 | } 49 | 50 | u_int32_t int64to32hash(u_int64_t key) 51 | { 52 | key = (~key) + (key << 18); // key = (key << 18) - key - 1; 53 | key = key ^ (key >> 31); 54 | key = key * 21; // key = (key + (key << 2)) + (key << 4); 55 | key = key ^ (key >> 11); 56 | key = key + (key << 6); 57 | key = key ^ (key >> 22); 58 | return (u_int32_t)key; 59 | } 60 | 61 | #include "lookup3.c" 62 | 63 | u_int64_t memhash(const char* buf, size_t n) 64 | { 65 | u_int32_t c=0xcafe8881, b=0x4d6a087c; 66 | 67 | hashlittle2(buf, n, &c, &b); 68 | return (u_int64_t)c | (((u_int64_t)b)<<32); 69 | } 70 | 71 | u_int32_t memhash32(const char* buf, size_t n) 72 | { 73 | u_int32_t c=0xcafe8881, b=0x4d6a087c; 74 | 75 | hashlittle2(buf, n, &c, &b); 76 | return c; 77 | } 78 | -------------------------------------------------------------------------------- /llt/hashing.h: -------------------------------------------------------------------------------- 1 | #ifndef __HASHING_H_ 2 | #define __HASHING_H_ 3 | 4 | uint_t nextipow2(uint_t i); 5 | u_int32_t int32hash(u_int32_t a); 6 | u_int64_t int64hash(u_int64_t key); 7 | u_int32_t int64to32hash(u_int64_t key); 8 | #ifdef BITS64 9 | #define inthash int64hash 10 | #else 11 | #define inthash int32hash 12 | #endif 13 | u_int64_t memhash(const char* buf, size_t n); 14 | u_int32_t memhash32(const char* buf, size_t n); 15 | 16 | #endif 17 | -------------------------------------------------------------------------------- /llt/htable.c: -------------------------------------------------------------------------------- 1 | /* 2 | functions common to all hash table instantiations 3 | */ 4 | 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | 11 | #include "dtypes.h" 12 | #include "htable.h" 13 | #include "hashing.h" 14 | 15 | htable_t *htable_new(htable_t *h, size_t size) 16 | { 17 | if (size <= HT_N_INLINE/2) { 18 | h->size = size = HT_N_INLINE; 19 | h->table = &h->_space[0]; 20 | } 21 | else { 22 | size = nextipow2(size); 23 | size *= 2; // 2 pointers per key/value pair 24 | size *= 2; // aim for 50% occupancy 25 | h->size = size; 26 | h->table = (void**)LLT_ALLOC(size*sizeof(void*)); 27 | } 28 | if (h->table == NULL) return NULL; 29 | size_t i; 30 | for(i=0; i < size; i++) 31 | h->table[i] = HT_NOTFOUND; 32 | return h; 33 | } 34 | 35 | void htable_free(htable_t *h) 36 | { 37 | if (h->table != &h->_space[0]) 38 | LLT_FREE(h->table); 39 | } 40 | 41 | // empty and reduce size 42 | void htable_reset(htable_t *h, size_t sz) 43 | { 44 | sz = nextipow2(sz); 45 | if (h->size > sz*4 && h->size > HT_N_INLINE) { 46 | size_t newsz = sz*4; 47 | void **newtab = (void**)LLT_REALLOC(h->table, newsz*sizeof(void*)); 48 | if (newtab == NULL) 49 | return; 50 | h->size = newsz; 51 | h->table = newtab; 52 | } 53 | size_t i, hsz=h->size; 54 | for(i=0; i < hsz; i++) 55 | h->table[i] = HT_NOTFOUND; 56 | } 57 | -------------------------------------------------------------------------------- /llt/htable.h: -------------------------------------------------------------------------------- 1 | #ifndef __HTABLE_H_ 2 | #define __HTABLE_H_ 3 | 4 | #define HT_N_INLINE 32 5 | 6 | typedef struct { 7 | size_t size; 8 | void **table; 9 | void *_space[HT_N_INLINE]; 10 | } htable_t; 11 | 12 | // define this to be an invalid key/value 13 | #define HT_NOTFOUND ((void*)1) 14 | 15 | // initialize and free 16 | htable_t *htable_new(htable_t *h, size_t size); 17 | void htable_free(htable_t *h); 18 | 19 | // clear and (possibly) change size 20 | void htable_reset(htable_t *h, size_t sz); 21 | 22 | #endif 23 | -------------------------------------------------------------------------------- /llt/htable.inc: -------------------------------------------------------------------------------- 1 | //-*- mode:c -*- 2 | 3 | /* 4 | include this file and call HTIMPL to generate an implementation 5 | */ 6 | 7 | #define hash_size(h) ((h)->size/2) 8 | 9 | // compute empirical max-probe for a given size 10 | #define max_probe(size) ((size)<=(HT_N_INLINE*2) ? (HT_N_INLINE/2) : (size)>>3) 11 | 12 | #define HTIMPL(HTNAME, HFUNC, EQFUNC) \ 13 | static void **HTNAME##_lookup_bp(htable_t *h, void *key) \ 14 | { \ 15 | uint_t hv; \ 16 | size_t i, orig, index, iter; \ 17 | size_t newsz, sz = hash_size(h); \ 18 | size_t maxprobe = max_probe(sz); \ 19 | void **tab = h->table; \ 20 | void **ol; \ 21 | \ 22 | hv = HFUNC((uptrint_t)key); \ 23 | retry_bp: \ 24 | iter = 0; \ 25 | index = (index_t)(hv & (sz-1)) * 2; \ 26 | sz *= 2; \ 27 | orig = index; \ 28 | \ 29 | do { \ 30 | if (tab[index+1] == HT_NOTFOUND) { \ 31 | tab[index] = key; \ 32 | return &tab[index+1]; \ 33 | } \ 34 | \ 35 | if (EQFUNC(key, tab[index])) \ 36 | return &tab[index+1]; \ 37 | \ 38 | index = (index+2) & (sz-1); \ 39 | iter++; \ 40 | if (iter > maxprobe) \ 41 | break; \ 42 | } while (index != orig); \ 43 | \ 44 | /* table full */ \ 45 | /* quadruple size, rehash, retry the insert */ \ 46 | /* it's important to grow the table really fast; otherwise we waste */ \ 47 | /* lots of time rehashing all the keys over and over. */ \ 48 | sz = h->size; \ 49 | ol = h->table; \ 50 | if (sz >= (1<<19) || (sz <= (1<<8))) \ 51 | newsz = sz<<1; \ 52 | else if (sz <= HT_N_INLINE) \ 53 | newsz = HT_N_INLINE; \ 54 | else \ 55 | newsz = sz<<2; \ 56 | /*printf("trying to allocate %d words.\n", newsz); fflush(stdout);*/ \ 57 | tab = (void**)LLT_ALLOC(newsz*sizeof(void*)); \ 58 | if (tab == NULL) \ 59 | return NULL; \ 60 | for(i=0; i < newsz; i++) \ 61 | tab[i] = HT_NOTFOUND; \ 62 | h->table = tab; \ 63 | h->size = newsz; \ 64 | for(i=0; i < sz; i+=2) { \ 65 | if (ol[i+1] != HT_NOTFOUND) { \ 66 | (*HTNAME##_lookup_bp(h, ol[i])) = ol[i+1]; \ 67 | } \ 68 | } \ 69 | if (ol != &h->_space[0]) \ 70 | LLT_FREE(ol); \ 71 | \ 72 | sz = hash_size(h); \ 73 | maxprobe = max_probe(sz); \ 74 | tab = h->table; \ 75 | \ 76 | goto retry_bp; \ 77 | \ 78 | return NULL; \ 79 | } \ 80 | \ 81 | void HTNAME##_put(htable_t *h, void *key, void *val) \ 82 | { \ 83 | void **bp = HTNAME##_lookup_bp(h, key); \ 84 | \ 85 | *bp = val; \ 86 | } \ 87 | \ 88 | void **HTNAME##_bp(htable_t *h, void *key) \ 89 | { \ 90 | return HTNAME##_lookup_bp(h, key); \ 91 | } \ 92 | \ 93 | /* returns bp if key is in hash, otherwise NULL */ \ 94 | /* if return is non-NULL and *bp == HT_NOTFOUND then key was deleted */ \ 95 | static void **HTNAME##_peek_bp(htable_t *h, void *key) \ 96 | { \ 97 | size_t sz = hash_size(h); \ 98 | size_t maxprobe = max_probe(sz); \ 99 | void **tab = h->table; \ 100 | size_t index = (index_t)(HFUNC((uptrint_t)key) & (sz-1)) * 2; \ 101 | sz *= 2; \ 102 | size_t orig = index; \ 103 | size_t iter = 0; \ 104 | \ 105 | do { \ 106 | if (tab[index] == HT_NOTFOUND) \ 107 | return NULL; \ 108 | if (EQFUNC(key, tab[index])) \ 109 | return &tab[index+1]; \ 110 | \ 111 | index = (index+2) & (sz-1); \ 112 | iter++; \ 113 | if (iter > maxprobe) \ 114 | break; \ 115 | } while (index != orig); \ 116 | \ 117 | return NULL; \ 118 | } \ 119 | \ 120 | void *HTNAME##_get(htable_t *h, void *key) \ 121 | { \ 122 | void **bp = HTNAME##_peek_bp(h, key); \ 123 | if (bp == NULL) \ 124 | return HT_NOTFOUND; \ 125 | return *bp; \ 126 | } \ 127 | \ 128 | int HTNAME##_has(htable_t *h, void *key) \ 129 | { \ 130 | return (HTNAME##_get(h,key) != HT_NOTFOUND); \ 131 | } \ 132 | \ 133 | int HTNAME##_remove(htable_t *h, void *key) \ 134 | { \ 135 | void **bp = HTNAME##_peek_bp(h, key); \ 136 | if (bp != NULL) { \ 137 | *bp = HT_NOTFOUND; \ 138 | return 1; \ 139 | } \ 140 | return 0; \ 141 | } \ 142 | \ 143 | void HTNAME##_adjoin(htable_t *h, void *key, void *val) \ 144 | { \ 145 | void **bp = HTNAME##_lookup_bp(h, key); \ 146 | if (*bp == HT_NOTFOUND) \ 147 | *bp = val; \ 148 | } 149 | -------------------------------------------------------------------------------- /llt/htableh.inc: -------------------------------------------------------------------------------- 1 | //-*- mode:c -*- 2 | 3 | #include "htable.h" 4 | 5 | #define HTPROT(HTNAME) \ 6 | void *HTNAME##_get(htable_t *h, void *key); \ 7 | void HTNAME##_put(htable_t *h, void *key, void *val); \ 8 | void HTNAME##_adjoin(htable_t *h, void *key, void *val); \ 9 | int HTNAME##_has(htable_t *h, void *key); \ 10 | int HTNAME##_remove(htable_t *h, void *key); \ 11 | void **HTNAME##_bp(htable_t *h, void *key); 12 | 13 | // return value, or HT_NOTFOUND if key not found 14 | 15 | // add key/value binding 16 | 17 | // add binding iff key is unbound 18 | 19 | // does key exist? 20 | 21 | // logically remove key 22 | 23 | // get a pointer to the location of the value for the given key. 24 | // creates the location if it doesn't exist. only returns NULL 25 | // if memory allocation fails. 26 | // this should be used for updates, for example: 27 | // void **bp = ptrhash_bp(h, key); 28 | // *bp = f(*bp); 29 | // do not reuse bp if there might be intervening calls to ptrhash_put, 30 | // ptrhash_bp, ptrhash_reset, or ptrhash_free. 31 | -------------------------------------------------------------------------------- /llt/ieee754.h: -------------------------------------------------------------------------------- 1 | #ifndef __IEEE754_H_ 2 | #define __IEEE754_H_ 3 | 4 | union ieee754_float { 5 | float f; 6 | 7 | struct { 8 | #if BYTE_ORDER == BIG_ENDIAN 9 | unsigned int negative:1; 10 | unsigned int exponent:8; 11 | unsigned int mantissa:23; 12 | #endif 13 | #if BYTE_ORDER == LITTLE_ENDIAN 14 | unsigned int mantissa:23; 15 | unsigned int exponent:8; 16 | unsigned int negative:1; 17 | #endif 18 | } ieee; 19 | }; 20 | 21 | #define IEEE754_FLOAT_BIAS 0x7f 22 | 23 | union ieee754_double { 24 | double d; 25 | 26 | struct { 27 | #if BYTE_ORDER == BIG_ENDIAN 28 | unsigned int negative:1; 29 | unsigned int exponent:11; 30 | unsigned int mantissa0:20; 31 | unsigned int mantissa1:32; 32 | #endif 33 | #if BYTE_ORDER == LITTLE_ENDIAN 34 | unsigned int mantissa1:32; 35 | unsigned int mantissa0:20; 36 | unsigned int exponent:11; 37 | unsigned int negative:1; 38 | #endif 39 | } ieee; 40 | }; 41 | 42 | #define IEEE754_DOUBLE_BIAS 0x3ff 43 | 44 | union ieee854_long_double { 45 | long double d; 46 | 47 | struct { 48 | #if BYTE_ORDER == BIG_ENDIAN 49 | unsigned int negative:1; 50 | unsigned int exponent:15; 51 | unsigned int empty:16; 52 | unsigned int mantissa0:32; 53 | unsigned int mantissa1:32; 54 | #endif 55 | #if BYTE_ORDER == LITTLE_ENDIAN 56 | unsigned int mantissa1:32; 57 | unsigned int mantissa0:32; 58 | unsigned int exponent:15; 59 | unsigned int negative:1; 60 | unsigned int empty:16; 61 | #endif 62 | } ieee; 63 | }; 64 | 65 | #define IEEE854_LONG_DOUBLE_BIAS 0x3fff 66 | 67 | #endif 68 | -------------------------------------------------------------------------------- /llt/int2str.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "dtypes.h" 3 | #include "utils.h" 4 | 5 | char *uint2str(char *dest, size_t len, uint64_t num, uint32_t base) 6 | { 7 | int i = len-1; 8 | uint64_t b = (uint64_t)base; 9 | char ch; 10 | dest[i--] = '\0'; 11 | while (i >= 0) { 12 | ch = (char)(num % b); 13 | if (ch < 10) 14 | ch += '0'; 15 | else 16 | ch = ch-10+'a'; 17 | dest[i--] = ch; 18 | num /= b; 19 | if (num == 0) 20 | break; 21 | } 22 | return &dest[i+1]; 23 | } 24 | 25 | int isdigit_base(char c, int base) 26 | { 27 | if (base < 11) 28 | return (c >= '0' && c < '0'+base); 29 | return ((c >= '0' && c <= '9') || 30 | (c >= 'a' && c < 'a'+base-10) || 31 | (c >= 'A' && c < 'A'+base-10)); 32 | } 33 | 34 | /* assumes valid base, returns 1 on error, 0 if OK */ 35 | /* 36 | int str2int(char *str, size_t len, int64_t *res, uint32_t base) 37 | { 38 | int64_t result, place; 39 | char digit; 40 | int i; 41 | 42 | place = 1; result = 0; 43 | for(i=len-1; i>=0; i--) { 44 | digit = str[i]; 45 | if (!isdigit_base(digit, base)) 46 | return 1; 47 | if (digit <= '9') 48 | digit -= '0'; 49 | else if (digit >= 'a') 50 | digit = digit-'a'+10; 51 | else if (digit >= 'A') 52 | digit = digit-'A'+10; 53 | result += digit * place; 54 | place *= base; 55 | } 56 | *res = result; 57 | return 0; 58 | } 59 | */ 60 | -------------------------------------------------------------------------------- /llt/ios.h: -------------------------------------------------------------------------------- 1 | #ifndef __IOS_H_ 2 | #define __IOS_H_ 3 | 4 | #include 5 | 6 | // this flag controls when data actually moves out to the underlying I/O 7 | // channel. memory streams are a special case of this where the data 8 | // never moves out. 9 | typedef enum { bm_none, bm_line, bm_block, bm_mem } bufmode_t; 10 | 11 | typedef enum { bst_none, bst_rd, bst_wr } bufstate_t; 12 | 13 | #define IOS_INLSIZE 54 14 | #define IOS_BUFSIZE 131072 15 | 16 | typedef struct { 17 | bufmode_t bm; 18 | 19 | // the state only indicates where the underlying file position is relative 20 | // to the buffer. reading: at the end. writing: at the beginning. 21 | // in general, you can do any operation in any state. 22 | bufstate_t state; 23 | 24 | int errcode; 25 | 26 | char *buf; // start of buffer 27 | size_t maxsize; // space allocated to buffer 28 | size_t size; // length of valid data in buf, >=ndirty 29 | size_t bpos; // current position in buffer 30 | size_t ndirty; // # bytes at &buf[0] that need to be written 31 | 32 | off_t fpos; // cached file pos 33 | size_t lineno; // current line number 34 | 35 | // pointer-size integer to support platforms where it might have 36 | // to be a pointer 37 | long fd; 38 | 39 | unsigned char readonly:1; 40 | unsigned char ownbuf:1; 41 | unsigned char ownfd:1; 42 | unsigned char _eof:1; 43 | 44 | // this means you can read, seek back, then read the same data 45 | // again any number of times. usually only true for files and strings. 46 | unsigned char rereadable:1; 47 | 48 | // this enables "stenciled writes". you can alternately write and 49 | // seek without flushing in between. this performs read-before-write 50 | // to populate the buffer, so "rereadable" capability is required. 51 | // this is off by default. 52 | //unsigned char stenciled:1; 53 | 54 | // request durable writes (fsync) 55 | // unsigned char durable:1; 56 | 57 | // todo: mutex 58 | char local[IOS_INLSIZE]; 59 | } ios_t; 60 | 61 | /* low-level interface functions */ 62 | size_t ios_read(ios_t *s, char *dest, size_t n); 63 | size_t ios_readall(ios_t *s, char *dest, size_t n); 64 | size_t ios_write(ios_t *s, char *data, size_t n); 65 | off_t ios_seek(ios_t *s, off_t pos); // absolute seek 66 | off_t ios_seek_end(ios_t *s); 67 | off_t ios_skip(ios_t *s, off_t offs); // relative seek 68 | off_t ios_pos(ios_t *s); // get current position 69 | size_t ios_trunc(ios_t *s, size_t size); 70 | int ios_eof(ios_t *s); 71 | int ios_flush(ios_t *s); 72 | void ios_close(ios_t *s); 73 | char *ios_takebuf(ios_t *s, size_t *psize); // release buffer to caller 74 | // set buffer space to use 75 | int ios_setbuf(ios_t *s, char *buf, size_t size, int own); 76 | int ios_bufmode(ios_t *s, bufmode_t mode); 77 | void ios_set_readonly(ios_t *s); 78 | size_t ios_copy(ios_t *to, ios_t *from, size_t nbytes); 79 | size_t ios_copyall(ios_t *to, ios_t *from); 80 | size_t ios_copyuntil(ios_t *to, ios_t *from, char delim); 81 | // ensure at least n bytes are buffered if possible. returns # available. 82 | size_t ios_readprep(ios_t *from, size_t n); 83 | //void ios_lock(ios_t *s); 84 | //int ios_trylock(ios_t *s); 85 | //int ios_unlock(ios_t *s); 86 | 87 | /* stream creation */ 88 | ios_t *ios_file(ios_t *s, char *fname, int rd, int wr, int create, int trunc); 89 | ios_t *ios_mem(ios_t *s, size_t initsize); 90 | ios_t *ios_str(ios_t *s, char *str); 91 | ios_t *ios_static_buffer(ios_t *s, char *buf, size_t sz); 92 | ios_t *ios_fd(ios_t *s, long fd, int isfile, int own); 93 | // todo: ios_socket 94 | extern ios_t *ios_stdin; 95 | extern ios_t *ios_stdout; 96 | extern ios_t *ios_stderr; 97 | void ios_init_stdstreams(); 98 | 99 | /* high-level functions - output */ 100 | int ios_putnum(ios_t *s, char *data, uint32_t type); 101 | int ios_putint(ios_t *s, int n); 102 | int ios_pututf8(ios_t *s, uint32_t wc); 103 | int ios_putstringz(ios_t *s, char *str, bool_t do_write_nulterm); 104 | int ios_printf(ios_t *s, const char *format, ...); 105 | int ios_vprintf(ios_t *s, const char *format, va_list args); 106 | 107 | void hexdump(ios_t *dest, const char *buffer, size_t len, size_t startoffs); 108 | 109 | /* high-level stream functions - input */ 110 | int ios_getnum(ios_t *s, char *data, uint32_t type); 111 | int ios_getutf8(ios_t *s, uint32_t *pwc); 112 | int ios_peekutf8(ios_t *s, uint32_t *pwc); 113 | int ios_ungetutf8(ios_t *s, uint32_t wc); 114 | int ios_getstringz(ios_t *dest, ios_t *src); 115 | int ios_getstringn(ios_t *dest, ios_t *src, size_t nchars); 116 | int ios_getline(ios_t *s, char **pbuf, size_t *psz); 117 | char *ios_readline(ios_t *s); 118 | 119 | // discard data buffered for reading 120 | void ios_purge(ios_t *s); 121 | 122 | // seek by utf8 sequence increments 123 | int ios_nextutf8(ios_t *s); 124 | int ios_prevutf8(ios_t *s); 125 | 126 | /* stdio-style functions */ 127 | #define IOS_EOF (-1) 128 | int ios_putc(int c, ios_t *s); 129 | //wint_t ios_putwc(ios_t *s, wchar_t wc); 130 | int ios_getc(ios_t *s); 131 | int ios_peekc(ios_t *s); 132 | //wint_t ios_getwc(ios_t *s); 133 | int ios_ungetc(int c, ios_t *s); 134 | //wint_t ios_ungetwc(ios_t *s, wint_t wc); 135 | #define ios_puts(str, s) ios_write(s, str, strlen(str)) 136 | 137 | /* 138 | With memory streams, mixed reads and writes are equivalent to performing 139 | sequences of *p++, as either an lvalue or rvalue. File streams behave 140 | similarly, but other streams might not support this. Using unbuffered 141 | mode makes this more predictable. 142 | 143 | Note on "unget" functions: 144 | There are two kinds of functions here: those that operate on sized 145 | blocks of bytes and those that operate on logical units like "character" 146 | or "integer". The "unget" functions only work on logical units. There 147 | is no "unget n bytes". You can only do an unget after a matching get. 148 | However, data pushed back by an unget is available to all read operations. 149 | The reason for this is that unget is defined in terms of its effect on 150 | the underlying buffer (namely, it rebuffers data as if it had been 151 | buffered but not read yet). IOS reserves the right to perform large block 152 | operations directly, bypassing the buffer. In such a case data was 153 | never buffered, so "rebuffering" has no meaning (i.e. there is no 154 | correspondence between the buffer and the physical stream). 155 | 156 | Single-bit I/O is able to write partial bytes ONLY IF the stream supports 157 | seeking. Also, line buffering is not well-defined in the context of 158 | single-bit I/O, so it might not do what you expect. 159 | 160 | implementation notes: 161 | in order to know where we are in a file, we must ensure the buffer 162 | is only populated from the underlying stream starting with p==buf. 163 | 164 | to switch from writing to reading: flush, set p=buf, cnt=0 165 | to switch from reading to writing: seek backwards cnt bytes, p=buf, cnt=0 166 | 167 | when writing: buf starts at curr. physical stream pos, p - buf is how 168 | many bytes we've written logically. cnt==0 169 | 170 | dirty == (bitpos>0 && state==iost_wr), EXCEPT right after switching from 171 | reading to writing, where we might be in the middle of a byte without 172 | having changed it. 173 | 174 | to write a bit: if !dirty, read up to maxsize-(p-buf) into buffer, then 175 | seek back by the same amount (undo it). write onto those bits. now set 176 | the dirty bit. in this state, we can bit-read up to the end of the byte, 177 | then formally switch to the read state using flush. 178 | 179 | design points: 180 | - data-source independence, including memory streams 181 | - expose buffer to user, allow user-owned buffers 182 | - allow direct I/O, don't always go through buffer 183 | - buffer-internal seeking. makes seeking back 1-2 bytes very fast, 184 | and makes it possible for sockets where it otherwise wouldn't be 185 | - tries to allow switching between reading and writing 186 | - support 64-bit and large files 187 | - efficient, low-latency buffering 188 | - special support for utf8 189 | - type-aware functions with byte-order swapping service 190 | - position counter for meaningful data offsets with sockets 191 | 192 | theory of operation: 193 | 194 | the buffer is a view of part of a file/stream. you can seek, read, and 195 | write around in it as much as you like, as if it were just a string. 196 | 197 | we keep track of the part of the buffer that's invalid (written to). 198 | we remember whether the position of the underlying stream is aligned 199 | with the end of the buffer (reading mode) or the beginning (writing mode). 200 | 201 | based on this info, we might have to seek back before doing a flush. 202 | 203 | as optimizations, we do no writing if the buffer isn't "dirty", and we 204 | do no reading if the data will only be overwritten. 205 | */ 206 | 207 | #endif 208 | -------------------------------------------------------------------------------- /llt/llt.h: -------------------------------------------------------------------------------- 1 | #ifndef __LLT_H_ 2 | #define __LLT_H_ 3 | 4 | #include 5 | #include "dtypes.h" 6 | #include "utils.h" 7 | #include "utf8.h" 8 | #include "ios.h" 9 | #include "socket.h" 10 | #include "timefuncs.h" 11 | #include "hashing.h" 12 | #include "ptrhash.h" 13 | #include "bitvector.h" 14 | #include "dirpath.h" 15 | #include "random.h" 16 | 17 | void llt_init(); 18 | 19 | #endif 20 | -------------------------------------------------------------------------------- /llt/lltinit.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include "dtypes.h" 7 | #include "timefuncs.h" 8 | #include "ios.h" 9 | #include "random.h" 10 | #include "utf8.h" 11 | 12 | double D_PNAN; 13 | double D_NNAN; 14 | double D_PINF; 15 | double D_NINF; 16 | float F_PNAN; 17 | float F_NNAN; 18 | float F_PINF; 19 | float F_NINF; 20 | 21 | int locale_is_utf8; 22 | 23 | void llt_init() 24 | { 25 | locale_is_utf8 = u8_is_locale_utf8(setlocale(LC_ALL, "")); 26 | 27 | randomize(); 28 | 29 | ios_init_stdstreams(); 30 | 31 | D_PNAN = strtod("+NaN",NULL); 32 | D_NNAN = -strtod("+NaN",NULL); 33 | D_PINF = strtod("+Inf",NULL); 34 | D_NINF = strtod("-Inf",NULL); 35 | F_PNAN = strtof("+NaN",NULL); 36 | F_NNAN = -strtof("+NaN",NULL); 37 | F_PINF = strtof("+Inf",NULL); 38 | F_NINF = strtof("-Inf",NULL); 39 | } 40 | -------------------------------------------------------------------------------- /llt/mt19937ar.c: -------------------------------------------------------------------------------- 1 | /* 2 | A C-program for MT19937, with initialization improved 2002/1/26. 3 | Coded by Takuji Nishimura and Makoto Matsumoto. 4 | 5 | Before using, initialize the state by using init_genrand(seed) 6 | or init_by_array(init_key, key_length). 7 | 8 | Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura, 9 | All rights reserved. 10 | 11 | Redistribution and use in source and binary forms, with or without 12 | modification, are permitted provided that the following conditions 13 | are met: 14 | 15 | 1. Redistributions of source code must retain the above copyright 16 | notice, this list of conditions and the following disclaimer. 17 | 18 | 2. Redistributions in binary form must reproduce the above copyright 19 | notice, this list of conditions and the following disclaimer in the 20 | documentation and/or other materials provided with the distribution. 21 | 22 | 3. The names of its contributors may not be used to endorse or promote 23 | products derived from this software without specific prior written 24 | permission. 25 | 26 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 27 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 28 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 29 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 30 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 31 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 32 | PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 33 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 34 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 35 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 36 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 37 | 38 | 39 | Any feedback is very welcome. 40 | http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html 41 | email: m-mat @ math.sci.hiroshima-u.ac.jp (remove space) 42 | */ 43 | 44 | #include 45 | 46 | /* Period parameters */ 47 | #define mtN 624 48 | #define mtM 397 49 | #define MATRIX_A 0x9908b0dfU /* constant vector a */ 50 | #define UPPER_MASK 0x80000000U /* most significant w-r bits */ 51 | #define LOWER_MASK 0x7fffffffU /* least significant r bits */ 52 | 53 | static uint32_t mt[mtN]; /* the array for the state vector */ 54 | static int mti=mtN+1; /* mti==mtN+1 means mt[mtN] is not initialized */ 55 | 56 | /* initializes mt[mtN] with a seed */ 57 | void init_genrand(uint32_t s) 58 | { 59 | mt[0]= s & 0xffffffffU; 60 | for (mti=1; mti> 30)) + mti); 63 | /* See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. */ 64 | /* In the previous versions, MSBs of the seed affect */ 65 | /* only MSBs of the array mt[]. */ 66 | /* 2002/01/09 modified by Makoto Matsumoto */ 67 | mt[mti] &= 0xffffffffU; 68 | /* for >32 bit machines */ 69 | } 70 | } 71 | 72 | /* initialize by an array with array-length */ 73 | /* init_key is the array for initializing keys */ 74 | /* key_length is its length */ 75 | /* slight change for C++, 2004/2/26 */ 76 | void init_by_array(uint32_t init_key[], int key_length) 77 | { 78 | int i, j, k; 79 | init_genrand(19650218U); 80 | i=1; j=0; 81 | k = (mtN>key_length ? mtN : key_length); 82 | for (; k; k--) { 83 | mt[i] = (mt[i] ^ ((mt[i-1] ^ (mt[i-1] >> 30)) * 1664525U)) 84 | + init_key[j] + j; /* non linear */ 85 | mt[i] &= 0xffffffffU; /* for WORDSIZE > 32 machines */ 86 | i++; j++; 87 | if (i>=mtN) { mt[0] = mt[mtN-1]; i=1; } 88 | if (j>=key_length) j=0; 89 | } 90 | for (k=mtN-1; k; k--) { 91 | mt[i] = (mt[i] ^ ((mt[i-1] ^ (mt[i-1] >> 30)) * 1566083941U)) 92 | - i; /* non linear */ 93 | mt[i] &= 0xffffffffU; /* for WORDSIZE > 32 machines */ 94 | i++; 95 | if (i>=mtN) { mt[0] = mt[mtN-1]; i=1; } 96 | } 97 | 98 | mt[0] = 0x80000000U; /* MSB is 1; assuring non-zero initial array */ 99 | } 100 | 101 | /* generates a random number on [0,0xffffffff]-interval */ 102 | uint32_t genrand_int32(void) 103 | { 104 | uint32_t y; 105 | static uint32_t mag01[2]={0x0U, MATRIX_A}; 106 | /* mag01[x] = x * MATRIX_A for x=0,1 */ 107 | 108 | if (mti >= mtN) { /* generate mtN words at one time */ 109 | int kk; 110 | 111 | if (mti == mtN+1) /* if init_genrand() has not been called, */ 112 | init_genrand(5489U); /* a default initial seed is used */ 113 | 114 | for (kk=0;kk> 1) ^ mag01[y & 0x1U]; 117 | } 118 | for (;kk> 1) ^ mag01[y & 0x1U]; 121 | } 122 | y = (mt[mtN-1]&UPPER_MASK)|(mt[0]&LOWER_MASK); 123 | mt[mtN-1] = mt[mtM-1] ^ (y >> 1) ^ mag01[y & 0x1U]; 124 | 125 | mti = 0; 126 | } 127 | 128 | y = mt[mti++]; 129 | 130 | /* Tempering */ 131 | y ^= (y >> 11); 132 | y ^= (y << 7) & 0x9d2c5680U; 133 | y ^= (y << 15) & 0xefc60000U; 134 | y ^= (y >> 18); 135 | 136 | return y; 137 | } 138 | 139 | #if 0 140 | /* generates a random number on [0,0x7fffffff]-interval */ 141 | long genrand_int31(void) 142 | { 143 | return (long)(genrand_int32()>>1); 144 | } 145 | 146 | /* generates a random number on [0,1]-real-interval */ 147 | double genrand_real1(void) 148 | { 149 | return genrand_int32()*(1.0/4294967295.0); 150 | /* divided by 2^32-1 */ 151 | } 152 | 153 | /* generates a random number on [0,1)-real-interval */ 154 | double genrand_real2(void) 155 | { 156 | return genrand_int32()*(1.0/4294967296.0); 157 | /* divided by 2^32 */ 158 | } 159 | 160 | /* generates a random number on (0,1)-real-interval */ 161 | double genrand_real3(void) 162 | { 163 | return (((double)genrand_int32()) + 0.5)*(1.0/4294967296.0); 164 | /* divided by 2^32 */ 165 | } 166 | 167 | /* generates a random number on [0,1) with 53-bit resolution*/ 168 | double genrand_res53(void) 169 | { 170 | uint32_t a=genrand_int32()>>5, b=genrand_int32()>>6; 171 | return(a*67108864.0+b)*(1.0/9007199254740992.0); 172 | } 173 | #endif 174 | /* These real versions are due to Isaku Wada, 2002/01/09 added */ 175 | #if 0 176 | int main(void) 177 | { 178 | int i; 179 | uint32_t init[4]={0x123, 0x234, 0x345, 0x456}, length=4; 180 | init_by_array(init, length); 181 | printf("1000 outputs of genrand_int32()\n"); 182 | for (i=0; i<1000; i++) { 183 | printf("%10lu ", genrand_int32()); 184 | if (i%5==4) printf("\n"); 185 | } 186 | printf("\n1000 outputs of genrand_real2()\n"); 187 | for (i=0; i<1000; i++) { 188 | printf("%10.8f ", genrand_real2()); 189 | if (i%5==4) printf("\n"); 190 | } 191 | return 0; 192 | } 193 | #endif 194 | -------------------------------------------------------------------------------- /llt/ptrhash.c: -------------------------------------------------------------------------------- 1 | /* 2 | pointer hash table 3 | optimized for storing info about particular values 4 | */ 5 | 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | 12 | #include "dtypes.h" 13 | #include "ptrhash.h" 14 | 15 | #define OP_EQ(x,y) ((x)==(y)) 16 | 17 | #ifdef BITS64 18 | static u_int64_t _pinthash(u_int64_t key) 19 | { 20 | key = (~key) + (key << 21); // key = (key << 21) - key - 1; 21 | key = key ^ (key >> 24); 22 | key = (key + (key << 3)) + (key << 8); // key * 265 23 | key = key ^ (key >> 14); 24 | key = (key + (key << 2)) + (key << 4); // key * 21 25 | key = key ^ (key >> 28); 26 | key = key + (key << 31); 27 | return key; 28 | } 29 | #else 30 | static u_int32_t _pinthash(u_int32_t a) 31 | { 32 | a = (a+0x7ed55d16) + (a<<12); 33 | a = (a^0xc761c23c) ^ (a>>19); 34 | a = (a+0x165667b1) + (a<<5); 35 | a = (a+0xd3a2646c) ^ (a<<9); 36 | a = (a+0xfd7046c5) + (a<<3); 37 | a = (a^0xb55a4f09) ^ (a>>16); 38 | return a; 39 | } 40 | #endif 41 | 42 | #include "htable.inc" 43 | 44 | HTIMPL(ptrhash, _pinthash, OP_EQ) 45 | -------------------------------------------------------------------------------- /llt/ptrhash.h: -------------------------------------------------------------------------------- 1 | #ifndef __PTRHASH_H_ 2 | #define __PTRHASH_H_ 3 | 4 | #include "htableh.inc" 5 | 6 | HTPROT(ptrhash) 7 | 8 | #endif 9 | -------------------------------------------------------------------------------- /llt/random.c: -------------------------------------------------------------------------------- 1 | /* 2 | random numbers 3 | */ 4 | #include 5 | #include 6 | #include 7 | #include "dtypes.h" 8 | #include "ieee754.h" 9 | #include "utils.h" 10 | #include "random.h" 11 | #include "timefuncs.h" 12 | 13 | #include "mt19937ar.c" 14 | 15 | double rand_double() 16 | { 17 | union ieee754_double d; 18 | 19 | d.ieee.mantissa0 = genrand_int32(); 20 | d.ieee.mantissa1 = genrand_int32(); 21 | d.ieee.negative = 0; 22 | d.ieee.exponent = IEEE754_DOUBLE_BIAS + 0; /* 2^0 */ 23 | return d.d - 1.0; 24 | } 25 | 26 | float rand_float() 27 | { 28 | union ieee754_float f; 29 | 30 | f.ieee.mantissa = genrand_int32(); 31 | f.ieee.negative = 0; 32 | f.ieee.exponent = IEEE754_FLOAT_BIAS + 0; /* 2^0 */ 33 | return f.f - 1.0; 34 | } 35 | 36 | double randn() 37 | { 38 | double s, vre, vim, ure, uim; 39 | static double next = -42; 40 | 41 | if (next != -42) { 42 | s = next; 43 | next = -42; 44 | return s; 45 | } 46 | do { 47 | ure = rand_double(); 48 | uim = rand_double(); 49 | vre = 2*ure - 1; 50 | vim = 2*uim - 1; 51 | s = vre*vre + vim*vim; 52 | } while (s >= 1); 53 | s = sqrt(-2*log(s)/s); 54 | next = s * vre; 55 | return s * vim; 56 | } 57 | 58 | void randomize() 59 | { 60 | u_int64_t tm = i64time(); 61 | init_by_array((uint32_t*)&tm, 2); 62 | } 63 | -------------------------------------------------------------------------------- /llt/random.h: -------------------------------------------------------------------------------- 1 | #ifndef __LLTRANDOM_H_ 2 | #define __LLTRANDOM_H_ 3 | 4 | #define random() genrand_int32() 5 | #define srandom(n) init_genrand(n) 6 | double rand_double(); 7 | float rand_float(); 8 | double randn(); 9 | void randomize(); 10 | uint32_t genrand_int32(); 11 | void init_genrand(uint32_t s); 12 | u_int64_t i64time(); 13 | 14 | #endif 15 | -------------------------------------------------------------------------------- /llt/socket.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | #include "dtypes.h" 9 | 10 | #if defined(MACOSX) 11 | #include 12 | #include 13 | #include 14 | #endif 15 | 16 | #include "socket.h" 17 | 18 | 19 | int mysocket(int domain, int type, int protocol) 20 | { 21 | int val; 22 | int s = socket(domain, type, protocol); 23 | if (s < 0) 24 | return s; 25 | val = 4096; 26 | setsockopt(s, SOL_SOCKET, SO_RCVBUF, (char*)&val, sizeof(int)); 27 | val = 4096; 28 | setsockopt(s, SOL_SOCKET, SO_SNDBUF, (char*)&val, sizeof(int)); 29 | return s; 30 | } 31 | 32 | void set_nonblock(int socket, int yes) 33 | { 34 | int flags; 35 | flags = fcntl(socket,F_GETFL,0); 36 | assert(flags != -1); 37 | if (yes) 38 | fcntl(socket, F_SETFL, flags | O_NONBLOCK); 39 | else 40 | fcntl(socket, F_SETFL, flags & ~O_NONBLOCK); 41 | } 42 | 43 | #ifdef WIN32 44 | void bzero(void *s, size_t n) 45 | { 46 | memset(s, 0, n); 47 | } 48 | #endif 49 | 50 | /* returns a socket on which to accept() connections */ 51 | int open_tcp_port(short portno) 52 | { 53 | int sockfd; 54 | struct sockaddr_in serv_addr; 55 | 56 | sockfd = mysocket(PF_INET, SOCK_STREAM, IPPROTO_TCP); 57 | if (sockfd < 0) 58 | return -1; 59 | bzero(&serv_addr, sizeof(serv_addr)); 60 | serv_addr.sin_family = AF_INET; 61 | serv_addr.sin_addr.s_addr = htonl(INADDR_ANY); 62 | serv_addr.sin_port = htons(portno); 63 | if (bind(sockfd, (struct sockaddr*)&serv_addr, sizeof(serv_addr)) < 0) { 64 | return -1; 65 | } 66 | 67 | listen(sockfd, 4); 68 | return sockfd; 69 | } 70 | 71 | /* returns a socket on which to accept() connections, finding some 72 | available port (portno is value-return) */ 73 | int open_any_tcp_port(short *portno) 74 | 75 | { 76 | int sockfd; 77 | struct sockaddr_in serv_addr; 78 | 79 | sockfd = mysocket(PF_INET, SOCK_STREAM, IPPROTO_TCP); 80 | if (sockfd < 0) 81 | return -1; 82 | bzero(&serv_addr, sizeof(serv_addr)); 83 | serv_addr.sin_family = AF_INET; 84 | serv_addr.sin_addr.s_addr = htonl(INADDR_ANY); 85 | serv_addr.sin_port = htons(*portno); 86 | while (bind(sockfd, (struct sockaddr*)&serv_addr, sizeof(serv_addr)) < 0) { 87 | (*portno)++; 88 | serv_addr.sin_port = htons(*portno); 89 | } 90 | 91 | listen(sockfd, 4); 92 | return sockfd; 93 | } 94 | 95 | /* returns a socket on which to accept() connections, finding some 96 | available port (portno is value-return) */ 97 | int open_any_udp_port(short *portno) 98 | { 99 | int sockfd; 100 | struct sockaddr_in serv_addr; 101 | 102 | sockfd = mysocket(PF_INET, SOCK_DGRAM, 0); 103 | if (sockfd < 0) 104 | return -1; 105 | bzero(&serv_addr, sizeof(serv_addr)); 106 | serv_addr.sin_family = AF_INET; 107 | serv_addr.sin_addr.s_addr = htonl(INADDR_ANY); 108 | serv_addr.sin_port = htons(*portno); 109 | while (bind(sockfd, (struct sockaddr*)&serv_addr, sizeof(serv_addr)) < 0) { 110 | (*portno)++; 111 | serv_addr.sin_port = htons(*portno); 112 | } 113 | 114 | return sockfd; 115 | } 116 | 117 | #ifndef WIN32 118 | void closesocket(int fd) 119 | { 120 | close(fd); 121 | } 122 | #endif 123 | 124 | /* returns a socket to use to send data to the given address */ 125 | int connect_to_host(char *hostname, short portno) 126 | { 127 | struct hostent *host_info; 128 | int sockfd, yes=1; 129 | struct sockaddr_in host_addr; 130 | 131 | host_info = gethostbyname(hostname); 132 | if (host_info == NULL) { 133 | return -1; 134 | } 135 | 136 | sockfd = mysocket(AF_INET, SOCK_STREAM, IPPROTO_TCP); 137 | if (sockfd < 0) { 138 | return -1; 139 | } 140 | (void)setsockopt(sockfd, SOL_SOCKET, SO_REUSEADDR, &yes, sizeof(int)); 141 | memset((char*)&host_addr, 0, sizeof(host_addr)); 142 | host_addr.sin_family = host_info->h_addrtype; 143 | memcpy((char*)&host_addr.sin_addr, host_info->h_addr, 144 | host_info->h_length); 145 | 146 | host_addr.sin_port = htons(portno); 147 | 148 | if (connect(sockfd, (struct sockaddr*)&host_addr, 149 | sizeof(struct sockaddr_in)) != 0) { 150 | closesocket(sockfd); 151 | return -1; 152 | } 153 | 154 | return sockfd; 155 | } 156 | 157 | int connect_to_addr(struct sockaddr_in *host_addr) 158 | { 159 | int sockfd, yes=1; 160 | 161 | sockfd = mysocket(AF_INET, SOCK_STREAM, IPPROTO_TCP); 162 | if (sockfd < 0) { 163 | return -1; 164 | } 165 | (void)setsockopt(sockfd, SOL_SOCKET, SO_REUSEADDR, &yes, sizeof(int)); 166 | 167 | if (connect(sockfd, (struct sockaddr*)host_addr, 168 | sizeof(struct sockaddr_in)) != 0) { 169 | closesocket(sockfd); 170 | return -1; 171 | } 172 | 173 | return sockfd; 174 | } 175 | 176 | /* repeated send until all of buffer is sent */ 177 | int sendall(int sockfd, char *buffer, int bufLen, int flags) 178 | { 179 | int numBytesToSend=bufLen, length; 180 | 181 | while (numBytesToSend>0) { 182 | length = send(sockfd, (void *) buffer, numBytesToSend, flags); 183 | if (length < 0) { 184 | return(-1); 185 | } 186 | numBytesToSend -= length ; 187 | buffer += length ; 188 | } 189 | return(bufLen); 190 | } 191 | 192 | /* repeated read until all of buffer is read */ 193 | int readall(int sockfd, char *buffer, int bufLen, int flags) 194 | { 195 | int numBytesToRead=bufLen, length; 196 | 197 | while (numBytesToRead>0) { 198 | length = recv(sockfd, buffer, numBytesToRead, flags); 199 | if (length <= 0) { 200 | return(length); 201 | } 202 | numBytesToRead -= length; 203 | buffer += length; 204 | } 205 | return(bufLen); 206 | } 207 | 208 | int addr_eq(struct sockaddr_in *a, struct sockaddr_in *b) 209 | { 210 | if (a->sin_port == b->sin_port && 211 | a->sin_addr.s_addr == b->sin_addr.s_addr) 212 | return 1; 213 | return 0; 214 | } 215 | 216 | int socket_ready(int sock) 217 | { 218 | fd_set fds; 219 | struct timeval timeout; 220 | 221 | timeout.tv_sec = 0; 222 | timeout.tv_usec = 1000; 223 | 224 | FD_ZERO(&fds); 225 | FD_SET(sock, &fds); 226 | select(sock+1, &fds, NULL, NULL, &timeout); 227 | return FD_ISSET(sock, &fds); 228 | } 229 | -------------------------------------------------------------------------------- /llt/socket.h: -------------------------------------------------------------------------------- 1 | #ifndef __LLTSOCKET_H_ 2 | #define __LLTSOCKET_H_ 3 | 4 | #ifdef WIN32 5 | #include 6 | #else 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #endif 13 | 14 | int open_tcp_port(short portno); 15 | int open_any_tcp_port(short *portno); 16 | int open_any_udp_port(short *portno); 17 | int connect_to_host(char *hostname, short portno); 18 | int connect_to_addr(struct sockaddr_in *host_addr); 19 | int sendall(int sockfd, char *buffer, int bufLen, int flags); 20 | int readall(int sockfd, char *buffer, int bufLen, int flags); 21 | int addr_eq(struct sockaddr_in *a, struct sockaddr_in *b); 22 | int socket_ready(int sock); 23 | 24 | #ifdef WIN32 25 | void bzero(void *s, size_t n); 26 | #endif 27 | #ifndef WIN32 28 | void closesocket(int fd); 29 | #endif 30 | 31 | #endif 32 | -------------------------------------------------------------------------------- /llt/timefuncs.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | 11 | #include "dtypes.h" 12 | 13 | #ifdef WIN32 14 | #include 15 | #include 16 | #include 17 | #else 18 | #include 19 | #include 20 | #include 21 | #endif 22 | 23 | #include "timefuncs.h" 24 | 25 | #ifdef WIN32 26 | /* 27 | double tvals2float(struct tm *t, struct timeb *tstruct) 28 | { 29 | return (double)t->tm_hour * 3600 + (double)t->tm_min * 60 + 30 | (double)t->tm_sec + (double)tstruct->millitm/1.0e3; 31 | } 32 | */ 33 | double floattime() 34 | { 35 | struct timeb tstruct; 36 | 37 | ftime(&tstruct); 38 | return (double)tstruct.time + (double)tstruct.millitm/1.0e3; 39 | } 40 | #else 41 | double tv2float(struct timeval *tv) 42 | { 43 | return (double)tv->tv_sec + (double)tv->tv_usec/1.0e6; 44 | } 45 | 46 | double diff_time(struct timeval *tv1, struct timeval *tv2) 47 | { 48 | return tv2float(tv1) - tv2float(tv2); 49 | } 50 | #endif 51 | 52 | // return as many bits of system randomness as we can get our hands on 53 | u_int64_t i64time() 54 | { 55 | u_int64_t a; 56 | #ifdef WIN32 57 | struct timeb tstruct; 58 | ftime(&tstruct); 59 | a = (((u_int64_t)tstruct.time)<<32) + (u_int64_t)tstruct.millitm; 60 | #else 61 | struct timeval now; 62 | gettimeofday(&now, NULL); 63 | a = (((u_int64_t)now.tv_sec)<<32) + (u_int64_t)now.tv_usec; 64 | #endif 65 | 66 | return a; 67 | } 68 | 69 | double clock_now() 70 | { 71 | #ifdef WIN32 72 | return floattime(); 73 | #else 74 | struct timeval now; 75 | 76 | gettimeofday(&now, NULL); 77 | return tv2float(&now); 78 | #endif 79 | } 80 | 81 | void timestring(double seconds, char *buffer, size_t len) 82 | { 83 | time_t tme = (time_t)seconds; 84 | 85 | #if defined(LINUX) || defined(MACOSX) || defined(OPENBSD) || defined(FREEBSD) 86 | char *fmt = "%c"; /* needed to suppress GCC warning */ 87 | struct tm tm; 88 | 89 | localtime_r(&tme, &tm); 90 | strftime(buffer, len, fmt, &tm); 91 | #else 92 | static char *wdaystr[] = {"Sun","Mon","Tue","Wed","Thu","Fri","Sat"}; 93 | static char *monthstr[] = {"Jan","Feb","Mar","Apr","May","Jun","Jul","Aug", 94 | "Sep","Oct","Nov","Dec"}; 95 | struct tm *tm; 96 | int hr; 97 | 98 | tm = localtime(&tme); 99 | hr = tm->tm_hour; 100 | if (hr > 12) hr -= 12; 101 | if (hr == 0) hr = 12; 102 | snprintf(buffer, len, "%s %02d %s %d %02d:%02d:%02d %s %s", 103 | wdaystr[tm->tm_wday], tm->tm_mday, monthstr[tm->tm_mon], 104 | tm->tm_year+1900, hr, tm->tm_min, tm->tm_sec, 105 | tm->tm_hour>11 ? "PM" : "AM", ""); 106 | #endif 107 | } 108 | 109 | #if defined(LINUX) || defined(MACOSX) || defined(OPENBSD) || defined(FREEBSD) 110 | extern char *strptime(const char *s, const char *format, struct tm *tm); 111 | double parsetime(const char *str) 112 | { 113 | char *fmt = "%c"; /* needed to suppress GCC warning */ 114 | char *res; 115 | time_t t; 116 | struct tm tm; 117 | 118 | res = strptime(str, fmt, &tm); 119 | if (res != NULL) { 120 | tm.tm_isdst = -1; /* Not set by strptime(); tells mktime() to determine 121 | whether daylight saving time is in effect */ 122 | t = mktime(&tm); 123 | if (t == ((time_t)-1)) 124 | return -1; 125 | return (double)t; 126 | } 127 | return -1; 128 | } 129 | #else 130 | // TODO 131 | #endif 132 | 133 | void sleep_ms(int ms) 134 | { 135 | if (ms == 0) 136 | return; 137 | 138 | #ifdef WIN32 139 | Sleep(ms); 140 | #else 141 | struct timeval timeout; 142 | 143 | timeout.tv_sec = ms/1000; 144 | timeout.tv_usec = (ms % 1000) * 1000; 145 | select(0, NULL, NULL, NULL, &timeout); 146 | #endif 147 | } 148 | 149 | void timeparts(int32_t *buf, double t) 150 | { 151 | time_t tme = (time_t)t; 152 | 153 | #ifndef WIN32 154 | struct tm tm; 155 | localtime_r(&tme, &tm); 156 | tm.tm_year += 1900; 157 | memcpy(buf, (char*)&tm, sizeof(struct tm)); 158 | #else 159 | struct tm *tm; 160 | 161 | tm = localtime(&tme); 162 | tm->tm_year += 1900; 163 | memcpy(buf, (char*)tm, sizeof(struct tm)); 164 | #endif 165 | } 166 | -------------------------------------------------------------------------------- /llt/timefuncs.h: -------------------------------------------------------------------------------- 1 | #ifndef __TIMEFUNCS_H_ 2 | #define __TIMEFUNCS_H_ 3 | 4 | u_int64_t i64time(); 5 | double clock_now(); 6 | void timestring(double seconds, char *buffer, size_t len); 7 | double parsetime(const char *str); 8 | void sleep_ms(int ms); 9 | void timeparts(int32_t *buf, double t); 10 | 11 | #endif 12 | -------------------------------------------------------------------------------- /llt/utf8.h: -------------------------------------------------------------------------------- 1 | #ifndef __UTF8_H_ 2 | #define __UTF8_H_ 3 | 4 | #if !defined(MACOSX) 5 | #if !defined(__DTYPES_H_) && !defined(_SYS_TYPES_H) 6 | typedef char int8_t; 7 | typedef short int16_t; 8 | typedef int int32_t; 9 | typedef long long int64_t; 10 | typedef unsigned char u_int8_t; 11 | typedef unsigned short u_int16_t; 12 | typedef unsigned int u_int32_t; 13 | typedef unsigned long long u_int64_t; 14 | #endif 15 | #endif 16 | 17 | extern int locale_is_utf8; 18 | 19 | #if defined(__WIN32__) 20 | extern int wcwidth(uint32_t); 21 | #endif 22 | 23 | /* is c the start of a utf8 sequence? */ 24 | #define isutf(c) (((c)&0xC0)!=0x80) 25 | 26 | #define UEOF ((u_int32_t)-1) 27 | 28 | /* convert UTF-8 data to wide character */ 29 | size_t u8_toucs(u_int32_t *dest, size_t sz, const char *src, size_t srcsz); 30 | 31 | /* the opposite conversion */ 32 | size_t u8_toutf8(char *dest, size_t sz, const u_int32_t *src, size_t srcsz); 33 | 34 | /* single character to UTF-8, returns # bytes written */ 35 | size_t u8_wc_toutf8(char *dest, u_int32_t ch); 36 | 37 | /* character number to byte offset */ 38 | size_t u8_offset(const char *str, size_t charnum); 39 | 40 | /* byte offset to character number */ 41 | size_t u8_charnum(const char *s, size_t offset); 42 | 43 | /* return next character, updating an index variable */ 44 | u_int32_t u8_nextchar(const char *s, size_t *i); 45 | 46 | /* next character without NUL character terminator */ 47 | u_int32_t u8_nextmemchar(const char *s, size_t *i); 48 | 49 | /* move to next character */ 50 | void u8_inc(const char *s, size_t *i); 51 | 52 | /* move to previous character */ 53 | void u8_dec(const char *s, size_t *i); 54 | 55 | /* returns length of next utf-8 sequence */ 56 | size_t u8_seqlen(const char *s); 57 | 58 | /* returns the # of bytes needed to encode a certain character */ 59 | size_t u8_charlen(u_int32_t ch); 60 | 61 | /* computes the # of bytes needed to encode a WC string as UTF-8 */ 62 | size_t u8_codingsize(u_int32_t *wcstr, size_t n); 63 | 64 | char read_escape_control_char(char c); 65 | 66 | /* assuming src points to the character after a backslash, read an 67 | escape sequence, storing the result in dest and returning the number of 68 | input characters processed */ 69 | size_t u8_read_escape_sequence(const char *src, size_t ssz, u_int32_t *dest); 70 | 71 | /* given a wide character, convert it to an ASCII escape sequence stored in 72 | buf, where buf is "sz" bytes. returns the number of characters output. 73 | sz must be at least 3. */ 74 | int u8_escape_wchar(char *buf, size_t sz, u_int32_t ch); 75 | 76 | /* convert a string "src" containing escape sequences to UTF-8 */ 77 | size_t u8_unescape(char *buf, size_t sz, const char *src); 78 | 79 | /* convert UTF-8 "src" to escape sequences. 80 | 81 | sz is buf size in bytes. must be at least 12. 82 | 83 | if escape_quotes is nonzero, quote characters will be escaped. 84 | 85 | if ascii is nonzero, the output is 7-bit ASCII, no UTF-8 survives. 86 | 87 | starts at src[*pi], updates *pi to point to the first unprocessed 88 | byte of the input. 89 | 90 | end is one more than the last allowable value of *pi. 91 | 92 | returns number of bytes placed in buf, including a NUL terminator. 93 | */ 94 | size_t u8_escape(char *buf, size_t sz, const char *src, size_t *pi, size_t end, 95 | int escape_quotes, int ascii); 96 | 97 | /* utility predicates used by the above */ 98 | int octal_digit(char c); 99 | int hex_digit(char c); 100 | 101 | /* return a pointer to the first occurrence of ch in s, or NULL if not 102 | found. character index of found character returned in *charn. */ 103 | char *u8_strchr(const char *s, u_int32_t ch, size_t *charn); 104 | 105 | /* same as the above, but searches a buffer of a given size instead of 106 | a NUL-terminated string. */ 107 | char *u8_memchr(const char *s, u_int32_t ch, size_t sz, size_t *charn); 108 | 109 | char *u8_memrchr(const char *s, u_int32_t ch, size_t sz); 110 | 111 | /* count the number of characters in a UTF-8 string */ 112 | size_t u8_strlen(const char *s); 113 | 114 | /* number of columns occupied by a string */ 115 | size_t u8_strwidth(const char *s); 116 | 117 | int u8_is_locale_utf8(const char *locale); 118 | 119 | /* printf where the format string and arguments may be in UTF-8. 120 | you can avoid this function and just use ordinary printf() if the current 121 | locale is UTF-8. */ 122 | size_t u8_vprintf(const char *fmt, va_list ap); 123 | size_t u8_printf(const char *fmt, ...); 124 | 125 | /* determine whether a sequence of bytes is valid UTF-8. length is in bytes */ 126 | int u8_isvalid(const char *str, int length); 127 | 128 | /* reverse a UTF-8 string. len is length in bytes. dest and src must both 129 | be allocated to at least len+1 bytes. returns 1 for error, 0 otherwise */ 130 | int u8_reverse(char *dest, char *src, size_t len); 131 | 132 | #endif 133 | -------------------------------------------------------------------------------- /llt/utils.h: -------------------------------------------------------------------------------- 1 | #ifndef __UTILS_H_ 2 | #define __UTILS_H_ 3 | 4 | 5 | #if defined( __amd64__ ) || defined( _M_AMD64 ) 6 | # define ARCH_X86_64 7 | # define __CPU__ 686 8 | #elif defined( _M_IX86 )//msvs, intel, digital mars, watcom 9 | # if ! defined( __386__ ) 10 | # error "unsupported target: 16-bit x86" 11 | # endif 12 | # define ARCH_X86 13 | # define __CPU__ ( _M_IX86 + 86 ) 14 | #elif defined( __i686__ )//gnu c 15 | # define ARCH_X86 16 | # define __CPU__ 686 17 | #elif defined( __i586__ )//gnu c 18 | # define ARCH_X86 19 | # define __CPU__ 586 20 | #elif defined( __i486__ )//gnu c 21 | # define ARCH_X86 22 | # define __CPU__ 486 23 | #elif defined( __i386__ )//gnu c 24 | # define ARCH_X86 25 | # define __CPU__ 386 26 | #else 27 | # error "unknown architecture" 28 | #endif 29 | 30 | 31 | char *uint2str(char *dest, size_t len, uint64_t num, uint32_t base); 32 | int str2int(char *str, size_t len, int64_t *res, uint32_t base); 33 | int isdigit_base(char c, int base); 34 | 35 | #ifdef ARCH_X86_64 36 | # define LEGACY_REGS "=Q" 37 | #else 38 | # define LEGACY_REGS "=q" 39 | #endif 40 | 41 | #if !defined(__INTEL_COMPILER) && (defined(ARCH_X86) || defined(ARCH_X86_64)) 42 | STATIC_INLINE u_int16_t ByteSwap16(u_int16_t x) 43 | { 44 | __asm("xchgb %b0,%h0" : 45 | LEGACY_REGS (x) : 46 | "0" (x)); 47 | return x; 48 | } 49 | #define bswap_16(x) ByteSwap16(x) 50 | 51 | STATIC_INLINE u_int32_t ByteSwap32(u_int32_t x) 52 | { 53 | #if __CPU__ > 386 54 | __asm("bswap %0": 55 | "=r" (x) : 56 | #else 57 | __asm("xchgb %b0,%h0\n"\ 58 | " rorl $16,%0\n" 59 | " xchgb %b0,%h0": 60 | LEGACY_REGS (x) : 61 | #endif 62 | "0" (x)); 63 | return x; 64 | } 65 | 66 | #define bswap_32(x) ByteSwap32(x) 67 | 68 | STATIC_INLINE u_int64_t ByteSwap64(u_int64_t x) 69 | { 70 | #ifdef ARCH_X86_64 71 | __asm("bswap %0": 72 | "=r" (x) : 73 | "0" (x)); 74 | return x; 75 | #else 76 | register union { __extension__ u_int64_t __ll; 77 | u_int32_t __l[2]; } __x; 78 | asm("xchgl %0,%1": 79 | "=r"(__x.__l[0]),"=r"(__x.__l[1]): 80 | "0"(bswap_32((unsigned long)x)),"1"(bswap_32((unsigned long)(x>>32)))); 81 | return __x.__ll; 82 | #endif 83 | } 84 | #define bswap_64(x) ByteSwap64(x) 85 | 86 | #else 87 | 88 | #define bswap_16(x) (((x) & 0x00ff) << 8 | ((x) & 0xff00) >> 8) 89 | 90 | #ifdef __INTEL_COMPILER 91 | #define bswap_32(x) _bswap(x) 92 | #else 93 | #define bswap_32(x) \ 94 | ((((x) & 0xff000000) >> 24) | (((x) & 0x00ff0000) >> 8) | \ 95 | (((x) & 0x0000ff00) << 8) | (((x) & 0x000000ff) << 24)) 96 | #endif 97 | 98 | STATIC_INLINE u_int64_t ByteSwap64(u_int64_t x) 99 | { 100 | union { 101 | u_int64_t ll; 102 | u_int32_t l[2]; 103 | } w, r; 104 | w.ll = x; 105 | r.l[0] = bswap_32 (w.l[1]); 106 | r.l[1] = bswap_32 (w.l[0]); 107 | return r.ll; 108 | } 109 | #define bswap_64(x) ByteSwap64(x) 110 | 111 | #endif 112 | 113 | #endif 114 | -------------------------------------------------------------------------------- /mkboot0.lsp: -------------------------------------------------------------------------------- 1 | ; -*- scheme -*- 2 | 3 | (if (not (bound? 'top-level-value)) (set! top-level-value %eval)) 4 | (if (not (bound? 'set-top-level-value!)) (set! set-top-level-value! set)) 5 | (if (not (bound? 'eof-object?)) (set! eof-object? (lambda (x) #f))) 6 | 7 | ;(load "compiler.lsp") 8 | 9 | (define (compile-file inf) 10 | (let ((in (file inf :read))) 11 | (let next ((E (read in))) 12 | (if (not (io.eof? in)) 13 | (begin (print (compile-thunk (expand E))) 14 | (princ "\n") 15 | (next (read in))))) 16 | (io.close in))) 17 | 18 | (for-each (lambda (file) 19 | (compile-file file)) 20 | (cdr *argv*)) 21 | -------------------------------------------------------------------------------- /mkboot1.lsp: -------------------------------------------------------------------------------- 1 | ; -*- scheme -*- 2 | 3 | (load "system.lsp") 4 | (load "compiler.lsp") 5 | (make-system-image "flisp.boot") 6 | -------------------------------------------------------------------------------- /opaque_type_template.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include "llt.h" 8 | #include "flisp.h" 9 | 10 | // global replace TYPE with your type name to make your very own type! 11 | 12 | static value_t TYPEsym; 13 | static fltype_t *TYPEtype; 14 | 15 | void print_TYPE(value_t v, ios_t *f, int princ) 16 | { 17 | } 18 | 19 | void print_traverse_TYPE(value_t self) 20 | { 21 | } 22 | 23 | void free_TYPE(value_t self) 24 | { 25 | } 26 | 27 | void relocate_TYPE(value_t oldv, value_t newv) 28 | { 29 | } 30 | 31 | cvtable_t TYPE_vtable = { print_TYPE, relocate_TYPE, free_TYPE, 32 | print_traverse_TYPE }; 33 | 34 | int isTYPE(value_t v) 35 | { 36 | return iscvalue(v) && cv_class((cvalue_t*)ptr(v)) == TYPEtype; 37 | } 38 | 39 | value_t fl_TYPEp(value_t *args, uint32_t nargs) 40 | { 41 | argcount("TYPE?", nargs, 1); 42 | return isTYPE(args[0]) ? FL_T : FL_F; 43 | } 44 | 45 | static TYPE_t *toTYPE(value_t v, char *fname) 46 | { 47 | if (!isTYPE(v)) 48 | type_error(fname, "TYPE", v); 49 | return (TYPE_t*)cv_data((cvalue_t*)ptr(v)); 50 | } 51 | 52 | static builtinspec_t TYPEfunc_info[] = { 53 | { "TYPE?", fl_TYPEp }, 54 | { NULL, NULL } 55 | }; 56 | 57 | void TYPE_init() 58 | { 59 | TYPEsym = symbol("TYPE"); 60 | TYPEtype = define_opaque_type(TYPEsym, sizeof(TYPE_t), 61 | &TYPE_vtable, NULL); 62 | assign_global_builtins(TYPEfunc_info); 63 | } 64 | -------------------------------------------------------------------------------- /opcodes.h: -------------------------------------------------------------------------------- 1 | #ifndef OPCODES_H 2 | #define OPCODES_H 3 | 4 | enum { 5 | OP_NOP=0, OP_DUP, OP_POP, OP_CALL, OP_TCALL, OP_JMP, OP_BRF, OP_BRT, 6 | OP_JMPL, OP_BRFL, OP_BRTL, OP_RET, 7 | 8 | OP_EQ, OP_EQV, OP_EQUAL, OP_ATOMP, OP_NOT, OP_NULLP, OP_BOOLEANP, 9 | OP_SYMBOLP, OP_NUMBERP, OP_BOUNDP, OP_PAIRP, OP_BUILTINP, OP_VECTORP, 10 | OP_FIXNUMP, OP_FUNCTIONP, 11 | 12 | OP_CONS, OP_LIST, OP_CAR, OP_CDR, OP_SETCAR, OP_SETCDR, 13 | OP_APPLY, 14 | 15 | OP_ADD, OP_SUB, OP_MUL, OP_DIV, OP_IDIV, OP_NUMEQ, OP_LT, OP_COMPARE, 16 | 17 | OP_VECTOR, OP_AREF, OP_ASET, 18 | 19 | OP_LOADT, OP_LOADF, OP_LOADNIL, OP_LOAD0, OP_LOAD1, OP_LOADI8, 20 | OP_LOADV, OP_LOADVL, 21 | OP_LOADG, OP_LOADGL, 22 | OP_LOADA, OP_LOADAL, OP_LOADC, OP_LOADCL, 23 | OP_SETG, OP_SETGL, 24 | OP_SETA, OP_SETAL, OP_SETC, OP_SETCL, 25 | 26 | OP_CLOSURE, OP_ARGC, OP_VARGC, OP_TRYCATCH, OP_FOR, 27 | OP_TAPPLY, OP_ADD2, OP_SUB2, OP_NEG, OP_LARGC, OP_LVARGC, 28 | OP_LOADA0, OP_LOADA1, OP_LOADC00, OP_LOADC01, OP_CALLL, OP_TCALLL, 29 | OP_BRNE, OP_BRNEL, OP_CADR, OP_BRNN, OP_BRNNL, OP_BRN, OP_BRNL, 30 | OP_OPTARGS, OP_BRBOUND, OP_KEYARGS, 31 | 32 | OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST, OP_EOF_OBJECT, 33 | 34 | N_OPCODES 35 | }; 36 | 37 | #ifdef USE_COMPUTED_GOTO 38 | #define VM_LABELS \ 39 | static void *vm_labels[] = { \ 40 | NULL, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, &&L_OP_TCALL, &&L_OP_JMP, \ 41 | &&L_OP_BRF, &&L_OP_BRT, \ 42 | &&L_OP_JMPL, &&L_OP_BRFL, &&L_OP_BRTL, &&L_OP_RET, \ 43 | \ 44 | &&L_OP_EQ, &&L_OP_EQV, &&L_OP_EQUAL, &&L_OP_ATOMP, &&L_OP_NOT, \ 45 | &&L_OP_NULLP, &&L_OP_BOOLEANP, \ 46 | &&L_OP_SYMBOLP, &&L_OP_NUMBERP, &&L_OP_BOUNDP, &&L_OP_PAIRP, \ 47 | &&L_OP_BUILTINP, &&L_OP_VECTORP, \ 48 | &&L_OP_FIXNUMP, &&L_OP_FUNCTIONP, \ 49 | \ 50 | &&L_OP_CONS, &&L_OP_LIST, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_SETCAR, \ 51 | &&L_OP_SETCDR, &&L_OP_APPLY, \ 52 | \ 53 | &&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV, &&L_OP_IDIV, &&L_OP_NUMEQ, \ 54 | &&L_OP_LT, &&L_OP_COMPARE, \ 55 | \ 56 | &&L_OP_VECTOR, &&L_OP_AREF, &&L_OP_ASET, \ 57 | \ 58 | &&L_OP_LOADT, &&L_OP_LOADF, &&L_OP_LOADNIL, &&L_OP_LOAD0, &&L_OP_LOAD1, \ 59 | &&L_OP_LOADI8, \ 60 | &&L_OP_LOADV, &&L_OP_LOADVL, \ 61 | &&L_OP_LOADG, &&L_OP_LOADGL, \ 62 | &&L_OP_LOADA, &&L_OP_LOADAL, &&L_OP_LOADC, &&L_OP_LOADCL, \ 63 | &&L_OP_SETG, &&L_OP_SETGL, \ 64 | &&L_OP_SETA, &&L_OP_SETAL, &&L_OP_SETC, &&L_OP_SETCL, \ 65 | \ 66 | &&L_OP_CLOSURE, &&L_OP_ARGC, &&L_OP_VARGC, &&L_OP_TRYCATCH, \ 67 | &&L_OP_FOR, \ 68 | &&L_OP_TAPPLY, &&L_OP_ADD2, &&L_OP_SUB2, &&L_OP_NEG, &&L_OP_LARGC, \ 69 | &&L_OP_LVARGC, \ 70 | &&L_OP_LOADA0, &&L_OP_LOADA1, &&L_OP_LOADC00, &&L_OP_LOADC01, \ 71 | &&L_OP_CALLL, &&L_OP_TCALLL, &&L_OP_BRNE, &&L_OP_BRNEL, &&L_OP_CADR,\ 72 | &&L_OP_BRNN, &&L_OP_BRNNL, &&L_OP_BRN, &&L_OP_BRNL, \ 73 | &&L_OP_OPTARGS, &&L_OP_BRBOUND, &&L_OP_KEYARGS \ 74 | } 75 | 76 | #define VM_APPLY_LABELS \ 77 | static void *vm_apply_labels[] = { \ 78 | NULL, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, &&L_OP_TCALL, &&L_OP_JMP, \ 79 | &&L_OP_BRF, &&L_OP_BRT, \ 80 | &&L_OP_JMPL, &&L_OP_BRFL, &&L_OP_BRTL, &&L_OP_RET, \ 81 | \ 82 | &&L_OP_EQ, &&L_OP_EQV, &&L_OP_EQUAL, &&L_OP_ATOMP, &&L_OP_NOT, \ 83 | &&L_OP_NULLP, &&L_OP_BOOLEANP, \ 84 | &&L_OP_SYMBOLP, &&L_OP_NUMBERP, &&L_OP_BOUNDP, &&L_OP_PAIRP, \ 85 | &&L_OP_BUILTINP, &&L_OP_VECTORP, \ 86 | &&L_OP_FIXNUMP, &&L_OP_FUNCTIONP, \ 87 | \ 88 | &&L_OP_CONS, &&apply_list, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_SETCAR, \ 89 | &&L_OP_SETCDR, &&apply_apply, \ 90 | \ 91 | &&apply_add, &&apply_sub, &&apply_mul, &&apply_div, &&L_OP_IDIV, &&L_OP_NUMEQ, \ 92 | &&L_OP_LT, &&L_OP_COMPARE, \ 93 | \ 94 | &&apply_vector, &&L_OP_AREF, &&L_OP_ASET \ 95 | } 96 | #else 97 | #define VM_LABELS 98 | #define VM_APPLY_LABELS 99 | #endif 100 | 101 | #endif 102 | -------------------------------------------------------------------------------- /table.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include "llt.h" 9 | #include "flisp.h" 10 | #include "equalhash.h" 11 | 12 | static value_t tablesym; 13 | static fltype_t *tabletype; 14 | 15 | void print_htable(value_t v, ios_t *f) 16 | { 17 | htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(v)); 18 | size_t i; 19 | int first=1; 20 | fl_print_str("#table(", f); 21 | for(i=0; i < h->size; i+=2) { 22 | if (h->table[i+1] != HT_NOTFOUND) { 23 | if (!first) fl_print_str(" ", f); 24 | fl_print_child(f, (value_t)h->table[i]); 25 | fl_print_chr(' ', f); 26 | fl_print_child(f, (value_t)h->table[i+1]); 27 | first = 0; 28 | } 29 | } 30 | fl_print_chr(')', f); 31 | } 32 | 33 | void print_traverse_htable(value_t self) 34 | { 35 | htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(self)); 36 | size_t i; 37 | for(i=0; i < h->size; i+=2) { 38 | if (h->table[i+1] != HT_NOTFOUND) { 39 | print_traverse((value_t)h->table[i]); 40 | print_traverse((value_t)h->table[i+1]); 41 | } 42 | } 43 | } 44 | 45 | void free_htable(value_t self) 46 | { 47 | htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(self)); 48 | htable_free(h); 49 | } 50 | 51 | void relocate_htable(value_t oldv, value_t newv) 52 | { 53 | htable_t *oldh = (htable_t*)cv_data((cvalue_t*)ptr(oldv)); 54 | htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(newv)); 55 | if (oldh->table == &oldh->_space[0]) 56 | h->table = &h->_space[0]; 57 | size_t i; 58 | for(i=0; i < h->size; i++) { 59 | if (h->table[i] != HT_NOTFOUND) 60 | h->table[i] = (void*)relocate_lispvalue((value_t)h->table[i]); 61 | } 62 | } 63 | 64 | cvtable_t table_vtable = { print_htable, relocate_htable, free_htable, 65 | print_traverse_htable }; 66 | 67 | int ishashtable(value_t v) 68 | { 69 | return iscvalue(v) && cv_class((cvalue_t*)ptr(v)) == tabletype; 70 | } 71 | 72 | value_t fl_tablep(value_t *args, uint32_t nargs) 73 | { 74 | argcount("table?", nargs, 1); 75 | return ishashtable(args[0]) ? FL_T : FL_F; 76 | } 77 | 78 | static htable_t *totable(value_t v, char *fname) 79 | { 80 | if (!ishashtable(v)) 81 | type_error(fname, "table", v); 82 | return (htable_t*)cv_data((cvalue_t*)ptr(v)); 83 | } 84 | 85 | value_t fl_table(value_t *args, uint32_t nargs) 86 | { 87 | size_t cnt = (size_t)nargs; 88 | if (cnt & 1) 89 | lerror(ArgError, "table: arguments must come in pairs"); 90 | value_t nt; 91 | // prevent small tables from being added to finalizer list 92 | if (cnt <= HT_N_INLINE) { 93 | tabletype->vtable->finalize = NULL; 94 | nt = cvalue(tabletype, sizeof(htable_t)); 95 | tabletype->vtable->finalize = free_htable; 96 | } 97 | else { 98 | nt = cvalue(tabletype, 2*sizeof(void*)); 99 | } 100 | htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(nt)); 101 | htable_new(h, cnt/2); 102 | uint32_t i; 103 | value_t k=FL_NIL, arg=FL_NIL; 104 | FOR_ARGS(i,0,arg,args) { 105 | if (i&1) 106 | equalhash_put(h, (void*)k, (void*)arg); 107 | else 108 | k = arg; 109 | } 110 | return nt; 111 | } 112 | 113 | // (put! table key value) 114 | value_t fl_table_put(value_t *args, uint32_t nargs) 115 | { 116 | argcount("put!", nargs, 3); 117 | htable_t *h = totable(args[0], "put!"); 118 | void **table0 = h->table; 119 | equalhash_put(h, (void*)args[1], (void*)args[2]); 120 | // register finalizer if we outgrew inline space 121 | if (table0 == &h->_space[0] && h->table != &h->_space[0]) { 122 | cvalue_t *cv = (cvalue_t*)ptr(args[0]); 123 | add_finalizer(cv); 124 | cv->len = 2*sizeof(void*); 125 | } 126 | return args[0]; 127 | } 128 | 129 | static void key_error(char *fname, value_t key) 130 | { 131 | lerrorf(fl_list2(KeyError, key), "%s: key not found", fname); 132 | } 133 | 134 | // (get table key [default]) 135 | value_t fl_table_get(value_t *args, uint32_t nargs) 136 | { 137 | if (nargs != 3) 138 | argcount("get", nargs, 2); 139 | htable_t *h = totable(args[0], "get"); 140 | value_t v = (value_t)equalhash_get(h, (void*)args[1]); 141 | if (v == (value_t)HT_NOTFOUND) { 142 | if (nargs == 3) 143 | return args[2]; 144 | key_error("get", args[1]); 145 | } 146 | return v; 147 | } 148 | 149 | // (has? table key) 150 | value_t fl_table_has(value_t *args, uint32_t nargs) 151 | { 152 | argcount("has", nargs, 2); 153 | htable_t *h = totable(args[0], "has"); 154 | return equalhash_has(h, (void*)args[1]) ? FL_T : FL_F; 155 | } 156 | 157 | // (del! table key) 158 | value_t fl_table_del(value_t *args, uint32_t nargs) 159 | { 160 | argcount("del!", nargs, 2); 161 | htable_t *h = totable(args[0], "del!"); 162 | if (!equalhash_remove(h, (void*)args[1])) 163 | key_error("del!", args[1]); 164 | return args[0]; 165 | } 166 | 167 | value_t fl_table_foldl(value_t *args, uint32_t nargs) 168 | { 169 | argcount("table.foldl", nargs, 3); 170 | value_t f=args[0], zero=args[1], t=args[2]; 171 | htable_t *h = totable(t, "table.foldl"); 172 | size_t i, n = h->size; 173 | void **table = h->table; 174 | fl_gc_handle(&f); 175 | fl_gc_handle(&zero); 176 | fl_gc_handle(&t); 177 | for(i=0; i < n; i+=2) { 178 | if (table[i+1] != HT_NOTFOUND) { 179 | zero = fl_applyn(3, f, 180 | (value_t)table[i], 181 | (value_t)table[i+1], 182 | zero); 183 | // reload pointer 184 | h = (htable_t*)cv_data((cvalue_t*)ptr(t)); 185 | if (h->size != n) 186 | lerror(EnumerationError, "table.foldl: table modified"); 187 | table = h->table; 188 | } 189 | } 190 | fl_free_gc_handles(3); 191 | return zero; 192 | } 193 | 194 | static builtinspec_t tablefunc_info[] = { 195 | { "table", fl_table }, 196 | { "table?", fl_tablep }, 197 | { "put!", fl_table_put }, 198 | { "get", fl_table_get }, 199 | { "has?", fl_table_has }, 200 | { "del!", fl_table_del }, 201 | { "table.foldl", fl_table_foldl }, 202 | { NULL, NULL } 203 | }; 204 | 205 | void table_init(void) 206 | { 207 | tablesym = symbol("table"); 208 | tabletype = define_opaque_type(tablesym, sizeof(htable_t), 209 | &table_vtable, NULL); 210 | assign_global_builtins(tablefunc_info); 211 | } 212 | -------------------------------------------------------------------------------- /tests/argv.lsp: -------------------------------------------------------------------------------- 1 | (print *argv*) (princ "\n") 2 | -------------------------------------------------------------------------------- /tests/ast/asttools.lsp: -------------------------------------------------------------------------------- 1 | ; -*- scheme -*- 2 | ; utilities for AST processing 3 | 4 | (define (symconcat s1 s2) 5 | (symbol (string s1 s2))) 6 | 7 | (define (list-adjoin item lst) 8 | (if (member item lst) 9 | lst 10 | (cons item lst))) 11 | 12 | (define (index-of item lst start) 13 | (cond ((null? lst) #f) 14 | ((eq item (car lst)) start) 15 | (#t (index-of item (cdr lst) (+ start 1))))) 16 | 17 | (define (each f l) 18 | (if (null? l) l 19 | (begin (f (car l)) 20 | (each f (cdr l))))) 21 | 22 | (define (maptree-pre f tr) 23 | (let ((new-t (f tr))) 24 | (if (pair? new-t) 25 | (map (lambda (e) (maptree-pre f e)) new-t) 26 | new-t))) 27 | 28 | (define (maptree-post f tr) 29 | (if (not (pair? tr)) 30 | (f tr) 31 | (let ((new-t (map (lambda (e) (maptree-post f e)) tr))) 32 | (f new-t)))) 33 | 34 | (define (foldtree-pre f t zero) 35 | (if (not (pair? t)) 36 | (f t zero) 37 | (foldl t (lambda (e state) (foldtree-pre f e state)) (f t zero)))) 38 | 39 | (define (foldtree-post f t zero) 40 | (if (not (pair? t)) 41 | (f t zero) 42 | (f t (foldl t (lambda (e state) (foldtree-post f e state)) zero)))) 43 | 44 | ; general tree transformer 45 | ; folds in preorder (foldtree-pre), maps in postorder (maptree-post) 46 | ; therefore state changes occur immediately, just by looking at the current node, 47 | ; while transformation follows evaluation order. this seems to be the most natural 48 | ; approach. 49 | ; (mapper tree state) - should return transformed tree given current state 50 | ; (folder tree state) - should return new state 51 | (define (map&fold t zero mapper folder) 52 | (let ((head (and (pair? t) (car t)))) 53 | (cond ((eq? head 'quote) 54 | t) 55 | ((or (eq? head 'the) (eq? head 'meta)) 56 | (list head 57 | (cadr t) 58 | (map&fold (caddr t) zero mapper folder))) 59 | (else 60 | (let ((new-s (folder t zero))) 61 | (mapper 62 | (if (pair? t) 63 | ; head symbol is a tag; never transform it 64 | (cons (car t) 65 | (map (lambda (e) (map&fold e new-s mapper folder)) 66 | (cdr t))) 67 | t) 68 | new-s)))))) 69 | 70 | ; convert to proper list, i.e. remove "dots", and append 71 | (define (append.2 l tail) 72 | (cond ((null? l) tail) 73 | ((atom? l) (cons l tail)) 74 | (#t (cons (car l) (append.2 (cdr l) tail))))) 75 | 76 | ; transform code by calling (f expr env) on each subexpr, where 77 | ; env is a list of lexical variables in effect at that point. 78 | (define (lexical-walk f t) 79 | (map&fold t () f 80 | (lambda (tree state) 81 | (if (and (eq? (car t) 'lambda) 82 | (pair? (cdr t))) 83 | (append.2 (cadr t) state) 84 | state)))) 85 | 86 | ; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e) 87 | (define (flatten-left-op op e) 88 | (maptree-post (lambda (node) 89 | (if (and (pair? node) 90 | (eq (car node) op) 91 | (pair? (cdr node)) 92 | (pair? (cadr node)) 93 | (eq (caadr node) op)) 94 | (cons op 95 | (append (cdadr node) (cddr node))) 96 | node)) 97 | e)) 98 | 99 | ; convert all local variable references to (lexref rib slot name) 100 | ; where rib is the nesting level and slot is the stack slot# 101 | ; name is just there for reference 102 | ; this assumes lambda is the only remaining naming form 103 | (define (lookup-var v env lev) 104 | (if (null? env) v 105 | (let ((i (index-of v (car env) 0))) 106 | (if i (list 'lexref lev i v) 107 | (lookup-var v (cdr env) (+ lev 1)))))) 108 | (define (lvc- e env) 109 | (cond ((symbol? e) (lookup-var e env 0)) 110 | ((pair? e) 111 | (if (eq (car e) 'quote) 112 | e 113 | (let* ((newvs (and (eq (car e) 'lambda) (cadr e))) 114 | (newenv (if newvs (cons newvs env) env))) 115 | (if newvs 116 | (cons 'lambda 117 | (cons (cadr e) 118 | (map (lambda (se) (lvc- se newenv)) 119 | (cddr e)))) 120 | (map (lambda (se) (lvc- se env)) e))))) 121 | (#t e))) 122 | (define (lexical-var-conversion e) 123 | (lvc- e ())) 124 | 125 | ; convert let to lambda 126 | (define (let-expand e) 127 | (maptree-post (lambda (n) 128 | (if (and (pair? n) (eq (car n) 'let)) 129 | `((lambda ,(map car (cadr n)) ,@(cddr n)) 130 | ,@(map cadr (cadr n))) 131 | n)) 132 | e)) 133 | 134 | ; alpha renaming 135 | ; transl is an assoc list ((old-sym-name . new-sym-name) ...) 136 | (define (alpha-rename e transl) 137 | (map&fold e 138 | () 139 | ; mapper: replace symbol if unbound 140 | (lambda (t env) 141 | (if (symbol? t) 142 | (let ((found (assq t transl))) 143 | (if (and found 144 | (not (memq t env))) 145 | (cdr found) 146 | t)) 147 | t)) 148 | ; folder: add locals to environment if entering a new scope 149 | (lambda (t env) 150 | (if (and (pair? t) (or (eq? (car t) 'let) 151 | (eq? (car t) 'lambda))) 152 | (append (cadr t) env) 153 | env)))) 154 | 155 | ; flatten op with any associativity 156 | (define-macro (flatten-all-op op e) 157 | `(pattern-expand 158 | (pattern-lambda (,op (-- l ...) (-- inner (,op ...)) (-- r ...)) 159 | (cons ',op (append l (cdr inner) r))) 160 | ,e)) 161 | 162 | (define-macro (pattern-lambda pat body) 163 | (let* ((args (patargs pat)) 164 | (expander `(lambda ,args ,body))) 165 | `(lambda (expr) 166 | (let ((m (match ',pat expr))) 167 | (if m 168 | ; matches; perform expansion 169 | (apply ,expander (map (lambda (var) (cdr (or (assq var m) '(0 . #f)))) 170 | ',args)) 171 | #f))))) 172 | -------------------------------------------------------------------------------- /tests/ast/match.lsp: -------------------------------------------------------------------------------- 1 | ; -*- scheme -*- 2 | ; tree regular expression pattern matching 3 | ; by Jeff Bezanson 4 | 5 | (define (unique lst) 6 | (if (null? lst) 7 | () 8 | (cons (car lst) 9 | (filter (lambda (x) (not (eq x (car lst)))) 10 | (unique (cdr lst)))))) 11 | 12 | ; list of special pattern symbols that cannot be variable names 13 | (define metasymbols '(_ ...)) 14 | 15 | ; expression tree pattern matching 16 | ; matches expr against pattern p and returns an assoc list ((var . expr) (var . expr) ...) 17 | ; mapping variables to captured subexpressions, or #f if no match. 18 | ; when a match succeeds, __ is always bound to the whole matched expression. 19 | ; 20 | ; p is an expression in the following pattern language: 21 | ; 22 | ; _ match anything, not captured 23 | ; any scheme function; matches if (func expr) returns #t 24 | ; match anything and capture as . future occurrences of in the pattern 25 | ; must match the same thing. 26 | ; (head etc) match an s-expr with 'head' matched literally, and the rest of the 27 | ; subpatterns matched recursively. 28 | ; (-/ ) match literally 29 | ; (-^

) complement of pattern

30 | ; (--

) match

and capture as if match succeeds 31 | ; 32 | ; regular match constructs: 33 | ; ... match any number of anything 34 | ; (-$ etc) match any of subpatterns , , etc 35 | ; (-*

) match any number of

36 | ; (-?

) match 0 or 1 of

37 | ; (-+

) match at least 1 of

38 | ; all of these can be wrapped in (-- var ) for capturing purposes 39 | ; This is NP-complete. Be careful. 40 | ; 41 | (define (match- p expr state) 42 | (cond ((symbol? p) 43 | (cond ((eq p '_) state) 44 | (#t 45 | (let ((capt (assq p state))) 46 | (if capt 47 | (and (equal? expr (cdr capt)) state) 48 | (cons (cons p expr) state)))))) 49 | 50 | ((procedure? p) 51 | (and (p expr) state)) 52 | 53 | ((pair? p) 54 | (cond ((eq (car p) '-/) (and (equal? (cadr p) expr) state)) 55 | ((eq (car p) '-^) (and (not (match- (cadr p) expr state)) state)) 56 | ((eq (car p) '--) 57 | (and (match- (caddr p) expr state) 58 | (cons (cons (cadr p) expr) state))) 59 | ((eq (car p) '-$) ; greedy alternation for toplevel pattern 60 | (match-alt (cdr p) () (list expr) state #f 1)) 61 | (#t 62 | (and (pair? expr) 63 | (equal? (car p) (car expr)) 64 | (match-seq (cdr p) (cdr expr) state (length (cdr expr))))))) 65 | 66 | (#t 67 | (and (equal? p expr) state)))) 68 | 69 | ; match an alternation 70 | (define (match-alt alt prest expr state var L) 71 | (if (null? alt) #f ; no alternatives left 72 | (let ((subma (match- (car alt) (car expr) state))) 73 | (or (and subma 74 | (match-seq prest (cdr expr) 75 | (if var 76 | (cons (cons var (car expr)) 77 | subma) 78 | subma) 79 | (- L 1))) 80 | (match-alt (cdr alt) prest expr state var L))))) 81 | 82 | ; match generalized kleene star (try consuming min to max) 83 | (define (match-star- p prest expr state var min max L sofar) 84 | (cond ; case 0: impossible to match 85 | ((> min max) #f) 86 | ; case 1: only allowed to match 0 subexpressions 87 | ((= max 0) (match-seq prest expr 88 | (if var (cons (cons var (reverse sofar)) state) 89 | state) 90 | L)) 91 | ; case 2: must match at least 1 92 | ((> min 0) 93 | (and (match- p (car expr) state) 94 | (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1) 95 | (cons (car expr) sofar)))) 96 | ; otherwise, must match either 0 or between 1 and max subexpressions 97 | (#t 98 | (or (match-star- p prest expr state var 0 0 L sofar) 99 | (match-star- p prest expr state var 1 max L sofar))))) 100 | (define (match-star p prest expr state var min max L) 101 | (match-star- p prest expr state var min max L ())) 102 | 103 | ; match sequences of expressions 104 | (define (match-seq p expr state L) 105 | (cond ((not state) #f) 106 | ((null? p) (if (null? expr) state #f)) 107 | (#t 108 | (let ((subp (car p)) 109 | (var #f)) 110 | (if (and (pair? subp) 111 | (eq (car subp) '--)) 112 | (begin (set! var (cadr subp)) 113 | (set! subp (caddr subp))) 114 | #f) 115 | (let ((head (if (pair? subp) (car subp) ()))) 116 | (cond ((eq subp '...) 117 | (match-star '_ (cdr p) expr state var 0 L L)) 118 | ((eq head '-*) 119 | (match-star (cadr subp) (cdr p) expr state var 0 L L)) 120 | ((eq head '-+) 121 | (match-star (cadr subp) (cdr p) expr state var 1 L L)) 122 | ((eq head '-?) 123 | (match-star (cadr subp) (cdr p) expr state var 0 1 L)) 124 | ((eq head '-$) 125 | (match-alt (cdr subp) (cdr p) expr state var L)) 126 | (#t 127 | (and (pair? expr) 128 | (match-seq (cdr p) (cdr expr) 129 | (match- (car p) (car expr) state) 130 | (- L 1)))))))))) 131 | 132 | (define (match p expr) (match- p expr (list (cons '__ expr)))) 133 | 134 | ; given a pattern p, return the list of capturing variables it uses 135 | (define (patargs- p) 136 | (cond ((and (symbol? p) 137 | (not (member p metasymbols))) 138 | (list p)) 139 | 140 | ((pair? p) 141 | (if (eq (car p) '-/) 142 | () 143 | (unique (apply append (map patargs- (cdr p)))))) 144 | 145 | (#t ()))) 146 | (define (patargs p) 147 | (cons '__ (patargs- p))) 148 | 149 | ; try to transform expr using a pattern-lambda from plist 150 | ; returns the new expression, or expr if no matches 151 | (define (apply-patterns plist expr) 152 | (if (null? plist) expr 153 | (if (procedure? plist) 154 | (let ((enew (plist expr))) 155 | (if (not enew) 156 | expr 157 | enew)) 158 | (let ((enew ((car plist) expr))) 159 | (if (not enew) 160 | (apply-patterns (cdr plist) expr) 161 | enew))))) 162 | 163 | ; top-down fixed-point macroexpansion. this is a typical algorithm, 164 | ; but it may leave some structure that matches a pattern unexpanded. 165 | ; the advantage is that non-terminating cases cannot arise as a result 166 | ; of expression composition. in other words, if the outer loop terminates 167 | ; on all inputs for a given set of patterns, then the whole algorithm 168 | ; terminates. pattern sets that violate this should be easier to detect, 169 | ; for example 170 | ; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3)) 171 | ; TODO: ignore quoted expressions 172 | (define (pattern-expand plist expr) 173 | (if (not (pair? expr)) 174 | expr 175 | (let ((enew (apply-patterns plist expr))) 176 | (if (eq enew expr) 177 | ; expr didn't change; move to subexpressions 178 | (cons (car expr) 179 | (map (lambda (subex) (pattern-expand plist subex)) (cdr expr))) 180 | ; expr changed; iterate 181 | (pattern-expand plist enew))))) 182 | -------------------------------------------------------------------------------- /tests/ast/match.scm: -------------------------------------------------------------------------------- 1 | ; tree regular expression pattern matching 2 | ; by Jeff Bezanson 3 | 4 | ; list of special pattern symbols that cannot be variable names 5 | (define metasymbols '(_ ...)) 6 | 7 | ; expression tree pattern matching 8 | ; matches expr against pattern p and returns an assoc list ((var . expr) (var . expr) ...) 9 | ; mapping variables to captured subexpressions, or #f if no match. 10 | ; when a match succeeds, __ is always bound to the whole matched expression. 11 | ; 12 | ; p is an expression in the following pattern language: 13 | ; 14 | ; _ match anything, not captured 15 | ; any scheme function; matches if (func expr) returns #t 16 | ; match anything and capture as . future occurrences of in the pattern 17 | ; must match the same thing. 18 | ; (head etc) match an s-expr with 'head' matched literally, and the rest of the 19 | ; subpatterns matched recursively. 20 | ; (-/ ) match literally 21 | ; (-^

) complement of pattern

22 | ; (--

) match

and capture as if match succeeds 23 | ; 24 | ; regular match constructs: 25 | ; ... match any number of anything 26 | ; (-$ etc) match any of subpatterns , , etc 27 | ; (-*

) match any number of

28 | ; (-?

) match 0 or 1 of

29 | ; (-+

) match at least 1 of

30 | ; all of these can be wrapped in (-- var ) for capturing purposes 31 | ; This is NP-complete. Be careful. 32 | ; 33 | (define (match- p expr state) 34 | (cond ((symbol? p) 35 | (cond ((eq? p '_) state) 36 | (else 37 | (let ((capt (assq p state))) 38 | (if capt 39 | (and (equal? expr (cdr capt)) state) 40 | (cons (cons p expr) state)))))) 41 | 42 | ((procedure? p) 43 | (and (p expr) state)) 44 | 45 | ((pair? p) 46 | (cond ((eq? (car p) '-/) (and (equal? (cadr p) expr) state)) 47 | ((eq? (car p) '-^) (and (not (match- (cadr p) expr state)) state)) 48 | ((eq? (car p) '--) 49 | (and (match- (caddr p) expr state) 50 | (cons (cons (cadr p) expr) state))) 51 | ((eq? (car p) '-$) ; greedy alternation for toplevel pattern 52 | (match-alt (cdr p) () (list expr) state #f 1)) 53 | (else 54 | (and (pair? expr) 55 | (equal? (car p) (car expr)) 56 | (match-seq (cdr p) (cdr expr) state (length (cdr expr))))))) 57 | 58 | (else 59 | (and (equal? p expr) state)))) 60 | 61 | ; match an alternation 62 | (define (match-alt alt prest expr state var L) 63 | (if (null? alt) #f ; no alternatives left 64 | (let ((subma (match- (car alt) (car expr) state))) 65 | (or (and subma 66 | (match-seq prest (cdr expr) 67 | (if var 68 | (cons (cons var (car expr)) 69 | subma) 70 | subma) 71 | (- L 1))) 72 | (match-alt (cdr alt) prest expr state var L))))) 73 | 74 | ; match generalized kleene star (try consuming min to max) 75 | (define (match-star p prest expr state var min max L) 76 | (define (match-star- p prest expr state var min max L sofar) 77 | (cond ; case 0: impossible to match 78 | ((> min max) #f) 79 | ; case 1: only allowed to match 0 subexpressions 80 | ((= max 0) (match-seq prest expr 81 | (if var (cons (cons var (reverse sofar)) state) 82 | state) 83 | L)) 84 | ; case 2: must match at least 1 85 | ((> min 0) 86 | (and (match- p (car expr) state) 87 | (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1) 88 | (cons (car expr) sofar)))) 89 | ; otherwise, must match either 0 or between 1 and max subexpressions 90 | (else 91 | (or (match-star- p prest expr state var 0 0 L sofar) 92 | (match-star- p prest expr state var 1 max L sofar))))) 93 | 94 | (match-star- p prest expr state var min max L ())) 95 | 96 | ; match sequences of expressions 97 | (define (match-seq p expr state L) 98 | (cond ((not state) #f) 99 | ((null? p) (if (null? expr) state #f)) 100 | (else 101 | (let ((subp (car p)) 102 | (var #f)) 103 | (if (and (pair? subp) 104 | (eq? (car subp) '--)) 105 | (begin (set! var (cadr subp)) 106 | (set! subp (caddr subp))) 107 | #f) 108 | (let ((head (if (pair? subp) (car subp) ()))) 109 | (cond ((eq? subp '...) 110 | (match-star '_ (cdr p) expr state var 0 L L)) 111 | ((eq? head '-*) 112 | (match-star (cadr subp) (cdr p) expr state var 0 L L)) 113 | ((eq? head '-+) 114 | (match-star (cadr subp) (cdr p) expr state var 1 L L)) 115 | ((eq? head '-?) 116 | (match-star (cadr subp) (cdr p) expr state var 0 1 L)) 117 | ((eq? head '-$) 118 | (match-alt (cdr subp) (cdr p) expr state var L)) 119 | (else 120 | (and (pair? expr) 121 | (match-seq (cdr p) (cdr expr) 122 | (match- (car p) (car expr) state) 123 | (- L 1)))))))))) 124 | 125 | (define (match p expr) (match- p expr (list (cons '__ expr)))) 126 | 127 | ; given a pattern p, return the list of capturing variables it uses 128 | (define (patargs p) 129 | (define (patargs- p) 130 | (cond ((and (symbol? p) 131 | (not (member p metasymbols))) 132 | (list p)) 133 | 134 | ((pair? p) 135 | (if (eq? (car p) '-/) 136 | () 137 | (delete-duplicates (apply append (map patargs- (cdr p)))))) 138 | 139 | (else ()))) 140 | (cons '__ (patargs- p))) 141 | 142 | ; try to transform expr using a pattern-lambda from plist 143 | ; returns the new expression, or expr if no matches 144 | (define (apply-patterns plist expr) 145 | (if (null? plist) expr 146 | (if (procedure? plist) 147 | (let ((enew (plist expr))) 148 | (if (not enew) 149 | expr 150 | enew)) 151 | (let ((enew ((car plist) expr))) 152 | (if (not enew) 153 | (apply-patterns (cdr plist) expr) 154 | enew))))) 155 | 156 | ; top-down fixed-point macroexpansion. this is a typical algorithm, 157 | ; but it may leave some structure that matches a pattern unexpanded. 158 | ; the advantage is that non-terminating cases cannot arise as a result 159 | ; of expression composition. in other words, if the outer loop terminates 160 | ; on all inputs for a given set of patterns, then the whole algorithm 161 | ; terminates. pattern sets that violate this should be easier to detect, 162 | ; for example 163 | ; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3)) 164 | ; TODO: ignore quoted expressions 165 | (define (pattern-expand plist expr) 166 | (if (not (pair? expr)) 167 | expr 168 | (let ((enew (apply-patterns plist expr))) 169 | (if (eq? enew expr) 170 | ; expr didn't change; move to subexpressions 171 | (cons (car expr) 172 | (map (lambda (subex) (pattern-expand plist subex)) (cdr expr))) 173 | ; expr changed; iterate 174 | (pattern-expand plist enew))))) 175 | -------------------------------------------------------------------------------- /tests/ast/rpasses.lsp: -------------------------------------------------------------------------------- 1 | ; -*- scheme -*- 2 | (load "match.lsp") 3 | (load "asttools.lsp") 4 | 5 | (define missing-arg-tag '*r-missing*) 6 | 7 | ; tree inspection utils 8 | 9 | (define (assigned-var e) 10 | (and (pair? e) 11 | (or (eq (car e) '<-) (eq (car e) 'ref=)) 12 | (symbol? (cadr e)) 13 | (cadr e))) 14 | 15 | (define (func-argnames f) 16 | (let ((argl (cadr f))) 17 | (if (eq argl '*r-null*) () 18 | (map cadr argl)))) 19 | 20 | ; transformations 21 | 22 | (let ((ctr 0)) 23 | (set! r-gensym (lambda () 24 | (prog1 (symbol (string "%r:" ctr)) 25 | (set! ctr (+ ctr 1)))))) 26 | 27 | (define (dollarsign-transform e) 28 | (pattern-expand 29 | (pattern-lambda ($ lhs name) 30 | (let* ((g (if (not (pair? lhs)) lhs (r-gensym))) 31 | (n (if (symbol? name) 32 | name ;(symbol->string name) 33 | name)) 34 | (expr `(r-call 35 | r-aref ,g (index-in-strlist ,n (r-call attr ,g "names"))))) 36 | (if (not (pair? lhs)) 37 | expr 38 | `(r-block (ref= ,g ,lhs) ,expr)))) 39 | e)) 40 | 41 | ; lower r expressions of the form f(lhs,...) <- rhs 42 | ; TODO: if there are any special forms that can be f in this expression, 43 | ; they need to be handled separately. For example a$b can be lowered 44 | ; to an index assignment (by dollarsign-transform), after which 45 | ; this transform applies. I don't think there are any others though. 46 | (define (fancy-assignment-transform e) 47 | (pattern-expand 48 | (pattern-lambda (-$ (<- (r-call f lhs ...) rhs) 49 | (<<- (r-call f lhs ...) rhs)) 50 | (let ((g (if (pair? rhs) (r-gensym) rhs)) 51 | (op (car __))) 52 | `(r-block ,@(if (pair? rhs) `((ref= ,g ,rhs)) ()) 53 | (,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g)) 54 | ,g))) 55 | e)) 56 | 57 | ; map an arglist with default values to appropriate init code 58 | ; function(x=blah) { ... } gets 59 | ; if (missing(x)) x = blah 60 | ; added to its body 61 | (define (gen-default-inits arglist) 62 | (map (lambda (arg) 63 | (let ((name (cadr arg)) 64 | (default (caddr arg))) 65 | `(when (missing ,name) 66 | (<- ,name ,default)))) 67 | (filter (lambda (arg) (not (eq (caddr arg) missing-arg-tag))) arglist))) 68 | 69 | ; convert r function expressions to lambda 70 | (define (normalize-r-functions e) 71 | (maptree-post (lambda (n) 72 | (if (and (pair? n) (eq (car n) 'function)) 73 | `(lambda ,(func-argnames n) 74 | (r-block ,@(gen-default-inits (cadr n)) 75 | ,@(if (and (pair? (caddr n)) 76 | (eq (car (caddr n)) 'r-block)) 77 | (cdr (caddr n)) 78 | (list (caddr n))))) 79 | n)) 80 | e)) 81 | 82 | (define (find-assigned-vars n) 83 | (let ((vars ())) 84 | (maptree-pre (lambda (s) 85 | (if (not (pair? s)) s 86 | (cond ((eq (car s) 'lambda) ()) 87 | ((eq (car s) '<-) 88 | (set! vars (list-adjoin (cadr s) vars)) 89 | (cddr s)) 90 | (#t s)))) 91 | n) 92 | vars)) 93 | 94 | ; introduce let based on assignment statements 95 | (define (letbind-locals e) 96 | (maptree-post (lambda (n) 97 | (if (and (pair? n) (eq (car n) 'lambda)) 98 | (let ((vars (find-assigned-vars (cddr n)))) 99 | `(lambda ,(cadr n) (let ,(map (lambda (v) (list v ())) 100 | vars) 101 | ,@(cddr n)))) 102 | n)) 103 | e)) 104 | 105 | (define (compile-ish e) 106 | (letbind-locals 107 | (normalize-r-functions 108 | (fancy-assignment-transform 109 | (dollarsign-transform 110 | (flatten-all-op && (flatten-all-op \|\| e))))))) 111 | -------------------------------------------------------------------------------- /tests/color.lsp: -------------------------------------------------------------------------------- 1 | ; -*- scheme -*- 2 | 3 | ; dictionaries ---------------------------------------------------------------- 4 | (define (dict-new) ()) 5 | 6 | (define (dict-extend dl key value) 7 | (cond ((null? dl) (list (cons key value))) 8 | ((equal? key (caar dl)) (cons (cons key value) (cdr dl))) 9 | (else (cons (car dl) (dict-extend (cdr dl) key value))))) 10 | 11 | (define (dict-lookup dl key) 12 | (cond ((null? dl) ()) 13 | ((equal? key (caar dl)) (cdar dl)) 14 | (else (dict-lookup (cdr dl) key)))) 15 | 16 | (define (dict-keys dl) (map car dl)) 17 | 18 | ; graphs ---------------------------------------------------------------------- 19 | (define (graph-empty) (dict-new)) 20 | 21 | (define (graph-connect g n1 n2) 22 | (dict-extend 23 | (dict-extend g n2 (cons n1 (dict-lookup g n2))) 24 | n1 25 | (cons n2 (dict-lookup g n1)))) 26 | 27 | (define (graph-adjacent? g n1 n2) (member n2 (dict-lookup g n1))) 28 | 29 | (define (graph-neighbors g n) (dict-lookup g n)) 30 | 31 | (define (graph-nodes g) (dict-keys g)) 32 | 33 | (define (graph-add-node g n1) (dict-extend g n1 ())) 34 | 35 | (define (graph-from-edges edge-list) 36 | (if (null? edge-list) 37 | (graph-empty) 38 | (graph-connect (graph-from-edges (cdr edge-list)) 39 | (caar edge-list) 40 | (cdar edge-list)))) 41 | 42 | ; graph coloring -------------------------------------------------------------- 43 | (define (node-colorable? g coloring node-to-color color-of-node) 44 | (not (member 45 | color-of-node 46 | (map 47 | (lambda (n) 48 | (let ((color-pair (assq n coloring))) 49 | (if (pair? color-pair) (cdr color-pair) ()))) 50 | (graph-neighbors g node-to-color))))) 51 | 52 | (define (try-each f lst) 53 | (if (null? lst) #f 54 | (let ((ret (f (car lst)))) 55 | (if ret ret (try-each f (cdr lst)))))) 56 | 57 | (define (color-node g coloring colors uncolored-nodes color) 58 | (cond 59 | ((null? uncolored-nodes) coloring) 60 | ((node-colorable? g coloring (car uncolored-nodes) color) 61 | (let ((new-coloring 62 | (cons (cons (car uncolored-nodes) color) coloring))) 63 | (try-each (lambda (c) 64 | (color-node g new-coloring colors (cdr uncolored-nodes) c)) 65 | colors))))) 66 | 67 | (define (color-graph g colors) 68 | (if (null? colors) 69 | (and (null? (graph-nodes g)) ()) 70 | (color-node g () colors (graph-nodes g) (car colors)))) 71 | 72 | (define (color-pairs pairs colors) 73 | (color-graph (graph-from-edges pairs) colors)) 74 | 75 | ; queens ---------------------------------------------------------------------- 76 | (define (can-attack x y) 77 | (let ((x1 (mod x 5)) 78 | (y1 (truncate (/ x 5))) 79 | (x2 (mod y 5)) 80 | (y2 (truncate (/ y 5)))) 81 | (or (= x1 x2) (= y1 y2) (= (abs (- y2 y1)) (abs (- x2 x1)))))) 82 | 83 | (define (generate-5x5-pairs) 84 | (let ((result ())) 85 | (dotimes (x 25) 86 | (dotimes (y 25) 87 | (if (and (not (= x y)) (can-attack x y)) 88 | (set! result (cons (cons x y) result)) ()))) 89 | result)) 90 | -------------------------------------------------------------------------------- /tests/equal.scm: -------------------------------------------------------------------------------- 1 | ; Terminating equal predicate 2 | ; by Jeff Bezanson 3 | ; 4 | ; This version only considers pairs and simple atoms. 5 | 6 | ; equal?, with bounded recursion. returns 0 if we suspect 7 | ; nontermination, otherwise #t or #f for the correct answer. 8 | (define (bounded-equal a b N) 9 | (cond ((<= N 0) 0) 10 | ((and (pair? a) (pair? b)) 11 | (let ((as 12 | (bounded-equal (car a) (car b) (- N 1)))) 13 | (if (number? as) 14 | 0 15 | (and as 16 | (bounded-equal (cdr a) (cdr b) (- N 1)))))) 17 | (else (eq? a b)))) 18 | 19 | ; union-find algorithm 20 | 21 | ; find equivalence class of a cons cell, or #f if not yet known 22 | ; the root of a class is a cons that is its own class 23 | (define (class table key) 24 | (let ((c (hashtable-ref table key #f))) 25 | (if (or (not c) (eq? c key)) 26 | c 27 | (class table c)))) 28 | 29 | ; move a and b to the same equivalence class, given c and cb 30 | ; as the current values of (class table a) and (class table b) 31 | ; Note: this is not quite optimal. We blindly pick 'a' as the 32 | ; root of the new class, but we should pick whichever class is 33 | ; larger. 34 | (define (union! table a b c cb) 35 | (let ((ca (if c c a))) 36 | (if cb 37 | (hashtable-set! table cb ca)) 38 | (hashtable-set! table a ca) 39 | (hashtable-set! table b ca))) 40 | 41 | ; cyclic equal. first, attempt to compare a and b as best 42 | ; we can without recurring. if we can't prove them different, 43 | ; set them equal and move on. 44 | (define (cyc-equal a b table) 45 | (cond ((eq? a b) #t) 46 | ((not (and (pair? a) (pair? b))) (eq? a b)) 47 | (else 48 | (let ((aa (car a)) (da (cdr a)) 49 | (ab (car b)) (db (cdr b))) 50 | (cond ((or (not (eq? (atom? aa) (atom? ab))) 51 | (not (eq? (atom? da) (atom? db)))) #f) 52 | ((and (atom? aa) 53 | (not (eq? aa ab))) #f) 54 | ((and (atom? da) 55 | (not (eq? da db))) #f) 56 | (else 57 | (let ((ca (class table a)) 58 | (cb (class table b))) 59 | (if (and ca cb (eq? ca cb)) 60 | #t 61 | (begin (union! table a b ca cb) 62 | (and (cyc-equal aa ab table) 63 | (cyc-equal da db table))))))))))) 64 | 65 | (define (equal a b) 66 | (let ((guess (bounded-equal a b 2048))) 67 | (if (boolean? guess) guess 68 | (cyc-equal a b (make-eq-hashtable))))) 69 | -------------------------------------------------------------------------------- /tests/err.lsp: -------------------------------------------------------------------------------- 1 | (define (f x) (begin (list-tail '(1) 3) 3)) 2 | (f 2) 3 | a 4 | (trycatch a (lambda (e) (print (stacktrace)))) 5 | -------------------------------------------------------------------------------- /tests/hashtest.lsp: -------------------------------------------------------------------------------- 1 | ; -*- scheme -*- 2 | 3 | (define (hins1) 4 | (let ((h (table))) 5 | (dotimes (n 200000) 6 | (put! h (mod (rand) 1000) 'apple)) 7 | h)) 8 | 9 | (define (hread h) 10 | (dotimes (n 200000) 11 | (get h (mod (rand) 10000) nil))) 12 | 13 | (time (dotimes (i 100000) 14 | (table :a 1 :b 2 :c 3 :d 4 :e 5 :f 6 :g 7 :foo 8 :bar 9))) 15 | (time (dotimes (i 100000) (table :a 1 :b 2 :c 3 :d 4 :e 5 :f 6 :g 7 :foo 8))) 16 | (time (dotimes (i 100000) (table :a 1 :b 2 :c 3 :d 4))) 17 | (time (dotimes (i 100000) (table :a 1 :b 2))) 18 | (time (dotimes (i 100000) (table))) 19 | 20 | #t 21 | 22 | #| 23 | 24 | with HT_N_INLINE==16 25 | Elapsed time: 0.0796329975128174 seconds 26 | Elapsed time: 0.0455679893493652 seconds 27 | Elapsed time: 0.0272290706634521 seconds 28 | Elapsed time: 0.0177979469299316 seconds 29 | Elapsed time: 0.0102229118347168 seconds 30 | 31 | 32 | with HT_N_INLINE==8 33 | 34 | Elapsed time: 0.1010119915008545 seconds 35 | Elapsed time: 0.174872875213623 seconds 36 | Elapsed time: 0.0322129726409912 seconds 37 | Elapsed time: 0.0195930004119873 seconds 38 | Elapsed time: 0.008836030960083 seconds 39 | 40 | |# 41 | -------------------------------------------------------------------------------- /tests/perf.lsp: -------------------------------------------------------------------------------- 1 | (load "test.lsp") 2 | 3 | (princ "colorgraph: ") 4 | (load "tcolor.lsp") 5 | 6 | (princ "fib(34): ") 7 | (assert (equal? (time (fib 34)) 5702887)) 8 | (princ "yfib(32): ") 9 | (assert (equal? (time (yfib 32)) 2178309)) 10 | 11 | (princ "sort: ") 12 | (set! r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000)) 13 | (time (simple-sort r)) 14 | 15 | (princ "expand: ") 16 | (time (dotimes (n 5000) (expand '(dotimes (i 100) body1 body2)))) 17 | 18 | (define (my-append . lsts) 19 | (cond ((null? lsts) ()) 20 | ((null? (cdr lsts)) (car lsts)) 21 | (else (letrec ((append2 (lambda (l d) 22 | (if (null? l) d 23 | (cons (car l) 24 | (append2 (cdr l) d)))))) 25 | (append2 (car lsts) (apply my-append (cdr lsts))))))) 26 | 27 | (princ "append: ") 28 | (set! L (map-int (lambda (x) (map-int identity 20)) 20)) 29 | (time (dotimes (n 1000) (apply my-append L))) 30 | 31 | (path.cwd "ast") 32 | (princ "p-lambda: ") 33 | (load "rpasses.lsp") 34 | (define *input* (load "datetimeR.lsp")) 35 | (time (set! *output* (compile-ish *input*))) 36 | (assert (equal? *output* (load "rpasses-out.lsp"))) 37 | (path.cwd "..") 38 | -------------------------------------------------------------------------------- /tests/pisum.lsp: -------------------------------------------------------------------------------- 1 | (define (pisum) 2 | (dotimes (j 500) 3 | ((label sumloop 4 | (lambda (i sum) 5 | (if (> i 10000) 6 | sum 7 | (sumloop (+ i 1) (+ sum (/ (* i i))))))) 8 | 1.0 0.0))) 9 | -------------------------------------------------------------------------------- /tests/printcases.lsp: -------------------------------------------------------------------------------- 1 | expand 2 | append 3 | bq-process 4 | 5 | (define (syntax-environment) 6 | (map (lambda (s) (cons s (symbol-syntax s))) 7 | (filter symbol-syntax (environment)))) 8 | 9 | (syntax-environment) 10 | 11 | (symbol-syntax 'try) 12 | 13 | (map-int (lambda (x) `(a b c d e)) 90) 14 | 15 | (list->vector (map-int (lambda (x) `(a b c d e)) 90)) 16 | 17 | '((lambda (x y) (if (< x y) x y)) (a b c) (d e f) 2 3 (r t y)) 18 | 19 | '((lambda (x y) (if (< x y) x yffffffffffffffffffff)) (a b c) (d e f) 2 3 (r t y)) 20 | 21 | '((lambda (x y) (if (< x y) x y)) (a b c) (d (e zz zzz) f) 2 3 (r t y)) 22 | 23 | '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e) 24 | (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d) 25 | (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e) 26 | (3 . d) (2 . c) (0 . b) (1 . a)) 27 | -------------------------------------------------------------------------------- /tests/tcolor.lsp: -------------------------------------------------------------------------------- 1 | ; -*- scheme -*- 2 | ; color for performance 3 | 4 | (load "color.lsp") 5 | 6 | ; 100x color 5 queens 7 | (define Q (generate-5x5-pairs)) 8 | (define (ct) 9 | (set! C (color-pairs Q '(a b c d e))) 10 | (dotimes (n 99) (color-pairs Q '(a b c d e)))) 11 | (time (ct)) 12 | (assert (equal? C 13 | '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e) 14 | (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d) 15 | (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e) 16 | (3 . d) (2 . c) (0 . b) (1 . a)))) 17 | -------------------------------------------------------------------------------- /tests/test.lsp: -------------------------------------------------------------------------------- 1 | ; -*- scheme -*- 2 | 3 | ; make label self-evaluating, but evaluating the lambda in the process 4 | ;(defmacro labl (name f) 5 | ; (list list ''labl (list 'quote name) f)) 6 | 7 | (define-macro (labl name f) 8 | `(let (,name) (set! ,name ,f))) 9 | 10 | ;(define (reverse lst) 11 | ; ((label rev-help (lambda (lst result) 12 | ; (if (null? lst) result 13 | ; (rev-help (cdr lst) (cons (car lst) result))))) 14 | ; lst ())) 15 | 16 | (define (append- . lsts) 17 | ((label append-h 18 | (lambda (lsts) 19 | (cond ((null? lsts) ()) 20 | ((null? (cdr lsts)) (car lsts)) 21 | (#t ((label append2 (lambda (l d) 22 | (if (null? l) d 23 | (cons (car l) 24 | (append2 (cdr l) d))))) 25 | (car lsts) (append-h (cdr lsts))))))) 26 | lsts)) 27 | 28 | ;(princ 'Hello '| | 'world! "\n") 29 | ;(filter (lambda (x) (not (< x 0))) '(1 -1 -2 5 10 -8 0)) 30 | (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) 31 | ;(princ (time (fib 34)) "\n") 32 | ;(dotimes (i 20000) (map-int (lambda (x) (list 'quote x)) 8)) 33 | ;(dotimes (i 40000) (append '(a b) '(1 2 3 4) () '(c) () '(5 6))) 34 | ;(dotimes (i 80000) (list 1 2 3 4 5)) 35 | ;(set! a (map-int identity 10000)) 36 | ;(dotimes (i 200) (rfoldl cons () a)) 37 | 38 | #| 39 | (define-macro (dotimes var . body) 40 | (let ((v (car var)) 41 | (cnt (cadr var))) 42 | `(let ((,v 0)) 43 | (while (< ,v ,cnt) 44 | (prog1 45 | ,(cons 'begin body) 46 | (set! ,v (+ ,v 1))))))) 47 | 48 | (define (map-int f n) 49 | (if (<= n 0) 50 | () 51 | (let ((first (cons (f 0) ()))) 52 | ((label map-int- 53 | (lambda (acc i n) 54 | (if (= i n) 55 | first 56 | (begin (set-cdr! acc (cons (f i) ())) 57 | (map-int- (cdr acc) (+ i 1) n))))) 58 | first 1 n)))) 59 | |# 60 | 61 | (define-macro (labl name fn) 62 | `((lambda (,name) (set! ,name ,fn)) ())) 63 | 64 | (define (square x) (* x x)) 65 | (define (expt b p) 66 | (cond ((= p 0) 1) 67 | ((= b 0) 0) 68 | ((even? p) (square (expt b (div0 p 2)))) 69 | (#t (* b (expt b (- p 1)))))) 70 | 71 | (define (gcd a b) 72 | (cond ((= a 0) b) 73 | ((= b 0) a) 74 | ((< a b) (gcd a (- b a))) 75 | (#t (gcd b (- a b))))) 76 | 77 | ; like eval-when-compile 78 | (define-macro (literal expr) 79 | (let ((v (eval expr))) 80 | (if (self-evaluating? v) v (list quote v)))) 81 | 82 | (define (cardepth l) 83 | (if (atom? l) 0 84 | (+ 1 (cardepth (car l))))) 85 | 86 | (define (nestlist f zero n) 87 | (if (<= n 0) () 88 | (cons zero (nestlist f (f zero) (- n 1))))) 89 | 90 | (define (mapl f . lsts) 91 | ((label mapl- 92 | (lambda (lsts) 93 | (if (null? (car lsts)) () 94 | (begin (apply f lsts) (mapl- (map cdr lsts)))))) 95 | lsts)) 96 | 97 | ; test to see if a symbol begins with : 98 | (define (keywordp s) 99 | (and (>= s '|:|) (<= s '|:~|))) 100 | 101 | ; swap the cars and cdrs of every cons in a structure 102 | (define (swapad c) 103 | (if (atom? c) c 104 | (set-cdr! c (K (swapad (car c)) 105 | (set-car! c (swapad (cdr c))))))) 106 | 107 | (define (without x l) 108 | (filter (lambda (e) (not (eq e x))) l)) 109 | 110 | (define (conscount c) 111 | (if (pair? c) (+ 1 112 | (conscount (car c)) 113 | (conscount (cdr c))) 114 | 0)) 115 | 116 | ; _ Welcome to 117 | ; (_ _ _ |_ _ | . _ _ 2 118 | ; | (-||||_(_)|__|_)|_) 119 | ; ==================|== 120 | 121 | ;[` _ ,_ |- | . _ 2 122 | ;| (/_||||_()|_|_\|) 123 | ; | 124 | 125 | (define-macro (while- test . forms) 126 | `((label -loop- (lambda () 127 | (if ,test 128 | (begin ,@forms 129 | (-loop-)) 130 | ()))))) 131 | 132 | ; this would be a cool use of thunking to handle 'finally' clauses, but 133 | ; this code doesn't work in the case where the user manually re-raises 134 | ; inside a catch block. one way to handle it would be to replace all 135 | ; their uses of 'raise' with '*_try_finally_raise_*' which calls the thunk. 136 | ; (try expr 137 | ; (catch (TypeError e) . exprs) 138 | ; (catch (IOError e) . exprs) 139 | ; (finally . exprs)) 140 | (define-macro (try expr . forms) 141 | (let ((final (f-body (cdr (or (assq 'finally forms) '(()))))) 142 | (body (foldr 143 | ; create a function to check for and handle one exception 144 | ; type, and pass off control to the next when no match 145 | (lambda (catc next) 146 | (let ((var (cadr (cadr catc))) 147 | (extype (caadr catc)) 148 | (todo (f-body (cddr catc)))) 149 | `(lambda (,var) 150 | (if (or (eq ,var ',extype) 151 | (and (pair? ,var) 152 | (eq (car ,var) ',extype))) 153 | ,todo 154 | (,next ,var))))) 155 | 156 | ; default function; no matches so re-raise 157 | '(lambda (e) (begin (*_try_finally_thunk_*) (raise e))) 158 | 159 | ; make list of catch forms 160 | (filter (lambda (f) (eq (car f) 'catch)) forms)))) 161 | `(let ((*_try_finally_thunk_* (lambda () ,final))) 162 | (prog1 (attempt ,expr ,body) 163 | (*_try_finally_thunk_*))))) 164 | 165 | (define Y 166 | (lambda (f) 167 | ((lambda (h) 168 | (f (lambda (x) ((h h) x)))) 169 | (lambda (h) 170 | (f (lambda (x) ((h h) x))))))) 171 | 172 | (define yfib 173 | (Y (lambda (fib) 174 | (lambda (n) 175 | (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))))) 176 | 177 | ;(defun tt () (time (dotimes (i 500000) (* 0x1fffffff 1) ))) 178 | ;(tt) 179 | ;(tt) 180 | ;(tt) 181 | 182 | (define-macro (accumulate-while cnd what . body) 183 | (let ((acc (gensym))) 184 | `(let ((,acc (list ()))) 185 | (cdr 186 | (prog1 ,acc 187 | (while ,cnd 188 | (begin (set! ,acc 189 | (cdr (set-cdr! ,acc (cons ,what ())))) 190 | ,@body))))))) 191 | 192 | (define-macro (accumulate-for var lo hi what . body) 193 | (let ((acc (gensym))) 194 | `(let ((,acc (list ()))) 195 | (cdr 196 | (prog1 ,acc 197 | (for ,lo ,hi 198 | (lambda (,var) 199 | (begin (set! ,acc 200 | (cdr (set-cdr! ,acc (cons ,what ())))) 201 | ,@body)))))))) 202 | 203 | (define (map-indexed f lst) 204 | (if (atom? lst) lst 205 | (let ((i 0)) 206 | (accumulate-while (pair? lst) (f (car lst) i) 207 | (begin (set! lst (cdr lst)) 208 | (set! i (1+ i))))))) 209 | 210 | (define (string.findall haystack needle . offs) 211 | (define (sub h n offs lst) 212 | (let ((i (string.find h n offs))) 213 | (if i 214 | (sub h n (string.inc h i) (cons i lst)) 215 | (reverse! lst)))) 216 | (sub haystack needle (if (null? offs) 0 (car offs)) ())) 217 | 218 | (let ((*profiles* (table))) 219 | (set! profile 220 | (lambda (s) 221 | (let ((f (top-level-value s))) 222 | (put! *profiles* s (cons 0 0)) 223 | (set-top-level-value! s 224 | (lambda args 225 | (define tt (get *profiles* s)) 226 | (define count (car tt)) 227 | (define time (cdr tt)) 228 | (define t0 (time.now)) 229 | (define v (apply f args)) 230 | (set-cdr! tt (+ time (- (time.now) t0))) 231 | (set-car! tt (+ count 1)) 232 | v))))) 233 | (set! show-profiles 234 | (lambda () 235 | (define pr (filter (lambda (x) (> (cadr x) 0)) 236 | (table.pairs *profiles*))) 237 | (define width (+ 4 238 | (apply max 239 | (map (lambda (x) 240 | (length (string x))) 241 | (cons 'Function 242 | (map car pr)))))) 243 | (princ (string.rpad "Function" width #\ ) 244 | "#Calls Time (seconds)") 245 | (newline) 246 | (princ (string.rpad "--------" width #\ ) 247 | "------ --------------") 248 | (newline) 249 | (for-each 250 | (lambda (p) 251 | (princ (string.rpad (string (caddr p)) width #\ ) 252 | (string.rpad (string (cadr p)) 11 #\ ) 253 | (car p)) 254 | (newline)) 255 | (simple-sort (map (lambda (l) (reverse (to-proper l))) 256 | pr))))) 257 | (set! clear-profiles 258 | (lambda () 259 | (for-each (lambda (k) 260 | (put! *profiles* k (cons 0 0))) 261 | (table.keys *profiles*))))) 262 | 263 | #;(for-each profile 264 | '(emit encode-byte-code const-to-idx-vec 265 | index-of lookup-sym in-env? any every 266 | compile-sym compile-if compile-begin 267 | compile-arglist expand builtin->instruction 268 | compile-app separate nconc get-defined-vars 269 | compile-in compile compile-f delete-duplicates 270 | map length> length= count filter append 271 | lastcdr to-proper reverse reverse! list->vector 272 | table.foreach list-head list-tail assq memq assoc member 273 | assv memv nreconc bq-process)) 274 | 275 | (define (filt1 pred lst) 276 | (define (filt1- pred lst accum) 277 | (if (null? lst) accum 278 | (if (pred (car lst)) 279 | (filt1- pred (cdr lst) (cons (car lst) accum)) 280 | (filt1- pred (cdr lst) accum)))) 281 | (filt1- pred lst ())) 282 | 283 | (define (filto pred lst (accum ())) 284 | (if (atom? lst) accum 285 | (if (pred (car lst)) 286 | (filto pred (cdr lst) (cons (car lst) accum)) 287 | (filto pred (cdr lst) accum)))) 288 | 289 | ; (pairwise? p a b c d) == (and (p a b) (p b c) (p c d)) 290 | (define (pairwise? pred . args) 291 | (or (null? args) 292 | (let f ((a (car args)) (d (cdr args))) 293 | (or (null? d) 294 | (and (pred a (car d)) (f (car d) (cdr d))))))) 295 | -------------------------------------------------------------------------------- /tests/tme.lsp: -------------------------------------------------------------------------------- 1 | (let ((t (table))) 2 | (time (dotimes (i 2000000) 3 | (put! t (rand) (rand))))) 4 | #t 5 | -------------------------------------------------------------------------------- /tests/torture.scm: -------------------------------------------------------------------------------- 1 | (define ones (map (lambda (x) 1) (iota 1000000))) 2 | 3 | (write (apply + ones)) 4 | (newline) 5 | 6 | (define (big n) 7 | (if (<= n 0) 8 | 0 9 | `(+ 1 1 1 1 1 1 1 1 1 1 ,(big (- n 1))))) 10 | 11 | (define nst (big 100000)) 12 | 13 | (write (eval nst)) 14 | (newline) 15 | 16 | (define longg (cons '+ ones)) 17 | (write (eval longg)) 18 | (newline) 19 | 20 | (define (f x) 21 | (begin (write x) 22 | (newline) 23 | (f (+ x 1)) 24 | 0)) 25 | -------------------------------------------------------------------------------- /tests/torus.lsp: -------------------------------------------------------------------------------- 1 | ; -*- scheme -*- 2 | (define (maplist f l) 3 | (if (null? l) () 4 | (cons (f l) (maplist f (cdr l))))) 5 | 6 | ; produce a beautiful, toroidal cons structure 7 | ; make m copies of a CDR-circular list of length n, and connect corresponding 8 | ; conses in CAR-circular loops 9 | ; replace maplist 'identity' with 'copy-tree' for rapdily exploding memory use 10 | (define (torus m n) 11 | (let* ((l (map-int identity n)) 12 | (g l) 13 | (prev g)) 14 | (dotimes (i (- m 1)) 15 | (set! prev g) 16 | (set! g (maplist identity g)) 17 | (set-cdr! (last-pair prev) prev)) 18 | (set-cdr! (last-pair g) g) 19 | (let ((a l) 20 | (b g)) 21 | (dotimes (i n) 22 | (set-car! a b) 23 | (set! a (cdr a)) 24 | (set! b (cdr b)))) 25 | l)) 26 | 27 | (define (cyl m n) 28 | (let* ((l (map-int identity n)) 29 | (g l)) 30 | (dotimes (i (- m 1)) 31 | (set! g (maplist identity g))) 32 | (let ((a l) 33 | (b g)) 34 | (dotimes (i n) 35 | (set-car! a b) 36 | (set! a (cdr a)) 37 | (set! b (cdr b)))) 38 | l)) 39 | 40 | (time (begin (print (torus 100 100)) ())) 41 | ;(time (dotimes (i 1) (load "100x100.lsp"))) 42 | ; with ltable 43 | ; printing time: 0.415sec 44 | ; reading time: 0.165sec 45 | 46 | ; with ptrhash 47 | ; printing time: 0.081sec 48 | ; reading time: 0.0264sec 49 | -------------------------------------------------------------------------------- /tests/wt.lsp: -------------------------------------------------------------------------------- 1 | (define-macro (while- test . forms) 2 | `((label -loop- (lambda () 3 | (if ,test 4 | (begin ,@forms 5 | (-loop-)) 6 | ()))))) 7 | 8 | (define (tw) 9 | (set! i 0) 10 | (while (< i 10000000) (set! i (+ i 1)))) 11 | 12 | (define (tw2) 13 | (letrec ((loop (lambda () 14 | (if (< i 10000000) 15 | (begin (set! i (+ i 1)) 16 | (loop)) 17 | ())))) 18 | (loop))) 19 | 20 | #| 21 | interpreter: 22 | while: 1.82sec 23 | macro: 2.98sec 24 | 25 | compiler: 26 | while: 0.72sec 27 | macro: 1.24sec 28 | |# 29 | -------------------------------------------------------------------------------- /tiny/Makefile: -------------------------------------------------------------------------------- 1 | FREEBSD-GE-10 = $(shell test `uname` = FreeBSD -a `uname -r | cut -d. -f1` -ge 10 && echo YES) 2 | CC = $(if $(FREEBSD-GE-10),clang,gcc) 3 | 4 | NAME = lisp 5 | SRC = $(NAME).c 6 | EXENAME = $(NAME) 7 | 8 | FLAGS = -Wall -Wextra 9 | LIBS = 10 | 11 | DEBUGFLAGS = -g -DDEBUG $(FLAGS) 12 | SHIPFLAGS = -O3 -fomit-frame-pointer $(FLAGS) 13 | 14 | default: release 15 | 16 | debug: $(SRC) 17 | $(CC) $(DEBUGFLAGS) $(SRC) -o $(EXENAME) $(LIBS) 18 | 19 | release: $(SRC) 20 | $(CC) $(SHIPFLAGS) $(SRC) -o $(EXENAME) $(LIBS) 21 | 22 | clean: 23 | rm -f $(EXENAME) 24 | -------------------------------------------------------------------------------- /tiny/flutils.c: -------------------------------------------------------------------------------- 1 | u_int32_t *bitvector_resize(u_int32_t *b, size_t n) 2 | { 3 | u_int32_t *p; 4 | size_t sz = ((n+31)>>5) * 4; 5 | p = realloc(b, sz); 6 | if (p == NULL) return NULL; 7 | memset(p, 0, sz); 8 | return p; 9 | } 10 | 11 | u_int32_t *mk_bitvector(size_t n) 12 | { 13 | return bitvector_resize(NULL, n); 14 | } 15 | 16 | void bitvector_set(u_int32_t *b, u_int32_t n, u_int32_t c) 17 | { 18 | if (c) 19 | b[n>>5] |= (1<<(n&31)); 20 | else 21 | b[n>>5] &= ~(1<<(n&31)); 22 | } 23 | 24 | u_int32_t bitvector_get(u_int32_t *b, u_int32_t n) 25 | { 26 | return b[n>>5] & (1<<(n&31)); 27 | } 28 | 29 | typedef struct { 30 | size_t n, maxsize; 31 | unsigned long *items; 32 | } ltable_t; 33 | 34 | void ltable_init(ltable_t *t, size_t n) 35 | { 36 | t->n = 0; 37 | t->maxsize = n; 38 | t->items = (unsigned long*)malloc(n * sizeof(unsigned long)); 39 | } 40 | 41 | void ltable_clear(ltable_t *t) 42 | { 43 | t->n = 0; 44 | } 45 | 46 | void ltable_insert(ltable_t *t, unsigned long item) 47 | { 48 | unsigned long *p; 49 | 50 | if (t->n == t->maxsize) { 51 | p = realloc(t->items, (t->maxsize*2)*sizeof(unsigned long)); 52 | if (p == NULL) return; 53 | t->items = p; 54 | t->maxsize *= 2; 55 | } 56 | t->items[t->n++] = item; 57 | } 58 | 59 | #define NOTFOUND ((int)-1) 60 | 61 | int ltable_lookup(ltable_t *t, unsigned long item) 62 | { 63 | int i; 64 | for(i=0; i < (int)t->n; i++) 65 | if (t->items[i] == item) 66 | return i; 67 | return NOTFOUND; 68 | } 69 | 70 | void ltable_adjoin(ltable_t *t, unsigned long item) 71 | { 72 | if (ltable_lookup(t, item) == NOTFOUND) 73 | ltable_insert(t, item); 74 | } 75 | 76 | static const u_int32_t offsetsFromUTF8[6] = { 77 | 0x00000000UL, 0x00003080UL, 0x000E2080UL, 78 | 0x03C82080UL, 0xFA082080UL, 0x82082080UL 79 | }; 80 | 81 | static const char trailingBytesForUTF8[256] = { 82 | 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 83 | 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 84 | 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 85 | 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 86 | 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 87 | 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 88 | 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 89 | 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,4,4,4,4,5,5,5,5 90 | }; 91 | 92 | int u8_seqlen(const char c) 93 | { 94 | return trailingBytesForUTF8[(unsigned int)(unsigned char)c] + 1; 95 | } 96 | 97 | #define UEOF ((u_int32_t)EOF) 98 | 99 | u_int32_t u8_fgetc(FILE *f) 100 | { 101 | int amt=0, sz, c; 102 | u_int32_t ch=0; 103 | 104 | c = fgetc(f); 105 | if (c == EOF) 106 | return UEOF; 107 | ch = (u_int32_t)c; 108 | amt = sz = u8_seqlen(ch); 109 | while (--amt) { 110 | ch <<= 6; 111 | c = fgetc(f); 112 | if (c == EOF) 113 | return UEOF; 114 | ch += (u_int32_t)c; 115 | } 116 | ch -= offsetsFromUTF8[sz-1]; 117 | 118 | return ch; 119 | } 120 | -------------------------------------------------------------------------------- /todo-scrap: -------------------------------------------------------------------------------- 1 | - readable gensyms. have uninterned symbols, but have all same-named 2 | gensyms read to the same (eq) symbol within an expression. 3 | - fat pointers, i.e. 64 bits on 32-bit platforms. we could have full 32-bit 4 | integers too. the mind boggles at the possibilities. 5 | (it would be great if everybody decided that pointer types should forever 6 | be wider than address spaces, with some bits reserved for application use) 7 | - any way at all to provide O(1) computed lookups (i.e. indexing). 8 | CL uses vectors for this. once you have it, it's sufficient to get 9 | efficient hash tables and everything else. 10 | - could be done just by generalizing cons cells to have more than 11 | car, cdr: c2r, c3r, etc. maybe (1 . 2 . 3 . 4 . ...) 12 | all you need is a tag+size on the front of the object so the collector 13 | knows how to deal with it. 14 | (car x) == (ref x 0), etc. 15 | (rplaca x v) == (rplac x 0 v), etc. 16 | (size (cons 1 2)) == 2, etc. 17 | - one possibility: if we see a cons whose CAR is tagptr(0x10,TAG_SYM), 18 | then the CDR is the size and the following words are the elements. 19 | . this approach is especially good if vectors are separate types from 20 | conses 21 | - another: add u_int32_t size to cons_t, making them all 50% bigger. 22 | access is simpler and more uniform, without fully doubling the size like 23 | we'd get with fat pointers. 24 | 25 | Notice that the size is one byte more than the number of characters in 26 | the string. This is because femtoLisp adds a NUL terminator to make its 27 | strings compatible with C. No effort is made to hide this fact. 28 | But since femtoLisp tracks the sizes of cvalues, it doesn't need the 29 | terminator itself. Therefore it treats zero bytes specially as rarely 30 | as possible. In particular, zeros are only special in values whose type 31 | is exactly (array char), and are only interpreted in the 32 | following cases: 33 |

    34 |
  • When printing strings, a final NUL is never printed. NULs in the 35 | middle of a string are printed though. 36 |
  • String constructors NUL-terminate their output. 37 |
  • Explicit string functions (like strlen) treat NULs the same 38 | way equivalent C functions would. 39 |
40 | Arrays of uchar, int8, etc. are treated as raw data and zero bytes are 41 | never special. 42 | -------------------------------------------------------------------------------- /types.c: -------------------------------------------------------------------------------- 1 | #include "equalhash.h" 2 | 3 | fltype_t *get_type(value_t t) 4 | { 5 | fltype_t *ft; 6 | if (issymbol(t)) { 7 | ft = ((symbol_t*)ptr(t))->type; 8 | if (ft != NULL) 9 | return ft; 10 | } 11 | void **bp = equalhash_bp(&TypeTable, (void*)t); 12 | if (*bp != HT_NOTFOUND) 13 | return *bp; 14 | 15 | int align, isarray=(iscons(t) && car_(t) == arraysym && iscons(cdr_(t))); 16 | size_t sz; 17 | if (isarray && !iscons(cdr_(cdr_(t)))) { 18 | // special case: incomplete array type 19 | sz = 0; 20 | } 21 | else { 22 | sz = ctype_sizeof(t, &align); 23 | } 24 | 25 | ft = (fltype_t*)malloc(sizeof(fltype_t)); 26 | ft->type = t; 27 | if (issymbol(t)) { 28 | ft->numtype = sym_to_numtype(t); 29 | ((symbol_t*)ptr(t))->type = ft; 30 | } 31 | else { 32 | ft->numtype = N_NUMTYPES; 33 | } 34 | ft->size = sz; 35 | ft->vtable = NULL; 36 | ft->artype = NULL; 37 | ft->marked = 1; 38 | ft->elsz = 0; 39 | ft->eltype = NULL; 40 | ft->init = NULL; 41 | if (iscons(t)) { 42 | if (isarray) { 43 | fltype_t *eltype = get_type(car_(cdr_(t))); 44 | if (eltype->size == 0) { 45 | free(ft); 46 | lerror(ArgError, "invalid array element type"); 47 | } 48 | ft->elsz = eltype->size; 49 | ft->eltype = eltype; 50 | ft->init = &cvalue_array_init; 51 | //eltype->artype = ft; -- this is a bad idea since some types carry array sizes 52 | } 53 | else if (car_(t) == enumsym) { 54 | ft->numtype = T_INT32; 55 | ft->init = &cvalue_enum_init; 56 | } 57 | } 58 | *bp = ft; 59 | return ft; 60 | } 61 | 62 | fltype_t *get_array_type(value_t eltype) 63 | { 64 | fltype_t *et = get_type(eltype); 65 | if (et->artype == NULL) 66 | et->artype = get_type(fl_list2(arraysym, eltype)); 67 | return et->artype; 68 | } 69 | 70 | fltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab, 71 | cvinitfunc_t init) 72 | { 73 | fltype_t *ft = (fltype_t*)malloc(sizeof(fltype_t)); 74 | ft->type = sym; 75 | ft->size = sz; 76 | ft->numtype = N_NUMTYPES; 77 | ft->vtable = vtab; 78 | ft->artype = NULL; 79 | ft->eltype = NULL; 80 | ft->elsz = 0; 81 | ft->marked = 1; 82 | ft->init = init; 83 | return ft; 84 | } 85 | 86 | void relocate_typetable(void) 87 | { 88 | htable_t *h = &TypeTable; 89 | size_t i; 90 | void *nv; 91 | for(i=0; i < h->size; i+=2) { 92 | if (h->table[i] != HT_NOTFOUND) { 93 | nv = (void*)relocate((value_t)h->table[i]); 94 | h->table[i] = nv; 95 | if (h->table[i+1] != HT_NOTFOUND) 96 | ((fltype_t*)h->table[i+1])->type = (value_t)nv; 97 | } 98 | } 99 | } 100 | --------------------------------------------------------------------------------