summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--HACKING112
-rw-r--r--INSTALL45
-rw-r--r--LICENSE7
-rw-r--r--LICENSE-CYG4
-rw-r--r--METALICENSE25
-rw-r--r--Makefile290
-rw-r--r--RELNOTES3007
-rw-r--r--alloca.h29
-rw-r--r--args.c76
-rw-r--r--args.h119
-rw-r--r--arith.c1373
-rw-r--r--arith.h36
-rw-r--r--autoload.c1141
-rw-r--r--autoload.h44
-rw-r--r--buf.c274
-rw-r--r--buf.h35
-rw-r--r--cadr.c41
-rw-r--r--cadr.h27
-rw-r--r--checkman.txr91
-rw-r--r--chksum.c608
-rw-r--r--chksum.h35
-rw-r--r--chksums/crc32.c27
-rw-r--r--chksums/crc32.h27
-rw-r--r--chksums/md5.c16
-rw-r--r--chksums/sha1.c321
-rw-r--r--chksums/sha1.h53
-rw-r--r--combi.c298
-rw-r--r--combi.h27
-rwxr-xr-xconfigure1283
-rw-r--r--debug.c46
-rw-r--r--debug.h28
-rw-r--r--eval.c2401
-rw-r--r--eval.h44
-rw-r--r--ffi.c3208
-rw-r--r--ffi.h56
-rw-r--r--filter.c97
-rw-r--r--filter.h27
-rw-r--r--ftw.c56
-rw-r--r--ftw.h27
-rw-r--r--gc.c330
-rw-r--r--gc.h51
-rw-r--r--gencadr.txr18
-rw-r--r--genchksum.txr266
-rw-r--r--genman.txr141
-rw-r--r--genvim.txr186
-rw-r--r--genvmop.txr13
-rw-r--r--glob.c248
-rw-r--r--glob.h27
-rw-r--r--gzio.c597
-rw-r--r--gzio.h38
-rw-r--r--hash.c1217
-rw-r--r--hash.h57
-rw-r--r--inst.nsi32
-rw-r--r--itypes.c99
-rw-r--r--itypes.h33
-rw-r--r--jmp.S251
-rw-r--r--lex.yy.c.patch13
-rw-r--r--lex.yy.c.shipped7955
-rw-r--r--lib.c7482
-rw-r--r--lib.h577
-rwxr-xr-xlibtags.txr469
-rw-r--r--linenoise/linenoise.c198
-rw-r--r--linenoise/linenoise.h11
-rw-r--r--lisplib.c897
-rw-r--r--lisplib.h35
-rw-r--r--match.c1002
-rw-r--r--match.h35
-rw-r--r--mpi/mpi-config.h8
-rw-r--r--mpi/mpi.c147
-rw-r--r--mpi/mpi.h5
-rw-r--r--parser.c808
-rw-r--r--parser.h57
-rw-r--r--parser.l414
-rw-r--r--parser.y573
-rw-r--r--pdf-clobber-stamps.tl22
-rw-r--r--protsym.c501
-rw-r--r--psquare.c169
-rw-r--r--psquare.h54
-rw-r--r--rand.c317
-rw-r--r--rand.h29
-rw-r--r--regex.c229
-rw-r--r--regex.h30
-rw-r--r--share/txr/stdlib/compiler.tl1865
-rw-r--r--share/txr/stdlib/getput.tl132
-rw-r--r--share/txr/stdlib/keyparams.tl90
-rw-r--r--share/txr/stdlib/op.tl198
-rw-r--r--share/txr/stdlib/path-test.tl185
-rw-r--r--share/txr/stdlib/pmac.tl34
-rw-r--r--share/txr/stdlib/socket.tl158
-rw-r--r--share/txr/stdlib/struct.tl367
-rw-r--r--share/txr/stdlib/type.tl39
-rw-r--r--share/txr/stdlib/vm-param.tl37
-rw-r--r--signal.c137
-rw-r--r--signal.h31
-rw-r--r--socket.c572
-rw-r--r--socket.h28
-rw-r--r--stdlib/arith-each.tl103
-rw-r--r--stdlib/asm.tl (renamed from share/txr/stdlib/asm.tl)155
-rw-r--r--stdlib/awk.tl (renamed from share/txr/stdlib/awk.tl)234
-rw-r--r--stdlib/build.tl (renamed from share/txr/stdlib/build.tl)107
-rw-r--r--stdlib/cadr.tl (renamed from share/txr/stdlib/cadr.tl)27
-rw-r--r--stdlib/comp-opts.tl51
-rw-r--r--stdlib/compiler.tl2735
-rw-r--r--stdlib/constfun.tl93
-rw-r--r--stdlib/conv.tl (renamed from share/txr/stdlib/conv.tl)73
-rw-r--r--stdlib/copy-file.tl (renamed from share/txr/stdlib/copy-file.tl)106
-rw-r--r--stdlib/csort.tl46
-rw-r--r--stdlib/debugger.tl (renamed from share/txr/stdlib/debugger.tl)32
-rw-r--r--stdlib/defset.tl (renamed from share/txr/stdlib/defset.tl)44
-rw-r--r--stdlib/doc-lookup.tl66
-rw-r--r--stdlib/doloop.tl (renamed from share/txr/stdlib/doloop.tl)29
-rw-r--r--stdlib/each-prod.tl110
-rw-r--r--stdlib/error.tl (renamed from share/txr/stdlib/error.tl)112
-rw-r--r--stdlib/except.tl (renamed from share/txr/stdlib/except.tl)34
-rw-r--r--stdlib/expander-let.tl44
-rw-r--r--stdlib/ffi.tl (renamed from share/txr/stdlib/ffi.tl)121
-rw-r--r--stdlib/getopts.tl (renamed from share/txr/stdlib/getopts.tl)244
-rw-r--r--stdlib/getput.tl212
-rw-r--r--stdlib/glob.tl93
-rw-r--r--stdlib/hash.tl (renamed from share/txr/stdlib/hash.tl)27
-rw-r--r--stdlib/ifa.tl (renamed from share/txr/stdlib/ifa.tl)46
-rw-r--r--stdlib/keyparams.tl78
-rw-r--r--stdlib/load-args.tl49
-rw-r--r--stdlib/match.tl1161
-rw-r--r--stdlib/op.tl281
-rw-r--r--stdlib/optimize.tl854
-rw-r--r--stdlib/package.tl (renamed from share/txr/stdlib/package.tl)31
-rw-r--r--stdlib/param.tl (renamed from share/txr/stdlib/param.tl)40
-rw-r--r--stdlib/path-test.tl363
-rw-r--r--stdlib/pic.tl191
-rw-r--r--stdlib/place.tl (renamed from share/txr/stdlib/place.tl)251
-rw-r--r--stdlib/pmac.tl41
-rw-r--r--stdlib/quips.tl128
-rw-r--r--stdlib/save-exe.tl (renamed from share/txr/stdlib/save-exe.tl)27
-rw-r--r--stdlib/socket.tl320
-rw-r--r--stdlib/stream-wrap.tl (renamed from share/txr/stdlib/stream-wrap.tl)27
-rw-r--r--stdlib/struct.tl503
-rw-r--r--stdlib/tagbody.tl (renamed from share/txr/stdlib/tagbody.tl)30
-rw-r--r--stdlib/termios.tl (renamed from share/txr/stdlib/termios.tl)51
-rw-r--r--stdlib/trace.tl (renamed from share/txr/stdlib/trace.tl)35
-rw-r--r--stdlib/txr-case.tl (renamed from share/txr/stdlib/txr-case.tl)29
-rw-r--r--stdlib/txr-case.txr (renamed from share/txr/stdlib/txr-case.txr)0
-rw-r--r--stdlib/type.tl53
-rw-r--r--stdlib/ver.tl (renamed from share/txr/stdlib/ver.tl)2
-rw-r--r--stdlib/ver.txr (renamed from share/txr/stdlib/ver.txr)0
-rw-r--r--stdlib/vm-param.tl37
-rw-r--r--stdlib/with-resources.tl (renamed from share/txr/stdlib/with-resources.tl)38
-rw-r--r--stdlib/with-stream.tl (renamed from share/txr/stdlib/with-stream.tl)27
-rw-r--r--stdlib/yield.tl (renamed from share/txr/stdlib/yield.tl)29
-rw-r--r--stream.c1988
-rw-r--r--stream.h85
-rw-r--r--struct.c543
-rw-r--r--struct.h46
-rw-r--r--strudel.c49
-rw-r--r--strudel.h27
-rw-r--r--sysif.c1179
-rw-r--r--sysif.h45
-rw-r--r--syslog.c47
-rw-r--r--syslog.h29
-rwxr-xr-xtags.tl194
-rw-r--r--termios.c158
-rw-r--r--termios.h27
-rw-r--r--tests/000/binding.expected6
-rw-r--r--tests/000/binding.txr5
-rw-r--r--tests/000/nilvar.expected1
-rw-r--r--tests/000/nilvar.txr3
-rw-r--r--tests/002/query-1.txr2
-rw-r--r--tests/006/freeform-4.expected26
-rw-r--r--tests/006/freeform-4.txr20
-rw-r--r--tests/006/freeform-5.expected4
-rw-r--r--tests/006/freeform-5.txr7
-rw-r--r--tests/007/except-3.expected1
-rw-r--r--tests/007/except-3.txr3
-rw-r--r--tests/007/except-4.expected1
-rw-r--r--tests/007/except-4.txr8
-rw-r--r--tests/008/call-2.txr6
-rw-r--r--tests/008/call.expected2
-rw-r--r--tests/008/call.txr13
-rw-r--r--tests/008/mdo.txr7
-rw-r--r--tests/008/no-stdin-hang.txr5
-rw-r--r--tests/008/repeat.expected3
-rw-r--r--tests/008/repeat.txr6
-rw-r--r--tests/009/json.expected96
-rw-r--r--tests/009/json.txr7
-rw-r--r--tests/010/cons.tl14
-rw-r--r--tests/010/eof-status.expected2
-rw-r--r--tests/010/eof-status.txr3
-rw-r--r--tests/010/hash.tl94
-rw-r--r--tests/010/json.tl194
-rw-r--r--tests/010/qquote.tl42
-rw-r--r--tests/010/range.tl103
-rw-r--r--tests/010/seq.expected36
-rw-r--r--tests/010/seq.txr63
-rw-r--r--tests/010/span-var.txr39
-rw-r--r--tests/010/tree.tl264
-rw-r--r--tests/010/vec.tl53
-rw-r--r--tests/011/keyparams.tl47
-rw-r--r--tests/011/macros-3.expected0
-rw-r--r--tests/011/macros-3.tl13
-rw-r--r--tests/011/macros-4.tl11
-rw-r--r--tests/011/mandel.txr22
-rw-r--r--tests/011/patmatch.tl619
-rw-r--r--tests/011/place.tl9
-rw-r--r--tests/011/tree-bind.tl20
-rw-r--r--tests/011/txr-case.expected1
-rw-r--r--tests/011/txr-case.txr17
-rw-r--r--tests/012/aseq.expected0
-rw-r--r--tests/012/aseq.tl11
-rw-r--r--tests/012/ashwin.expected0
-rw-r--r--tests/012/binding.tl5
-rw-r--r--tests/012/buf.tl28
-rw-r--r--tests/012/cadr.tl14
-rw-r--r--tests/012/callable.tl31
-rw-r--r--tests/012/case.tl32
-rw-r--r--tests/012/circ.tl6
-rw-r--r--tests/012/compile.tl15
-rw-r--r--tests/012/cons.tl35
-rw-r--r--tests/012/const.tl23
-rw-r--r--tests/012/cont.expected0
-rw-r--r--tests/012/cont.tl17
-rw-r--r--tests/012/defset.expected0
-rw-r--r--tests/012/defset.tl12
-rw-r--r--tests/012/fini.expected48
-rw-r--r--tests/012/fini.tl26
-rw-r--r--tests/012/ifa.expected0
-rw-r--r--tests/012/ifa.tl7
-rw-r--r--tests/012/iter.tl92
-rw-r--r--tests/012/lambda.tl162
-rw-r--r--tests/012/lazy.tl6
-rw-r--r--tests/012/less.tl21
-rw-r--r--tests/012/oop-dsc.tl80
-rw-r--r--tests/012/oop-mac.tl18
-rw-r--r--tests/012/oop-mi.expected12
-rw-r--r--tests/012/oop-mi.tl13
-rw-r--r--tests/012/oop-prelude.expected5
-rw-r--r--tests/012/oop-prelude.tl13
-rw-r--r--tests/012/oop-seq.tl87
-rw-r--r--tests/012/oop.tl74
-rw-r--r--tests/012/op.tl127
-rw-r--r--tests/012/parse.tl66
-rw-r--r--tests/012/quasi.expected0
-rw-r--r--tests/012/quasi.tl15
-rw-r--r--tests/012/quine.expected0
-rw-r--r--tests/012/readprint.tl13
-rw-r--r--tests/012/seq.expected0
-rw-r--r--tests/012/seq.tl866
-rw-r--r--tests/012/sort.tl98
-rw-r--r--tests/012/stack.tl50
-rw-r--r--tests/012/stack2.expected1
-rw-r--r--tests/012/stack2.txr9
-rw-r--r--tests/012/struct.expected0
-rw-r--r--tests/012/struct.tl44
-rw-r--r--tests/012/stslot.expected0
-rw-r--r--tests/012/syms.expected6
-rw-r--r--tests/012/syms.tl28
-rw-r--r--tests/012/syntax.tl74
-rw-r--r--tests/012/type.tl68
-rw-r--r--tests/012/typecase.tl18
-rw-r--r--tests/012/use-as.tl39
-rw-r--r--tests/013/chksum.tl40
-rw-r--r--tests/013/maze.expected118
-rw-r--r--tests/013/maze.tl16
-rw-r--r--tests/013/rand.tl84
-rw-r--r--tests/013/well512a.expected16
-rw-r--r--tests/013/well512a.tl8
-rw-r--r--tests/014/dgram-stream.expected0
-rw-r--r--tests/014/dgram-stream.tl8
-rw-r--r--tests/014/in6addr-str.tl120
-rw-r--r--tests/014/inaddr-str.tl78
-rw-r--r--tests/014/sockaddr-str.tl49
-rw-r--r--tests/014/socket-basic.expected0
-rw-r--r--tests/014/socket-basic.tl19
-rw-r--r--tests/014/socket-misc.tl20
-rw-r--r--tests/014/str-addr.tl68
-rw-r--r--tests/015/awk-fconv.tl21
-rw-r--r--tests/015/awk-fields.tl37
-rw-r--r--tests/015/awk-misc.tl10
-rw-r--r--tests/015/awk-redir.tl42
-rw-r--r--tests/015/awk-res.tl8
-rw-r--r--tests/015/comb.tl443
-rw-r--r--tests/015/esc.tl39
-rw-r--r--tests/015/lazy-str.tl98
-rw-r--r--tests/015/match-str.tl69
-rw-r--r--tests/015/split.expected0
-rw-r--r--tests/015/split.tl117
-rw-r--r--tests/015/str.tl28
-rw-r--r--tests/015/trie.tl58
-rw-r--r--tests/015/trim.tl41
-rw-r--r--tests/016/arith.expected0
-rw-r--r--tests/016/arith.tl341
-rw-r--r--tests/016/conv.tl50
-rw-r--r--tests/016/ud-arith.expected0
-rw-r--r--tests/016/ud-arith.tl96
-rw-r--r--tests/017/bitfields.tl607
-rw-r--r--tests/017/carray.tl16
-rw-r--r--tests/017/ffi-misc.expected0
-rw-r--r--tests/017/ffi-misc.tl104
-rw-r--r--tests/017/flexstruct.tl73
-rw-r--r--tests/017/glob-carray.tl2
-rw-r--r--tests/017/glob-zarray.tl2
-rw-r--r--tests/017/mmap.tl52
-rw-r--r--tests/017/pack-align.tl112
-rw-r--r--tests/017/realpath.tl9
-rw-r--r--tests/017/setjmp.expected4
-rw-r--r--tests/017/setjmp.tl47
-rw-r--r--tests/017/str-s.tl11
-rw-r--r--tests/017/variadic.expected1
-rw-r--r--tests/017/variadic.tl6
-rw-r--r--tests/018/chmod.expected0
-rw-r--r--tests/018/chmod.tl36
-rw-r--r--tests/018/clean.expected100
-rw-r--r--tests/018/clean.tl10
-rw-r--r--tests/018/close-delegate.expected6
-rw-r--r--tests/018/close-delegate.tl40
-rw-r--r--tests/018/close-lazy.tl3
-rw-r--r--tests/018/combine-tlo.tl27
-rw-r--r--tests/018/crypt.tl23
-rw-r--r--tests/018/errno.tl8
-rw-r--r--tests/018/forkflush.expected12
-rw-r--r--tests/018/forkflush.tl36
-rw-r--r--tests/018/format.tl273
-rw-r--r--tests/018/getput.tl33
-rw-r--r--tests/018/glob.tl142
-rw-r--r--tests/018/gzip.tl59
-rw-r--r--tests/018/noclose.expected1
-rw-r--r--tests/018/noclose.txr16
-rw-r--r--tests/018/path-equal.tl17
-rw-r--r--tests/018/path-safe.tl105
-rw-r--r--tests/018/path-test.tl22
-rw-r--r--tests/018/path.tl320
-rw-r--r--tests/018/process.tl36
-rw-r--r--tests/018/rel-path.tl25
-rw-r--r--tests/018/sh-esc.tl58
-rw-r--r--tests/019/comp-bugs.tl6
-rw-r--r--tests/019/compile-package.tl7
-rwxr-xr-xtests/019/data/a3
-rwxr-xr-xtests/019/data/a.tl1
-rwxr-xr-xtests/019/data/a.tlo2
-rwxr-xr-xtests/019/data/a.txr3
-rwxr-xr-xtests/019/data/b.tl1
-rwxr-xr-xtests/019/data/b.tlo2
-rwxr-xr-xtests/019/data/b.txr3
-rwxr-xr-xtests/019/data/c.tl1
-rwxr-xr-xtests/019/data/c.txr3
-rw-r--r--tests/019/data/program.tl5
-rw-r--r--tests/019/load-args.tl72
-rw-r--r--tests/019/load-hook.tl28
-rw-r--r--tests/019/load-ret.tl23
-rw-r--r--tests/019/load-ret/bad.tl1
-rw-r--r--tests/019/load-ret/module.tl1
-rw-r--r--tests/019/load-ret/module2.tl2
-rw-r--r--tests/019/load-ret/script.tl1
-rw-r--r--tests/019/load-search.tl69
-rw-r--r--tests/019/load-time.tl30
-rw-r--r--tests/019/pct-fun.expected18
-rw-r--r--tests/019/pct-fun.tl42
-rw-r--r--tests/019/progv.tl29
-rw-r--r--tests/019/redef.tl23
-rw-r--r--tests/019/symbol-value.tl24
-rw-r--r--tests/common.tl102
-rw-r--r--tests/load-hook.tl4
-rw-r--r--time.c591
-rw-r--r--time.h53
-rw-r--r--tl.vim1256
-rw-r--r--tree.c697
-rw-r--r--tree.h53
-rw-r--r--txr.129704
-rw-r--r--txr.c483
-rw-r--r--txr.h29
-rw-r--r--txr.vim1279
-rwxr-xr-xtxrtags.tl422
-rw-r--r--unwind.c216
-rw-r--r--unwind.h169
-rw-r--r--utf8.c88
-rw-r--r--utf8.h31
-rw-r--r--vm.c301
-rw-r--r--vm.h31
-rw-r--r--vmop.h107
-rwxr-xr-xwin/cleansvg.txr2
-rw-r--r--y.tab.c.patch28
-rw-r--r--y.tab.c.shipped7997
-rw-r--r--y.tab.h.shipped186
382 files changed, 91896 insertions, 20254 deletions
diff --git a/HACKING b/HACKING
index 127bf7cb..caa7501c 100644
--- a/HACKING
+++ b/HACKING
@@ -5,44 +5,43 @@ CONTENTS:
SECTION LINE
-0. Overview 48
-
-1. Coding Practice 55
-1.2 Program File Structure 78
-1.3 Style 92
-1.3 Error Handling 154
-1.4 I/O 167
-1.5 Type Safety 177
-1.6 Regression 219
-
-2. Dynamic Types 228
-2.1 Two Kinds of Values 235
-2.1 Pointer Bitfield 246
-2.2 Heap Objects 269
-2.3 The COBJ type 289
-2.4 Strings 306
-2.4.1 Encapsulated C Strings 321
-2.4.2 Representation Hacks for 2-byte wchar_t 365
-2.4.3 Representation hacks for 4-byte wchar_t that is 2-byte aligned 423
-
-3. Garbage Collection 433
-3.1 Root Pointers 451
-3.2 GC-safe Code 474
-3.2.1 Rule One: Full Initialization 500
-3.2.2 Rule Two: Make it Reachable 529
-3.3 Weak Reference Support 717
-3.4 Finalization 760
-3.5 Generational GC 784
-3.5.2 Representation of Generations 793
-3.5.3 Basic Algorithm 829
-3.5.4 Handling Backpointers 864
-3.5.5 Generational GC and Finalization 942
-
-4. Debugging 971
-4.2. Debugging the Yacc-generated Parser 1102
-4.3. Debugging GC Issues 1115
-4.4 Object Breakpoint 1138
-4.5 Valgrind: Your Friend 1157
+0. Overview 47
+
+1. Coding Practice 54
+1.2 Program File Structure 95
+1.3 Style 109
+1.3 Error Handling 171
+1.4 I/O 184
+1.5 Type Safety 194
+1.6 Regression 236
+
+2. Dynamic Types 245
+2.1 Two Kinds of Values 252
+2.1 Pointer Bitfield 263
+2.2 Heap Objects 286
+2.3 The COBJ type 306
+2.4 Strings 323
+2.4.1 Encapsulated C Strings 338
+2.4.2 Representation Hacks for 2-byte wchar_t 382
+
+3. Garbage Collection 441
+3.1 Root Pointers 459
+3.2 GC-safe Code 482
+3.2.1 Rule One: Full Initialization 508
+3.2.2 Rule Two: Make it Reachable 537
+3.3 Weak Reference Support 725
+3.4 Finalization 768
+3.5 Generational GC 792
+3.5.2 Representation of Generations 801
+3.5.3 Basic Algorithm 837
+3.5.4 Handling Backpointers 872
+3.5.5 Generational GC and Finalization 950
+
+4. Debugging 979
+4.2. Debugging the Yacc-generated Parser 1110
+4.3. Debugging GC Issues 1123
+4.4 Object Breakpoint 1146
+4.5 Valgrind: Your Friend 1165
0. Overview
@@ -57,11 +56,29 @@ provide rationale and make coding recommendations.
1.1 Language
Txr is written in a language that consists of the common dialect between C90
-and C++98. The code can be built with either the GNU C compiler or the GNU C++
-compiler. Use is made of some Unix functions from before Unix95, which are
-requested by means of -D_XOPEN_SOURCE (POSIX.1, POSIX.2, X/Open Portability
-Guide 4). Also, the <wchar.h> header is used, which was introduced by a 1995
-addendum to the C language, so it may be said that the actual C dialect is C95.
+and C++98, with some GCC extensions, such as:
+
+- initializing structure members with values not computable at load-time
+- converting between object and function pointers
+- certain extensions detected by the configure script as working, such
+ as the long long type
+- bitfields of an enum type rather than int.
+
+The code can be built with either the GNU C compiler or the GNU C++
+compiler.
+
+Use is made of numerous library functions which are detected by the configure
+script without regard for dialect. For instance, some C99 mathematics functions
+are used, if available, as well as numerous POSIX functions. Effectively, these
+can be regarded as extensions to the C90 language, since they are revealed in
+the headers and library linkage.
+
+The <inttypes.h> header isn't used, though there is a reference to it in
+the Flex-generated scanner, active only if that is compiled in C99 mode.
+
+The <wchar.h> header is used, which was introduced by a 1995 addendum to the C
+language, so it may be said that the actual C dialect is C95 with some
+extensions.
In coding new features or fixing bugs, care must be taken to preserve this.
Code must continue to compile as C and C++, and not increase the portability
@@ -420,15 +437,6 @@ The wref macro hides the displacement of the first character:
On a platform where this hack isn't needed, these w* macros are no-ops.
-2.4.3 Representation hacks for 4-byte wchar_t that is 2-byte aligned
-
-On the LLVM compiler on OS X, I ran into the issue that although wchar_t
-is four byte aligned, the compiler neglects to make wide string literals
-four byte aligned. Cases occur of misaligned literals.
-
-The solution is to borrow some of the logic that is used for handling
-two-byte wchar_t. The data is similarly padded, and an adjustment calculation
-takes place similarly to recover the pointer.
3. Garbage Collection
diff --git a/INSTALL b/INSTALL
index f98524ce..e725dbd3 100644
--- a/INSTALL
+++ b/INSTALL
@@ -35,12 +35,17 @@ directory, for instance like this:
$ mkdir build-txr
$ cd build-dir
- build-dir $ ../txr-039/configure
+ build-dir $ ../txr/configure
-If you're going to be making changes to txr, it's easier to build in the same
-directory, but to build txr for multiple architectures, or multiple kinds of
-builds at the same time (e.g. optimized or unoptimized) it's useful to follow
-the separate-directory approach.
+If you're going to be making changes to txr, it's easier to build in the
+source directory, but to build txr for multiple architectures, or multiple
+kinds of builds at the same time it's useful to follow the separate-directory
+approach.
+
+On that topic, note that TXR supports building optimized and unoptimized in the same tree;
+using "make txr-dbg", you can build an optimized debug target. The regular
+build places object files in the opt/ subdirectory; the unoptimized objects
+are placed into dbg/.
Run configure --help to see an explanation of what options are available and
what are their default values. If you aren't cross-compiling, you probably
@@ -104,6 +109,36 @@ compiler_prefix and tool_prefix will have to have a leading slash.
These variables are just catenated together.
+1.2. Handling the .tl files in Cross-Compiling
+
+During ordinary non-cross compilation, when the txr executable is built,
+that executable is then used to compile numerous .tl files in the standard
+library, producing .tlo files. These filesa are architecture-independent, and
+therefore do not require cross-compiling per se; however, their dependency on
+the txr executable poses a problem: if the txr executable is cross compiled, it
+cannot be executed.
+
+There are two solutions for this:
+
+Solution 1: build a native txr for the build machine. Then simply copy
+its .tlo files. Suppose the native TXR is built in a directory called
+native-build, and the cross-compiled txr has been built in the cross-build
+directory to the point that the executable exists. Simply:
+
+ cp native-build/stdlib/*.tlo cross-build/stdlib
+
+then change to the cross-build directory and continue the build with
+make install.
+
+Solution 2: build a native txr for the build machine. When building
+the cross-compiled txr, use the TXR make variable to specify the native
+executable:
+
+ make TXR=/path/to/native/txr
+
+The native txr should be the same version. If the version differs, the
+cross-compilation might not work.
+
2. Prefix Selection
One configure variable you may need to set is --prefix. What is a prefix?
diff --git a/LICENSE b/LICENSE
index a876974f..26132713 100644
--- a/LICENSE
+++ b/LICENSE
@@ -2,7 +2,7 @@ The license below covers all of the code comprising the TXR program.
For more information, see the METALICENSE file.
TXR:
- Copyright (C) 2009-2020, Kaz Kylheku.
+ Copyright (C) 2009-2024, Kaz Kylheku.
All rights reserved.
Linenoise:
@@ -10,6 +10,11 @@ Linenoise:
Copyright (c) 2010-2013, Pieter Noordhuis <pcnoordhuis at gmail dot com>
All rights reserved.
+SHA-1:
+ Copyright 1995-1998 WIDE Project (implementor: Jun-ichiro Itoh)
+ All rights reserved.
+ NOTE: three-clause BSD license, not two.
+
SHA-256:
Copyright 2005 Colin Percival
All rights reserved.
diff --git a/LICENSE-CYG b/LICENSE-CYG
index ebeea815..3e2b2e9b 100644
--- a/LICENSE-CYG
+++ b/LICENSE-CYG
@@ -6,11 +6,11 @@ comes from Cygwin. Neither Cygnal nor the GCC redistributable run-time are a
component of TXR; the TXR source code base contains no portion of these
libraries, and other ports of TXR to other platforms do not use them.
-Cygwin is Copyright (C) 1995-2020 Red Hat Inc. and the Cygnal version
+Cygwin is Copyright (C) 1995-2024 Red Hat Inc. and the Cygnal version
is distributed and used with TXR in accordance with the Lesser GNU Public
License (LGPL), Version 3 <https://cygwin.com/COPYING.LIB>.
The Cygnal project is hosted at <http://www.kylheku.com/cygnal>.
The redistributable GCC runtime is also under the Lesser GNU Public License,
-and is Copyright (C) 2020 The Free Software Foundation, Inc.
+and is Copyright (C) 2024 The Free Software Foundation, Inc.
diff --git a/METALICENSE b/METALICENSE
index 88b9cfb2..86f4c6a9 100644
--- a/METALICENSE
+++ b/METALICENSE
@@ -1,4 +1,4 @@
-Copyright (C) 2009-2020, Kaz Kylheku <kaz@kylheku.com>.
+Copyright (C) 2009-2024, Kaz Kylheku <kaz@kylheku.com>.
All rights reserved.
The document named LICENSE specifies the license for the TXR program,
@@ -6,7 +6,7 @@ including the library modules which it it uses, most of which are likewise
BSD licensed.
The MPI library, found in the mpi/ subdirectory, was developed over
-the yeras 1998-2006 by Michael J. Fromberger. Its license consists
+the years 1998-2006 by Michael J. Fromberger. Its license consists
of the mpi/README file, which states:
This software is in the public domain. It is entirely free, and you
@@ -29,6 +29,27 @@ and md5.h files. The permission is compatible with the BSD license,
as it allows unfettered redistribution and use, without any advertizing
clauses.
+SHA-1 routines used in TXR are derived from code written by Jun-ichiro Itoh
+in the 1990s. Their copyright notice attributes them to the WIDE project,
+and licenses them under a three-clause BSD license.
+
+SHA-256 routines used in TXR are derived from code which is
+Copyright 2005 Colin Percival, and available under the same two-clause
+BSD license as TXR.
+
+TXR ships with files (y.tab.c, y.tab.h) generated from the file parser.y using
+GNU Bison. The source file parser.y is the original work of Kaz Kylheku, and
+licensed under the same terms as the rest of TXR. The generated files contain
+all of that material, plus material coming from Bison. The material coming from
+Bison is owned by the Free Software Foundation, distributed under the GPLv3
+license, with a special "Bison exception" which allows unrestricted,
+unencumbered redistribution in source or compiled form, similar to the BSD
+license. That special exception lapses if the material is borrowed for creating
+a parser skeleton for a parser generator program (analogous to Bison). In such
+a situation, the GPLv3 license comes into full force. TXR readily complies with
+this condition; therefore, those two files are compatible with TXR's BSD
+license, and may be redistributed as part of TXR.
+
TXR is ported to Windows with the help of a derivative of the Cygwin library.
For user convenience, a packaged version of TXR includes the CYGWIN1.DLL, in
accordance with the terms of Cygwin's license, the GNU Lesser Public License,
diff --git a/Makefile b/Makefile
index 7ff11c4d..b481c6b9 100644
--- a/Makefile
+++ b/Makefile
@@ -1,4 +1,4 @@
-# Copyright 2009-2020
+# Copyright 2009-2024
# Kaz Kylheku <kaz@kylheku.com>
# Vancouver, Canada
# All rights reserved.
@@ -6,36 +6,40 @@
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
-# 1. Redistributions of source code must retain the above copyright notice, this
-# list of conditions and the following disclaimer.
+# 1. Redistributions of source code must retain the above copyright notice,
+# this list of conditions and the following disclaimer.
#
# 2. Redistributions in binary form must reproduce the above copyright notice,
# this list of conditions and the following disclaimer in the documentation
# and/or other materials provided with the distribution.
#
-# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-# DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-# OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+-include config.make
+
+ifeq ($(parallelmake),)
.NOTPARALLEL:
+endif
--include config.make
+.DELETE_ON_ERROR:
VERBOSE :=
-TXR_CFLAGS := $(CFLAGS)
-TXR_CFLAGS += -iquote . $(if $(top_srcdir), -iquote $(top_srcdir)) \
- $(LANG_FLAGS) $(DIAG_FLAGS) \
- $(DBG_FLAGS) $(PLATFORM_CFLAGS) $(EXTRA_FLAGS)
+TXR_CFLAGS := -iquote . $(if $(top_srcdir), -iquote $(top_srcdir)) \
+ $(LANG_FLAGS) $(DIAG_FLAGS) $(DBG_FLAGS) $(PLATFORM_CFLAGS) \
+ $(EXTRA_FLAGS) $(CFLAGS) $(CPPFLAGS)
TXR_CFLAGS := $(filter-out $(REMOVE_FLAGS),$(TXR_CFLAGS))
-TXR_LDFLAGS := $(LDFLAGS)
-TXR_LDFLAGS += -lm $(CONF_LDFLAGS) $(PLATFORM_LDFLAGS) $(EXTRA_LDFLAGS)
+TXR_LDFLAGS := $(CONF_LDFLAGS) $(PLATFORM_LDFLAGS) $(EXTRA_LDFLAGS) $(LDFLAGS)
+TXR_LDLIBS := -lm $(CONF_LDLIBS) $(PLATFORM_LDLIBS) $(EXTRA_LDLIBS) $(LDLIBS)
ifneq ($(subst g++,@,$(notdir $(TXR_CC))),$(notdir $(TXR_CC)))
TXR_CFLAGS := $(filter-out -Wmissing-prototypes -Wstrict-prototypes,$(TXR_CFLAGS))
@@ -51,9 +55,10 @@ EXTRA_OBJS-y :=
OBJS := txr.o lex.yy.o y.tab.o match.o lib.o regex.o gc.o unwind.o stream.o
OBJS += arith.o hash.o utf8.o filter.o eval.o parser.o rand.o combi.o sysif.o
-OBJS += args.o lisplib.o cadr.o struct.o itypes.o buf.o jmp.o protsym.o ffi.o
-OBJS += strudel.o vm.o chksum.o chksums/sha256.o chksums/crc32.o chksums/md5.o
-OBJS += tree.o
+OBJS += args.o autoload.o cadr.o struct.o itypes.o buf.o jmp.o protsym.o ffi.o
+OBJS += strudel.o vm.o tree.o time.o psquare.o
+OBJS += chksum.o chksums/sha1.o chksums/sha256.o chksums/crc32.o chksums/md5.o
+OBJS += linenoise/linenoise.o
OBJS-$(debug_support) += debug.o
OBJS-$(have_syslog) += syslog.o
OBJS-$(have_glob) += glob.o
@@ -61,25 +66,27 @@ OBJS-$(have_ftw) += ftw.o
OBJS-$(have_posix_sigs) += signal.o
OBJS-$(have_sockets) += socket.o
OBJS-$(have_termios) += termios.o
-OBJS-$(have_termios) += linenoise/linenoise.o
+OBJS-$(have_zlib) += gzio.o
EXTRA_OBJS-$(add_win_res) += win/txr.res
-STDLIB_SRCS := $(wildcard share/txr/stdlib/*.tl)
+STDLIB_SRCS := $(wildcard stdlib/*.tl)
STDLIB_TLOS := $(patsubst %.tl,%.tlo,$(STDLIB_SRCS))
-STDLIB_EARLY_PATS := %/error.tlo # these must be compiled first
-STDLIB_EARLY_TLOS := $(filter $(STDLIB_EARLY_PATS),$(STDLIB_TLOS))
+STDLIB_EARLY_TLOS := $(addprefix stdlib/,optimize.tlo param.tlo \
+ compiler.tlo place.tlo asm.tlo)
STDLIB_LATE_TLOS := $(filter-out $(STDLIB_EARLY_TLOS),$(STDLIB_TLOS))
ifneq ($(have_git),)
SRCS := $(addprefix $(top_srcdir),\
$(filter-out lex.yy.c y.tab.c y.tab.h,\
- $(shell git $(if $(top_srcdir), \
- --work-tree=$(top_srcdir)) \
+ $(shell git $(if $(top_srcdir),\
+ --work-tree=$(top_srcdir)) \
--git-dir=$(top_srcdir).git \
- ls-files "*.c" "*.h" "*.l" "*.y")))
+ ls-files "*.c" "*.h" "*.l" "*.y")))
endif
+SHIPPED := lex.yy.c y.tab.c y.tab.h
+
# MPI objects
MPI_OBJ_BASE=mpi.o
@@ -93,12 +100,6 @@ OBJS := $(DBG_OBJS) $(OPT_OBJS)
TXR := ./$(PROG)
-ifneq ($(yacc_is_newer_bison),)
-YACC_FLAGS := -Wno-yacc -Wno-deprecated
-else
-YACC_FLAGS :=
-endif
-
.SUFFIXES:
MAKEFLAGS += --no-builtin-rules
@@ -108,18 +109,12 @@ ABBREV = $(if $(VERBOSE),\
@:,\
@printf "%s %s -> %s\n" $(1) \
"$(patsubst $(top_srcdir)%,%,$<)" $@)
-# Filtering out $(DEP_$@) allows the abbreviated output to show just the direct
-# prerequisites without the long laundry list of additional dependencies.
ABBREVN = $(if $(VERBOSE),\
@:,\
@printf "%s %s -> %s\n" $(1) \
- "$(patsubst $(top_srcdir)%,%,$(filter-out $(DEP_$@),$^))" $@)
+ "$(patsubst $(top_srcdir)%,%,$^)" $@)
ABBREV3 = $(if $(VERBOSE),@:,@printf "%s %s -> %s\n" $(1) "$(3)" $(2))
-
-define DEPGEN
-$(V)sed ':x; /\\$$/ { N; s/\\\n//; tx }' < $(1) | \
- sed -e '1s/^/DEP_/' -e '1s/: [^ ]\+/ :=/' > $(1:.d=.v)
-endef
+ABBREV3SH = $(if $(VERBOSE),:,printf "%s %s -> %s\n" $(1) "$(3)" $(2))
define SH
$(if $(VERBOSE), \
@@ -138,29 +133,28 @@ endef
define COMPILE_C_WITH_DEPS
$(call ABBREV,CC)
-$(call SH,mkdir -p $(dir $@))
$(call SH,$(TXR_CC) -MMD -MT $@ $(1) $(TXR_CFLAGS) -c -o $@ $<)
-$(call DEPGEN,${@:.o=.d})
endef
define LINK_PROG
$(call ABBREVN,LINK)
-$(call SH,$(TXR_CC) $(1) $(TXR_CFLAGS) -o $@ $^ $(TXR_LDFLAGS))
+$(call SH,$(TXR_CC) $(1) $(TXR_CFLAGS) $(TXR_LDFLAGS) -o $@ $^ $(TXR_LDLIBS))
endef
define WINDRES
$(call ABBREV,RES)
-$(call SH,mkdir -p $(dir $@))
$(call SH,windres -O coff -DTXR_VER=$(txr_ver) $< $@)
endef
define COMPILE_TL
$(call ABBREV,TXR)
-$(call SH,$(TXR) -e \
- "(progn (in-package sys) (compile-file \"$<\" \"$@.tmp\"))")
+$(call SH,rm -f $@.tmp)
+$(call SH,$(TXR) --in-package=sys --compile=$<:$@.tmp)
$(call SH,mv $@.tmp $@)
endef
+LN := ln
+
ifneq ($(top_srcdir),)
dbg/%.o: $(top_srcdir)%.c
$(call COMPILE_C_WITH_DEPS,$(DBG_ONLY_FLAGS))
@@ -193,7 +187,7 @@ dbg/%-win.o: $(top_srcdir)%.c
opt/%-win.o: $(top_srcdir)%.c
$(call COMPILE_C_WITH_DEPS, $(OPT_FLAGS))
-win/%.res: $(top_srcdir)win/%.rc $(top_srcdir)win/%.ico
+win/%.res: $(top_srcdir)win/%.rc $(top_srcdir)win/%.ico | win
$(call WINDRES)
%.tlo: %.tl | $(PROG)
@@ -215,17 +209,15 @@ ifneq ($(wildcard $(top_srcdir)/config.h $(top_srcdir)/y.tab.h),)
.PHONY: tainted
tainted:
$(V)echo "Source directory $(top_srcdir) is in a configured state."
- $(V)echo "Generated files there with interfere with the build here."
- $(V)echo "Please do a \"make distclean\" in $(top_srcdir) first."
+ $(V)echo "Generated files there will interfere with the build here."
+ $(V)echo "Please run \"make distclean\" in $(top_srcdir) first."
$(V)exit 1
endif
endif
.PHONY: all
-all: $(BUILD_TARGETS) $(STDLIB_TLOS)
-
-$(STDLIB_LATE_TLOS): | $(STDLIB_EARLY_TLOS)
+all: $(BUILD_TARGETS) $(STDLIB_EARLY_TLOS) $(STDLIB_LATE_TLOS)
$(PROG): $(OPT_OBJS) $(EXTRA_OBJS-y)
$(call LINK_PROG,$(OPT_FLAGS))
@@ -239,40 +231,36 @@ $(PROG)-win: $(patsubst %/txr.o,%/txr-win.o,$(OPT_OBJS)) $(EXTRA_OBJS-y)
$(PROG)-win-dbg: $(patsubst %/txr.o,%/txr-win.o,$(DBG_OBJS)) $(EXTRA_OBJS-y)
$(call LINK_PROG,-mwindows)
-# Newline constant
-define NL
-
-
-endef
+# Pull in dependencies
+-include $(OBJS:.o=.d)
-CM := ,
+# Rebuild if config.make changes.
+$(OBJS) $(EXTRA_OBJS-y): config.make
-define DEP
-$(1): $(2)
+# Parser dependencies
+opt/lex.yy.o opt/txr.o opt/match.o opt/parser.o: y.tab.h
+dbg/lex.yy.o dbg/txr.o dbg/match.o dbg/parser.o: y.tab.h
-$(eval $(foreach item,$(1),DEP_$(item) += $(2)$(NL)))
-endef
+opt/lex.yy.o: lex.yy.c
+dbg/lex.yy.o: lex.yy.c
-# Pull in dependencies
--include $(OBJS:.o=.d) $(OBJS:.o=.v)
+opt/y.tab.o: y.tab.c
+dbg/y.tab.o: y.tab.c
-# Add dependencies
-$(call DEP,$(OBJS) $(EXTRA_OBJS-y),config.make config.h)
+# Turn each directory in the object file tree into target built by mkdir -p
+$(sort $(foreach name,$(OBJS),$(dir $(name)))) win:
+ $(call SH,mkdir -p $@)
-$(eval $(foreach item,lex.yy.o txr.o match.o parser.o,\
- $(call DEP,opt/$(item) dbg/$(item),y.tab.h)))
+# Make each object file depend on its own directory, so that it's created.
+$(foreach obj,$(OBJS),$(eval $(obj): | $(dir $(obj))))
-$(eval $(foreach item,y.tab.c y.tab.h lex.yy.c,\
- $(call DEP,$(item),config.make config.h)))
-
-BS_LIC_FROM := ^[/][*] Bison impl
-BS_LIC_TO := Bison. [*][/]
+ifeq ($(maintainer),y)
lex.yy.c: $(top_srcdir)parser.l
$(call ABBREV,LEX)
$(call SH,rm -f $@)
$(call SH, \
- if $(TXR_LEX) $(LEX_DBG_FLAGS) $< ; then \
+ if $(TXR_LEX) $(LEX_DBG_FLAGS) $< ; then \
sed -e s@//.*@@ < $@ > $@.tmp ; \
mv $@.tmp $@ ; \
else \
@@ -280,37 +268,32 @@ lex.yy.c: $(top_srcdir)parser.l
fi)
$(call SH,chmod a-w $@)
-y.tab.h: y.tab.c
- $(call SH, \
- if ! [ -e y.tab.h ] ; then \
- echo "Someone removed y.tab.h but left y.tab.c" ; \
- echo "Remove y.tab.c and re-run make" ; \
- exit 1 ; \
- fi)
-
-y.tab.c: $(top_srcdir)parser.y
+%.tab.c %.tab.h: $(top_srcdir)parser.%
$(call ABBREV,YACC)
+ $(call SH,rm -f y.tab.c y.tab.h)
$(call SH, \
- if [ -e y.tab.h ]; then mv y.tab.h y.tab.h.old ; fi)
- $(call SH,rm -f y.tab.c)
- $(call SH, \
- if $(TXR_YACC) $(YACC_FLAGS) -v -d $< ; then \
- grep -qs '$(BS_LIC_FROM)' y.tab.c && \
- grep -qs '$(BS_LIC_TO)' y.tab.c && \
- sed -e '/$(BS_LIC_FROM)/$(CM)/$(BS_LIC_TO)/d' \
- < y.tab.c > y.tab.c.tmp && \
- mv y.tab.c.tmp y.tab.c ; \
+ if $(TXR_YACC) -v -d $< ; then \
chmod a-w y.tab.c ; \
- sed -e '/yyparse/d' < y.tab.h > y.tab.h.tmp && \
- mv y.tab.h.tmp y.tab.h ; \
- if cmp -s y.tab.h y.tab.h.old ; then \
- mv y.tab.h.old y.tab.h ; \
- fi ; \
else \
rm y.tab.c ; \
false ; \
fi)
+shipped:
+ $(V)$(foreach NAME,$(SHIPPED), \
+ $(call ABBREV3SH,COPY,$(NAME).shipped,$(NAME)); \
+ cp $(NAME) $(NAME).shipped; \
+ [ -e $(NAME).patch ] && patch < $(NAME).patch || true;)
+
+else
+
+%: $(top_srcdir)%.shipped
+ $(call ABBREV,COPY)
+ $(call SH,rm -f $@)
+ $(call SH,cp $< $@)
+
+endif
+
# Suppress useless sccs id array and unused label warning in byacc otuput.
# Bison-generated parser also tests for this lint define.
$(call EACH_CONF,y.tab.o): TXR_CFLAGS += -Dlint
@@ -332,36 +315,53 @@ opt/txr-win.o: TXR_CFLAGS += -DPROG_NAME=\"$(PROG)-win\" \
-DTXR_REL_PATH=\"$(bindir_rel)/$(PROG)-win$(EXE)\"
dbg/txr-win.o: TXR_CFLAGS += -DPROG_NAME=\"$(PROG)-win-dbg\" \
-DTXR_REL_PATH=\"$(bindir_rel)/$(PROG)-win-dbg$(EXE)\"
+
+old_build_id=$(shell cat .build_id 2> /dev/null)
+ifneq ($(build_id_exp),$(old_build_id))
+$(shell rm -f $(call EACH_CONF,txr.o txr-win.o))
+endif
+$(shell printf "%s" "$(build_id_exp)" > .build_id)
+
+ifneq ($(build_id_exp),)
+$(call EACH_CONF,txr.o txr-win.o): TXR_CFLAGS += -DTXR_BUILD_ID=\"$(build_id_exp)\"
+endif
$(call EACH_CONF,txr.o txr-win.o): TXR_CFLAGS += -DEXE_SUFF=\"$(EXE)\"
$(call EACH_CONF,txr.o txr-win.o): TXR_CFLAGS += -DTXR_VER=\"$(txr_ver)\"
$(call EACH_CONF,linenoise/linenoise.o): TXR_CFLAGS += -D$(termios_define)
-.PHONY: rebuild clean repatch clean-tlo distclean
+.PHONY: rebuild clean clean-tlo distclean
ifeq ($(PROG),)
-rebuild clean repatch: notconfigured
+rebuild clean: notconfigured
distclean:
$(V)echo "executing generic cleanup for non-configured directory"
- rm -f txr txr.exe txr-dbg txr-dbg.exe txr-win.exe txr-win-dbg.exe
- rm -rf y.tab.c lex.yy.c y.tab.h y.output
- rm -rf config opt dbg share/txr/stdlib/*.tlo* run.sh
- rm -f config.* reconfigure
- rm -rf mpi-1.?.?
+ rm -f txr txr.exe txr-dbg txr-dbg.exe txr-win.exe txr-win-dbg.exe .build_id
+ rm -f y.tab.c lex.yy.c y.tab.h y.output
+ rm -rf opt dbg tst
+ rm -f stdlib/*.tlo run.sh
+ rm -f config.h config.make reconfigure txr-manpage.html txr-manpage.pdf
+ # artifacts from prior versions of TXR
+ rm -rf config config.* share/txr/stdlib mpi-1.?.?
+ -rmdir share/txr
+ -rmdir share
else
-rebuild: clean repatch $(PROG)
+rebuild: clean $(PROG)
-clean: conftest.clean clean-tlo
+clean: conftest.clean clean-c clean-tlo
+
+clean-c:
rm -f $(PROG)$(EXE) $(PROG)-dbg$(EXE) y.tab.c lex.yy.c y.tab.h y.output
rm -f y.tab.h.old
- rm -f $(PROG)-win$(EXE) $(PROG)-win-dbg$(EXE)
- rm -rf opt dbg $(EXTRA_OBJS-y) run.sh
+ rm -f $(PROG)-win$(EXE) $(PROG)-win-dbg$(EXE) .build_id
+ rm -rf opt dbg tst
+ rm -f $(EXTRA_OBJS-y) run.sh
clean-tlo:
rm -f $(STDLIB_TLOS)
distclean: clean
- rm -f config.h config.make reconfigure
+ rm -f config.h config.make reconfigure txr-manpage.html txr-manpage.pdf
endif
TESTS_OK := $(addprefix tst/,\
@@ -369,10 +369,23 @@ TESTS_OK := $(addprefix tst/,\
$(patsubst %.txr,%.ok,\
$(wildcard $(addprefix tests/*/*.,txr tl)))))
+ifneq ($(have_ubsan),)
+TESTS_OK := $(filter-out %/012/stack.ok,$(TESTS_OK))
+endif
+
.PHONY: tests
tests: $(TESTS_OK)
$(V)echo "** tests passed!"
+.PHONY: retest
+retest:
+ $(V)rm -rf tst
+ $(V)$(MAKE) tests
+
+%.expected:
+ $(V)touch $@
+
+tst/tests/000/binding.ok: TXR_OPTS := -B
tst/tests/001/%: TXR_ARGS := tests/001/data
tst/tests/001/query-1.ok: TXR_OPTS := -B
tst/tests/001/query-2.ok: TXR_OPTS := -B
@@ -392,10 +405,12 @@ tst/tests/008/configfile.ok: TXR_ARGS := tests/008/configfile
tst/tests/008/students.ok: TXR_ARGS := tests/008/students.xml
tst/tests/008/soundex.ok: TXR_ARGS := soundex sowndex lloyd lee jackson robert
tst/tests/008/filtenv.ok: TXR_OPTS := -B
+tst/tests/008/no-stdin-hang.ok: TXR_OPTS := -n
tst/tests/009/json.ok: TXR_ARGS := $(addprefix tests/009/,webapp.json pass1.json)
tst/tests/010/align-columns.ok: TXR_ARGS := tests/010/align-columns.dat
tst/tests/010/block.ok: TXR_OPTS := -B
tst/tests/010/reghash.ok: TXR_OPTS := -B
+tst/tests/010/eof-status.ok: TXR_OPTS := -B
tst/tests/013/maze.ok: TXR_ARGS := 20 20
tst/tests/018/chmod.ok: TXR_ARGS := tst/tests/018/tempfile
@@ -409,6 +424,10 @@ tst/tests/015/%: TXR_DBG_OPTS :=
tst/tests/016/%: TXR_DBG_OPTS :=
tst/tests/017/%: TXR_DBG_OPTS :=
tst/tests/018/%: TXR_DBG_OPTS :=
+tst/tests/019/%: TXR_DBG_OPTS :=
+tst/tests/019/load-hook.ok: TXR_DBG_OPTS := --free-all
+
+tst/tests/014/dgram-stream.ok: | tst/tests/014/socket-basic.ok
TST_EXPECTED = $(word 2,$^)
TST_OUT = $(patsubst %.expected,tst/%.out,$(TST_EXPECTED))
@@ -421,11 +440,12 @@ tst/%.ok: %.txr %.expected $(TXR)
$(if $(TXR_SCRIPT_ON_CMDLINE), \
$(TXR) $(TXR_DBG_OPTS) $(TXR_OPTS) -c "$$(cat $<)" \
$(TXR_ARGS) > $(TST_OUT), \
- $(TXR) $(TXR_DBG_OPTS) $(TXR_OPTS) $< $(TXR_ARGS) > $(TST_OUT)))
- $(call SH, \
- if ! diff -u $(TST_EXPECTED) $(TST_OUT) ; then \
- exit 1 ; \
- fi)
+ $(TXR) $(TXR_DBG_OPTS) $(TXR_OPTS) $< $(TXR_ARGS) > $(TST_OUT)) ; \
+ case $$? in \
+ ( 0 ) diff -u $(TST_EXPECTED) $(TST_OUT) ;; \
+ ( 13 ) printf "SKIP %s\n" $< ; exit 0 ;; \
+ ( * ) exit 1 ;; \
+ esac)
$(call SH,touch $@)
tst/%.ok: %.tl %.expected $(TXR)
@@ -439,13 +459,6 @@ tst/%.ok: %.tl %.expected $(TXR)
fi)
$(call SH,touch $@)
-.PHONY: tests.clean
-tests.clean:
- rm -rf tst
-
-.PHONY: retest
-retest: tests.clean tests
-
define GREP_CHECK
$(V)if [ $$(grep -E $(1) $(SRCS) | wc -l) -ne $(3) ] ; then \
echo "New '$(2)' occurrences have been found:" ; \
@@ -486,17 +499,28 @@ define INSTALL
done)
endef
+define HARDLINK
+ $(call ABBREV3,HARDLINK,$(1),$(2))
+ $(call SH,$(LN) -f $(1) $(2) || printf "(HARDLINK failed)\n")
+endef
+
PREINSTALL := :
.PHONY: install
install: $(PROG)
$(V)$(PREINSTALL)
$(call INSTALL,0755,txr$(EXE),$(DESTDIR)$(bindir))
+ $(call HARDLINK,\
+ $(DESTDIR)$(bindir)/txr$(EXE),\
+ $(DESTDIR)$(bindir)/txrlisp$(EXE))
+ $(call HARDLINK,\
+ $(DESTDIR)$(bindir)/txr$(EXE),\
+ $(DESTDIR)$(bindir)/txrvm$(EXE))
$(call INSTALL,0444,$(top_srcdir)LICENSE,$(DESTDIR)$(datadir))
$(call INSTALL,0444,$(top_srcdir)METALICENSE,$(DESTDIR)$(datadir))
$(call INSTALL,0444,$(top_srcdir)txr.1,$(DESTDIR)$(mandir)/man1)
$(call INSTALL,0444,\
- $(addprefix share/txr/stdlib/,*.txr *.tl *.tlo),\
+ $(addprefix stdlib/,*.txr *.tl *.tlo),\
$(DESTDIR)$(datadir)/stdlib)
.PHONY: unixtar gnutar zip
@@ -528,7 +552,7 @@ install-tests:
$(call SH, \
(echo "#!/bin/sh" ; \
echo "set -ex" ; \
- echo "cd $(datadir)" ; \
+ echo 'cd "$$(dirname "$$(dirname "$$0")")"' ; \
make -s -n tests VERBOSE=y TXR=$(bindir)/txr) \
> run.sh)
$(call INSTALL,0755,run.sh,$(DESTDIR)$(datadir)/tests)
@@ -542,6 +566,7 @@ txr-manpage.html: txr.1 genman.txr
txr-manpage.pdf: txr.1 checkman.txr
$(TXR) checkman.txr $<
tbl $< | pdfroff -ww -man --no-toc - > $@
+ [ $$SOURCE_DATE_EPOCH ] && $(TXR) pdf-clobber-stamps.tl || true
#
# Special targets used by ./configure
@@ -553,9 +578,6 @@ conftest: conftest.c
conftest2: conftest1.c conftest2.c
$(call LINK_PROG,)
-conftest.syms: conftest.o
- $(TXR_NM) -n -t o -P $^ > $@
-
.PHONY: conftest.yacc
conftest.yacc:
$(V)echo $(TXR_YACC)
@@ -574,8 +596,14 @@ conftest.darwin:
echo yes ; \
fi
+.PHONY: conftest.android
+conftest.android:
+ $(V)if echo | $(CC) -dM -E - | grep -s __ANDROID__ > /dev/null 2>&1 ; then \
+ echo yes ; \
+ fi
+
.PHONY: conftest.clean
conftest.clean:
$(V)rm -f conftest$(EXE) conftest.[co] \
conftest2$(EXE) conftest[12].[oc] \
- conftest.err conftest.syms
+ conftest.err
diff --git a/RELNOTES b/RELNOTES
index 6b0cd21b..839b00cc 100644
--- a/RELNOTES
+++ b/RELNOTES
@@ -1,3 +1,3008 @@
+ TXR 294
+ 2024-03-17
+
+
+ Features
+
+ - Compiler:
+ - Now generates inline code for chained functions and lambdas, such
+ as that arising out of the opip syntax.
+
+ - OOP:
+ - new special method length-< lets a lazy sequence object implement support
+ for being tested with the length-< function (is the length less than a
+ given integer without forcing existence).
+
+ - Lib:
+ - New hist-sort-by function: hist-sort with a mapping function.
+ - New functions cons-count and cons-find.
+ - New function rangeref for obtaining an intermediate value from
+ a range using an integer index as if it were a sequence.
+ - For consistency: because ranges can be treated as sequences.
+
+ - Pattern matching:
+ - End pattern in @(sme) and @(end) can be any pattern now, not
+ a list pattern.
+
+ - Internals:
+ - New framework introduced for gathering items into a sequence,
+ called "seq_iter".
+ - Takes into account the type of sequence being constructed up-front,
+ to avoid the overhead of collecting a list and then coercing it.
+ - Functions that have been improved with seq_build and in some
+ cases seq_iter: keep-keys-if, separate, separate-keys, tuples, mapcar,
+ mappend, mapdo, partition-by, partition-if, partition, split, split*,
+ zip, unique, find, rfind, window-map, append, nconc.
+
+ Bugs
+
+ - stability:
+ - gc problem in iter-begin.
+ - gc problem in sub-str on lazy string arg.
+ - gc issue in eval in code related to binding special variables.
+ - gc correctness issues in make-strlist-input-stream,
+ make-struct, make-lazy-struct, copy-search-tree,
+ make-similar-tree, copy-fun (for VM functions).
+ - build:
+ - fix in configure script for BSD grep.
+ - fixes in ordering issues in compilation of stdlib to actually achieve the
+ shortest bootstrapping time.
+ - ports:
+ - fixes for OpenBSD.
+ - Support PPC64 with Altivec more properly by saving and restoring
+ VR31 register. Fixes a reported failure to build and pass tests.
+ - Not a perfect fix: pragmatic whack-a-mole approach based on
+ empirically seeing which Altivec registers occur in the code,
+ needing saving.
+ - cygwin:
+ - fixed broken handling of drive-relative paths.
+ - handling of termination status in run and sh functions fixed
+ to be like that on POSIX platforms.
+ - documentation:
+ - source parameter of mmap documented.
+ - mmap: too low length confusingly diagnosed: as "zero-sized element type".
+ - hash-eql: always returning zero due to regression.
+ - mapcar, mappend, mapdo: avoid alloca request proportional to number of
+ args, switching to malloc over a certain size.
+ - list-vec: accidental use of int type to hold vector length: fail on
+ 64 bit systems with vectors having more than 4G entries.
+ - misc:
+ - avoid realloc to size zero, since latest ISO C draft makes
+ it undefined behavior.
+ - keep-if: don't report as remove-if in errors.
+
+
+
+ TXR 293
+ 2023-12-28
+
+
+ Features
+
+ - load:
+ - when a top-level load exits by returning from the load block, the block
+ value now becomes termination status of process.
+
+ - JSON:
+ - now supports Lisp comments as an extension.
+
+ - I/O:
+ - New functions read-objects, file-get-objects, file-put-objects,
+ file-append-objects.
+
+ - Hash Tables:
+ - New function hash-join, similar to hash-uni but usefully different.
+
+ Bugs
+
+ - TXR: bug in @{nil ...} variable match.
+ - compiler:
+ - compile-file can now handle top-level forms that
+ perpetrate a non-local exit, without requiring compile-only
+ around them.
+ - optimizer now watches for exceptions during constant folding,
+ similarly to how the front end does.
+ - listener:
+ - several bugs in auto compound expr mode fixed.
+ - perm, rperm, comb, rcomb functions:
+ - now support all sequence types, not only lists, vectors and strings.
+ - comb was skipping combinations: defective function repaired.
+ - glob:
+ - suppress duplicates generated when multiple double
+ star patterns are present (supported by the recent glob*).
+ - fix memory leak that can happen on early exit due to error
+ function performing a nonlocal control transfer.
+ - sh-esc family of functions (recently introduced):
+ - incorrect specifications overhauled.
+ - (rcons ...) print/read consistency issue fixed.
+ - Cygwin: termination status returned by (sh ...) and (run ...)
+ now has the correct integer value, or nil for abnormal exit,
+ like on Linux.
+
+
+
+ TXR 292
+ 2023-11-20
+
+
+ Features
+
+ - Build:
+ - speed up compilation of stdlib with optimal compilation
+ order of several key files.
+ - Revised confusing build instructions in ./configure script.
+ - Makefile improvements:
+ - cruft removed; dependency generation simplified.
+ - mkdir invocations factored out to rule.
+ - DELETE_ON_ERROR: used now.
+
+ - Streams:
+ - A new protocol between the close-stream function and its
+ lower-level implementation allows delegate streams to
+ implement a reference counting discipline for closing.
+ - open-file now supports a "T" mode for O_TMPFILE (on Linux,
+ or anywhere else O_TMPFILE is supported).
+
+ - Sequences:
+ - New functions nested-vec and nested-vec-of for easily
+ constructing (simulated) multi-dimensional arrays.
+ - New mref accessor for multi-dimensional access.
+ - also has a side job calling curried functions.
+ - New csort-group function:
+ - Like sort-group, but uses csort instead of sort for key caching.
+ - New hist-sort function: make histogram of sequence, and sort
+ by descending frequency.
+ - New length-list-< function for testing whether a list is
+ shorter than a given length without traversing it beyond
+ that length.
+ - New length-< function for testing any sequence's length
+ against a value without traversing/forcing the sequence
+ to calculate its length.
+ - ref now documented as accessor, not just function.
+ - del operator now allowed on places that index into sequences
+ implemented by structures:
+ - requires both lambda and lambda-set methods.
+
+ - Strings:
+ - New str-esc function for generic character escaping.
+ - New shell escaping functions: sh-esc, sh-esc-all, sh-esc-dq
+ and sh-esc-sq.
+
+ - Packages
+ - New feature: local symbol renaming
+ - Symbols can be imported under alternative names.
+ - New use-sym-as function and :use-syms-as defpackage clause.
+ - Better idea than nicknaming packages (package-local nicknames).
+
+ - Functional library:
+ - New: left-inserting pipeline operators: lflow, lopip, loand.
+ - New: macros orf and lorf for condensing certain op syntax.
+ - New: tap macro, for expressing side effects in pipelines while passing
+ through the value.
+
+ - Syntactic places:
+ - New: ensure macro evaluates an expression and stores its value
+ into a place, if that place's current value is nil.
+
+ - Pattern matching:
+ - some match-case instances are now transformed into casequal.
+
+ - FFI:
+ - Now provides a setjmp macro, longjmp function as well
+ as a jmp-buf utility function that allocates a jmp-buf.
+ - Now possible to interact with libraries that use longjmp
+ for error aborts like libpng and such.
+
+ - POSIX:
+ - chdir function takes stream or file descriptor, which are
+ handled via fchdir.
+ - New glob* function to complement glob:
+ - glob* supports the ** (double star) operator for recursing,
+ via its own implementation, not relying on glob providing that.
+ - glob* has its own implementation of brace expansion.
+ - New rlink function which is like link, but resolves the target path
+ if it denotes a symlink.
+
+ - Listener:
+ - *listener-sel-inclusive-p* is now default, since most terminals
+ have block cursors by default.
+ - New feature: auto compound expression mode lets you omit
+ the parentheses.
+
+ - Math:
+ - The tofloat and toint functions are now generic via the
+ user-defined arithmetic struct mechanism.
+
+ - JSON:
+ - Allow integer objects to be printed rather than insisting on
+ numbers being floating-point.
+ - Allow lists (including lazy lists) to print as [ ... ]
+ rather than insisting on vectors.
+
+ - Windows Installer:
+ - Does not require admin privileges any more; will install for
+ just the current user if the user isn't admin.
+
+ - Documentation:
+ - big change: new hashing scheme for navigation and doc lookup.
+ - section titles now hashed in a more robust way that is resistant
+ against most kinds of edits.
+ - stdlib/doc-syms.tl file is now gone: one less thing to maintain.
+ - Numerous fixes in manual.
+
+ Bugs
+
+ - Compiler:
+ - numbers now externalized sanely in .tlo files:
+ - compile-file makes sure base 10 is used for integers
+ - floating point numbers written with sufficient precision
+
+ - Loading:
+ - load-args-process bugfix: :compile action must load.
+
+ - Streams:
+ - close-stream caches only successful result from underlying
+ function.
+ - a few close functions underneath close-stream were returning
+ nil in the successful case.
+
+ - OOP:
+ - Fix segfault looking up special method after the static slots
+ table of the type has been resized.
+
+ - Pattern matching:
+ - Missing autoloads for match-error and sys:match-pat-error,
+ causing compiled files containing pattern matching not to load.
+
+ - Awk macro:
+ - prn returns nil
+
+ - Search trees:
+ - bug: tree-delete-specific-node not using key fun.
+
+ - Lib:
+ - Two bugs in flatten* function.
+ - Bug in deletion of (ref ...) place: incorrect when object is list.
+
+ - Crypt:
+ - less strict error token detection for wider platform support.
+
+ - Time:
+ - time-utc and time-local methods must subtract gmtime, not add.
+ - time-parse-utc and time-parse-local, likewise.
+
+ - Build:
+ - Misspelled PLATFORM_LDLIBS corrected.
+ - Fix for _TIME_BITS being tied to _FILE_OFFSET_BITS
+ - Address autoload circular dependency involving stdlib/error.tl
+ that can fail builds under some library build orders.
+
+ - Vim:
+ - Fix lack of recognition for char escapes in quasilit.
+
+
+
+ TXR 291
+ 2023-08-06
+
+
+ Features
+
+ - opip macro:
+ - now supports binding variables which are visible
+ to the rest of the chain.
+
+
+ Bugs
+
+ - symbol-function accessor: not supporting functions whose names are not
+ symbols, like (meth ...)
+ - Regression introduced in TXR 290.
+ - compiler: invalid constant folding of load-time values.
+ - Recent regression.
+ - Pattern Language: in output-side @(repeat), inability to specify :vars
+ together with :counter.
+ - Regression dating back to March 2016.
+
+
+
+ TXR 290
+ 2023-07-29
+
+
+ Features
+
+ - Compiler:
+ - Deeper constant-folding optimizations, assisted
+ by data flow information.
+
+ - Data Integrity:
+ - SHA-1 digest now provided; it is in wide use.
+
+ - Lib:
+ - group-by, group-reduce and unique functions refactored to use sequence
+ iteration.
+
+ - Math:
+ - Numerous C99 math functions now exposed:
+ - cbrt, erf, erfc, exp10, exp2, expm1, gamma, j0, j1, lgamma,
+ log1p, logb, nearbyint, rint, significand, tgamma, y0, y1,
+ copysign, drem, fdim, fmax, fmin, hypot, jn, ldexp, nextafter,
+ remainder, scalb, scalbln, and yn
+ - All of these can be user-defined in a custom arithmetic struct.
+
+ - Environments
+ - Internal representation of top-level environments is simplified,
+ eliminating a level of indirection.
+ - New functions for lexical introspection:
+ - lexical-binding-kind, lexical-fun-binding-kind,
+ lexical-symacro-p and lexical-macro-p.
+
+ Bugs
+
+ - hash: out-of-bounds access in hash-iter-peek function causing instability
+ in hash iteration that depend on this function.
+ - crypt function:
+ - handle libxcrypt failure tokens properly, so that we treat them as an
+ error instead of returnig them to the application.
+ - md5: was totally broken on big endian.
+ - VM: compiled functions were not picking up redefinitions of functions that
+ they call, sticking with the old functions. This issue was uncovered during
+ work on the new representation of top-level environments, which also
+ happens to fix the problem.
+ - pattern matching:
+ - the above VM bug fix means that the double definition of
+ sys:non-triv-pat-p in the pattern matching module is handled right;
+ causing sys:transform-qquote to be expanded using the correct definition
+ of the function, exposing an obscure issue with quasiquoted hash
+ literals.
+ - another bug: variable patterns like @var were not seeing lexical
+ symbol macros, only global symbol macros, global variables and
+ lexical variables.
+ - environments: redefinition of symbol macros was found not to trigger cache
+ invalidation in VM descriptors, causing compiled code to keep seeing
+ the old definitions of the symbol.
+ - lib: the del operator now works with index lists, which is the access
+ notation like [obj '(1 2 4)] for picking out indices.
+ As a result of this, there is a change in semantics in how the
+ replace function handles index lists. If there are fewer replacement
+ items than indices, then instead of stopping, the replace function
+ deletes the specified indices. (Subject to -C option.)
+ - paths: rel-path function was considering empty strings to be
+ absolute paths, causing (rel-path "" "a") to be diagnosed as an
+ invalid mixture of absolute and relative paths.
+ - environments: bugfix in lexical-var-p and lexical-lisp1-binding.
+
+
+
+ TXR 289
+ 2023-07-02
+
+
+ Features
+
+ - TXR Pattern Language:
+ - New @(push) directive uses @(output) syntax to push lines
+ back into input.
+
+ - Pattern Matching:
+ - New match-cond macro.
+
+ - Lib:
+ - New cached sorting functions, for situations when a fairly expensive
+ keyfun is used for sorting.
+
+ - Lisp:
+ - eval takes macro environment.
+ - integers and ranges are function-callable objects
+ - provides succinct indexed access in functional expressions, using
+ integers and ranges as higher-order functions.
+
+ - Hash Tables:
+ - Switched from chained hashing to open-addressing with linear probing.
+ - New hash-map function: populate a hash with keys from a sequence, and
+ values from a function over those keys.
+
+ Bugs
+
+ - hash tables: bug in initial hash mask calculation, caused zero bits,
+ causing some chains not to be used, reducing efficiency.
+
+ - gc bug in vector case of ssort function, causing crash.
+
+ - equal: fix broken cases in equality substitution.
+
+ - range objects were not treated as iterable in some situations,
+ for no good reason: e.g. (take 13 "AA".."BB") didn't work,
+ requiring (take 13 (list-seq "AA".."BB")) as a workaround.
+
+
+
+ TXR 288
+ 2023-06-10
+
+
+ Features
+
+ - Lib:
+ - New keep-keys-if, separate-keys functions.
+
+ - Compiler:
+ - New clean-file function for removing compiled file
+ with name built-in path resolution strategy
+ harmonizing with compile-file.
+ - New compiler option log-level.
+ - level 1: info message when file is compiled.
+ - level 2: info message when top-level form is compiled.
+
+ - Modularization:
+ - New functions load-args-recurse and load-args-process
+ - Handle a build/load command passed in *load-args*.
+ - Provide a disciplined way to structure programs
+ into hierarchical library modules.
+
+ Bugs
+
+ - Obscure in bug in compile-file giving rise to a .tlo
+ that cannot be loaded, under certain conditions.
+
+ - Autoload issue affecting with-compilation-unit,
+ causing compiled files that use with-compilation-unit
+ not to load.
+
+
+
+ TXR 287
+ 2023-06-03
+
+
+ Features:
+
+ - Lisp:
+ - New: progv special operator, similar to Common Lisp's
+
+ - New: compiler-let: binds dynamic variables in the
+ compiler's context, allowing control over the compiler
+ at the expression level.
+ - with-compile-options now implemented using compiler-let.
+
+ - Awk macro:
+ - redirection operators visible in wider scope
+ - new :fun clause for binding functions local to macro.
+
+ - Compiler:
+ - small optimizations: when all local functions in
+ a labels/flet block are unused, the frame is not
+ generated for them.
+
+ - Expander:
+ - Parameter list macros now work in nested lambda lists.
+ (This is also listed below under Bugs.)
+ - New expander-let macro for binding special variables
+ at macro-expansion time.
+ - Allows customization of macros which occur inside,
+ by having them respond to the values of the specials.
+ - Used in TL-WHO port of CL-WHO to fix CL-WHO bugs.
+
+ - Command line:
+ - The -e option evaluates multiple expressions from
+ the same argument string.
+ - They are read together before evaluation, almost
+ as if they were in the same progn.
+
+ - Listener:
+ - Evaluates multiple expressions in command line,
+ instead of complaining about trailing material.
+
+ - Lib:
+ - load function has new features:
+ - extra arguments may be passed to load, which are
+ dynamically bound to a special var called *load-args*
+ - a loaded file can bail early using using
+ (return-from load) or (return-from load <value>)
+ - the interrupted load function will then return that
+ value to its caller.
+ - thus loaded files can behave like functions with
+ arguments and return values.
+
+ Bugs
+
+ - Android: fixes for running on Android 13 via Termux.
+
+ - Environments:
+ - Fixed crash when certain built in variables are removed
+ with makunbound.
+ - Fixed (symbol-value ...) wrongly storing a value to the
+ top-level binding rather than the current dynamic binding.
+ - Fixed bug in the VM: getlx and setlx instructions
+ using dynamic lookup rather than global.
+
+ - Expander:
+ - Fixed bug in empty case of flets/labels causing
+ unrelated symbol macros to be strangely affected.
+ - Parameter list macros now work in nested lambda lists.
+
+ - Awk macro: fixed completely broken redirection operators.
+
+ - Parser:
+ - There is now a proper handler for fatal Flex errors, like
+ when a token is ridiculously long.
+ - Flex-generated default handler prints something and exits.
+ - Our handler throws exception.
+
+
+
+ TXR 286
+ 2023-05-07
+
+
+ Features
+
+ - Hash tables:
+ - some internal code improvements/streamlining
+ - new hash-props function from instantiating a table from
+ alternating key/value arguments, requiring no temporary
+ list to be consed up.
+
+ - Sorting:
+ - New ssort and snsort functions: these are counterparts
+ of sort and nsort which are stable on vector-like
+ sequences.
+ - The nsort and sort function's quicksort
+ implementation now uses the Hoare partitioning
+ scheme instead of Lomuto:
+ - Observed a 21% improvement sorting a randomized
+ vector of a million items.
+ - The quadratic behavior on a sequence consisting
+ of a repeated item is gone.
+
+ - Time:
+ - New time-str-local and time-str-utc functions, which
+ reverse the arguments, for better
+ partial application.
+ - the time argument in time-{fields,struct}-{local,utc} is
+ now optional; if omitted, the current time is used as if
+ by calling (time).
+
+ - Structs:
+ - Small improvement in defstruct: if boa arguments are
+ defined referencing slots that don't exist in any
+ struct, this is now diagnosed.
+
+ - Compiler:
+ - Lots of new optimization work. There is now one more
+ optimization round, and *opt-level* now goes up to 6
+ rather than 7, 7 being the new default value. This
+ release makes 23 compiler commits.
+
+ Bugs
+
+ - Fixed incorrect scope in conda/condlet.
+ - Fixes for regressions preventing the source code of of
+ stdlib/ being used (.tl files, not .tlo), which is needed
+ for debugging some TXR problems.
+ - Fixed issue that happens when code is loaded that
+ generates warnings during error exception processing,
+ causing an "invalid re-entry of exception logic",
+ interfering with debugging TXR using an uncompiled
+ library (.tl files rather than .tlo).
+ - Fixed another issue using .tl files: interference
+ between library loading and the -C compat option.
+ Compatibility is temporarily disabled while
+ auto-loading.
+ - build macro: code rearranged to eliminate circular
+ dependency, preventing modules which depend on the macro
+ from loading.
+ - Pattern matching: ^#S() and ^H(()) quasiquote patterns
+ work now, thanks to a change in the parser.
+ - Compiler:
+ - Fixed incorrect evaluation order of function arguments
+ (when local variables are involved that are subject to
+ side effects during evaluation).
+ - Fixed issue with compiling defmacro:
+ - entire macro form was being retained
+ - yet errors not reported against the correct operator
+ name: e.g. (defstruct) says that defmacro has
+ insufficient arguments.
+ - fix also affects tree-bind and other operators.
+ - Fixes September 2022 regression in liveness
+ calculation, causing certain optimizations to be
+ forgone.
+ - Fixed incorrect blind register renaming across the
+ arguments of a close instruction, which are not
+ actually source operands of that instruction.
+ - Latent problem exposed when trying to replace V
+ register by T register more aggressively.
+ - Fixed incorrect live register calculation across catch
+ instruction.
+ - This has two clobber register operands.
+ - Representation of instruction live info was expanded
+ to handle two register defs.
+
+
+
+ TXR 285
+ 2023-03-28
+
+
+ Features
+
+ - Lib:
+ - time (on platforms that have a timezone field in struct tm):
+ - functions which convert a destructured time into a
+ numeric time, like time-parse-utc, now take the time zone into
+ account, and add a displacement.
+ - functions which format time now via strftime now set the time
+ zone field in the underlying struct tm, so that the %z specifier
+ featured in glibc's strftime can be meaningfully used.
+ - New function: ignore: synonym of nilf, intended for suppressing
+ unbound variable warnings
+ - New function: arithp: tests for arithmetic objects, including
+ ranges and structures with + method.
+ - range/range*: these functions now support non-arithmetic
+ types: e.g (range "AAA" "ZZZ" 2) generates ("AAA" "AAC" ...
+ "ZZW" "ZZY").
+
+ - TXR Pattern Language:
+ - fix exception being thrown in matching a bound variable whose
+ value is a lazy list of strings rather than ordinary list.
+ - e.g. value captured with @(data ...)
+
+ - Structural Pattern Matching:
+ - @nil is now supported in predicates.
+ - @(< @nil 42) is like @(< @a 42) but no variable is bound.
+
+ - Syntax:
+ - The symbol t can be used in macro parameter lists and tree-bind,
+ to specify a pseud-variable which just throws away the
+ corresponding value.
+
+ - Compiler:
+ - New options mechanism:
+ - compile-options struct type
+ - *compile-options* special variable.
+ - with-compile-options macro
+ - New unused variable warnings are on by default.
+
+ Bugs
+
+ - build: fixed regression in building without CONFIG_GEN_GC
+ or CONFIG_DEBUG_SUPPORT, which are 1 by default.
+ - gc:
+ - premature reclamation bug in lisp_parse_impl which is used
+ internally and as the implementation for functions that parse
+ Lisp, regex and JSON.
+ - premature reclamation bug in implementation of FFI enum types:
+ neglect to traverse a struct member during gc marking.
+ - premature bug in constructor for FFI structs: neglect
+ to protect member types from gc in the loop that processes struct
+ members.
+ - printer:
+ - [] object now prints as [] rather than [. nil],
+ which isn't incorrect, just ugly.
+ - search tree objects now print as #T(...) beyond the maximum
+ printing depth, just like #H(...) and others.
+ - Vim:
+ - Fixed syntax highlighting for decimal integers and
+ uninterned symbols.
+
+
+
+ TXR 284
+ 2022-12-30
+
+ Features
+
+ - OOP:
+ - new :inherit clause in defstruct so that inheritance
+ bases can be specified by clauses.
+ - Motivated by clauses being programmable.
+ - Allows defstruct clause macro to bring in bases.
+ - new feature: struct preludes.
+ - preludes can specify clauses to inject into specific
+ defstruct definitions (that have not yet been processed),
+ without those definitions mentioning anything.
+ - purely a macro-expansion-time feature.
+
+ - Lib:
+ - cat-str/join/join-with now allow nested sequences.
+
+ - System Functions:
+ - ftw function: the flags argument now defaults to ftw-phys
+ if omitted (do not follow symbolic links).
+
+ - compiler:
+ - optimizations around catch
+
+ - Awk macro:
+ - result of condition in condition-action clause is avaialble
+ via a new Awk variable named res.
+
+ Bugs
+
+ - Compilation from command line via --compile now
+ sets the self-path variable.
+ - Listener: drop security checks on Windows, where they
+ don't work and generate false positives.
+ - They are geared toward a multi-user system with
+ a bona fide POSIX security and file permission model.
+ - crypt: remove dubious validator.
+ - cannot reproduce the crash issue it was supposed to work around.
+ - read-once: now supports global variables properly.
+ - crypt: fix ridiculous stack usage, caused by giant context
+ structure for glibc's crypt_r.
+ - hashing: negative floating-point zero handled.
+ - math: expt with a zero exponent yields 1.0.
+ - though works that way already on all platforms, it is now documented and
+ assured.
+ - compiler:
+ - some functions were constant folded that must not be, because
+ they are required to allocate fresh objects each time they are called.
+ - an instance of runaway recursion in the compiler was fixed in
+ constant-folding code.
+
+
+
+ TXR 283
+ 2022-10-16
+
+
+ Features
+
+ - Low Level:
+ - NaN boxing now works on Android, in spite of its pointer tagging.
+ - String objects no longer track their storage allocation size
+ on platforms that have malloc_usable_size.
+ - The word of storage in a string object thus made available has not yet
+ been put to a use.
+
+
+ - Lisp:
+ - New %fun% symbol macro provides name of current function.
+ - Separator commas are now allowed in numeric tokens.
+ - New functions
+ - macroexpand-params:
+ - expand parameter list macros made with define-param-expander.
+ - macroexpand-place:
+ - expand place macros made with define-place-macro
+ - macroexpand-match:
+ - expand macro patterns made with defmatch.
+ - macroexpand-struct-clause:
+ - expand defstruct macro clause made with define-struct-clause.
+ - Small performance improvements in function dispatch.
+ - functions with optional arguments no longer put through slow path
+ - this could be listed under Bugs below
+ - helper functions for fixed argument dispatch cases now handle
+ more cases themselves rather than defer to slow path.
+ - use of alloca has been eliminated from the creation of arguments on the
+ stack in cases when the size is statically know.
+
+ - OOP:
+ - new :postfini clause in defstruct, allowing for finalization
+ with order opposite to :fini
+ - relaxation of constraint: defstruct can specify multiple :init,
+ :fini, :postinit and :postfini clauses.
+ - optional arguments :delegate clause now have init expressions
+ that are not ignored, but specify the default value.
+ - thus delegates can now customize the defaulting of
+ optionals rather than being stuck with the target's behavior.
+ - when delegates specify an optional parameter that corresponds
+ to a non-optional target parameter, they can thus now
+ specify a default value, rather than being stuck with nil.
+
+ - Networking:
+ - New sockaddr-str function: parse various textual address
+ types into appropriate type of sockaddr.
+ - New str-addr method in every sockaddr structure,
+ for generating textual address.
+
+ - I/O streams:
+ - new inc-indent-abs function for incrementing absolute
+ indentation, not relatively to current horizontal position.
+
+ - JSON:
+ - JSON printing now uses "standard-style" formatting,
+ if a the newly introduced *print-json-format* variable
+ is set/bound to the value :standard.
+
+
+
+ Bugs
+
+ - build: ./reconfigure issue when ./configure is interrupted.
+ - str-in6addr bug.
+ - hash: don't trim hash seed to 32 bits on 64 bit platforms.
+ - JSON: restore stream indentation state if exception occurs
+ during JSON printing.
+
+
+
+ TXR 282
+ 2022-09-16
+
+
+ Features:
+
+ - New [. expr] syntax. This is also a bugfix because we
+ have been printing (dwim . @sym) as [. @sym] without being able
+ to read that syntax (read-print consitency issue).
+
+ - NaN boxing representation for Lisp values.
+ - enabled by ./configure --nan-boxing
+ - 64 bit platforms only.
+ - allows floating-point values not to be heap-allocated,
+
+ Bugs:
+
+ - compiler:
+ - incorrect scopeing for init expressions of optional parameters.
+ - bug in dead-code elimination causing compile-time exception.
+ - bug in optimizer affecting code generated by prof operator,
+ leading to a wrong result value.
+ - compiler now diagnoses if there are too many variables added
+ to a lexical frame (more than 1024).
+ - numeric ranges in sequence iteration (seq-begin) now work
+ with floating-point values.
+
+
+
+ TXR 281
+ 2022-09-03
+
+
+ Features:
+
+ - Lib:
+ - New search-all library function: like search but finds all matches.
+ - New macro: close-lazy-streams: creates a dynamic contour of code which
+ closes all streams that were bound to lazy conses during its execution.
+
+ - TXR Pattern Language:
+ - The @(next) directive now supports a :noclose modifier.
+ - Because @(next) now closes the stream when it's done processing (see
+ Bugs below), this new feature is required to opt-out of that behavior.
+
+ - Vim:
+ - Improvements to syntax highlighting definitions.
+
+ Bugs
+
+ - ffi: now defends against out-of-range wchar_t values being converted
+ to Lisp character type.
+ - TXR Pattern Language:
+ - When a subquery opens a stream as a data source, that is now closed
+ when that subquery is finished processing.
+
+
+
+ TXR 280
+ 2022-08-09
+
+
+ Bugs
+
+ - Listener:
+ - Fix regression: ~/.txr_history not loading unless ~/.txr_profile exists.
+
+ - Build:
+ - Handle failing hard link operation in "make install" so things
+ work on Android again.
+
+
+
+ TXR 279
+ 2022-08-08
+
+
+ Features
+
+ - Lib
+ - missing count function added.
+ - regsub
+ - now accepts a string in place of the regex,
+ - avoids consing a list of pieces to be catenated; works using string-extend.
+ - gcd function rewritten for efficiency
+ - when arguments fit into a machine word, bignum math is avoided
+
+ - Build/Deployment
+ - make install now creates hard links to the txr executable
+ called txrlisp and txrvm, useful in scripting with unsuffixed files.
+ - txrlisp behaves much like txr --lisp
+ - txrvm behaves much like txr --compiled
+ - compile-file translates txrlisp to txrvm in hash bang line.
+
+ - Path test functions:
+ - All path test functions now use effective UID not real.
+ - New function path-components-safe for validating permissions
+ along an entire path.
+ - Useful for testing whether a path that is supposed to be private
+ is actually properly secured.
+
+ - Listener:
+ - Security checks on .txr_history and .txr_profile have been revised.
+ - Now done with help of path-components-safe in additition to
+ path-private-to-me-p.
+
+ Bugs
+
+ - compile-file:
+ - tries unsuffixed path before adding .tl, like load.
+ - only tries different names on nonexistence error.
+ - other exceptios now propagate out of the function.
+
+
+
+ TXR 278
+ 2022-07-01
+
+
+ Features
+
+ - New str function for making a string filled with
+ repeating pattern.
+ - Syntax: stricter check in for/for* loop syntax.
+ - I/O:
+ - open-fileno (TXR's "fdopen") now takes pid argument, to associate
+ the resulting stream with a process.
+ - close-stream will subsequently wait on that process, and convert
+ the status to a return value or exception.
+ - all I/O convenience functions like command-get-linews
+ now have a mode-opt argument.
+ - For instance "z" can be used for compressed I/O.
+
+ Bugs
+
+ - Build: broken when no HAVE_ZLIB.
+ - Command line: broken --free-all option.
+ - String output streams: GC issue, occuring in some builds.
+ - Listener: properly handle warnings coming out of code that is
+ autoloaded during Tab completion.
+ - Issue seen when working on TXR, with library .tlo files removed,
+ so .tl files are used.
+ - Compiler: failure in optimizer.
+ - Compression: missing "z" support in open-command.
+ - Missing: mode-opt argument of file-get-lines now implemented.
+
+
+
+ TXR LZ77 :-)
+ 2022-05-31
+
+
+ Features
+
+ - Zlib integration:
+ - New "z" mode option in open-file and open-fileno
+ for Deflate compression (reading and writing): reads and writes
+ gzip-compatible files.
+ - Supported in convenience functions like file-put-string,
+ file-get-buf and all those.
+ - buf-compress and buf-decompress functions.
+ - .tlo.gz files recognized by load as compressed.
+ - .tlo.gz files may be catenated just like .tlo files.
+
+ - Lib:
+ - tok-str function takes count argument.
+ - new spln and tokn functions: like spl and tok, but take
+ a count argument limiting pieces returned.
+
+ Bugs
+
+ - tests: load-search test when run as superuser.
+ - configure: don't exit when mmap isn't detected.
+ - stream-set-prop: return t when :name prop set on file stream.
+ - compilation bug in gc.c if HAVE_VALGRIND is on (maintainer mode only).
+ - removed workaround for old Cygwin bug in I/O streams.
+ - tags.tl renamed to txr-tags.tl to avoid name clash with tags file.
+ - cygwin: sh function was wrongly using cmd.exe /c.
+
+
+
+ TXR 276
+ 2022-05-24
+
+
+ Features
+
+ - Syntax:
+ - printer: now nicely prints (a . @b) rather than (a sys:var b)
+ and (a . @(e)) rather than (a sys:expr (e)).
+
+ - Macros:
+ - Subtle new expansion rule allows for more thorough expansion
+ in situations when a macro and function are defined for the
+ same symbol:
+ - When a macro expands into the same-named function call,
+ and that function call's arguments undergo expansion,
+ the result is tried again as the original macro.
+
+ - Command line:
+ - New command line option --compile allows compile-update-file
+ to be invoked more directly, without having to encode a Lisp
+ expression as a command argument.
+ - New command line option --in-package allows a package switch
+ to take place within the command line. This is used by the
+ compilation of stdlib, which takes place in the sys package.
+ - In relation to command line: the message during the handling
+ of an error exception encouraging the --backtrace option to
+ be used is removed. This was a nuisance, and appeared in
+ deployed programs that don't offer such an option.
+
+ - Lib:
+ - split-str now has a count parameter, to limit how many
+ pieces are produced. When the split doesn't use the entire
+ string, the remainder appears as a piece. This improvement
+ was suggested by Paul. A. Patience in January 2022.
+ - The spl function as well as tok-str could use this too;
+ that is postponed to another release.
+ - New trim-path-seps function for removing trailing path
+ separators from a path.
+
+ - FFI:
+ - 64 bit bitfields are now supported. this means integer types which
+ are 64 bits wide can now be be used as the basis of a bitfield,
+ which can therefore be specified as 0 to 64 bits wide.
+ - align operator now only increases alignment.
+ - New pack operator for packing.
+ - (pack (struct s ...)) syntax allows for all members of
+ a struct to be packed.
+ - The endian types like be-uint32 or le-uint16 can now be used as bit
+ fields.
+ - The layout takes place like on the machine of that endian;
+ e.g. be-uint32 bitfields are filled most-significant-bit
+ first.
+ - If a bitfield follows a member of opposite endian, it starts a
+ new storage cell in a fresh byte.
+
+ Bugs
+
+ - lambda-match: issue with variadic pattern.
+ - FFI: bug: all unions were marked as incomplete types.
+ - FFI: bug: empty structs/unions had an alignment of 0; should be 1.
+ - FFI: bug: null terminated strings didn't work as flexible arrays.
+ - copy-path-rec: didn't like trailing slash on source path.
+ - FFI: alignment bug: arrays without a dimension were all treated
+ as having pointer alignment, 4 or 8 byte, rather than inheriting
+ alignment from the element type.
+ - FFI: support for bitfields in the face of alignment and packing.
+ - FFI: bug in internal type cloning function, leaving the type
+ descriptor structure pointing to the original type as its "self",
+ manifesting itself as a wrong result from something like
+ (alignof foo.bar) when foo.bar has a cloned type (e.g. by
+ the align operator).
+ - UTF8: Incredibly, a bug was found: the UTF-8 decoder was silently
+ eating an incomplete character at the end of the input, instead
+ of treating the incomplete sequence as bad bytes, to be mapped
+ into the U+DCxx range. Thus there were binary strings which
+ were not preserved in the decode -> encode round trip.
+ - OOP: Fixed an out-of-bounds stack access in the struct type
+ initialization code which deals with suppressing redundant
+ initializations of repeated multiple-inheritance bases.
+ This more readily affects big-endian systems: showed upon PPC64.
+
+
+
+ TXR 275
+ 2022-05-10
+
+
+ Features
+
+ - Architecture support: RISC-V and Loongarch (64 bit).
+
+ - Hashing: new group-map function: group-reduce with
+ built-in map pass.
+
+ - Lib: new isecp function: test whether two sequences
+ intersect without calculating intersectin.
+
+ - FFI:
+ - intmax-t and uintmax-t types.
+ - new str-s, bstr-s and wstr-s types for receiving foreign
+ string without freeing its memory.
+ - after a FFI call, the arguments are processed for
+ reverse data flows and memory clean-up in reverse order.
+ - with above two features, strtol can be wrapped in FFI,
+ including the error-reporting char **end pointer.
+
+ - Loading: new *load-search-dirs* variable.
+ - default search directory list includes sysrooted lib dir
+
+ Bugs
+
+ - configure: minor escaping corner cases in in production of
+ ./reconfigure script.
+ - compiler: package-related bug in file-compilation, reported
+ by Paul A. Patience.
+ - load: regression: do not try adding suffixes to a path
+ which exists; try the given path before anything else
+ - Reported by Paul A. Patience.
+ - sh, run, open-command and open-process now flush *stdout*
+ in situations when it makes sense, standard output is
+ ordered between the subprocesses and the parent.
+ - listener: Ctrl-Z issue when txr is one of multiple processes
+ in a job control process group.
+
+
+
+ TXR 274
+ 2022-02-24
+
+
+ Features
+
+ - Configure/Build:
+ - 'make clean-c" now cleans the C object files without removing .tlo files.
+ - complementary to "make clean-tlo".
+ - experimental, not tested support for configuring 64 bit time_t on
+ 32 bit Glibc.
+ - CPPFLAGS (C preprocessor flags) variable noticed and used now.
+ - TXR now supports building with -fsanitize=undefined option.
+ - you must specify it yourself via platform-flags, etc.
+ - configure detects it and puts #define HAVE_UBSAN 1 into config.h
+
+ - FFI:
+ - new feature: enumed bitfield type combination now works.
+
+ - Doc:
+ - numerous documentation fixes.
+
+ - Lib:
+ - cptr-int: allow full unsigned range, so pointers can be specified
+ as unsigned integers, or using negative signed values also.
+ - New copy-cptr function; copy copies cptr objects.
+ - New nandf and norf functions.
+ - New function random-sample for one-pass reservoir sampling of a sequence.
+ - load: supports catenated .tlo files now
+ - cat-files: new function for catenating files, like POSIX cat.
+ - find-max uses generic iteration.
+ - new find-max-key function.
+ - new partition-if function.
+ - new list-builder method oust
+ - also local function in build macro
+
+ - Getopts:
+ - various improvements.
+ - opt-help function/method split up into several.
+
+ - Macros:
+ - New etypecase macro.
+ - New nand and nor macros and functions.
+ - opip now allows embedded (ap ...) and so on.
+
+ - Compiler:
+ - new optimizations.
+
+ - TXR Pattern Language:
+ - new function match-fboundp for testing whether a symbol has a binding
+ as a pattern function.
+
+ - Expander:
+ - new @,expr hack: quasiquote generates (sys:var ...) or (sys:expr ...)
+ based on type of substituted value.
+ - macro-time is no longer a special operator, but a macro.
+
+ - Listener:
+ - Hack: Ctrl-V Ctrl-J now inserts CR (i.e. new line in multiline mode) rather than a LF.
+ - Good for people used to inserting line breaks in GNU Readline.
+ - Improvement in method completion.
+
+ - getopts:
+ - Numerous improvements, mainly in area of help generation.
+
+ - Autoloading:
+ - More nuanced implementation with multiple symbol namespaces, reduces spurious
+ loading of modules not actually used.
+
+ Bugs
+
+ - TXR Pattern Language:
+ - bug fixed in @(freeform)
+ - involves bugfix in lazy-str-get-trailing-list function.
+ - filtering now throws when there is an invalid filter,
+ due to a fix in the filter-string-tree function.
+
+ - Parser:
+ - bug: carriage returns in JSON not tolerated.
+
+ - Configure/Build
+ - fixed broken file offset bits detection, resulting in no large
+ file support on 32 bit Glibc platforms (regression since 244).
+ - fixed broken syntax in unwind.h causing build to break if
+ CONFIG_DEBUG_SUPPORT disabled.
+
+ - Macros:
+ - sum-each, mul-each: handle no vars case.
+ - typecase: return nil from formless clauses.
+ - fix broken :key parameters.
+
+ - Lib:
+ - carray: allow t and floating 0 in sub and replace.
+ - carray-replace: two overrun bugs.
+ - separate: wrong return value when seq is nil.
+ - time structure: added missing wday and yday slots.
+
+ - Listener:
+ - bug handling comments in plain mode.
+ - issue handling Ctrl-C in plain mode.
+
+ - Structural Pattern Matching:
+ - quasiliteral match wrongly allowing loose prefix matching.
+ - `@{nil #/regex/}` wrongly throwing exception.
+
+ - Command Line:
+ - -Dvar now binds var to empty string rather than t.
+ - this t was some thing inadvertently introduced in 2014.
+ - -Dvar=foo=bar (value containing equal sign) works.
+ - -Dx,y,z now diagnosed.
+
+ - Vim Syntax Files:
+ - improvement in handling multi-line string literals.
+
+ - Search trees:
+ - fixed two array underruns found by ubsan.
+ - both situations work reliably by fluke in unfixed code due the memory
+ cell below the array reliably being zero bits.
+
+ - PRNG:
+ - undefined behavior (32 bit shift of 32 bit value) in random function.
+
+ - termios:
+ - variables cmspar and crtscts had wrong values on 32 bits due to
+ overflow in initialization.
+
+ - General:
+ - numerous numeric conversion issues identified by ubsan were
+ addressed in various places in the code base.
+ - Missing autoload for *in-compilation-unit* caused loading problem for
+ compiled code making use of with-compilation-unit.
+
+
+
+ TXR 273
+ 2021-12-28
+
+
+ Features
+
+ - compiler:
+ - new jump optimizations.
+ - register compacting optimization: greatly reduces stack use,
+ especially of complex functions, and improves cache locality.
+
+ - pattern language:
+ - @{var /regex/} changes:
+ - regex no longer ignored when var already has binding
+ - text is extracted with regex, then compared to variable
+ - @{var (fun ..)} changes:
+ - (fun ...) now processed in vertical mode if sole item in line.
+ - variable captures lines skipped over in vertical processing.
+ - (fun ...) no longer ignored when var already has binding.
+ - fun executed like in unbound case.
+ - text that would be bound to variable is compared to existing value.
+
+ - structural pattern matching:
+ - in quasiliteral patterns, @{var #/regex/} can specify bound variable now:
+ - matches text in same way as unbound case
+ - matched text must then match content of var
+
+ - lib:
+ - new functions: tuples*, rot, nrot, subq, subq, subqual, subst, pairlis.
+
+ - hash tables:
+ - use 64 bit hash on 64 bit platforms, rather than 32 bit.
+
+ - search trees:
+ - new function tree-count, and length/len works on trees.
+ - duplicate keys supported:
+ - tree, tree-insert, tree-insert-node have optional argument for
+ allowing duplicates.
+ - tree-delete-specific-node allows specific node to be
+ removed, when removing by key is ambiguous.
+ - priority queue support:
+ - tree-min, tree-min-node, tree-del-min, tree-del-min-node
+
+ - oop/structs:
+ - new feature: application-defined struct clause macros.
+ - new: :delegate and :mass-delegate clause macros for
+ generating delegate method boilerplate with minimal code.
+
+ Bugs
+
+ - compiler:
+ - fix non-working (compile '(lambda ...)).
+
+ - buffers:
+ - file-get-buf and command-get-buf use unbuffered I/O
+ to read the exact number of bytes into the buffer,
+ avoiding reading more bytes than requested.
+
+ - case macros (mainly affecting casequal):
+ - fixed 2017 regression causing a key value like ((a b c)),
+ which is the single key (a b c), to be wrongly converted
+ into a list of three keys.
+
+ - each-match, each-prod, sum-each family of macros:
+ - documented and added missing anonymous block
+
+ - maprodo: spurious non-nil return value issue.
+
+ - interpreter: bug in interpreting optional parameters,
+ present in original implementation from 2014 (absent in compiler).
+
+ - iteration: gc stability problem in iter-begin and iter-reset.
+
+ - define-accessor: broken argument handling.
+
+ - less/greater: gaping bug, vectors not supported.
+
+
+
+ TXR 272
+ 2021-11-11
+
+
+ Features:
+
+ - path manipulation:
+ - new path-equal function for comparing paths.
+ - pic macro:
+ - support for digit-separating commas.
+ - support for (...) notation for negative values.
+ - FFI:
+ - internal improvements and minor optimizations.
+ - more ergonomic handling of carray, cptr passed
+ by pointer.
+ - compiler:
+ - now diagnoses constant expressions that throw.
+ - improved elimination of wasteful jmp instructions.
+ - minor new optimization eliminating a wasteful register copy.
+ - PRNG:
+ - new random-float-incl function: like random-float
+ but the range is [0, 1] rather than [0, 1).
+ - syntactic places:
+ - new read-once accessor for caching a place so
+ that it is read only once even by place mutating
+ operators which access it more than once.
+ - ifa macro semantics adjusted to take advantage of read-once.
+
+ Bugs:
+
+ - FFI:
+ - broken range checks in enum types.
+ - bad format calls in enum error handling code.
+ - math:
+ - bad edge cases in 64 bit conversion (affecting
+ 32-bit platforms).
+ - path manipulation:
+ - rel-path bugfixes for native Windows.
+ - printer:
+ - cases where fallback package syms are wrongly
+ printed without package prefix.
+ - compiler:
+ - ordering issue in load-time.
+ - incorrect algebraic transformation of
+ (- a b c ...) minus forms.
+ - incorrect code generation when compiling catch forms.
+ - top-level lambdas no longer captured into D
+ registers:
+ - not strictly a bug, but undesirable behavior that
+ crept in when lambda lifting by load-time was
+ introduced.
+ - syntax:
+ - broken #; syntax for first element of list.
+ - listener:
+ - bug causing incomplete auto-loading of modules
+ during Tab completion.
+ - structural pattern matching:
+ - unquoted quasiliteral patterns now work.
+ - less function:
+ - crash when arguments are symbolic and
+ the right one is nil.
+ - other inconsistent, incorrect behavior for some
+ combinations of symbolic arguments.
+
+
+
+ TXR 271
+ 2021-10-05
+
+
+ Features:
+
+ - load:
+ - new *load-hooks*: defer exeucution to load finish time.
+ - used via push-after-load and pop-after-load
+ - libtags.txr: script for generating extra tags to jump to
+ TXR's C code using Lisp symbols.
+ - lib:
+ - delcons function: destructively remove indicated cons from list.
+ - improvements in string-extend.
+ - set-mask and clear-mask macros: shorter code working with masks.
+ - new module for quantile estimation: see quantile function.
+ - summing and producing variations of each operator:
+ - sum-each-prod, mul-each-prod, sum-each-prod*, mul-each-prod*
+ - path-search: semantics changes.
+ - path access test functions now use read uid/gid rather than
+ effective uid/gid.
+ - new replace-env function.
+ - new *child-env* variable for specifying environment for
+ executed process images.
+ - FFI:
+ - socklen-t type now defined.
+ - ffi macro now generates load-time form to avoid repeated
+ invocation of FFI type compiler.
+ - new cptr-carray function, inverse of carray-cptr.
+ - exceptions:
+ - system exceptions now store errno in exception message.
+ - see string-get-code in doc.
+ - sockets:
+ - socket options now supported via new sock-opt and set-sock-opt.
+ - exception now thrown if socket call fails.
+ - compiler:
+ - one small optimization improvement and internal improvements.
+ - awk:
+ - new :fields feature to give fields names and type conversions.
+
+ Bugs:
+
+ - compiler:
+ - regression in calculation of output path of compiled files.
+ - random perturbation in code generation due to dependency
+ on hash table order in an optimization routine.
+ - poll: array from alloca passed to free.
+ - sockets: bug in sock-peer assignment place.
+ - hash: gc problem in copy-hash function.
+ - sequence iteration: gc problem.
+ - maprodo: problm with single-list argument.
+
+
+
+ TXR 270
+ 2021-08-30
+
+
+ Features
+
+ - open-file now supports "x" mode for exclusive create, contributed
+ by Paul A. Patience.
+
+ Bugs
+
+ - sequence iteration:
+ - garbage collection corruption was discovered via experimentation
+ with string ranges (new feature in 269).
+ - caused by not properly doing the counter-generation object mutations.
+ - Bug is not new: affects bignum ranges, oop sequences.
+ - iterating ranges that go from fixnum to bignum now allowed.
+ - open-file:
+ - "+" mode was behaving like "r" and not "r+" (Paul A. Patience)
+ - "w+", "m+" and "a+" refused to create file (Paul A. Patience)
+
+
+
+ TXR 269
+ 2021-08-28
+
+ Twelfth Anniversary Edition
+
+
+ Features
+
+ - networking:
+ - getaddrinfo now implements ai-canonname flag.
+ - system interface:
+ - mmap function now supported, integrated with carray.
+ - mprotect, msync, madvise are there.
+ - structural pattern matching:
+ - new match and match-ecase macros for irrefutable matching.
+ - basic Lisp:
+ - new ecase family of macros.
+ - sequences/iterables:
+ - string ranges like "AAA".."ZZZ" are now iterable.
+ - iterators (objects from iter-begin) are iterable.
+ - sub function allows iterables.
+ - FFI:
+ - carray-pun function allows displacement
+ - improved support for big/little endian types:
+ - more efficient when matches local endian
+ - aligned reads and writes transfer word at a time.
+ - PRNG:
+ - new random-buf function for obtaining a block of
+ pseudo-random bytes.
+ - doc improvements.
+ - build/port:
+ - builds on FreeBSD; test cases pass.
+ - new --no-full-repl option builds trimmed-down listener
+ that supports only plain mode editing, not requiring termios.
+
+ Bugs
+
+ - int-str: bug stripping 0x unconditionally regardess of radix argument.
+ - format: leading sign state leaking into subsequent conversions.
+ - ffi: deffi: broken support for variadic functions.
+ - random: bug with modulus that is multiple of 32 bits, found on PPC64.
+ - open-file: "+" mode must be equivalent to "r+" not "r".
+
+
+
+ TXR 268
+ 2021-08-07
+
+
+ Features
+
+ - subtypep: arguments can now be struct type objects returned
+ by find-struct-type, not only type symbols.
+ - JSON:
+ - new *read-bad-json* dynamic variable, enabling tolerance for
+ trailing commas in JSON arrays and objects.
+ - OOP:
+ - syntactic infelicity in new* and lnew* operators addressed.
+ - streams:
+ - close-stream now replays return value if called redudnantly.
+ - get-lines/lazy-stream-cons now have optional parameter
+ controlling whether the implicit close-stream can throw.
+ - listener: plain mode
+ - handles multi-line expressions
+ - prints prompts if stdin is tty
+ - prompts can be turned on with :prompt-on
+ - banner is suppressed when stdin isn't tty; more usable in pipes.
+ - TXR Pattern Language:
+ - @(eof) now takes an optional argument which can bind
+ the exit status of the input source. Useful for process pipes.
+
+ Bugs
+
+ - gc: aborts caused by incorrectness in several object-copying functions.
+ - correct diagnostic name in remql function.
+ - listener: plain mode (txr -n, or input is not a terminal) now
+ handles multi-line expressions.
+ - build: musl fix for socket.c: need <sys/time.h>.
+ - streams: incorrect argument defaulting of second arg of close-stream
+
+
+
+ TXR 267
+ 2021-07-26
+
+
+ Features
+
+ - system interface:
+ - new getrlimit, setrlimit functions
+ - random numbers:
+ - buffer objects can be used as random seeds now
+ - build:
+ - txr.c now recompiled if build_id changes.
+ - PDF build is now reproducible even if ghostscript
+ and groff don't have patches for this.
+ - tags.tl:
+ - now supports --emacs argument for Emacs-style tags,
+ thanks to Paul A. Patience.
+ - other improvements
+ - hashes:
+ - Hashes now support both and-semantics and or-semantics
+ for tables that have both weak keys and values.
+ - and-semantics means both key and value must be unreachable
+ for the hash entry to disappear.
+ - or-semantics means the entry disappears if just the key
+ or the value is unreachable.
+
+ Bugs
+
+ - compat:
+ - glaring bug fixed going back more than 150 versions.
+ - certain effects of the -C compatibility option not
+ having their documented effect.
+ - caused by referencing the opt_compat variable in global
+ initialization functions, at which time opt_compat is
+ always zero due to -C not having been processed yet.
+ - Test case fixes for missing /bin/sh situation exemplified
+ by Guix build environment.
+ - op:
+ - weirdness in handling nested do (do do do ...) fixed
+ - hashes:
+ - fixed TXR 235 regression in weak processing, causing
+ entries to spuriously disappear from weak hash tables that are only
+ referenced by other weak hash tables.
+ - fixed incorrect recalculation of hash table counts of weak
+ hash tables during garbage collection.
+ - carray:
+ - missing type checking in a couple of functions, creating
+ opportunity for trivial crash.
+
+
+
+ TXR 266
+ 2021-07-12
+
+
+ Features
+
+ - built-in macros and special operators are now subject to more
+ rigorous syntax checking during the macro-expansion walk.
+ - improvements in error reporting
+ - built-in macros use compiler-like error reporting now.
+ - Lisp files executed from command line rather than loaded, ditto.
+ - running make tests out of an editor now takes you to the error line.
+ - improvements in doc function, and OpenBSD support.
+ - type system overhauled to disallow structs that clash with built-in types.
+ - new function called separate contributed by Paul A. Patience.
+ - combines keep-if and remove-if semantics
+ - new path-manipulation-related functions trim-short-suffix, trim-long-suffix
+ and add-suffix.
+ - new build-id feature: optional string that can be inserted into TXR
+ at build time, displayed by txr --build-id.
+
+ Bugs
+
+ - non-functional chmod.tl test case fixed, thanks to Paul A. Patience.
+ - regex: argument defaulting problem in regex-compile.
+ - *stderr* stream is now sanely reset during unhandled exception processing.
+ - new steps taken to prevent runaway recursion in exception processing.
+ - streams:
+ - close-stream function refuses to close stderr.
+ (previously refused only stdin and stdout.)
+ - put-char, put-line: lack of type checking on stream argument.
+ - bug in with-resources problem fixed, reported by Paul A. Patience.
+ - doc ignores BROWSER variable if it is empty.
+
+
+
+ TXR 265
+ 2021-07-04
+
+
+ Features
+
+ - requirements change in new long-suffix and short-suffix functions:
+ - dot is now part of suffix.
+ - leading dot is not a suffix delimiter: e.g. .bashrc is not a suffix.
+ - trailing path separators ignored, like in base-name.
+ - regex: optimization function exposed.
+ - constantp function now recognizes more kinds of expressions:
+ - (+ 1 (* 3 4)) is constantp, as is (symacrolet ((a (+ 2 2))) (* b 3)).
+ - doc function
+ - now handles situations in which xdg-open blocks until browser exits.
+ - now reacts to BROWSER variable, and if xdg-open is not found,
+ falls back on the first of a long list of possible browsers.
+ - filesystem interface:
+ - path-cat function is now variadic: (path-cat "a" "b" "c" ...).
+ - new path-search function, searches for an executable by name in path,
+ defaulting to the system's PATH.
+ - sequences:
+ - new find-true function; like find-if, but returns the true value
+ that the predicate produces, rather than the item from the sequence.
+ - I/O streams:
+ - argument defaulting tightened; functions no longer treat a nil
+ value for the stream argument as a missing argument.
+ - stack limit:
+ - minimum limit now imposed when the system's stack limit is too low,
+ rather than disabling the mechanism.
+ - stack limit is now always on, even if we don't obtain a value
+ from the system or that value indicates that there is no limit.
+ - documentation infrastructure:
+ - improvements from Paul A. Patience integrated.
+ - doc workflow catches more kinds of problems.
+ - listener: empty EDITOR variable now treated as missing.
+
+ Bugs
+
+ - build: regression in separate-directory build.
+ - parser: regression: not working with byacc.
+ - compiler: a number of bugs in inline lambda implementation.
+ - op: subtle bug in do operator; code refactored.
+ - base-name function: problem with empty suffix.
+ - listener: end-of-line/buffer visual glitch in selection.
+ - trie: bugs in regex-from-trie function, now covered by tests.
+ - regex: print/read consistency problem printing n-ary operators.
+ - doc: *doc-url* variable not special, as documented.
+ - getopts: throwing sys:opt-error instead of usr:opt-error.
+ - command line: lack of robustness in -b option fixed.
+ - documentation: numerous fixes.
+ - packages: find-symbol was behaving identically to find-symbol-fb.
+ - signals: itimer-prof variable misspelled as itimer-prov.
+ - search trees: documented tnodep function now actually exists.
+ - stack limit: fix crash when system stack limit is RLIM_INFINITY.
+
+
+
+ TXR 264
+ 2021-06-25
+
+
+ Features
+
+ - system interface:
+ - TXR no longer relies on popen for open-command.
+ - glob function accepts multiple pattern arguments and
+ uses multiple calls to the C function with GLOB_APPEND.
+ - parser:
+ - parsing Lisp or JSON from a string now produces error
+ if there is any trailing material in the string.
+ - paths:
+ - new functions short-suffix and long-suffix for robustly
+ extracting the suffixes/extensions of path names.
+ - lib:
+ - new functions cxr and cyr for traversing cons-cell
+ structures using a car/cdr path binary-coded in an integer.
+ - mismatch/rmismatch better optimized for strings
+ - starts-with and ends-with use these.
+ - structural pattern matching:
+ - new looping macros while-match, while-match-case, while-true-match-case.
+ - parser:
+ - no longer wastefully allocates dynamic string when scanning a
+ floating-point token.
+ - tests:
+ - target-installable test cases are now relocatable (can be installed
+ at any path) due to a small improvement in the run.sh script.
+
+ - program-wide:
+ - share/txr/stdlib moved to stdlib.
+ - type mismatches when a string is expected now give
+ function name in error diagnostic.
+ - stack overflow protection is introduced:
+ - in key places, TXR detects whether the stack pointer is over a
+ predetermined limit and throws a stack-overflow exception.
+ - controlled by set-stack-limit function.
+
+ Bugs
+
+ - fixed wrong result from (rmismatch #() ()) and (rmismatch "" ()).
+
+
+
+
+ TXR 263
+ 2021-06-17
+
+
+ Features
+
+ - New macro named flow, providing the syntactic sugar for
+ using an opip function on a value.
+ - I/O:
+ - the *stdnull* stream lazily attaches to /dev/null if
+ fileno is invoked on it
+ - formatted printing:
+ - format: new precision modifier - for zero instead of plus sign.
+ - pic macro: takes advantage of format work to generate better code.
+ - subprocesses:
+ - some file descriptor saving-restoring manipulations moved
+ into child process (in open-process, open-subprocess, run)
+ - diagnostic for situation when *stdout*, *stdin* or *stderr*
+ are redirected to something that cannot produce a file descriptor.
+ - match-fun/txr-if
+ - documented that input can be a stream
+ - documented that input can be a single string
+ - txr-case:
+ - if input is a stream, it is now converted to a lazy list of lines,
+ so that the txr-case construct effectively backtracks over the
+ data as it tries successive cases.
+ - command-line
+ - new --noprofile option to invoke listener without processing
+ ~/.txr_profile file.
+
+ Bugs
+
+ - format: numeric handling maintenance
+ - poor behaviors identified and revised.
+ - requirements clarified.
+ - cemented in test cases.
+ - exceptions:
+ - unwind dynamic environment when tracing unhandled exception
+ - solves problem when exception goes off while *stderr* is redirected.
+ - subprocesses:
+ - diagnostic for situation when *stdout*, *stdin* or *stderr*
+ are redirected to something that cannot produce a file descriptor.
+ - macros:
+ - fixed TXR 191 regression in defsymacro: expanding the replacement form
+ before associating it with the symbol, rather than taking as-is.
+ - quasiliterals:
+ - fixed issue arising when a macro invoked as a @(...) expression in a
+ quasiliteral expands to a non-string atom.
+ - math:
+ - forbid dubious inequality comparisons like (< 1 "abc") which
+ became unintentionally allowed due to numbers being iterable.
+
+
+
+ TXR 262
+ 2021-06-11
+
+
+ Features
+
+ - structural pattern matching:
+ - new feature: quasiquote matching.
+ - JSON:
+ - improved escaping of JSON output for safe embedding in <script> tags.
+ - new JSON pattern matching.
+ - text processing:
+ - new pic macro for formatting using pattern similar to perl's
+ format or PRINT USING in BASIC languages: ####.# <<<<<<.
+ - works by compiling to fmt calls.
+ - FFI:
+ - bad FFI call diagnostics now have function name.
+ - failures in dlsym function converted to better diagnosis.
+ - carray objects can be passed to cptr argument now.
+ - new deffi-struct and deffi-union macros for less verbose
+ definitions without a typedef.
+ - lib:
+ - new fill-vec function for efficiently filling an area of a vector
+ with repetitions of a value.
+ - reduce-left rewritten with generic sequence iteration, for
+ better efficiency (e.g. not consing memory over vectors).
+ - sum and prod functions likewise.
+ - expander:
+ - fixed issue in defun expansion interfering with defining a macro
+ and then a function of the same name which calls the macro.
+ - parser:
+ - new *read-unknown-structs* Boolean variable
+ - if set, the reader can read #S syntax which names undefined
+ structure types, without blowing up.
+ - used in tags.tl, which can therefore handle source code
+ that contains struct literals.
+ - compile/eval:
+ - improved coordination between error exceptions, compiler
+ error messages sent to the error stream, and deferred warnings.
+
+ Bugs
+
+ - listener:
+ - doc function not working in Cygwin/Cygnal port.
+ - macro and operator completion after ' (quote) character;
+ so that (doc 'wh[Tab] will complete on a macro name like while.
+ - system interface:
+ - mkstemp build problem problem affecting Solaris and other platforms.
+ - printer:
+ - added missing handling for printing (sys:struct-lit ...) syntax
+ as #S syntax.
+ - parser
+ - bug with #; commenting syntax not playing nicely with #S literals.
+ - JSON:
+ - test cases on Cygwin work.
+ - JSON print-read consistency problem addressed.
+ - FFI:
+ - memory leaks in FFI type system when struct type is redefined.
+ - bug in deffi causing the libffi ffi_prep_cif_var function to
+ always be used, even for non-variadic functions.
+ - FFI now properly calculates the structure member descriptor arrays
+ for libffi, and fakes them out for arrays and unions also.
+ This should address problems with passing small structures by value.
+ - The material is calculated lazily: not done for types that are
+ never used as by-value parameters or return values.
+ - format:
+ - fix bugs in leading zero in precision field of format specifier.
+
+
+
+
+ TXR 261
+ 2021-06-01
+
+
+ Features
+
+ - JSON support:
+ - #J syntax in TXR Lisp
+ - allows quasi-quoting and circular notation.
+ - I/O with JSON objects, with convenience routines like
+ file-put-json, and others.
+ - Vim syntax highlighting support for everything.
+ - parser:
+ - new parse-errors function for retrieving number or
+ parse errors from stream or nil if no errors.
+ - filesystem:
+ - new functions tmpfile, mkdtemp and mkstemp.
+ - lib:
+ - chr-iscntrl now recognizes Unicode C1 control character block,
+ not only the C0 from ASCII.
+
+ Bugs
+
+ - compiler:
+ - invalid move into register T0 generated when compiling catch code,
+ causing assembler to throw error.
+ - search trees:
+ - GC abort caused by tree-delete/tree-delete-node.
+ - parser:
+ - GC bug due to storing lookahead token in parser using
+ a wrong-way assignment.
+
+
+
+ TXR 260
+ 2021-05-26
+
+
+ Features
+
+ - structural pattern matching:
+ - values in hash pattern can be now omitted with usefully nuanced
+ semantics.
+ - parser:
+ - unterminated expression diagnostic now given in in format that lets
+ editors jump to the start of the unterminated construct.
+ - compiler:
+ - better translation strategy for global var definitions.
+ - documentation improvements.
+
+ Bugs
+
+ - lib:
+ - buggy :wrap and :reflect in window-map fixed.
+ - case{q*,ql*,qual*} macros failing to expand key expressions.
+ - compiler:
+ - fix compile-file warnings being deferred to end of surrounding load
+ - ffi:
+ - crash when carray object passed as argument to foreign function.
+ - arithmetic:
+ - several bugs in the area of bignum to 64 bit conversions.
+ - listener:
+ - don't complete on symbols that are just interned, with no binding.
+ - doc function now handling symbols like <= that use HTML codes in
+ the document.
+
+
+
+ TXR 259
+ 2021-05-13
+
+
+ Features
+
+ - lib:
+ - New rel-path function for calculating relative path
+ between two directories.
+ - format function's ~x/~X supports printing buffer
+ objects in hex.
+ - structural pattern matching:
+ - new each-match family of macros for iterating over
+ sequences, with destructuring.
+ - search trees:
+ - numerous new functions
+ - tree iterators support sub-ranges of trees
+ - trees are now sequences and can be mapped over with
+ mapcar, each and other functions.
+ - build:
+ - fixed issue with ./reconfigure overwriting itself,
+ causing instability.
+ - ./reconfigure takes configure parameters to be added.
+
+ Bugs
+
+ - join-with segfault on character (not string) separator.
+ - parser:
+ - regression introduced in 258: crash when the #; syntax
+ for commenting out an object is processed.
+ - bug in handling certain objects, such as string
+ literals, as top-level forms in a file.
+ - compiler:
+ - failing to diagnose wrong number of arguments in calls to lexical
+ functions that have been lambda-lifted to the top level.
+ - buffers:
+ - int-buf and uint-buf functions wrongly referring to
+ buffer's allocated size instead of its length.
+ - sha256/md5:
+ - memory leak in use of buffers.
+
+
+
+ TXR 258
+ 2021-04-30
+
+
+ Features
+
+ - Structural pattern matching now supports quasiliteral patterns
+ for matching into strings.
+ - Search tree module supports a way to start scanning nodes
+ in order at or above a given lower bound key.
+ - improvements in Vim syntax highlighting files.
+
+ Bugs
+
+ - GC issue in sequence iterators: not marking iterated object
+ when it's a structure.
+ - GC issue in parser.
+ - lexical-var-p: no longer wrongly returns t for locally bound
+ special variables.
+ - regression in mapcar*, going back to 240.
+ - search tree module:
+ - massive gc problems
+ - broken tree-lookup
+
+
+
+ TXR 257
+ 2021-04-22
+
+
+ Features
+
+ - parser:
+ - Invalid UTF-8 bytes and characters now allowed in literals and regexes.
+ - Treated using rules consistent with behavior of text streams.
+ - doc:
+ - General improvements in documentation, many thanks to Paul A. Patience.
+ - build:
+ - Test suite no longer requires .expected files which are empty;
+ they materialize on-the-fly and make cleans them away afterward.
+ - streams:
+ - stream-max-len behavior changes for strings. Some small bugs
+ fixed in this area.
+ - structural pattern matching
+ - new @(scan) operator for finding a match over a list
+ - new defmatch macro for defining new pattern operators
+ - new pattern operators @(end) and @(sme) defined using defmatch
+ - TXR:
+ - Debug output for @(gather) directive reports exact list of variables
+ that were not bound.
+ - compile/eval:
+ - compile-error macro now prints error on *stdout* in addition to
+ throwing exception.
+ - upshot of this is that this helps editors navigate to the error.
+ - previously this worked for warnings, not errors.
+ - new binding operator: mac-env-param-bind
+ - port status:
+ - TXR ported to OpenBSD, amd64.
+ - internal:
+ - New C function dis that can be used debugging TXR with gdb to
+ disassemble VM code.
+
+ Bugs
+
+ - compiler:
+ - (call (fun f) ...) forms not registering the reference to f,
+ causing lambdas to be incorrectly lifted to a scope where they
+ lose access to a needed lexical function.
+ - incorrect handling of trailing arguments in immediately-called lambda.
+ - bad diagnostic in compile-file when output file can't be opened.
+ - constant-folded (call ...) expressions not quoted.
+ - bug in dead code elimination (optimization level 6) causing
+ references to nonexistent assembly language labels.
+ - bug in frame elimination (optimization level 2) not initializing
+ some registers in code that can execute more than once due to loops.
+ - GC:
+ - Bug in sys:gc function fixed, whereby it wrongly resets the
+ internal flag which requests a full collection, leading to corruption
+ (since that flag is sometimes set for reasons of correctness).
+ - regex:
+ - The regsub function was found to have destructive behavior,
+ contrary to documentation.
+ - lib:
+ - fixed a bug causing the functions base-name, dir-name and TXR's
+ sysrooting calculations to be wrong on platforms where sizeof(wchar_t)
+ is 2 (Windows/Cygwin) and on MacOS.
+ - fixed the bogus assumption in the code, introduced in 2015, that there
+ are platforms with four-byte wchar_t which don't align L"..." literals
+ to four byte boundaries, and that MacOS is one of them.
+ - continuations:
+ - fix stack alignment on amd64 under clang.
+ - discovered during OpenBSD port, but not an OpenBSD problem.
+ - build:
+ - make referenced in a few places instead of $make, causing
+ some nuisance error messages on platform where GNU Make is gmake.
+
+
+
+ TXR 256
+ 2021-04-07
+
+
+ Features
+
+ - Compiler:
+ - Compiler now checks number of arguments in a function call
+ against its definition.
+
+ - Doc:
+ - numerous improvements in the manual, especially HTML output.
+ - New library function doc for documentation lookup:
+ - (doc) -> open manual with default browser
+ - (doc 'cons) -> open manual to specific symbol
+ - INSTALL document maintained.
+
+ - Awk:
+ - :name argument not restricted to symbol, but any valid
+ object usable as a block name.
+
+ Bugs
+
+ - Compiler:
+ - fixed incorrect constant folding of call function.
+ - some instances of misleading diagnostic wording fixed.
+ - fixed regression in source location info propagation
+ - causing errors not to have location information in some cases
+ - caused by recent optimization work.
+ - OOP:
+ - fixed lack of hygiene in qref operator with regard to
+ a.?b syntax, causing mutiple evaluations of a.
+ - GC:
+ - fixed bug in weak hash processing dating back to the
+ initial weak hash implementation in 2009.
+ - Awk:
+ - The value of the rs (record separator) variable being
+ wrongly compiled as regex syntax even if it is a string object
+ that must be a fixed pattern.
+ - Lib:
+ - bug in UTF-8 decoding function
+ - affecting situations when buffered bytes are decoded as utf-8
+ (I/O streams not effected).
+ - incorrect behavior when invalid bytes are present;
+ valid UTF-8 not affected.
+ - func-optparam-count: function was returning bogus value
+ for interpreted functions.
+
+
+
+ TXR 255
+ 2021-03-26
+
+
+ Features
+
+ - TXR has been ported to Arm64 Mac OS Darwin (Apple M1).
+
+ - lib:
+ - argument to cat-str treated via sequence iteration
+ for better efficiency on non-lists.
+ - likewise for the poll-list argument in poll.
+ - compiler:
+ - optimization improvements
+ - The VM's T registers can now be used for function arguments,
+ promoting further optimizations, and eliminating the
+ need to allocate a variable frame for arguments.
+ - several other optimization improvements.
+ - code improvements in compiler.
+ - FFI:
+ - float type used as variadic argument in deffi and deffi-cb
+ now promoted to double, preventing a programmer pitfall.
+ - VM:
+ - execution of VM code is now interruptible by signals,
+ most notably the SIGINT generated by Ctrl-C.
+ - this is done in a way that shows vanishingly low overhead.
+
+ Bugs
+
+ - ffi: fixed missing support for retrieving ushort type from
+ misaligned buffer
+ - tests:
+ - on Mac OS, the socket-basic.tl test passes on the stock OS
+ configuration, not requiring limit on UDP datagram size to
+ be relaxed via sysctl.
+ - make -j retest now works reliably via a recursive invocation.
+
+
+
+ TXR 254
+ 2021-03-10
+
+
+ Features:
+
+ - compiler:
+ - elimination of function calls that produce unused values.
+ - this compiles down to just "nil":
+ (let ((x (cons y z))) (set x (cons u v)) (set x nil) x)))
+ - elimination of unused accesses to globals
+ - elimination of unused lambdas.
+ - optimization control: new variable *opt-level*, valued 0-6.
+
+ - lib:
+ - new functions join and join-with to complement the tired old
+ cat-str for joining strings and characters.
+ - (join-with ":" "a" "b" "c") -> "a:b:c"
+ - (join "a" "b" "c") -> "abc"
+
+ Bugs:
+
+ - broken sort function over vectors and strings
+ - failing to return the sorted object
+
+
+
+ TXR 253
+ 2021-03-06
+
+
+ Features:
+
+ - build:
+ - parallel builds allowed with ./configure --parallelmake
+ - after above, make -j is supported.
+ - recommended for development, not distro builds.
+
+ - compiler:
+ - new optimizations
+ - order of optimization passes rearranged
+ - new peephole patterns.
+ - Pattern-matching Ackermann 48 times faster
+ than interpreted
+ - functional combinator expressions are now automatically
+ hoisted to load time.
+ - E.g. [chain .foo car list] is now computed once when
+ the code is loaded, and then referenced.
+
+ Bugs:
+
+ - compiler:
+ - mistake in (if (equal ...) ...) pattern corrected,
+ allowing corresponding reduction to take place.
+ - fixed bug in frame depth calculation when load-time forms
+ are involved.
+ - fixed bug causing redundant dead code to be added to load-time.
+
+ - hashing:
+ - fixed bug causing hash-equal to produce zero for floats
+ and bignums
+ - equal-based hash tables using bignums or floats as keys
+ are affected.
+
+
+
+
+ TXR 252
+ 2021-02-28
+
+
+ Features:
+
+ - compiler:
+ - new optimizations introduced:
+ - elimination of frames for non-captured lexical variables
+ - elimination of blocks in self-recursive functions
+ - more compact frame size for closures
+ - strength reduction of equal (helps pattern matching)
+ - list construction optimization:
+ - e.g. (cons 1 (cons 2 3)) -> (list* 1 2 3) and more
+ - other algebraic reductions.
+ - aggressive constant-folding of over 300 library functions.
+ - new control-flow and data-flow analysis:
+ - removal of dead registers
+ - elimination of inefficiently used temporary registers
+ - comprehensive dead code removal
+
+ - structural pattern matching
+ - internal code cleanup, improvements and improved
+ diagnostics for hash patterns.
+
+ - syntax:
+ - obj.[fun ...] syntax changes meaning; it is now
+ method dispatch.
+ - obj.[method ...] is to [fun ...] as
+ obj.(method ...) is to (fun ....)
+ - improved diagnosis of invalid dotted forms.
+
+ - library:
+ - list-builder methods now return the object, allowing
+ chaining like (new list-builder).(add 3).(get)
+
+ - vm:
+ - backwards compatibility jump: TXR 251 generates version 6
+ object files (.tlo) and will not read older ones.
+ - Some obsolescent instructions have been removed from the
+ instruction set.
+
+ - TXR Pattern Language:
+ - function calls, including indirect calls via @(call ...)
+ are now considered non-matching directives, thus not
+ calling for the input source to be opened.
+
+ Bugs:
+
+ - math:
+ - fixed out-of-bounds memory access in or and xor
+ functions when the arguments are bignums.
+ - build:
+ - bug fixed: not dealing with spaces in configuration arguments when
+ generating ./reconfigure script
+ - printer:
+ - obscure bug in printing lambda expressions fixed,
+ triggering function lookup and expansion at print time.
+ - compiler:
+ - fixed internal error in compiler when compiling
+ certain cases sys:switch forms generated in certain cases
+ of caseq/caseql.
+ - assignment to a function binding being internally marked as
+ an a free variable reference by the compiler, rather than
+ a free function reference.
+ - incorrect compilation unwind-protect form when the
+ protected form is trivial, like a literal constant.
+ - TXR Pattern Language:
+ - fixed broken implementation of @(call ...), in several independent
+ aspects.
+
+
+
+ TXR 251
+ 2021-02-08
+
+
+ Features
+
+ - structural pattern matching:
+ - now allows back-referencing with existing variables
+ outside of the pattern, greatly improving expressiveness.
+ - new @(with) operator, allows match between side pattern
+ and side object in parallel with main pattern and main object.
+ - @(let) renamed to @(as).
+ - clauses of @(and) now in same scope allowing back-referencing.
+ - redesign of lambda-match, using special argument matching rather
+ than a list pattern against the argument list.
+ - functions based on pattern matching now perform much better
+ - new :match parameter macro:
+ - adds pattern matching to any function in any situation
+ - supports mixture of regular arguments and pattern matching.
+ - predicate pattern syntax and semantics redesigned.
+ - predicates now have multiple arguments
+ - variable can be inserted anywhere in a predicate call,
+ including dot position
+ - variable can be omitted, giving rise to the object being
+ passed as the rightmost argument to the predicate call
+ - @(op ...) pattern is removed:
+ - not necessary due to improved predicate handling.
+
+ - compiler:
+ - new optimizations
+ - error location reporting improved.
+
+ Bugs
+
+ - structural pattern matching
+ - fixed bad hygiene in match-case due to not using gensym.
+ - lib:
+ - fixed crash in nullify and iterable, when argument is
+ a C object that is not a struct.
+ - fixed long-standing bug in multi-sort: when the list(s)
+ are empty, it must return a list of empty lists, not nil.
+ E.g. [multi-sort '(nil nil nil) less] now returns
+ (nil nil nil) as documented, and not nil.
+
+
+
+ TXR 250
+ 2021-01-31
+
+
+ Features
+
+ - structural pattern matching:
+ - new @[...] predicate operator.
+ - can capture object, as well as value of predicae
+ - better code generation
+
+ - compiler:
+ - jump threading optimization
+ - dead code removal
+ - peephole optimizations
+
+
+ Bugs
+
+ - structural pattern matching:
+ - numerous new test cases introduced showing various
+ breakage, and fixed.
+ - code substantially refactored
+ - @(or ...) pattern handled in new way.
+ - compiler:
+ - fixed totally broken treatment of append-each operator
+ - destructively catenating lists
+ - not observing append semantics w.r.t. generic sequences.
+ - sub-str: now subject to compatibility; -C 215 or lower
+ restores the behavior of always copying the input string,
+ even when sub-str covers the entire string.
+ - lazy strings: instance of invalid substrucure sharing
+ fixed in lazy-sub-str, causing incorrect behavior,
+ showing up as strangeness in @(freeform) processing
+ and anything else relying on lazy-sub-str.
+ - fixed broken @(rebind) directive.
+ - not removing variables from environment if left hand
+ side is a pattern with multiple variables.
+ - wrongly removing right hand side variable from environment.
+
+
+
+ TXR 249
+ 2021-01-24
+
+
+ Features:
+
+ - structural pattern matching:
+ - variables can now back-reference so that (@a @a)
+ matches a two-element list whose items are equal.
+ - @(some) and @(all) operators work with any sequences, not just lists.
+ - New pattern-matching @(coll ...) operator for collecting
+ from a sequence those objects which match.
+ - New @(hash ...) operator for matching hash tables on keys,
+ values or both.
+ - Matching ranges using range objects is now supported,
+ e.g. #R(@a @b) matches a range, and binds a and b to its from and to.
+ - Trivial patterns (those containing no operators or variables) are
+ now handled more efficiently. E.g. the pattern (1 2 3) or #(1 2 3)
+ will just be tested using equal as an atom, rather than
+ compiled into individual tests over the elements.
+
+ - hashing:
+ - hash-revget now uses equal equality for finding matching
+ values in the hash table, rather than eql.
+
+
+ Bugs:
+
+ - structural pattern matching:
+ - fixed order of evaluation problem in @(require)
+ - iter-step: no longer traverses into terminators of improper lists, which
+ caused situations like (each ((x '(1 2 . 3))) ...) to iterate indefinitely.
+ - fixed a regression which caused carrayp, hashp, random-state-p, regexp and
+ struct-type-p to indicate true as 1 instead of t.
+ - internally, the way t is initialized when TXR starts up has also been
+ improved as a result.
+ - parser:
+ - fixed badly designed low-precedence of the @ token: the one applied to
+ expressions as in @(foo).
+ - printer:
+ - fixed the print/read ambiguity that both (rcons @a @b) and @(rcons a b)
+ printed as @a..@b.
+ - @(rcons ...) now prints as @(rcons ...) and never as the x..y notation,
+ so only (rcons @a @b) prints as @a..@b.
+ - we also know that only (rcons @(a) @(b)) prints as @(a)..@(b), and
+ thanks to the parser fix mentioned above, @(a)..@(b) parses as
+ (rcons @(a) @(b)).
+ - places:
+ - The function name call-delete-expander was wrongly in sys package, rather
+ than the usr package, as documented.
+ - Addressed runaway recursion in place expansion logic, causing, for
+ instance the expansion of (let (a) (set a #1=(#1#))) to recurse
+ infinitely.
+ - manual: fixed wrong 2020 date.
+
+
+
+ TXR 248
+ 2021-01-20
+
+
+ Features:
+
+ - hashing:
+ - new hash-key-of function: get all keys that map to the specified value.
+
+ Bugs:
+
+ - compiler regression: incorrect reduction of (and <true-constant>) forms
+ to t instead of <true-constant>.
+
+
+
+ TXR 247
+ 2021-01-19
+
+
+ Features
+
+ - lib:
+ - structural pattern matching introduced.
+ - prog2 macro introduced.
+ - progn, prog1 and prog2 are now also functions.
+
+ - build:
+ - configure's test for how to define inline functions fixed.
+ - hopefully this will fix things for Brew.
+ - linker options and library flags are now separate;
+ there is a new platform-ldlibs configure option.
+ - LDLIBS variable is now honored, not just LDLIBS.
+
+ - gc:
+ - finalizers now registered during finalization processing
+ may be called in the same phase, if they are eligible.
+
+ Bugs
+
+ - show-stopper regression in mapcar/maprod.
+
+
+
+
+ TXR 246
+ 2020-12-31
+
+
+ Features:
+
+ - Library:
+ - shuffle and nshuffle functions take optional random state
+ argument now.
+
+ Bugs:
+
+ - gc:
+ - bug in finalization leading to assertion in garbage collector.
+ - affects situations in which finalizers are explcitly called,
+ rather than naturally occurring during garbage collection.
+ - flaw in object finalization logic causing unnecessary full
+ generation to be requested.
+ - awk:
+ - fixed regression in fconv macro (probably dating back several years):
+ - the conversion shortcuts like i, x, o, r became unavailable
+ due to being sys: symbols rather than usr: symbols.
+
+
+
+ TXR 245
+ 2020-12-24
+
+
+ Features:
+
+ - Android is now a supported target platform: builds in termux environment.
+ - TXR executable builds as PIE, which is mandatory on Android.
+ - test suite passes nevertheless: PIE-related has not been observed.
+
+ - System Interface:
+ - env-hash now returns the same hash object every time it is called,
+ whose contents are updated by setenv, unsetenv and getenv.
+
+ - Build:
+ - C compiler now operated in C99 dialect, except in maintainer mode.
+
+
+ Bugs:
+
+ - math: bad edge-case in int-flo function affecting 64 bit systems.
+ - time: do not offer a make-time-utc function if we have neither timegm nor
+ setenv in the C library; we don't simulate setenv with putenv any more.
+ - printer: don't print leading zeros in characters printed in hexadecimal.
+
+
+
+ TXR 244
+ 2020-10-10
+
+
+ Features:
+
+ - Build:
+ - Dropped dependency on Bison/Byacc and Flex:
+ - TXR now ships the generated parser and scanner source.
+ - The --maintainer option must be given to configure to enable
+ regenerating these sources, otherwise the shipped ones are used.
+
+ - Lib:
+ - New trim-left and trim-right functions for removing a suffix.
+ - Time-related functionality moved out of lib.c into a new time.c module.
+ - New time-nsec function for nanosecond-precision time.
+ - PRNG uses nanoseconds now in seeding, rather than microseconds.
+
+ - Listener:
+ - New quip function produces a randomly selected humorous line,
+ suitable for printing out of the ~/.txr_profile startup file.
+
+ - Compiler/VM:
+ - movi family of instructions (move immediate operand into register)
+ are deprecated and no longer used by the compiler.
+ - It is cheaper to the integer or character operand in a D register
+ already, since no instruction needs to be executed to get it into a
+ register.
+ - The downside is that code which uses a large number of small integer
+ literals can now run out of D registers, whereas previously
+ it woudl have not run into any limit.
+
+ Bugs:
+
+ - output-side @(repeat) was still not finding Lisp variables embedded
+ in braced expansions.
+ - fixed two defects in the implementation of the WELL512a pseudo-random-number
+ generator.
+ - compat option (-C 243 or lower) restores broken PRNG behavior for
+ reproducibility of old PRNG sequences.
+ - regression in two-or-more-sequence form of mapcar: it was not
+ converting the output to the type of the leftmost sequence.
+
+
+
+ TXR 243
+ 2020-09-01
+
+
+ Features:
+
+ - TXR:
+ - output-side @(repeat) directive more intelligent:
+ - now identifies variables referenced in Lisp code
+ - many uses of :vars now unnecessary
+ - variables identified in expansion pass now, before query execution
+
+ - OOP:
+ - diamond problem in multiple inheritance addressed.
+ - duplicate inheritance bases no longer cause multiple
+ calls to :init, :postinit and :fini handlers.
+
+ - Lib:
+ - new reject funtion, complements select.
+
+ Bugs:
+
+ - FFI:
+ - several bugs addressed in the allocation of bitfields.
+ - documentation of Bitfield Allocation Rules also updated.
+
+
+
+ TXR 242
+ 2020-08-14
+
+
+ Bugs
+
+ - TXR: fix serious regression introduced in TXR 235, affecting
+ correctness of behavior in multiple places.
+ - listener: fix regression introduced in TXR 239, causing funny
+ behavior when invoking Tab completion on keywords and qualified symbols.
+
+
+
+ TXR 241
+ 2020-08-08
+
+ Eleventh Anniversary Edition
+
+
+ Features
+
+ - MIPS (32 and 64 bit) is a a target platform now.
+ - Lib:
+ - New list-seq, ved-seq and str-seq functions.
+ - New maprodo function: like maprod, but returns nil.
+ - New each-prod, collect-each-prod and append-each-prod operators:
+ - traverse cross product of the sequences rather than in parallel.
+ - crc32 has initial crc argument, allowing multi-step
+ crc32 calculation over multiple objects.
+ - New iterable predicate function for detecting whether object is iterable.
+ - Structs:
+ - New iteration protocol
+ - comes in two flavors, using either two or three methods.
+ - System Interface:
+ - New strerror and strsignal functions.
+ - Argument of exit now optional, defaulting to success.
+ - New opendir, readdir and closedir functions for lower-level directory
+ traversal (complementing ftw and glob).
+ - stat family of funtions can now fill an existing struct.
+ - TXR:
+ - @(if)/@(elif)/@(else)/@(end) syntax now supported in @(output).
+ - @(if test then [else]) Lisp form still supported.
+ - Listener:
+ - new *-1, *-2, ..., *-20 macros for referencing prior values
+ relatively.
+ - Symbols:
+ - packages can now be created weak. If a symbol is reachable only through a
+ weak package, it can be garbage-collected.
+ - FFI:
+ - new cptr-get and cptr-out functions for accessing through a cptr.
+ - Networking:
+ - New address parsing functions inaddr-str and in6addr-str.
+ - support for port number and / prefix notation.
+
+ Bugs
+
+ - listener: bogus permission complaint when .txr_history file missing.
+ - structs:
+ - static slot handling in autoload leading to spurious errors.
+ - autoload on instance slots also to prevent spurious no such slot errors.
+ - parser:
+ - minor omission in syntax error diagnostic logic leading to internal token
+ values being printed as if they were characters.
+ - TXR: regression in vertical-horizontal fallback (see 7006ede9).
+ - printer: bugs in printing uref and qref syntax.
+ - parser:
+ - fixed breakage on some platforms like newer Mac OS X due to Flex
+ scanner containing an #include <unistd.h> in the middle of lex.yy.c,
+ after we have included our headers which define numerous macros.
+ - eliminated calls to isatty from the lexer.
+ - cygwin:
+ - broken cat-str and split-str family of functions when using a character
+ object as a separator.
+
+
+
+ TXR 240
+ 2020-06-06
+
+
+ Features
+
+ - New iteration paradigm for sequences.
+ - iter-begin function takes an iterable, returns an iterator.
+ - iter-more tests whether iterator has more items.
+ - iter-item gets first available item
+ - iter-step takes an iterator, returns either new iterator,
+ or the same iterator, mutated.
+ - integrated into sequence processing functions.
+ - works for sequences, as well as integers and ranges.
+ - e.g. [mapcar list '(a b c) 1] -> ((a 1) (b 2) (c 3))
+ - each, collect-each, ... operators work with this paradigm.
+ - mapcar, mappend, mapdo, maprod, maprend now optimized:
+ - work well with sequences of all types
+ - allocate parallel iterators on the native stack
+
+ Bugs
+
+ - maprod bug: wrongly reducing to mapcar, rather than mappend
+ in the one-sequence case.
+ - fixed interpreter segfault on (each ()) expression.
+
+
+
+ TXR 239
+ 2020-06-02
+
+
+ Features
+
+ - Minor optimizations in library:
+ - many instances of internal (format nil ...) calls replaced with cheaper
+ string catenation operations.
+ - consing reduced in the compiled implementation of string quasiliterals.
+ - search, rsearch and update functions switched to seq_info.
+
+ Bugs
+
+ - compiler: showstopper bug fixed: operators in the each family, and the
+ dohash operator were missing the implicit anonymous block.
+ - vm: fixed interal bug: when diagnosing the situation that an anonymous
+ block is not visible, format was called with excess arguments, hijacking
+ the situation with a different exception.
+ - lib: fixed broken rsearch function, and a minor flaw in the diagnostic
+ generated by search and rsearch for a wrongly typed key object.
+ - signals: fixed mismanagement of the sigaltstack memory.
+ - streams: improved dubious integer format string detector logic that is
+ invoked at global initialization time.
+
+
+
+ TXR 238
+ 2020-05-18
+
+
+ Features
+
+ - Compiler:
+ - optimization of load-time and fine-tuning of its semantics.
+ - compiler now does lambda lifting: lambdas that don't reference
+ lexical variables are created one time at load-time.
+ - Now almost no penalty for moving a defun into a labels/flet,
+ unless capture is introduced.
+ - Lib:
+ - Functions countqual, countql, countq, count-if, some, all, none
+ now use the sequence iteration, so they are more efficient on
+ non-list objects.
+ - This is part of a slow-moving, on-going effort.
+ - sort and shuffle are now non-destructive
+ - the original destructive functions are available as
+ nsort and nshuffle, respectively.
+ - compat mode (value 237 or lower) restores destructive behavior.
+ - New assert macro: something that has been conspicuously missing.
+ - System Interface:
+ - isatty function exposed.
+
+ Bugs
+
+ - sockets: bug in formatting IPv6 textual address.
+ - symbol-function: fix failure to expand lambda expression arguments.
+ - compile function no longer wastefully expands already expanded input.
+ - configure: ./configure --help no longer clobbers ./reconfigure script.
+
+
+
+ TXR 237
+ 2020-04-26
+
+
+ Features
+
+ - I/O:
+ - get-line-as-buf function: read a line from a text stream
+ as a buf object: saves storage compared to a string.
+ - poll function now enables async signal handlers invocation,
+ allowing it to beinterrupted.
+
+ - Parser:
+ - improvement in buffering of stream reads in lexical
+ analyzer speeds up parsing.
+ - compiled files (.tlo) load something like 75% faster.
+
+ - Math:
+ - relational functions =, <, >, <= and >= now work
+ on sequences of numbers.
+ - /= function avoids consing.
+
+ - Sockets:
+ - poll is now used for timed out connect and accept;
+ select is a fallback if poll is not detected at config time.
+
+ Bugs
+
+ - Sequences:
+ - uninitialized memory problem affecting the functions
+ in, reverse, find, rfind, pos, rpos and tprint
+ when used with vector-like sequences.
+ - The function in is also affected when used with
+ hashes.
+
+ - Compiler:
+ - fixed miscompilation of if form when the test is
+ a constant expression that evaluates to false.
+
+ - tags.tl:
+ - fixed bug in file opening logic when following (load ...) forms.
+
+ - Printer:
+ - symbols with zero-length names now printed with package prefix,
+ instead of nothing, so they enjoy read-print consistency.
+
+ - Sockets:
+ - broken timed-out connect fixed.
+
+ - FFI:
+ - some bugs fixed in carray code after a code review.
+
+
+
+ TXR 236
+ 2020-04-18
+
+
+ Features
+
+ - open-file:
+ - new "n" mode for non-blocking open.
+ - now allows async signal delivery during open so blocking open can be
+ interrupted.
+ - New touch function, analogous to Unix utility.
+ - Unicode:
+ - map of characters that need two spaces on the terminal has been updated
+ - now includes emoji in the U+1Fxxxx plane.
+ - Listener:
+ - Tab completion over Unicode identifiers works now.
+ - Path testing functions now also accept integer file descriptor.
+ - configure:
+ - shell identification and re-execution logic in configure script
+ - now avoids re-execution if the original shell seems good.
+
+ Bugs
+
+ - ignwarn: fixed neglect to handle warning exceptions
+ with multiple arguments.
+ - autoloading: definitions now trigger autoload, not only references.
+ Otherwise if user code redefines some system entity that as not yet been
+ loaded, a subsequent attempt to use that entity will trigger autoload,
+ clobbering the user's definition.
+ - open-socket-pair: fix broken function.
+ - sockets: add missing shut-rd, shut-wr and shut-rw variables that are
+ already documented.
+ - unwind/signals: fixed signal mask restoring regression that first
+ appeared in TXR 230.
+ - txr-parse: release deferred warnings if erroring.
+ - open-file: when "m" flag is in effect and POSIX open is used,
+ use 0666 mode, not 0777, else the file will be created with
+ execute permissios if the umask doesn't remove them.
+ - regex: fix crash caused by duplicate regex character range.
+ - vim: work around bug in Vim that causes it to treat "contains"
+ (the name of a TXR Lisp function) as a reserved keyword in the syntax
+ highlighting definition.
+
+
+
+ TXR 235
+ 2020-04-12
+
+
+ Features
+
+ - Lib:
+ - new txr-parse function, opening access to the
+ parser for the TXR Pattern Language.
+ - used by tags.tl.
+ - path testing funtions now accept stream argument.
+ - Exceptions:
+ - unhandled non-error exception throws now simply
+ return instead of terminating.
+ - in pattern language unhandled @(assert) with
+ a non-error exception behaves as failed match.
+ - Parser:
+ - more efficient handling of list syntax.
+ - Listener:
+ - Ctrl-X Ctrl-F command to force submission of unbalanced line.
+ - dot file security tests improved.
+ - permissions of .txr_history files checked also
+ - if permissions on .txr_profile or .txr_history are
+ bad, txr checks and diagnoses the user's umask.
+ - tags.tl script:
+ - now handles txr files: define and bind directives,
+ as well as Lisp forms in @(do ...).
+ - now follows load forms and processes defpackage.
+ - each file read in new temporary package, and
+ restores list of packages after each file.
+ - Build:
+ - Now builds cleanly with -Wextra under GCC 7+.
+
+ Bugs
+
+ - tags.tl:
+ - backslashes not escaped in tags file.
+ - macro-time forms not handled.
+ - configure:
+ - quote characters handled in config variable values.
+ - Doc:
+ - existing lineno argument of read and iread documented.
+ - Hashing:
+ - flaw in weak hash algorithm leading to spurious retention in situations
+ when keys are weak, but values have reference to keys, or vice versa.
+ - caused streams and parsers to leak.
+ - Pattern Language
+ - addressed spurious retention issues, causing memory
+ growth proportional to the amount of input scanned.
+
+
+
+ TXR 234
+ 2020-03-25
+
+
+ Features
+
+ - New base64url encoding:
+ - :frombase64url, :tobase64url filters.
+ - base64url-encode, base64url-decode and other functions.
+ - Compiler:
+ - When a TXR Lisp hash-bang script is compiled, the
+ execute permissions are now propagated to the
+ compiled file, too.
+ - Editing support:
+ - tags.tl script can now be compiled by compile-file,
+ and no longer scans files twice.
+ - GC:
+ - small memory support: ./configure --small-mem.
+ - reduces start-up footprint and size of incremental
+ heap allocations.
+ - Listener:
+ - All major delete operations now yank the deleted
+ text into the clipboard.
+ - Hashing:
+ - hash-uni function has two useful new functional
+ arguments in addition to the join function.
+ - Lib:
+ - apf and ipf functions take additional arguments
+ which are retained and inserted into the apply call.
+ - search function now available under the name contains.
+ - contains reverses the arguments:
+ (search seq it) -> (contains it seq)
+ - OOP:
+ - more efficient stored argument in method and umethod.
+ - (mapcar .(foo 1 2 3 ...) objlist) now allocates one
+ special object that stores the 1 2 3 ... args
+ compactly, rather than consing a list.
+ - more use of this mechanism will be made going forward.
+
+ Bugs
+
+ - Regression in open-process dating to TXR 228.
+ - The hash-count value of weak hashes was not maintained
+ when the garbage collector removed lapsed entries.
+ This was broken from the start; never implemented.
+ - tags.tl: correctly take advantage of FTW_ACTIONRETVAL
+ on glibc.
+ - listener:
+ - Del key not copying to clipboard, rendering it
+ inequivalent to Ctrl-D.
+ - Ctrl-W, when deleting a visual selection and the
+ previous word, not recording undo history properly.
+
+
+
TXR 233
2020-03-08
@@ -1601,7 +4606,7 @@
Features
- - read an iread no longer record source code location info
+ - read and iread no longer record source-code location info
unconditionally
- now controlled by new *rec-source-loc* special variable.
diff --git a/alloca.h b/alloca.h
index 6d55245b..1996b321 100644
--- a/alloca.h
+++ b/alloca.h
@@ -1,4 +1,4 @@
-/* Copyright 2019-2020
+/* Copyright 2019-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#ifndef alloca
@@ -36,3 +37,5 @@
#error portme
#endif
#endif
+
+#define zalloca(size) memset(alloca(size), 0, size)
diff --git a/args.c b/args.c
index cb8c062b..639c9dbc 100644
--- a/args.c
+++ b/args.c
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,29 +6,29 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stddef.h>
#include <signal.h>
#include <string.h>
-#include <stdarg.h>
#include "config.h"
#include "alloca.h"
#include "lib.h"
@@ -37,16 +37,16 @@
#include "gc.h"
#include "args.h"
-val args_cons_list(struct args *args);
+val args_cons_list(varg args);
-val args_add_checked(val name, struct args *args, val arg)
+val args_add_checked(val name, varg args, val arg)
{
if (args->fill >= args->argc)
uw_throwf(assert_s, lit("~a: argument list size exceeded"), name, nao);
return args_add(args, arg);
}
-void args_normalize_exact(struct args *args, cnum fill)
+void args_normalize_exact(varg args, cnum fill)
{
bug_unless (fill <= args->argc);
@@ -58,15 +58,15 @@ void args_normalize_exact(struct args *args, cnum fill)
}
-void args_normalize_least(struct args *args, cnum minfill)
+void args_normalize_least(varg args, cnum minfill)
{
- bug_unless (args->fill <= args->argc);
+ bug_unless (minfill <= args->argc);
while (args->fill < minfill && args->list)
args_add(args, pop(&args->list));
}
-void args_normalize_fill(struct args *args, cnum minfill, cnum maxfill)
+void args_normalize_fill(varg args, cnum minfill, cnum maxfill)
{
args_normalize_least(args, maxfill);
@@ -75,14 +75,14 @@ void args_normalize_fill(struct args *args, cnum minfill, cnum maxfill)
args_add(args, colon_k);
}
-val args_get_checked(val name, struct args *args, cnum *arg_index)
+val args_get_checked(val name, varg args, cnum *arg_index)
{
if (*arg_index >= args->fill && !args->list)
uw_throwf(assert_s, lit("~a: insufficient arguments"), name, nao);
return args_get(args, arg_index);
}
-struct args *args_copy(struct args *to, struct args *from)
+varg args_copy(varg to, varg from)
{
to->fill = from->fill;
to->list = from->list;
@@ -90,14 +90,14 @@ struct args *args_copy(struct args *to, struct args *from)
return to;
}
-struct args *args_copy_zap(struct args *to, struct args *from)
+varg args_copy_zap(varg to, varg from)
{
args_copy(to, from);
memset(from->arg, 0, sizeof *from->arg * from->fill);
return to;
}
-struct args *args_cat(struct args *to, struct args *from)
+varg args_cat(varg to, varg from)
{
size_t size = sizeof *from->arg * from->fill;
to->list = from->list;
@@ -106,7 +106,16 @@ struct args *args_cat(struct args *to, struct args *from)
return to;
}
-struct args *args_cat_zap(struct args *to, struct args *from)
+varg args_cat_from(varg to, varg from, cnum index)
+{
+ size_t size = sizeof *from->arg * (from->fill - index);
+ to->list = from->list;
+ memcpy(to->arg + to->fill, from->arg + index, size);
+ to->fill += from->fill - index;
+ return to;
+}
+
+varg args_cat_zap(varg to, varg from)
{
size_t size = sizeof *from->arg * from->fill;
to->list = from->list;
@@ -116,7 +125,7 @@ struct args *args_cat_zap(struct args *to, struct args *from)
return to;
}
-struct args *args_cat_zap_from(struct args *to, struct args *from, cnum index)
+varg args_cat_zap_from(varg to, varg from, cnum index)
{
size_t size = sizeof *from->arg * (from->fill - index);
to->list = from->list;
@@ -126,7 +135,7 @@ struct args *args_cat_zap_from(struct args *to, struct args *from, cnum index)
return to;
}
-struct args *args_copy_reverse(struct args *to, struct args *from, cnum nargs)
+varg args_copy_reverse(varg to, varg from, cnum nargs)
{
cnum i, index = 0;
@@ -137,7 +146,7 @@ struct args *args_copy_reverse(struct args *to, struct args *from, cnum nargs)
return to;
}
-val args_copy_to_list(struct args *args)
+val args_copy_to_list(varg args)
{
list_collect_decl (out, ptail);
cnum i;
@@ -150,7 +159,7 @@ val args_copy_to_list(struct args *args)
return out;
}
-void args_for_each(struct args *args,
+void args_for_each(varg args,
int (*fn)(val arg, int ix, mem_t *ctx),
mem_t *ctx)
{
@@ -177,6 +186,8 @@ static int args_key_check_store(val arg, int ix, mem_t *ctx)
struct args_bool_ctx *acx = coerce(struct args_bool_ctx *, ctx);
int i, n = acx->n;
+ (void) ix;
+
if (acx->next_arg_store != 0) {
*acx->next_arg_store = arg;
acx->next_arg_store = 0;
@@ -197,7 +208,7 @@ static int args_key_check_store(val arg, int ix, mem_t *ctx)
return 0;
}
-void args_keys_extract(struct args *args, struct args_bool_key *akv, int n)
+void args_keys_extract(varg args, struct args_bool_key *akv, int n)
{
if (n > 0) {
struct args_bool_ctx acx;
@@ -208,11 +219,10 @@ void args_keys_extract(struct args *args, struct args_bool_key *akv, int n)
}
}
-val dyn_args(struct args *args, val car, val cdr)
+val dyn_args(varg args, val car, val cdr)
{
size_t size = offsetof(struct args, arg) + sizeof (val) * args->argc;
- struct args *copy = coerce(struct args *, chk_copy_obj(coerce(mem_t *, args),
- size));
+ varg copy = coerce(varg , chk_copy_obj(coerce(mem_t *, args), size));
val obj = make_obj();
obj->a.type = DARG;
diff --git a/args.h b/args.h
index c1455fd6..7d703845 100644
--- a/args.h
+++ b/args.h
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,30 +6,31 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
struct args {
cnum argc;
cnum fill;
val list;
- val arg[1];
+ val arg[1]; /* deliberate disuse of FLEX_ARRAY */
};
typedef int arg_index;
@@ -37,13 +38,15 @@ typedef int arg_index;
#define ARGS_MAX 32
#define ARGS_MIN 4
+#define ARGS_ABS_MIN 1
+
struct args_bool_key {
val key;
val arg_p;
val *store;
};
-INLINE struct args *args_init_list(struct args *args, cnum argc, val list)
+INLINE varg args_init_list(varg args, cnum argc, val list)
{
args->argc = argc;
args->fill = 0;
@@ -51,27 +54,32 @@ INLINE struct args *args_init_list(struct args *args, cnum argc, val list)
return args;
}
-INLINE void args_set_fill(struct args *args, cnum fill)
+INLINE void args_set_fill(varg args, cnum fill)
{
args->fill = fill;
}
#define args_decl_list(NAME, N, L) \
+ struct { struct args args; val arg[(N) - 1]; } _ac; \
+ varg NAME = args_init_list(&_ac.args, N, L)
+
+#define args_decl_constsize(NAME, N) args_decl_list(NAME, N, nil)
+
+#define args_decl_list_dyn(NAME, N, L) \
mem_t *NAME ## _mem = \
coerce(mem_t *, \
alloca(offsetof(struct args, arg) + (N)*sizeof (val))); \
- struct args *NAME = args_init_list(coerce(struct args *, \
+ varg NAME = args_init_list(coerce(varg , \
NAME ## _mem), N, L)
-#define args_decl(NAME, N) args_decl_list(NAME, N, nil)
+#define args_decl(NAME, N) args_decl_list_dyn(NAME, N, nil)
-
-INLINE val args_add(struct args *args, val arg)
+INLINE val args_add(varg args, val arg)
{
return args->arg[args->fill++] = arg;
}
-INLINE void args_add2(struct args *args, val arg1, val arg2)
+INLINE void args_add2(varg args, val arg1, val arg2)
{
val *arg = args->arg + args->fill;
args->fill += 2;
@@ -79,7 +87,7 @@ INLINE void args_add2(struct args *args, val arg1, val arg2)
*arg++ = arg2;
}
-INLINE void args_add3(struct args *args, val arg1, val arg2, val arg3)
+INLINE void args_add3(varg args, val arg1, val arg2, val arg3)
{
val *arg = args->arg + args->fill;
args->fill += 3;
@@ -88,7 +96,7 @@ INLINE void args_add3(struct args *args, val arg1, val arg2, val arg3)
*arg++ = arg3;
}
-INLINE void args_add4(struct args *args, val arg1, val arg2, val arg3, val arg4)
+INLINE void args_add4(varg args, val arg1, val arg2, val arg3, val arg4)
{
val *arg = args->arg + args->fill;
args->fill += 4;
@@ -98,7 +106,7 @@ INLINE void args_add4(struct args *args, val arg1, val arg2, val arg3, val arg4)
*arg++ = arg4;
}
-INLINE void args_add5(struct args *args, val arg1, val arg2, val arg3,
+INLINE void args_add5(varg args, val arg1, val arg2, val arg3,
val arg4, val arg5)
{
val *arg = args->arg + args->fill;
@@ -110,19 +118,19 @@ INLINE void args_add5(struct args *args, val arg1, val arg2, val arg3,
*arg++ = arg5;
}
-val args_add_checked(val name, struct args *args, val arg);
+val args_add_checked(val name, varg args, val arg);
-INLINE void args_add_list(struct args *args, val list)
+INLINE void args_add_list(varg args, val list)
{
args->list = list;
}
-INLINE int args_more(struct args *args, cnum index)
+INLINE int args_more(varg args, cnum index)
{
return index < args->fill || args->list;
}
-INLINE int args_two_more(struct args *args, cnum index)
+INLINE int args_two_more(varg args, cnum index)
{
return
index + 1 < args->fill ||
@@ -130,11 +138,16 @@ INLINE int args_two_more(struct args *args, cnum index)
cdr(args->list);
}
-void args_normalize_exact(struct args *args, cnum fill);
-void args_normalize_least(struct args *args, cnum fill);
-void args_normalize_fill(struct args *args, cnum minfill, cnum maxfill);
+INLINE int args_more_nozap(varg args, cnum index, val list)
+{
+ return list || index < args->fill;
+}
-INLINE val args_get_list(struct args *args)
+void args_normalize_exact(varg args, cnum fill);
+void args_normalize_least(varg args, cnum fill);
+void args_normalize_fill(varg args, cnum minfill, cnum maxfill);
+
+INLINE val args_get_list(varg args)
{
if (args->fill == 0)
return z(args->list);
@@ -142,7 +155,7 @@ INLINE val args_get_list(struct args *args)
return z(args->list);
}
-INLINE val args_get_rest(struct args *args, cnum index)
+INLINE val args_get_rest(varg args, cnum index)
{
if (args->fill == index)
return z(args->list);
@@ -150,14 +163,14 @@ INLINE val args_get_rest(struct args *args, cnum index)
return z(args->list);
}
-INLINE val args_at(struct args *args, cnum arg_index)
+INLINE val args_at(varg args, cnum arg_index)
{
if (arg_index < args->fill)
return args->arg[arg_index];
return car(args->list);
}
-INLINE val args_atz(struct args *args, cnum arg_index)
+INLINE val args_atz(varg args, cnum arg_index)
{
if (arg_index < args->fill) {
return z(args->arg[arg_index]);
@@ -166,28 +179,36 @@ INLINE val args_atz(struct args *args, cnum arg_index)
}
}
-INLINE val args_get(struct args *args, cnum *arg_index)
+INLINE val args_get(varg args, cnum *arg_index)
{
if (*arg_index < args->fill)
return z(args->arg[(*arg_index)++]);
return pop(&args->list);
}
-INLINE cnum args_count(struct args *args)
+INLINE val args_get_nozap(varg args, cnum *arg_index, val *list)
+{
+ if (*arg_index < args->fill)
+ return args->arg[(*arg_index)++];
+ return pop(list);
+}
+
+INLINE cnum args_count(varg args, val self)
{
- return args->fill + c_num(length_list(args->list));
+ return args->fill + c_num(length_list(args->list), self);
}
-val args_get_checked(val name, struct args *args, cnum *arg_index);
-struct args *args_copy(struct args *to, struct args *from);
-struct args *args_copy_zap(struct args *to, struct args *from);
-struct args *args_cat(struct args *to, struct args *from);
-struct args *args_cat_zap(struct args *to, struct args *from);
-struct args *args_cat_zap_from(struct args *to, struct args *from, cnum index);
-struct args *args_copy_reverse(struct args *to, struct args *from, cnum nargs);
-val args_copy_to_list(struct args *args);
-void args_for_each(struct args *args,
+val args_get_checked(val name, varg args, cnum *arg_index);
+varg args_copy(varg to, varg from);
+varg args_copy_zap(varg to, varg from);
+varg args_cat(varg to, varg from);
+varg args_cat_from(varg to, varg from, cnum index);
+varg args_cat_zap(varg to, varg from);
+varg args_cat_zap_from(varg to, varg from, cnum index);
+varg args_copy_reverse(varg to, varg from, cnum nargs);
+val args_copy_to_list(varg args);
+void args_for_each(varg args,
int (*fn)(val arg, int ix, mem_t *ctx),
mem_t *ctx);
-void args_keys_extract(struct args *args, struct args_bool_key *, int n);
-val dyn_args(struct args *args, val car, val cdr);
+void args_keys_extract(varg args, struct args_bool_key *, int n);
+val dyn_args(varg args, val car, val cdr);
diff --git a/arith.c b/arith.c
index ed559a26..928da790 100644
--- a/arith.c
+++ b/arith.c
@@ -1,4 +1,4 @@
-/* Copyright 2010-2020
+/* Copyright 2010-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stdio.h>
@@ -30,7 +31,6 @@
#include <stddef.h>
#include <string.h>
#include <wctype.h>
-#include <stdarg.h>
#include <wchar.h>
#include <math.h>
#include <signal.h>
@@ -50,13 +50,12 @@
#include "itypes.h"
#include "struct.h"
#include "txr.h"
+#include "psquare.h"
+#include "autoload.h"
#include "arith.h"
#define max(a, b) ((a) > (b) ? (a) : (b))
-#define TAG_PAIR(A, B) ((A) << TAG_SHIFT | (B))
-#define NOOP(A, B)
-#define CNUM_BIT ((int) sizeof (cnum) * CHAR_BIT)
#define ABS(A) ((A) < 0 ? -(A) : (A))
val plus_s, minus_s, inv_minus_s, neg_s, abs_s, signum_s;
@@ -75,6 +74,18 @@ val logand_s, logior_s, logxor_s;
val lognot1_s, lognot_s, r_lognot_s, logtrunc_s, r_logtrunc_s;
val sign_extend_s, ash_s, bit_s, width_s, bitset_s, logcount_s;
+val cbrt_s, erf_s, erfc_s, exp10_s, exp2_s, expm1_s;
+val gamma_s, j0_s, j1_s, lgamma_s, log1p_s, logb_s;
+val nearbyint_s, rint_s, significand_s, tgamma_s, y0_s, y1_s;
+val copysign_s, drem_s, fdim_s, fmax_s, fmin_s, hypot_s;
+val jn_s, ldexp_s, nextafter_s, remainder_s, scalb_s;
+val scalbln_s, yn_s;
+val r_copysign_s, r_drem_s, r_fdim_s, r_fmax_s, r_fmin_s, r_hypot_s;
+val r_jn_s, r_ldexp_s, r_nextafter_s, r_remainder_s, r_scalb_s;
+val r_scalbln_s, r_yn_s;
+
+val tofloat_s, toint_s;
+
val make_bignum(void)
{
val n = make_obj();
@@ -125,33 +136,22 @@ val num_from_buffer(mem_t *buf, int bytes)
return normalize(n);
}
-static noreturn void not_number(val self, val obj)
+static NORETURN void not_number(val self, val obj)
{
uw_throwf(type_error_s, lit("~a: ~s is not a number"), self, obj, nao);
}
-static noreturn void not_integer(val self, val obj)
+static NORETURN void not_integer(val self, val obj)
{
uw_throwf(type_error_s, lit("~a: ~s is not an integer"), self, obj, nao);
}
-static noreturn void invalid_ops(val self, val obj1, val obj2)
-{
- uw_throwf(type_error_s, lit("~a: invalid operands ~s ~s"), self,
- obj1, obj2, nao);
-}
-
-static noreturn void invalid_op(val self, val obj)
-{
- uw_throwf(type_error_s, lit("~a: invalid operand ~s"), self, obj, nao);
-}
-
int num_to_buffer(val num, mem_t *buf, int bytes)
{
switch (type(num)) {
case CHR: case NUM:
{
- cnum n = coerce(cnum, num) >> TAG_SHIFT;
+ cnum n = c_n(num);
mem_t *ptr = buf + bytes;
for (; n != 0; n >>= 8) {
@@ -199,12 +199,19 @@ val normalize(val bignum)
}
}
-ucnum c_unum(val num)
+ucnum c_unum(val num, val self)
{
switch (type(num)) {
- case CHR: case NUM:
+ case CHR:
{
- cnum n = coerce(cnum, num) >> TAG_SHIFT;
+ cnum n = c_ch(num);
+ if (n >= 0)
+ return n;
+ }
+ goto range;
+ case NUM:
+ {
+ cnum n = c_n(num);
if (n >= 0)
return n;
}
@@ -217,10 +224,10 @@ ucnum c_unum(val num)
}
/* fallthrough */
range:
- uw_throwf(error_s, lit("~s is out of allowed range [0, ~a]"),
- num, unum(UINT_PTR_MAX), nao);
+ uw_throwf(error_s, lit("~a: ~s is out of allowed range [0, ~a]"),
+ self, num, unum(UINT_PTR_MAX), nao);
default:
- type_mismatch(lit("~s is not an integer"), num, nao);
+ uw_throwf(type_error_s, lit("~a: ~s is not an integer"), self, num, nao);
}
}
@@ -240,8 +247,10 @@ val unum(ucnum u)
dbl_cnum c_dbl_num(val n)
{
switch (type(n)) {
- case CHR: case NUM:
- return coerce(cnum, n) >> TAG_SHIFT;
+ case CHR:
+ return c_ch(n);
+ case NUM:
+ return c_n(n);
case BGNUM:
if (mp_in_double_intptr_range(mp(n))) {
double_intptr_t out;
@@ -258,19 +267,32 @@ dbl_cnum c_dbl_num(val n)
dbl_ucnum c_dbl_unum(val n)
{
switch (type(n)) {
- case CHR: case NUM:
- return coerce(cnum, n) >> TAG_SHIFT;
+ case CHR:
+ {
+ dbl_cnum cn = c_ch(n);
+ if (cn >= 0)
+ return cn;
+ break;
+ }
+ case NUM:
+ {
+ dbl_cnum cn = c_n(n);
+ if (cn >= 0)
+ return cn;
+ break;
+ }
case BGNUM:
if (mp_in_double_uintptr_range(mp(n))) {
double_uintptr_t out;
mp_get_double_uintptr(mp(n), &out);
return out;
}
- uw_throwf(error_s, lit("~s is out of unsigned ~a bit range"),
- n, num_fast(SIZEOF_DOUBLE_INTPTR * CHAR_BIT), nao);
+ break;
default:
type_mismatch(lit("~s is not an integer"), n, nao);
}
+ uw_throwf(error_s, lit("~s is out of unsigned ~a bit range"),
+ n, num_fast(SIZEOF_DOUBLE_INTPTR * CHAR_BIT), nao);
}
#endif
@@ -470,7 +492,13 @@ static int highest_significant_bit(int_ptr_t n)
{
if (n >= 0)
return highest_bit(n);
- return highest_bit(n ^ INT_PTR_MAX);
+ return highest_bit(-n - 1);
+}
+
+static UNUSED NORETURN void not_available(val name)
+{
+ uw_throwf(file_error_s, lit("~a is not available on this platform"),
+ name, nao);
}
void do_mp_error(val self, mp_err code)
@@ -479,13 +507,13 @@ void do_mp_error(val self, mp_err code)
uw_throwf(numeric_error_s, lit("~a: ~a"), self, errstr, nao);
}
-static noreturn void not_struct_error(val self, val obj)
+static NORETURN void not_struct_error(val self, val obj)
{
uw_throwf(error_s, lit("~a: ~s isn't a structure"),
self, obj, nao);
}
-static noreturn void method_error(val self, val obj, val fun)
+static NORETURN void method_error(val self, val obj, val fun)
{
uw_throwf(error_s, lit("~a: object ~s lacks ~a method"),
self, obj, fun, nao);
@@ -663,7 +691,7 @@ tail:
break;
case TAG_PAIR(TAG_CHR, TAG_NUM):
{
- wchar_t a = c_chr(anum);
+ wchar_t a = c_ch(anum);
cnum b = c_n(bnum);
cnum sum = a + b;
@@ -674,7 +702,7 @@ tail:
case TAG_PAIR(TAG_NUM, TAG_CHR):
{
cnum a = c_n(anum);
- wchar_t b = c_chr(bnum);
+ wchar_t b = c_ch(bnum);
cnum sum = a + b;
if (sum < 0 || sum > 0x10FFFF)
@@ -703,9 +731,18 @@ val minus(val anum, val bnum)
tail:
switch (TAG_PAIR(tag(anum), tag(bnum))) {
- case TAG_PAIR(TAG_NUM, TAG_NUM):
case TAG_PAIR(TAG_CHR, TAG_CHR):
{
+ cnum a = c_ch(anum);
+ cnum b = c_ch(bnum);
+ cnum sum = a - b;
+
+ if (sum < NUM_MIN || sum > NUM_MAX)
+ return bignum(sum);
+ return num_fast(sum);
+ }
+ case TAG_PAIR(TAG_NUM, TAG_NUM):
+ {
cnum a = c_n(anum);
cnum b = c_n(bnum);
cnum sum = a - b;
@@ -835,7 +872,7 @@ tail:
break;
case TAG_PAIR(TAG_CHR, TAG_NUM):
{
- wchar_t a = c_chr(anum);
+ wchar_t a = c_ch(anum);
cnum b = c_n(bnum);
cnum sum = a - b;
@@ -918,7 +955,7 @@ static val signum(val anum)
return if3(mp_isneg(mp(anum)), negone, one);
case FLNUM:
{
- double a = anum->fl.n;
+ double a = c_f(anum);
return flo(if3(a > 0, 1.0, if3(a < 0, -1.0, 0.0)));
}
case NUM:
@@ -951,7 +988,7 @@ tail:
#else
cnum ap = ABS(a);
cnum bp = ABS(b);
- if (highest_bit(ap) + highest_bit(bp) < CNUM_BIT - 1) {
+ if (highest_bit(ap) + highest_bit(bp) < PTR_BIT - 1) {
cnum product = a * b;
if (product >= NUM_MIN && product <= NUM_MAX)
return num_fast(product);
@@ -1109,7 +1146,7 @@ static val trunc1(val self, val num)
invalid_op(self, num);
}
-static noreturn void divzero(val self)
+static NORETURN void divzero(val self)
{
uw_throwf(numeric_error_s, lit("~a: division by zero"), self, nao);
}
@@ -1898,16 +1935,89 @@ val pppred(val num)
return minus(num, three);
}
+static void seq_lt_compat_check(seq_iter_t *ita, seq_iter_t *itb,
+ val a, val b, val self)
+{
+ if (ita->inf.kind == SEQ_NOTSEQ || ita->inf.kind == SEQ_HASHLIKE ||
+ itb->inf.kind == SEQ_NOTSEQ || itb->inf.kind == SEQ_HASHLIKE)
+ {
+ uw_throwf(error_s, lit("~a: invalid operands ~s ~s"), self, a, b, nao);
+ }
+}
+
+static val seq_lt(val self, val aseq, val bseq)
+{
+ seq_iter_t ita, itb;
+ seq_iter_init(self, &ita, aseq);
+ seq_iter_init(self, &itb, bseq);
+
+ seq_lt_compat_check(&ita, &itb, aseq, bseq, self);
+
+ for (;;) {
+ val aelem, belem;
+ switch (seq_peek(&ita, &aelem) << 1 | seq_peek(&itb, &belem)) {
+ case 0:
+ return nil;
+ case 1:
+ return t;
+ case 2:
+ return nil;
+ case 3:
+ if (lt(aelem, belem))
+ return t;
+ if (!numeq(aelem, belem))
+ return nil;
+ seq_geti(&ita);
+ seq_geti(&itb);
+ break;
+ default:
+ internal_error("bad return value from iterator peek");
+ }
+ }
+}
+
+static val seq_le(val self, val aseq, val bseq)
+{
+ seq_iter_t ita, itb;
+ seq_iter_init(self, &ita, aseq);
+ seq_iter_init(self, &itb, bseq);
+
+ seq_lt_compat_check(&ita, &itb, aseq, bseq, self);
+
+ for (;;) {
+ val aelem, belem;
+ switch (seq_peek(&ita, &aelem) << 1 | seq_peek(&itb, &belem)) {
+ case 0:
+ return t;
+ case 1:
+ return t;
+ case 2:
+ return nil;
+ case 3:
+ if (!le(aelem, belem))
+ return nil;
+ seq_geti(&ita);
+ seq_geti(&itb);
+ break;
+ default:
+ internal_error("bad return value from iterator peek");
+ }
+ }
+}
+
val gt(val anum, val bnum)
{
val self = gt_s;
tail:
switch (TYPE_PAIR(type(anum), type(bnum))) {
case TYPE_PAIR(NUM, NUM):
+ return c_n(anum) > c_n(bnum) ? t : nil;
case TYPE_PAIR(CHR, CHR):
+ return c_ch(anum) > c_ch(bnum) ? t : nil;
case TYPE_PAIR(NUM, CHR):
+ return c_n(anum) > c_ch(bnum) ? t : nil;
case TYPE_PAIR(CHR, NUM):
- return c_n(anum) > c_n(bnum) ? t : nil;
+ return c_ch(anum) > c_n(bnum) ? t : nil;
case TYPE_PAIR(NUM, BGNUM):
case TYPE_PAIR(CHR, BGNUM):
return mp_cmp_z(mp(bnum)) == MP_LT ? t : nil;
@@ -1917,11 +2027,13 @@ tail:
case TYPE_PAIR(BGNUM, BGNUM):
return mp_cmp(mp(anum), mp(bnum)) == MP_GT ? t : nil;
case TYPE_PAIR(NUM, FLNUM):
- case TYPE_PAIR(CHR, FLNUM):
return c_n(anum) > c_flo(bnum, self) ? t : nil;
+ case TYPE_PAIR(CHR, FLNUM):
+ return c_ch(anum) > c_flo(bnum, self) ? t : nil;
case TYPE_PAIR(FLNUM, NUM):
- case TYPE_PAIR(FLNUM, CHR):
return c_flo(anum, self) > c_n(bnum) ? t : nil;
+ case TYPE_PAIR(FLNUM, CHR):
+ return c_flo(anum, self) > c_ch(bnum) ? t : nil;
case TYPE_PAIR(FLNUM, FLNUM):
return c_flo(anum, self) > c_flo(bnum, self) ? t : nil;
case TYPE_PAIR(FLNUM, BGNUM):
@@ -1956,9 +2068,9 @@ tail:
case TYPE_PAIR(FLNUM, COBJ):
case TYPE_PAIR(RNG, COBJ):
return do_binary_method(self, lt_s, bnum, anum);
+ default:
+ return seq_lt(self, bnum, anum);
}
-
- invalid_ops(self, anum, bnum);
}
val lt(val anum, val bnum)
@@ -1967,10 +2079,13 @@ val lt(val anum, val bnum)
tail:
switch (TYPE_PAIR(type(anum), type(bnum))) {
case TYPE_PAIR(NUM, NUM):
+ return c_n(anum) < c_n(bnum) ? t : nil;
case TYPE_PAIR(CHR, CHR):
+ return c_ch(anum) < c_ch(bnum) ? t : nil;
case TYPE_PAIR(NUM, CHR):
+ return c_n(anum) < c_ch(bnum) ? t : nil;
case TYPE_PAIR(CHR, NUM):
- return c_n(anum) < c_n(bnum) ? t : nil;
+ return c_ch(anum) < c_n(bnum) ? t : nil;
case TYPE_PAIR(NUM, BGNUM):
case TYPE_PAIR(CHR, BGNUM):
return mp_cmp_z(mp(bnum)) == MP_GT ? t : nil;
@@ -1980,11 +2095,13 @@ tail:
case TYPE_PAIR(BGNUM, BGNUM):
return mp_cmp(mp(anum), mp(bnum)) == MP_LT ? t : nil;
case TYPE_PAIR(NUM, FLNUM):
- case TYPE_PAIR(CHR, FLNUM):
return c_n(anum) < c_flo(bnum, self) ? t : nil;
+ case TYPE_PAIR(CHR, FLNUM):
+ return c_ch(anum) < c_flo(bnum, self) ? t : nil;
case TYPE_PAIR(FLNUM, NUM):
- case TYPE_PAIR(FLNUM, CHR):
return c_flo(anum, self) < c_n(bnum) ? t : nil;
+ case TYPE_PAIR(FLNUM, CHR):
+ return c_flo(anum, self) < c_ch(bnum) ? t : nil;
case TYPE_PAIR(FLNUM, FLNUM):
return c_flo(anum, self) < c_flo(bnum, self) ? t : nil;
case TYPE_PAIR(FLNUM, BGNUM):
@@ -2019,9 +2136,9 @@ tail:
case TYPE_PAIR(FLNUM, COBJ):
case TYPE_PAIR(RNG, COBJ):
return do_binary_method(self, gt_s, bnum, anum);
+ default:
+ return seq_lt(self, anum, bnum);
}
-
- invalid_ops(self, anum, bnum);
}
val ge(val anum, val bnum)
@@ -2030,10 +2147,13 @@ val ge(val anum, val bnum)
tail:
switch (TYPE_PAIR(type(anum), type(bnum))) {
case TYPE_PAIR(NUM, NUM):
+ return c_n(anum) >= c_n(bnum) ? t : nil;
case TYPE_PAIR(CHR, CHR):
+ return c_ch(anum) >= c_ch(bnum) ? t : nil;
case TYPE_PAIR(NUM, CHR):
+ return c_n(anum) >= c_ch(bnum) ? t : nil;
case TYPE_PAIR(CHR, NUM):
- return c_n(anum) >= c_n(bnum) ? t : nil;
+ return c_ch(anum) >= c_n(bnum) ? t : nil;
case TYPE_PAIR(NUM, BGNUM):
case TYPE_PAIR(CHR, BGNUM):
return mp_cmp_z(mp(bnum)) == MP_LT ? t : nil;
@@ -2048,11 +2168,13 @@ tail:
return nil;
}
case TYPE_PAIR(NUM, FLNUM):
- case TYPE_PAIR(CHR, FLNUM):
return c_n(anum) >= c_flo(bnum, self) ? t : nil;
+ case TYPE_PAIR(CHR, FLNUM):
+ return c_ch(anum) >= c_flo(bnum, self) ? t : nil;
case TYPE_PAIR(FLNUM, NUM):
- case TYPE_PAIR(FLNUM, CHR):
return c_flo(anum, self) >= c_n(bnum) ? t : nil;
+ case TYPE_PAIR(FLNUM, CHR):
+ return c_flo(anum, self) >= c_ch(bnum) ? t : nil;
case TYPE_PAIR(FLNUM, FLNUM):
return c_flo(anum, self) >= c_flo(bnum, self) ? t : nil;
case TYPE_PAIR(FLNUM, BGNUM):
@@ -2087,9 +2209,9 @@ tail:
case TYPE_PAIR(FLNUM, COBJ):
case TYPE_PAIR(RNG, COBJ):
return do_binary_method(self, le_s, bnum, anum);
+ default:
+ return seq_le(self, bnum, anum);
}
-
- invalid_ops(self, anum, bnum);
}
val le(val anum, val bnum)
@@ -2098,10 +2220,13 @@ val le(val anum, val bnum)
tail:
switch (TYPE_PAIR(type(anum), type(bnum))) {
case TYPE_PAIR(NUM, NUM):
+ return c_n(anum) <= c_n(bnum) ? t : nil;
case TYPE_PAIR(CHR, CHR):
+ return c_ch(anum) <= c_ch(bnum) ? t : nil;
case TYPE_PAIR(NUM, CHR):
+ return c_n(anum) <= c_ch(bnum) ? t : nil;
case TYPE_PAIR(CHR, NUM):
- return c_n(anum) <= c_n(bnum) ? t : nil;
+ return c_ch(anum) <= c_n(bnum) ? t : nil;
case TYPE_PAIR(NUM, BGNUM):
case TYPE_PAIR(CHR, BGNUM):
return mp_cmp_z(mp(bnum)) == MP_GT ? t : nil;
@@ -2116,11 +2241,13 @@ tail:
return nil;
}
case TYPE_PAIR(NUM, FLNUM):
- case TYPE_PAIR(CHR, FLNUM):
return c_n(anum) <= c_flo(bnum, self) ? t : nil;
+ case TYPE_PAIR(CHR, FLNUM):
+ return c_ch(anum) <= c_flo(bnum, self) ? t : nil;
case TYPE_PAIR(FLNUM, NUM):
- case TYPE_PAIR(FLNUM, CHR):
return c_flo(anum, self) <= c_n(bnum) ? t : nil;
+ case TYPE_PAIR(FLNUM, CHR):
+ return c_flo(anum, self) <= c_ch(bnum) ? t : nil;
case TYPE_PAIR(FLNUM, FLNUM):
return c_flo(anum, self) <= c_flo(bnum, self) ? t : nil;
case TYPE_PAIR(FLNUM, BGNUM):
@@ -2155,9 +2282,39 @@ tail:
case TYPE_PAIR(FLNUM, COBJ):
case TYPE_PAIR(RNG, COBJ):
return do_binary_method(self, ge_s, bnum, anum);
+ default:
+ return seq_le(self, anum, bnum);
}
+}
- invalid_ops(self, anum, bnum);
+static val seq_numeq(val self, val aseq, val bseq)
+{
+ seq_iter_t ita, itb;
+ seq_iter_init(self, &ita, aseq);
+ seq_iter_init(self, &itb, bseq);
+
+ if (ita.inf.kind == SEQ_VECLIKE && itb.inf.kind == SEQ_VECLIKE) {
+ if (length(aseq) != length(bseq))
+ return nil;
+ }
+
+ for (;;) {
+ val aelem, belem;
+ switch (seq_peek(&ita, &aelem) + seq_peek(&itb, &belem)) {
+ case 0:
+ return t;
+ case 1:
+ return nil;
+ case 2:
+ if (!numeq(aelem, belem))
+ return nil;
+ seq_geti(&ita);
+ seq_geti(&itb);
+ break;
+ default:
+ internal_error("bad return value from iterator peek");
+ }
+ }
}
val numeq(val anum, val bnum)
@@ -2166,10 +2323,13 @@ val numeq(val anum, val bnum)
tail:
switch (TYPE_PAIR(type(anum), type(bnum))) {
case TYPE_PAIR(NUM, NUM):
+ return c_n(anum) == c_n(bnum) ? t : nil;
case TYPE_PAIR(CHR, CHR):
+ return c_ch(anum) == c_ch(bnum) ? t : nil;
case TYPE_PAIR(NUM, CHR):
+ return c_n(anum) == c_ch(bnum) ? t : nil;
case TYPE_PAIR(CHR, NUM):
- return c_n(anum) == c_n(bnum) ? t : nil;
+ return c_ch(anum) == c_n(bnum) ? t : nil;
case TYPE_PAIR(NUM, BGNUM):
case TYPE_PAIR(CHR, BGNUM):
return mp_cmp_z(mp(bnum)) == MP_EQ ? t : nil;
@@ -2179,11 +2339,13 @@ tail:
case TYPE_PAIR(BGNUM, BGNUM):
return mp_cmp(mp(anum), mp(bnum)) == MP_EQ ? t : nil;
case TYPE_PAIR(NUM, FLNUM):
- case TYPE_PAIR(CHR, FLNUM):
return c_n(anum) == c_flo(bnum, self) ? t : nil;
+ case TYPE_PAIR(CHR, FLNUM):
+ return c_ch(anum) == c_flo(bnum, self) ? t : nil;
case TYPE_PAIR(FLNUM, NUM):
- case TYPE_PAIR(FLNUM, CHR):
return c_flo(anum, self) == c_n(bnum) ? t : nil;
+ case TYPE_PAIR(FLNUM, CHR):
+ return c_flo(anum, self) == c_ch(bnum) ? t : nil;
case TYPE_PAIR(FLNUM, FLNUM):
return c_flo(anum, self) == c_flo(bnum, self) ? t : nil;
case TYPE_PAIR(FLNUM, BGNUM):
@@ -2208,9 +2370,9 @@ tail:
case TYPE_PAIR(FLNUM, COBJ):
case TYPE_PAIR(RNG, COBJ):
return do_binary_method(self, self, bnum, anum);
+ default:
+ return seq_numeq(self, anum, bnum);
}
-
- invalid_ops(self, anum, bnum);
}
val expt(val anum, val bnum)
@@ -2325,6 +2487,8 @@ tail:
cnum a = c_n(anum);
double b = c_flo(bnum, self);
+ if (b == 0.0)
+ return flo(1.0);
if (a == 0 && b < 0)
goto divzero;
return flo(pow(a, b));
@@ -2334,6 +2498,8 @@ tail:
double a = c_flo(anum, self);
cnum b = c_n(bnum);
+ if (b == 0)
+ return flo(1.0);
if (a == 0 && b < 0)
goto divzero;
return flo(pow(a, b));
@@ -2343,6 +2509,8 @@ tail:
{
double a = c_flo(anum, self);
double b = c_flo(bnum, self);
+ if (b == 0.0)
+ return flo(1.0);
if (a == 0 && b < 0)
goto divzero;
return flo(pow(a, b));
@@ -2467,7 +2635,7 @@ val square(val anum)
return num_fast(product);
#else
cnum ap = ABS(a);
- if (2 * highest_bit(ap) < CNUM_BIT - 1) {
+ if (2 * highest_bit(ap) < PTR_BIT - 1) {
cnum product = a * a;
if (product >= NUM_MIN && product <= NUM_MAX)
return num_fast(product);
@@ -2509,33 +2677,84 @@ val square(val anum)
val gcd(val anum, val bnum)
{
- val n;
-
- if (!integerp(anum) || !integerp(bnum))
- goto inval;
-
- if (anum == zero)
- return bnum;
-
- if (bnum == zero)
- return anum;
-
- if (fixnump(anum))
- anum = bignum(c_n(anum));
-
- if (fixnump(bnum))
- bnum = bignum(c_n(bnum));
+ val self = lit("gcd");
+ ucnum ua, ub;
- n = make_bignum();
+ switch (TYPE_PAIR(type(anum), type(bnum))) {
+ case TYPE_PAIR(BGNUM, BGNUM):
+ if (mp_in_uintptr_range(mp(anum)) && mp_in_uintptr_range(mp(bnum))) {
+ ua = c_unum(anum, self);
+ ub = c_unum(bnum, self);
+ goto both_ucnum;
+ } else {
+ val n = make_bignum();
+ if (mp_gcd(mp(anum), mp(bnum), mp(n)) != MP_OKAY)
+ break;
+ return normalize(n);
+ }
+ case TYPE_PAIR(NUM, NUM):
+ if (anum == zero)
+ return bnum;
+ if (bnum == zero)
+ return anum;
+ ua = c_u(anum);
+ ub = c_u(bnum);
+ both_ucnum:
+ {
+ int k = 0;
+ while ((ua & 1) == 0 && (ub & 1) == 0) {
+ ua >>= 1;
+ ub >>= 1;
+ k++;
+ }
+ while ((ub & 1) == 0)
+ ub >>= 1;
+ while ((ua & 1) == 0)
+ ua >>= 1;
+ for (;;) {
+ if (ua > ub) {
+ ucnum tmp = ua;
+ ua = ub;
+ ub = tmp;
+ }
+ ub -= ua;
+ if (ub == 0)
+ break;
+ while ((ub & 1) == 0)
+ ub >>= 1;
+ }
+ return unum(ua << k);
+ }
+ case TYPE_PAIR(NUM, BGNUM):
+ {
+ val tmp = anum;
+ anum = bnum;
+ bnum = tmp;
+ }
+ /* fallthrough */
+ case TYPE_PAIR(BGNUM, NUM):
+ if (mp_in_uintptr_range(mp(anum))) {
+ ua = c_unum(anum, self);
+ ub = c_u(bnum);
+ goto both_ucnum;
+ } else {
+ mp_int bn;
+ val n = make_bignum();
- if (mp_gcd(mp(anum), mp(bnum), mp(n)) != MP_OKAY)
- goto bad;
+ mp_init(&bn);
+ mp_set_intptr(&bn, c_u(bnum));
+ if (mp_gcd(mp(anum), &bn, mp(n)) != MP_OKAY) {
+ mp_clear(&bn);
+ break;
+ }
+ mp_clear(&bn);
+ return normalize(n);
+ }
+ default:
+ uw_throwf(error_s, lit("gcd: non-integral operands ~s ~s"),
+ anum, bnum, nao);
+ }
- return normalize(n);
-inval:
- uw_throwf(error_s, lit("gcd: non-integral operands ~s ~s"),
- anum, bnum, nao);
-bad:
uw_throwf(error_s, lit("gcd: operation failed on ~s ~s"),
anum, bnum, nao);
}
@@ -2821,6 +3040,418 @@ val sqroot(val num)
return flo(sqrt(c_flo(to_float(self, num), self)));
}
+static val cbrt_wrap(val num)
+{
+ val self = cbrt_s;
+ if (cobjp(num))
+ return do_unary_method(self, self, num);
+#if HAVE_CBRT
+ return flo(cbrt(c_flo(to_float(self, num), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val erf_wrap(val num)
+{
+ val self = erf_s;
+ if (cobjp(num))
+ return do_unary_method(self, self, num);
+#if HAVE_ERF
+ return flo(erf(c_flo(to_float(self, num), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val erfc_wrap(val num)
+{
+ val self = erfc_s;
+ if (cobjp(num))
+ return do_unary_method(self, self, num);
+#if HAVE_ERFC
+ return flo(erfc(c_flo(to_float(self, num), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val exp10_wrap(val num)
+{
+ val self = exp10_s;
+ if (cobjp(num))
+ return do_unary_method(self, self, num);
+#if HAVE_EXP10
+ return flo(exp10(c_flo(to_float(self, num), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val exp2_wrap(val num)
+{
+ val self = exp2_s;
+ if (cobjp(num))
+ return do_unary_method(self, self, num);
+#if HAVE_EXP2
+ return flo(exp2(c_flo(to_float(self, num), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val expm1_wrap(val num)
+{
+ val self = expm1_s;
+ if (cobjp(num))
+ return do_unary_method(self, self, num);
+#if HAVE_EXPM1
+ return flo(expm1(c_flo(to_float(self, num), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val gamma_wrap(val num)
+{
+ val self = gamma_s;
+ if (cobjp(num))
+ return do_unary_method(self, self, num);
+#if HAVE_GAMMA
+ return flo(gamma(c_flo(to_float(self, num), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val j0_wrap(val num)
+{
+ val self = j0_s;
+ if (cobjp(num))
+ return do_unary_method(self, self, num);
+#if HAVE_J0
+ return flo(j0(c_flo(to_float(self, num), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val j1_wrap(val num)
+{
+ val self = j1_s;
+ if (cobjp(num))
+ return do_unary_method(self, self, num);
+#if HAVE_J1
+ return flo(j1(c_flo(to_float(self, num), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val lgamma_wrap(val num)
+{
+ val self = lgamma_s;
+ if (cobjp(num))
+ return do_unary_method(self, self, num);
+#if HAVE_LGAMMA
+ return flo(lgamma(c_flo(to_float(self, num), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val log1p_wrap(val num)
+{
+ val self = log1p_s;
+ if (cobjp(num))
+ return do_unary_method(self, self, num);
+#if HAVE_LOG1P
+ return flo(log1p(c_flo(to_float(self, num), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val logb_wrap(val num)
+{
+ val self = logb_s;
+ if (cobjp(num))
+ return do_unary_method(self, self, num);
+#if HAVE_LOGB
+ return flo(logb(c_flo(to_float(self, num), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val nearbyint_wrap(val num)
+{
+ val self = nearbyint_s;
+ if (cobjp(num))
+ return do_unary_method(self, self, num);
+#if HAVE_NEARBYINT
+ return flo(nearbyint(c_flo(to_float(self, num), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val rint_wrap(val num)
+{
+ val self = rint_s;
+ if (cobjp(num))
+ return do_unary_method(self, self, num);
+#if HAVE_RINT
+ return flo(rint(c_flo(to_float(self, num), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val significand_wrap(val num)
+{
+ val self = significand_s;
+ if (cobjp(num))
+ return do_unary_method(self, self, num);
+#if HAVE_SIGNIFICAND
+ return flo(significand(c_flo(to_float(self, num), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val tgamma_wrap(val num)
+{
+ val self = tgamma_s;
+ if (cobjp(num))
+ return do_unary_method(self, self, num);
+#if HAVE_TGAMMA
+ return flo(tgamma(c_flo(to_float(self, num), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val y0_wrap(val num)
+{
+ val self = y0_s;
+ if (cobjp(num))
+ return do_unary_method(self, self, num);
+#if HAVE_Y0
+ return flo(y0(c_flo(to_float(self, num), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val y1_wrap(val num)
+{
+ val self = y1_s;
+ if (cobjp(num))
+ return do_unary_method(self, self, num);
+#if HAVE_Y1
+ return flo(y1(c_flo(to_float(self, num), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val copysign_wrap(val anum, val bnum)
+{
+ val self = copysign_s;
+ if (cobjp(anum))
+ return do_binary_method(self, self, anum, bnum);
+ if (cobjp(bnum))
+ return do_binary_method(self, r_copysign_s, bnum, anum);
+#if HAVE_COPYSIGN
+ return flo(copysign(c_flo(to_float(self, anum), self),
+ c_flo(to_float(self, bnum), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val drem_wrap(val anum, val bnum)
+{
+ val self = drem_s;
+ if (cobjp(anum))
+ return do_binary_method(self, self, anum, bnum);
+ if (cobjp(bnum))
+ return do_binary_method(self, r_drem_s, bnum, anum);
+#if HAVE_DREM
+ return flo(drem(c_flo(to_float(self, anum), self),
+ c_flo(to_float(self, bnum), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val fdim_wrap(val anum, val bnum)
+{
+ val self = fdim_s;
+ if (cobjp(anum))
+ return do_binary_method(self, self, anum, bnum);
+ if (cobjp(bnum))
+ return do_binary_method(self, r_fdim_s, bnum, anum);
+#if HAVE_FDIM
+ return flo(fdim(c_flo(to_float(self, anum), self),
+ c_flo(to_float(self, bnum), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val fmax_wrap(val anum, val bnum)
+{
+ val self = fmax_s;
+ if (cobjp(anum))
+ return do_binary_method(self, self, anum, bnum);
+ if (cobjp(bnum))
+ return do_binary_method(self, r_fmax_s, bnum, anum);
+#if HAVE_FMAX
+ return flo(fmax(c_flo(to_float(self, anum), self),
+ c_flo(to_float(self, bnum), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val fmin_wrap(val anum, val bnum)
+{
+ val self = fmin_s;
+ if (cobjp(anum))
+ return do_binary_method(self, self, anum, bnum);
+ if (cobjp(bnum))
+ return do_binary_method(self, r_fmin_s, bnum, anum);
+#if HAVE_FMIN
+ return flo(fmin(c_flo(to_float(self, anum), self),
+ c_flo(to_float(self, bnum), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val hypot_wrap(val anum, val bnum)
+{
+ val self = hypot_s;
+ if (cobjp(anum))
+ return do_binary_method(self, self, anum, bnum);
+ if (cobjp(bnum))
+ return do_binary_method(self, r_hypot_s, bnum, anum);
+#if HAVE_HYPOT
+ return flo(hypot(c_flo(to_float(self, anum), self),
+ c_flo(to_float(self, bnum), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val jn_wrap(val anum, val bnum)
+{
+ val self = jn_s;
+ if (cobjp(anum))
+ return do_binary_method(self, self, anum, bnum);
+ if (cobjp(bnum))
+ return do_binary_method(self, r_jn_s, bnum, anum);
+#if HAVE_JN
+ return flo(jn(c_flo(to_float(self, anum), self),
+ c_flo(to_float(self, bnum), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val ldexp_wrap(val anum, val bnum)
+{
+ val self = ldexp_s;
+ if (cobjp(anum))
+ return do_binary_method(self, self, anum, bnum);
+ if (cobjp(bnum))
+ return do_binary_method(self, r_ldexp_s, bnum, anum);
+#if HAVE_LDEXP
+ return flo(ldexp(c_flo(to_float(self, anum), self),
+ c_flo(to_float(self, bnum), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val nextafter_wrap(val anum, val bnum)
+{
+ val self = nextafter_s;
+ if (cobjp(anum))
+ return do_binary_method(self, self, anum, bnum);
+ if (cobjp(bnum))
+ return do_binary_method(self, r_nextafter_s, bnum, anum);
+#if HAVE_NEXTAFTER
+ return flo(nextafter(c_flo(to_float(self, anum), self),
+ c_flo(to_float(self, bnum), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val remainder_wrap(val anum, val bnum)
+{
+ val self = remainder_s;
+ if (cobjp(anum))
+ return do_binary_method(self, self, anum, bnum);
+ if (cobjp(bnum))
+ return do_binary_method(self, r_remainder_s, bnum, anum);
+#if HAVE_REMAINDER
+ return flo(remainder(c_flo(to_float(self, anum), self),
+ c_flo(to_float(self, bnum), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val scalb_wrap(val anum, val bnum)
+{
+ val self = scalb_s;
+ if (cobjp(anum))
+ return do_binary_method(self, self, anum, bnum);
+ if (cobjp(bnum))
+ return do_binary_method(self, r_scalb_s, bnum, anum);
+#if HAVE_SCALB
+ return flo(scalb(c_flo(to_float(self, anum), self),
+ c_flo(to_float(self, bnum), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val scalbln_wrap(val anum, val bnum)
+{
+ val self = scalbln_s;
+ if (cobjp(anum))
+ return do_binary_method(self, self, anum, bnum);
+ if (cobjp(bnum))
+ return do_binary_method(self, r_scalbln_s, bnum, anum);
+#if HAVE_SCALBLN
+ return flo(scalbln(c_flo(to_float(self, anum), self),
+ c_flo(to_float(self, bnum), self)));
+#else
+ not_available(self);
+#endif
+}
+
+static val yn_wrap(val anum, val bnum)
+{
+ val self = yn_s;
+ if (cobjp(anum))
+ return do_binary_method(self, self, anum, bnum);
+ if (cobjp(bnum))
+ return do_binary_method(self, r_yn_s, bnum, anum);
+#if HAVE_YN
+ return flo(yn(c_flo(to_float(self, anum), self),
+ c_flo(to_float(self, bnum), self)));
+#else
+ not_available(self);
+#endif
+}
+
+
/*
* TODO: replace this text-based hack!
*/
@@ -2828,13 +3459,20 @@ val int_flo(val f)
{
val self = lit("int-flo");
double d = c_flo(f, self);
+#if SIZEOF_PTR >= 8
+ cnum margin = 512;
+ ucnum umargin = 1024;
+#else
+ cnum margin = 0;
+ ucnum umargin = 0;
+#endif
- if (d >= INT_PTR_MIN && d <= INT_PTR_MAX) {
+ if (d >= INT_PTR_MIN && d <= INT_PTR_MAX - margin) {
cnum n = d;
if (n < NUM_MIN || n > NUM_MAX)
return bignum(n);
return num_fast(n);
- } else if (d >= 0 && d <= UINT_PTR_MAX) {
+ } else if (d >= 0 && d <= UINT_PTR_MAX - umargin) {
ucnum n = d;
return unum(n);
} else {
@@ -2851,6 +3489,19 @@ val int_flo(val f)
self, nao);
have_exp = (strchr(text, 'e') != 0);
+
+#if CONFIG_LOCALE_TOLERANCE
+ have_point = (strchr(text, dec_point) != 0);
+
+ if (have_exp && have_point)
+ sscanf(text, "%127[-0-9]%*1[^0-9e]%127[0-9]e%d", mint, mfrac, &exp);
+ else if (have_exp)
+ sscanf(text, "%127[-0-9]e%d", mint, &exp);
+ else if (have_point)
+ sscanf(text, "%127[-0-9]%*1[^0-9]*[%127[0-9]", mint, mfrac);
+ else
+ return int_str(string_utf8(text), nil);
+#else
have_point = (strchr(text, '.') != 0);
if (have_exp && have_point)
@@ -2861,6 +3512,7 @@ val int_flo(val f)
sscanf(text, "%127[-0-9].%127[0-9]", mint, mfrac);
else
return int_str(string_utf8(text), nil);
+#endif
if (have_exp && exp < 0)
return zero;
@@ -2909,9 +3561,14 @@ val logand(val a, val b)
switch (TYPE_PAIR(type(a), type(b))) {
case TYPE_PAIR(NUM, CHR):
- case TYPE_PAIR(CHR, NUM):
{
cnum ac = c_n(a);
+ cnum bc = c_ch(b);
+ return chr(ac & bc);
+ }
+ case TYPE_PAIR(CHR, NUM):
+ {
+ cnum ac = c_ch(a);
cnum bc = c_n(b);
return chr(ac & bc);
}
@@ -2960,9 +3617,14 @@ val logior(val a, val b)
switch (TYPE_PAIR(type(a), type(b))) {
case TYPE_PAIR(NUM, CHR):
- case TYPE_PAIR(CHR, NUM):
{
cnum ac = c_n(a);
+ cnum bc = c_ch(b);
+ return chr(ac | bc);
+ }
+ case TYPE_PAIR(CHR, NUM):
+ {
+ cnum ac = c_ch(a);
cnum bc = c_n(b);
return chr(ac | bc);
}
@@ -3011,9 +3673,14 @@ val logxor(val a, val b)
switch (TYPE_PAIR(type(a), type(b))) {
case TYPE_PAIR(NUM, CHR):
- case TYPE_PAIR(CHR, NUM):
{
cnum ac = c_n(a);
+ cnum bc = c_ch(b);
+ return chr(ac ^ bc);
+ }
+ case TYPE_PAIR(CHR, NUM):
+ {
+ cnum ac = c_ch(a);
cnum bc = c_n(b);
return chr(ac ^ bc);
}
@@ -3064,11 +3731,18 @@ val logxor_old(val a, val b)
switch (TYPE_PAIR(type(a), type(b))) {
case TYPE_PAIR(NUM, CHR):
- case TYPE_PAIR(CHR, NUM):
if (a == b) {
return a;
} else {
cnum ac = c_n(a);
+ cnum bc = c_ch(b);
+ return chr(ac ^ bc);
+ }
+ case TYPE_PAIR(CHR, NUM):
+ if (a == b) {
+ return a;
+ } else {
+ cnum ac = c_ch(a);
cnum bc = c_n(b);
return chr(ac ^ bc);
}
@@ -3117,7 +3791,6 @@ static val comp_trunc(val a, val bits)
cnum an, bn;
val b;
const cnum num_mask = (NUM_MAX << 1) | 1;
- const int num_bits = CHAR_BIT * sizeof (cnum) - TAG_SHIFT;
if (!fixnump(bits))
goto bad2;
@@ -3130,8 +3803,8 @@ static val comp_trunc(val a, val bits)
switch (type(a)) {
case NUM:
an = c_n(a);
- if (bn < num_bits) {
- cnum mask = num_mask >> (num_bits - bn);
+ if (bn < NUM_BIT) {
+ cnum mask = num_mask >> (NUM_BIT - bn);
return num_fast((an & mask) ^ mask);
}
a = bignum(an);
@@ -3196,7 +3869,6 @@ val logtrunc(val a, val bits)
cnum an, bn;
val b;
const cnum num_mask = (NUM_MAX << 1) | 1;
- const int num_bits = CHAR_BIT * sizeof (cnum) - TAG_SHIFT;
if (!fixnump(bits))
goto bad2;
@@ -3210,8 +3882,8 @@ val logtrunc(val a, val bits)
mp_err mpe;
case NUM:
an = c_n(a);
- if (bn <= num_bits) {
- cnum mask = num_mask >> (num_bits - bn);
+ if (bn <= NUM_BIT) {
+ cnum mask = num_mask >> (NUM_BIT - bn);
return num_fast(an & mask);
}
a = bignum(an);
@@ -3285,7 +3957,6 @@ val ash(val a, val bits)
val self = ash_s;
type_t ta = type(a);
cnum bn;
- const int num_bits = CHAR_BIT * sizeof (cnum) - TAG_SHIFT;
mp_err mpe = MP_OKAY;
if (ta == COBJ)
@@ -3310,8 +3981,12 @@ val ash(val a, val bits)
{
cnum an = c_n(a);
int hb = highest_significant_bit(an);
- if (bn + hb < num_bits) {
+ if (bn + hb < NUM_BIT) {
+#if HAVE_UBSAN
+ return num_fast(an * (convert(cnum, 1) << bn));
+#else
return num_fast(an << bn);
+#endif
} else {
val b = make_bignum();
mp_int tmp;
@@ -3342,9 +4017,9 @@ val ash(val a, val bits)
{
cnum an = c_n(a);
bn = -bn;
- if (bn <= num_bits)
+ if (bn <= NUM_BIT)
return num_fast(an >> bn);
- return num_fast(an >> num_bits);
+ return num_fast(an >> NUM_BIT);
}
case BGNUM:
{
@@ -3390,13 +4065,19 @@ val bit(val a, val bit)
switch (ta) {
case NUM:
- case CHR:
{
cnum an = c_n(a);
if (bn < (SIZEOF_PTR * CHAR_BIT))
return (an & (convert(cnum, 1) << bn)) ? t : nil;
return an < 0 ? t : nil;
}
+ case CHR:
+ {
+ cnum an = c_ch(a);
+ if (bn < (SIZEOF_PTR * CHAR_BIT))
+ return (an & (convert(cnum, 1) << bn)) ? t : nil;
+ return an < 0 ? t : nil;
+ }
case BGNUM:
{
mpe = mp_bit(mp(a), bn);
@@ -3427,7 +4108,7 @@ bad4:
do_mp_error(self, mpe);
}
-val maskv(struct args *bits)
+val maskv(varg bits)
{
cnum index = 0;
val accum = zero;
@@ -3448,7 +4129,6 @@ val bitset(val n)
switch (type(n)) {
case NUM:
- case CHR:
{
cnum c = c_n(n);
ucnum d = c;
@@ -3463,6 +4143,21 @@ val bitset(val n)
return out;
}
+ case CHR:
+ {
+ cnum c = c_ch(n);
+ ucnum d = c;
+ int p = 0;
+
+ if (c < 0)
+ d = ~d;
+
+ for (; d; d >>= 1, p++)
+ if (d & 1)
+ ptail = list_collect(ptail, num_fast(p));
+
+ return out;
+ }
case BGNUM:
{
mp_int *mn = mp(n);
@@ -3506,8 +4201,9 @@ val logcount(val n)
val self = logcount_s;
switch (type(n)) {
- case NUM:
case CHR:
+ return logcount(num_fast(c_ch(n)));
+ case NUM:
{
int_ptr_t c = c_n(n);
uint_ptr_t d = c;
@@ -3664,12 +4360,14 @@ val n_perm_k(val n, val k)
val tofloat(val obj)
{
+ val self = tofloat_s;
+
switch (tag(obj)) {
case TAG_NUM:
return flo_int(obj);
case TAG_CHR:
{
- cnum ch = c_n(obj);
+ cnum ch = c_ch(obj);
if (ch >= '0' && ch <= '9')
return flo(ch - '0');
return nil;
@@ -3691,12 +4389,17 @@ val tofloat(val obj)
}
/* fallthrough */
default:
- uw_throwf(error_s, lit("tofloat: ~s is not convertible to float"), obj, nao);
+ if (type(obj) == COBJ)
+ return do_unary_method(self, self, obj);
+ uw_throwf(error_s, lit("~s: ~s is not convertible to float"),
+ self, obj, nao);
}
}
val toint(val obj, val base)
{
+ val self = toint_s;
+
switch (tag(obj)) {
case TAG_NUM:
return obj;
@@ -3704,14 +4407,14 @@ val toint(val obj, val base)
return int_str(obj, base);
case TAG_CHR:
{
- cnum ch = c_n(obj);
+ cnum ch = c_ch(obj);
if (ch >= '0' && ch <= '9')
return num(ch - '0');
if (iswalpha(ch)) {
cnum n = 10 + towupper(ch) - 'A';
- cnum b = c_num(default_arg(base, num_fast(10)));
+ cnum b = c_num(default_arg(base, num_fast(10)), self);
if (n < b)
return num(n);
@@ -3733,7 +4436,10 @@ val toint(val obj, val base)
}
/* fallthrough */
default:
- uw_throwf(error_s, lit("toint: ~s is not convertible to integer"), obj, nao);
+ if (type(obj) == COBJ)
+ return do_unary_method(self, self, obj);
+ uw_throwf(error_s, lit("~a: ~s is not convertible to integer"),
+ self, obj, nao);
}
}
@@ -3759,6 +4465,7 @@ val width(val obj)
switch (type(obj)) {
case CHR:
+ return width(num_fast(c_ch(obj)));
case NUM:
{
cnum n = c_n(obj);
@@ -3853,7 +4560,7 @@ val digits(val n, val base)
val poly(val x, val seq)
{
- val self = lit("rpoly");
+ val self = lit("poly");
val acc = zero;
seq_info_t si = seq_info(seq);
@@ -3884,7 +4591,7 @@ val poly(val x, val seq)
return acc;
}
default:
- uw_throwf(error_s, lit("~a: bad argument ~s; poly wants a sequence!"),
+ uw_throwf(error_s, lit("~a: bad argument ~s; poly wants a list or vector!"),
self, seq, nao);
}
@@ -3892,7 +4599,7 @@ val poly(val x, val seq)
val rpoly(val x, val seq)
{
- val self = lit("poly");
+ val self = lit("rpoly");
val acc = zero;
val pow = x;
seq_info_t si = seq_info(seq);
@@ -3929,7 +4636,7 @@ val rpoly(val x, val seq)
return acc;
}
default:
- uw_throwf(error_s, lit("~a: bad argument ~s; poly wants a sequence!"),
+ uw_throwf(error_s, lit("~a: bad argument ~s; poly wants a list or vector!"),
self, seq, nao);
}
@@ -3956,29 +4663,33 @@ val num(cnum n)
return (n >= NUM_MIN && n <= NUM_MAX) ? num_fast(n) : bignum(n);
}
-cnum c_num(val n)
+cnum c_num(val n, val self)
{
switch (type(n)) {
- case CHR: case NUM:
- return coerce(cnum, n) >> TAG_SHIFT;
+ case CHR:
+ return c_ch(n);
+ case NUM:
+ return c_n(n);
case BGNUM:
if (mp_in_intptr_range(mp(n))) {
int_ptr_t out;
mp_get_intptr(mp(n), &out);
return out;
}
- uw_throwf(error_s, lit("~s is out of allowed range [~s, ~s]"),
- n, num(INT_PTR_MIN), num(INT_PTR_MAX), nao);
+ uw_throwf(error_s, lit("~a: ~s is out of allowed range [~s, ~s]"),
+ self, n, num(INT_PTR_MIN), num(INT_PTR_MAX), nao);
default:
- type_mismatch(lit("~s is not an integer"), n, nao);
+ uw_throwf(type_error_s, lit("~a: ~s is not an integer"), self, n, nao);
}
}
cnum c_fixnum(val num, val self)
{
switch (type(num)) {
- case CHR: case NUM:
- return coerce(cnum, num) >> TAG_SHIFT;
+ case CHR:
+ return c_ch(num);
+ case NUM:
+ return c_n(num);
default:
type_mismatch(lit("~a: ~s is not fixnum integer or character"),
self, num, nao);
@@ -4001,22 +4712,41 @@ INLINE int bad_float(double d)
#define bad_float(d) (0)
#endif
+#if CONFIG_NAN_BOXING && defined __GNUC__
+#pragma GCC diagnostic ignored "-Wstrict-aliasing"
+#endif
+
val flo(double n)
{
if (bad_float(n)) {
uw_throw(numeric_error_s, lit("out-of-range floating-point result"));
} else {
+#if CONFIG_NAN_BOXING
+ ucnum u = *(ucnum *) &n + NAN_FLNUM_DELTA;
+ return coerce(val, u);
+#else
val obj = make_obj();
obj->fl.type = FLNUM;
obj->fl.n = n;
return obj;
+#endif
}
}
+#if CONFIG_NAN_BOXING && defined __GNUC__
+#pragma GCC diagnostic warning "-Wstrict-aliasing"
+#endif
+
double c_flo(val num, val self)
{
+#if CONFIG_NAN_BOXING
+ if (is_flo(num))
+ return c_f(num);
+ throw_mismatch(self, num, FLNUM);
+#else
type_check(self, num, FLNUM);
return num->fl.n;
+#endif
}
val fixnump(val num)
@@ -4031,7 +4761,7 @@ val bignump(val num)
val integerp(val num)
{
- switch (tag(num)) {
+ switch (tag_ex(num)) {
case TAG_NUM:
return t;
case TAG_PTR:
@@ -4052,9 +4782,13 @@ val floatp(val num)
val numberp(val num)
{
- switch (tag(num)) {
+ switch (tag_ex(num)) {
case TAG_NUM:
return t;
+#if CONFIG_NAN_BOXING
+ case TAG_FLNUM:
+ return t;
+#endif
case TAG_PTR:
if (num == nil)
return nil;
@@ -4066,9 +4800,26 @@ val numberp(val num)
}
}
+val arithp(val obj)
+{
+ switch (type(obj)) {
+ case NUM:
+ case BGNUM:
+ case FLNUM:
+ case CHR:
+ case RNG:
+ return t;
+ default:
+ if (obj_struct_p(obj) && get_special_slot(obj, plus_m))
+ return t;
+ }
+
+ return nil;
+}
+
val nary_op(val self, val (*bfun)(val, val),
val (*ufun)(val self, val),
- struct args *args, val emptyval)
+ varg args, val emptyval)
{
val acc, next;
cnum index = 0;
@@ -4089,41 +4840,61 @@ val nary_op(val self, val (*bfun)(val, val),
return acc;
}
-static val nary_op_keyfun(val self, val (*bfun)(val, val),
- val (*ufun)(val self, val),
- struct args *args, val emptyval,
- val keyfun)
+val nary_simple_op(val (*bfun)(val, val),
+ varg args, val firstval)
{
- val acc, next;
+ val acc = firstval, next;
cnum index = 0;
- if (!args_more(args, index))
- return emptyval;
+ while (args_more(args, index)) {
+ next = args_get(args, &index);
+ acc = bfun(acc, next);
+ }
- acc = funcall1(keyfun, args_get(args, &index));
+ return acc;
+}
- if (!args_more(args, index))
+static val nary_op_seq(val self, val (*bfun)(val, val),
+ val (*ufun)(val self, val),
+ val seq, val emptyval)
+{
+ seq_iter_t item_iter;
+ val acc, next;
+ seq_iter_init(self, &item_iter, seq);
+
+ if (!seq_get(&item_iter, &acc))
+ return emptyval;
+
+ if (!seq_get(&item_iter, &next))
return ufun(self, acc);
do {
- next = funcall1(keyfun, args_get(args, &index));
acc = bfun(acc, next);
- } while (args_more(args, index));
+ } while (seq_get(&item_iter, &next));
return acc;
}
-
-val nary_simple_op(val self, val (*bfun)(val, val),
- struct args *args, val firstval)
+static val nary_op_seq_keyfun(val self, val (*bfun)(val, val),
+ val (*ufun)(val self, val),
+ val seq, val emptyval, val keyfun)
{
- val acc = firstval, next;
- cnum index = 0;
+ seq_iter_t item_iter;
+ val acc, next;
+ seq_iter_init(self, &item_iter, seq);
- while (args_more(args, index)) {
- next = args_get(args, &index);
+ if (!seq_get(&item_iter, &acc))
+ return emptyval;
+
+ acc = funcall1(keyfun, acc);
+
+ if (!seq_get(&item_iter, &next))
+ return ufun(self, acc);
+
+ do {
+ next = funcall1(keyfun, next);
acc = bfun(acc, next);
- }
+ } while (seq_get(&item_iter, &next));
return acc;
}
@@ -4162,12 +4933,12 @@ static val unary_int(val self, val arg)
return arg;
}
-val plusv(struct args *nlist)
+val plusv(varg nlist)
{
return nary_op(plus_s, plus, unary_arith, nlist, zero);
}
-val minusv(val minuend, struct args *nlist)
+val minusv(val minuend, varg nlist)
{
val acc = minuend, next;
cnum index = 0;
@@ -4183,12 +4954,12 @@ val minusv(val minuend, struct args *nlist)
return acc;
}
-val mulv(struct args *nlist)
+val mulv(varg nlist)
{
return nary_op(mul_s, mul, unary_num, nlist, one);
}
-val divv(val dividend, struct args *nlist)
+val divv(val dividend, varg nlist)
{
val acc = dividend, next;
cnum index = 0;
@@ -4204,17 +4975,17 @@ val divv(val dividend, struct args *nlist)
return acc;
}
-val logandv(struct args *nlist)
+val logandv(varg nlist)
{
return nary_op(logand_s, logand, unary_int, nlist, negone);
}
-val logiorv(struct args *nlist)
+val logiorv(varg nlist)
{
return nary_op(logior_s, logior, unary_int, nlist, zero);
}
-val gtv(val first, struct args *rest)
+val gtv(val first, varg rest)
{
cnum index = 0;
@@ -4231,7 +5002,7 @@ val gtv(val first, struct args *rest)
return t;
}
-val ltv(val first, struct args *rest)
+val ltv(val first, varg rest)
{
cnum index = 0;
@@ -4248,7 +5019,7 @@ val ltv(val first, struct args *rest)
return t;
}
-val gev(val first, struct args *rest)
+val gev(val first, varg rest)
{
cnum index = 0;
@@ -4265,7 +5036,7 @@ val gev(val first, struct args *rest)
return t;
}
-val lev(val first, struct args *rest)
+val lev(val first, varg rest)
{
cnum index = 0;
@@ -4282,7 +5053,7 @@ val lev(val first, struct args *rest)
return t;
}
-val numeqv(val first, struct args *rest)
+val numeqv(val first, varg rest)
{
cnum index = 0;
@@ -4299,44 +5070,51 @@ val numeqv(val first, struct args *rest)
return t;
}
-val numneqv(struct args *args)
+val numneqv(varg args)
{
- val i, j;
- val list = args_get_list(args);
+ if (!args->list) {
+ cnum i, j, n = args->fill;
- if (list && !cdr(list)) {
- (void) unary_arith(lit("/="), car(list));
- return t;
- }
+ if (n == 1) {
+ (void) unary_arith(lit("/="), args->arg[0]);
+ return t;
+ }
- for (i = list; i; i = cdr(i))
- for (j = cdr(i); j; j = cdr(j))
- if (numeq(car(i), car(j)))
- return nil;
+ for (i = 0; i < n; i++)
+ for (j = i + 1; j < n; j++)
+ if (numeq(args->arg[i], args->arg[j]))
+ return nil;
- return t;
-}
+ return t;
+ } else {
+ val i, j;
+ val list = args_get_list(args);
-static val sumv(struct args *nlist, val keyfun)
-{
- return nary_op_keyfun(plus_s, plus, unary_arith, nlist, zero, keyfun);
-}
+ if (list && !cdr(list)) {
+ (void) unary_arith(lit("/="), car(list));
+ return t;
+ }
-val sum(val seq, val keyfun)
-{
- args_decl_list(args, ARGS_MIN, tolist(seq));
- return if3(missingp(keyfun), plusv(args), sumv(args, keyfun));
+ for (i = list; i; i = cdr(i))
+ for (j = cdr(i); j; j = cdr(j))
+ if (numeq(car(i), car(j)))
+ return nil;
+ return t;
+ }
}
-static val prodv(struct args *nlist, val keyfun)
+val sum(val seq, val keyfun)
{
- return nary_op_keyfun(mul_s, mul, unary_num, nlist, one, keyfun);
+ return if3(missingp(keyfun),
+ nary_op_seq(plus_s, plus, unary_arith, seq, zero),
+ nary_op_seq_keyfun(plus_s, plus, unary_arith, seq, zero, keyfun));
}
val prod(val seq, val keyfun)
{
- args_decl_list(args, ARGS_MIN, tolist(seq));
- return if3(missingp(keyfun), mulv(args), prodv(args, keyfun));
+ return if3(missingp(keyfun),
+ nary_op_seq(mul_s, mul, unary_num, seq, one),
+ nary_op_seq_keyfun(mul_s, mul, unary_num, seq, one, keyfun));
}
static val rexpt(val right, val left)
@@ -4344,9 +5122,10 @@ static val rexpt(val right, val left)
return expt(left, right);
}
-val exptv(struct args *nlist)
+val exptv(varg nlist)
{
- cnum nargs = args_count(nlist);
+ val self = lit("exptv");
+ cnum nargs = args_count(nlist, self);
args_decl(rnlist, max(ARGS_MIN, nargs));
args_copy_reverse(rnlist, nlist, nargs);
return nary_op(expt_s, rexpt, unary_num, rnlist, one);
@@ -4358,16 +5137,167 @@ static val abso_self(val self, val arg)
return abso(arg);
}
-val gcdv(struct args *nlist)
+val gcdv(varg nlist)
{
return nary_op(lit("gcd"), gcd, abso_self, nlist, zero);
}
-val lcmv(struct args *nlist)
+val lcmv(varg nlist)
{
return nary_op(lit("lcm"), lcm, abso_self, nlist, zero);
}
+static struct cobj_ops psq_ops = cobj_ops_init(cobj_equal_handle_op,
+ cptr_print_op,
+ cobj_destroy_free_op,
+ cobj_mark_op,
+ cobj_handle_hash_op);
+
+static val quant_fun(val psqo, varg args)
+{
+ val self = lit("quantile");
+ cnum idx = 0;
+ struct psquare *psq = coerce(struct psquare *, psqo->cp.handle);
+
+ while (args_more(args, idx)) {
+ val arg = args_get(args, &idx);
+ if (numberp(arg)) {
+ double s = c_flo(to_float(self, arg), self);
+ psq_add_sample(psq, s, self);
+ } else {
+ seq_iter_t item_iter;
+ val sample;
+ seq_iter_init(self, &item_iter, arg);
+
+ while (seq_get(&item_iter, &sample)) {
+ double s = c_flo(to_float(self, sample), self);
+ psq_add_sample(psq, s, self);
+ }
+ }
+ }
+
+ return flo(psq_get_estimate(psq));
+}
+
+val quantile(val pv, val grsize_in, val rate_in)
+{
+ val self = lit("quantile");
+ double p = c_flo(to_float(self, pv), self);
+ struct psquare *psq = coerce(struct psquare *, chk_malloc(sizeof *psq));
+ val psqo = cptr_typed(coerce(mem_t *, psq), nil, &psq_ops);
+ if (missingp(grsize_in)) {
+ psq_init(psq, p);
+ } else {
+ ucnum grsize = c_unum(grsize_in, self);
+ double rate = if3(missingp(rate_in),
+ 0.999,
+ c_flo(to_float(self, rate_in), self));
+ psq_init_grouped(psq, p, grsize, rate);
+ }
+ return func_f0v(psqo, quant_fun);
+}
+
+static val arith_set_entries(val fun)
+{
+ val name[] = {
+ lit("cbrt"),lit("erf"), lit("erfc"), lit("exp10"),
+ lit("exp2"),lit("expm1"), lit("gamma"), lit("j0"),
+ lit("j1"),lit("lgamma"), lit("log1p"), lit("logb"),
+ lit("nearbyint"),lit("rint"), lit("significand"), lit("tgamma"),
+ lit("y0"),lit("y1"), lit("copysign"), lit("drem"),
+ lit("fdim"),lit("fmax"), lit("fmin"), lit("hypot"),
+ lit("jn"),lit("ldexp"), lit("nextafter"),
+ lit("remainder"),lit("scalb"), lit("scalbln"), lit("yn"),
+ lit("r-copysign"), lit("r-drem"),
+ lit("r-fdim"),lit("r-fmax"), lit("r-fmin"), lit("r-hypot"),
+ lit("r-jn"),lit("r-ldexp"), lit("r-nextafter"),
+ lit("r-remainder"),lit("r-scalb"), lit("r-scalbln"), lit("r-yn"),
+ nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val arith_instantiate(void)
+{
+ cbrt_s = intern(lit("cbrt"), user_package);
+ erf_s = intern(lit("erf"), user_package);
+ erfc_s = intern(lit("erfc"), user_package);
+ exp10_s = intern(lit("exp10"), user_package);
+ exp2_s = intern(lit("exp2"), user_package);
+ expm1_s = intern(lit("expm1"), user_package);
+ gamma_s = intern(lit("gamma"), user_package);
+ j0_s = intern(lit("j0"), user_package);
+ j1_s = intern(lit("j1"), user_package);
+ lgamma_s = intern(lit("lgamma"), user_package);
+ log1p_s = intern(lit("log1p"), user_package);
+ logb_s = intern(lit("logb"), user_package);
+ nearbyint_s = intern(lit("nearbyint"), user_package);
+ rint_s = intern(lit("rint"), user_package);
+ significand_s = intern(lit("significand"), user_package);
+ tgamma_s = intern(lit("tgamma"), user_package);
+ y0_s = intern(lit("y0"), user_package);
+ y1_s = intern(lit("y1"), user_package);
+ copysign_s = intern(lit("copysign"), user_package);
+ drem_s = intern(lit("drem"), user_package);
+ fdim_s = intern(lit("fdim"), user_package);
+ fmax_s = intern(lit("fmax"), user_package);
+ fmin_s = intern(lit("fmin"), user_package);
+ hypot_s = intern(lit("hypot"), user_package);
+ jn_s = intern(lit("jn"), user_package);
+ ldexp_s = intern(lit("ldexp"), user_package);
+ nextafter_s = intern(lit("nextafter"), user_package);
+ remainder_s = intern(lit("remainder"), user_package);
+ scalb_s = intern(lit("scalb"), user_package);
+ scalbln_s = intern(lit("scalbln"), user_package);
+ yn_s = intern(lit("yn"), user_package);
+ r_copysign_s = intern(lit("r-copysign"), user_package);
+ r_drem_s = intern(lit("r-drem"), user_package);
+ r_fdim_s = intern(lit("r-fdim"), user_package);
+ r_fmax_s = intern(lit("r-fmax"), user_package);
+ r_fmin_s = intern(lit("r-fmin"), user_package);
+ r_hypot_s = intern(lit("r-hypot"), user_package);
+ r_jn_s = intern(lit("r-jn"), user_package);
+ r_ldexp_s = intern(lit("r-ldexp"), user_package);
+ r_nextafter_s = intern(lit("r-nextafter"), user_package);
+ r_remainder_s = intern(lit("r-remainder"), user_package);
+ r_scalb_s = intern(lit("r-scalb"), user_package);
+ r_scalbln_s = intern(lit("r-scalbln"), user_package);
+ r_yn_s = intern(lit("r-yn"), user_package);
+
+ reg_fun(cbrt_s, func_n1(cbrt_wrap));
+ reg_fun(erf_s, func_n1(erf_wrap));
+ reg_fun(erfc_s, func_n1(erfc_wrap));
+ reg_fun(exp10_s, func_n1(exp10_wrap));
+ reg_fun(exp2_s, func_n1(exp2_wrap));
+ reg_fun(expm1_s, func_n1(expm1_wrap));
+ reg_fun(gamma_s, func_n1(gamma_wrap));
+ reg_fun(j0_s, func_n1(j0_wrap));
+ reg_fun(j1_s, func_n1(j1_wrap));
+ reg_fun(lgamma_s, func_n1(lgamma_wrap));
+ reg_fun(log1p_s, func_n1(log1p_wrap));
+ reg_fun(logb_s, func_n1(logb_wrap));
+ reg_fun(nearbyint_s, func_n1(nearbyint_wrap));
+ reg_fun(rint_s, func_n1(rint_wrap));
+ reg_fun(significand_s, func_n1(significand_wrap));
+ reg_fun(tgamma_s, func_n1(tgamma_wrap));
+ reg_fun(y0_s, func_n1(y0_wrap));
+ reg_fun(y1_s, func_n1(y1_wrap));
+ reg_fun(copysign_s, func_n2(copysign_wrap));
+ reg_fun(drem_s, func_n2(drem_wrap));
+ reg_fun(fdim_s, func_n2(fdim_wrap));
+ reg_fun(fmax_s, func_n2(fmax_wrap));
+ reg_fun(fmin_s, func_n2(fmin_wrap));
+ reg_fun(hypot_s, func_n2(hypot_wrap));
+ reg_fun(jn_s, func_n2(jn_wrap));
+ reg_fun(ldexp_s, func_n2(ldexp_wrap));
+ reg_fun(nextafter_s, func_n2(nextafter_wrap));
+ reg_fun(remainder_s, func_n2(remainder_wrap));
+ reg_fun(scalb_s, func_n2(scalb_wrap));
+ reg_fun(scalbln_s, func_n2(scalbln_wrap));
+ reg_fun(yn_s, func_n2(yn_wrap));
+ return nil;
+}
void arith_init(void)
{
@@ -4445,13 +5375,8 @@ void arith_init(void)
width_s = intern(lit("width"), user_package);
bitset_s = intern(lit("bitset"), user_package);
logcount_s = intern(lit("logcount"), user_package);
-
- if (opt_compat && opt_compat <= 199) {
- reg_varl(intern(lit("*flo-dig*"), user_package), num_fast(DBL_DIG));
- reg_varl(intern(lit("*flo-max*"), user_package), flo(DBL_MAX));
- reg_varl(intern(lit("*flo-min*"), user_package), flo(DBL_MIN));
- reg_varl(intern(lit("*flo-epsilon*"), user_package), flo(DBL_EPSILON));
- }
+ tofloat_s = intern(lit("tofloat"), user_package);
+ toint_s = intern(lit("toint"), user_package);
reg_varl(intern(lit("flo-dig"), user_package), num_fast(DBL_DIG));
reg_varl(intern(lit("flo-max-dig"), user_package), num_fast(FLO_MAX_DIG));
@@ -4470,11 +5395,10 @@ void arith_init(void)
#endif
reg_varl(intern(lit("%e%"), user_package), flo(M_E));
- if (opt_compat && opt_compat <= 199) {
- reg_varl(intern(lit("*pi*"), user_package), flo(M_PI));
- reg_varl(intern(lit("*e*"), user_package), flo(M_E));
- }
-
+ reg_fun(tofloat_s, func_n1(tofloat));
+ reg_fun(toint_s, func_n2o(toint, 1));
+ reg_fun(intern(lit("tofloatz"), user_package), func_n1(tofloatz));
+ reg_fun(intern(lit("tointz"), user_package), func_n2o(tointz, 1));
reg_fun(plus_s, func_n0v(plusv));
reg_fun(minus_s, func_n1v(minusv));
reg_fun(mul_s, func_n0v(mulv));
@@ -4537,8 +5461,7 @@ void arith_init(void)
reg_fun(sqrt_s, func_n1(sqroot));
reg_fun(logand_s, func_n0v(logandv));
reg_fun(logior_s, func_n0v(logiorv));
- reg_fun(logxor_s,
- func_n2(if3(opt_compat && opt_compat <= 202, logxor_old, logxor)));
+ reg_fun(logxor_s, func_n2(logxor));
reg_fun(intern(lit("logtest"), user_package), func_n2(logtest));
reg_fun(lognot_s, func_n2o(lognot, 1));
reg_fun(logtrunc_s, func_n2(logtrunc));
@@ -4558,7 +5481,7 @@ void arith_init(void)
reg_fun(intern(lit("floatp"), user_package), func_n1(floatp));
reg_fun(intern(lit("integerp"), user_package), func_n1(integerp));
reg_fun(intern(lit("numberp"), user_package), func_n1(numberp));
-
+ reg_fun(intern(lit("arithp"), user_package), func_n1(arithp));
reg_fun(signum_s, func_n1(signum));
@@ -4581,6 +5504,7 @@ void arith_init(void)
reg_fun(intern(lit("b/"), system_package), func_n2(divi));
reg_fun(neg_s, func_n1(neg));
+ reg_fun(intern(lit("quantile"), user_package), func_n3o(quantile, 1));
#if HAVE_ROUNDING_CTL_H
reg_varl(intern(lit("flo-near"), user_package), num(FE_TONEAREST));
reg_varl(intern(lit("flo-down"), user_package), num(FE_DOWNWARD));
@@ -4591,6 +5515,23 @@ void arith_init(void)
reg_fun(intern(lit("flo-set-round-mode"), user_package),
func_n1(flo_set_round_mode));
#endif
+
+ autoload_reg(arith_instantiate, arith_set_entries);
+}
+
+void arith_compat_fixup(int compat_ver)
+{
+ if (compat_ver <= 202)
+ reg_fun(logxor_s, func_n2(logxor_old));
+
+ if (compat_ver <= 199) {
+ reg_varl(intern(lit("*pi*"), user_package), flo(M_PI));
+ reg_varl(intern(lit("*e*"), user_package), flo(M_E));
+ reg_varl(intern(lit("*flo-dig*"), user_package), num_fast(DBL_DIG));
+ reg_varl(intern(lit("*flo-max*"), user_package), flo(DBL_MAX));
+ reg_varl(intern(lit("*flo-min*"), user_package), flo(DBL_MIN));
+ reg_varl(intern(lit("*flo-epsilon*"), user_package), flo(DBL_EPSILON));
+ }
}
void arith_free_all(void)
diff --git a/arith.h b/arith.h
index cf352040..2031299b 100644
--- a/arith.h
+++ b/arith.h
@@ -1,4 +1,4 @@
-/* Copyright 2012-2020
+/* Copyright 2012-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,26 +6,27 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
-extern val mod_s, bit_s;
+extern val mod_s, bit_s, minus_s;
val make_bignum(void);
val bignum(cnum cn);
val bignum_from_long(long l);
@@ -39,8 +40,6 @@ val bignum_dbl_ipt(double_intptr_t di);
val bignum_dbl_uipt(double_uintptr_t dui);
#endif
val in_int_ptr_range(val bignum);
-ucnum c_unum(val num);
-val unum(ucnum u);
#if HAVE_DOUBLE_INTPTR_T
double_intptr_t c_dbl_num(val num);
double_uintptr_t c_dbl_unum(val num);
@@ -62,6 +61,9 @@ val digits(val n, val base);
val poly(val x, val seq);
val rpoly(val x, val seq);
-noreturn void do_mp_error(val self, mp_err code);
+val quantile(val pv, val chsize_in, val rate_in);
+
+NORETURN void do_mp_error(val self, mp_err code);
void arith_init(void);
+void arith_compat_fixup(int compat_ver);
void arith_free_all(void);
diff --git a/autoload.c b/autoload.c
new file mode 100644
index 00000000..512369f2
--- /dev/null
+++ b/autoload.c
@@ -0,0 +1,1141 @@
+/* Copyright 2015-2024
+ * Kaz Kylheku <kaz@kylheku.com>
+ * Vancouver, Canada
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ */
+
+#include <stdio.h>
+#include <wchar.h>
+#include <stdarg.h>
+#include <signal.h>
+#include "config.h"
+#include "lib.h"
+#include "eval.h"
+#include "stream.h"
+#include "hash.h"
+#include "gc.h"
+#include "debug.h"
+#include "txr.h"
+#include "autoload.h"
+
+int opt_dbg_autoload;
+val trace_loaded;
+
+static val autoload_hash[al_max + 1];
+static val autoload_reg_hash;
+
+static void autload_set_impl(al_ns_t ns, val *name, val fun, val package)
+{
+ for (; *name; name++) {
+ val sym = intern(*name, package);
+
+ if (fun)
+ sethash(autoload_hash[ns], sym, fun);
+ else
+ remhash(autoload_hash[ns], sym);
+ }
+}
+
+void autoload_set(al_ns_t ns, val *name, val fun)
+{
+ autload_set_impl(ns, name, fun, user_package);
+}
+
+static void autoload_sys_set(al_ns_t ns, val *name, val fun)
+{
+ autload_set_impl(ns, name, fun, system_package);
+}
+
+static void autoload_key_set(al_ns_t ns, val *name, val fun)
+{
+ autload_set_impl(ns, name, fun, keyword_package);
+}
+
+static void intern_only(val *name)
+{
+ for (; *name; name++)
+ intern(*name, user_package);
+}
+
+static val place_set_entries(val fun)
+{
+ val sys_name[] = {
+ lit("get-fun-getter-setter"), lit("get-mb"), lit("get-vb"),
+ lit("register-simple-accessor"),
+ nil
+ };
+ val vname[] = {
+ lit("*place-clobber-expander*"), lit("*place-update-expander*"),
+ lit("*place-delete-expander*"), lit("*place-macro*"),
+ nil
+ };
+ val name[] = {
+ lit("get-update-expander"), lit("get-clobber-expander"),
+ lit("get-delete-expander"),
+ lit("place-form-p"),
+ lit("rlet"), lit("slet"), lit("alet"), lit("with-gensyms"),
+ lit("call-update-expander"), lit("call-clobber-expander"),
+ lit("call-delete-expander"),
+ lit("with-update-expander"), lit("with-clobber-expander"),
+ lit("with-delete-expander"),
+ lit("set"), lit("pset"), lit("zap"), lit("flip"), lit("inc"), lit("dec"),
+ lit("pinc"), lit("pdec"),
+ lit("push"), lit("pop"), lit("swap"), lit("shift"), lit("rotate"),
+ lit("test-set"), lit("test-clear"), lit("compare-swap"),
+ lit("test-inc"), lit("test-dec"),
+ lit("pushnew"), lit("del"), lit("lset"), lit("upd"), lit("ensure"),
+ lit("defplace"), lit("define-place-macro"), lit("define-modify-macro"),
+ lit("placelet"), lit("placelet*"), lit("read-once"),
+ lit("define-accessor"), lit("with-slots"),
+ lit("macroexpand-place"), lit("macroexpand-1-place"),
+ nil
+ };
+
+ autoload_sys_set(al_fun, sys_name, fun);
+ autoload_set(al_var, vname, fun);
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val place_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("place")));
+ return nil;
+}
+
+static val ver_set_entries(val fun)
+{
+ val vname[] = { lit("*lib-version*"), lit("lib-version"), nil };
+ autoload_set(al_var, vname, fun);
+ return nil;
+}
+
+static val ver_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("ver")));
+ return nil;
+}
+
+static val ifa_set_entries(val fun)
+{
+ val name[] = {
+ lit("ifa"), lit("whena"), lit("conda"), lit("condlet"), lit("it"), nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val ifa_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("ifa")));
+ return nil;
+}
+
+static val txr_case_set_entries(val fun)
+{
+ val name[] = { lit("txr-if"), lit("txr-when"), lit("txr-case"), nil };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val txr_case_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("txr-case")));
+ return nil;
+}
+
+static val with_resources_set_entries(val fun)
+{
+ val name[] = {
+ lit("with-resources"),
+ lit("with-objects"),
+ nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val with_resources_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("with-resources")));
+ return nil;
+}
+
+static val path_test_set_entries(val fun)
+{
+ val name[] = {
+ lit("path-exists-p"), lit("path-file-p"), lit("path-dir-p"),
+ lit("path-symlink-p"), lit("path-blkdev-p"), lit("path-chrdev-p"),
+ lit("path-sock-p"), lit("path-pipe-p"), lit("path-pipe-p"),
+ lit("path-setgid-p"), lit("path-setuid-p"), lit("path-sticky-p"),
+ lit("path-mine-p"), lit("path-my-group-p"), lit("path-executable-to-me-p"),
+ lit("path-writable-to-me-p"), lit("path-readable-to-me-p"),
+ lit("path-read-writable-to-me-p"),
+ lit("path-safe-sticky-dir"), lit("path-components-safe"),
+ lit("path-newer"), lit("path-older"),
+ lit("path-same-object"), lit("path-private-to-me-p"),
+ lit("path-strictly-private-to-me-p"),
+ lit("path-dir-empty"),
+ lit("rel-path"), lit("path-equal"),
+ nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val path_test_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("path-test")));
+ return nil;
+}
+
+static val struct_set_entries(val fun)
+{
+ val sys_name[] = {
+ lit("define-method"), lit("rslotset"), nil
+ };
+ val name[] = {
+ lit("defstruct"), lit("qref"), lit("uref"), lit("new"), lit("lnew"),
+ lit("new*"), lit("lnew*"),
+ lit("meth"), lit("umeth"), lit("usl"), lit("defmeth"), lit("rslot"),
+ lit("define-struct-prelude"),
+ lit("define-struct-clause"), lit("macroexpand-struct-clause"), nil
+ };
+ val vname[] = {
+ lit("*struct-clause-expander*"), nil
+ };
+
+ autoload_sys_set(al_fun, sys_name, fun);
+ autoload_set(al_fun, name, fun);
+ autoload_set(al_var, vname, fun);
+
+ if (fun)
+ sethash(autoload_hash[al_fun], struct_lit_s, fun);
+ else
+ remhash(autoload_hash[al_fun], struct_lit_s);
+
+ return nil;
+}
+
+static val struct_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("struct")));
+ return nil;
+}
+
+static val with_stream_set_entries(val fun)
+{
+ val name[] = {
+ lit("with-out-string-stream"),
+ lit("with-out-strlist-stream"),
+ lit("with-out-buf-stream"),
+ lit("with-in-string-stream"),
+ lit("with-in-string-byte-stream"),
+ lit("with-in-buf-stream"),
+ lit("with-stream"),
+ nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val with_stream_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("with-stream")));
+ return nil;
+}
+
+static val hash_set_entries(val fun)
+{
+ val name[] = { lit("with-hash-iter"), nil };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val hash_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("hash")));
+ return nil;
+}
+
+static val except_set_entries(val fun)
+{
+ val name[] = {
+ lit("catch"), lit("catch*"), lit("catch**"), lit("handle"), lit("handle*"),
+ lit("ignwarn"), lit("macro-time-ignwarn"),
+ nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val except_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("except")));
+ return nil;
+}
+
+static val type_set_entries(val fun)
+{
+ val name[] = {
+ lit("typecase"), lit("etypecase"), nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val type_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("type")));
+ return nil;
+}
+
+static val yield_set_entries(val fun)
+{
+ val sys_name[] = {
+ lit("obtain-impl"), nil
+ };
+ val name[] = {
+ lit("obtain"), lit("obtain-block"), lit("yield-from"), lit("yield"),
+ lit("obtain*"), lit("obtain*-block"),
+ lit("suspend"), lit("hlet"), lit("hlet*"),
+ nil
+ };
+ autoload_sys_set(al_fun, sys_name, fun);
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val yield_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("yield")));
+ return nil;
+}
+
+static val awk_set_entries(val fun)
+{
+ val sys_sname[] = {
+ lit("awk-state"), nil
+ };
+ val name[] = {
+ lit("awk"), nil
+ };
+ val name_noload[] = {
+ lit("rec"), lit("orec"), lit("f"), lit("nf"), lit("nr"), lit("fnr"),
+ lit("arg"), lit("fname"), lit("rs"), lit("krs"), lit("fs"), lit("ft"),
+ lit("fw"), lit("kfs"), lit("ofs"), lit("ors"), lit("next"), lit("again"),
+ lit("next-file"), lit("rng"), lit("-rng"), lit("rng-"), lit("-rng-"),
+ lit("--rng"), lit("--rng-"), lit("rng+"), lit("-rng+"), lit("--rng+"),
+ lit("ff"), lit("f"), lit("mf"), lit("fconv"), lit("->"), lit("->>"),
+ lit("<-"), lit("!>"), lit("<!"), lit("prn"),
+ lit("i"), lit("o"), lit("x"), lit("b"), lit("c"), lit("r"),
+ lit("iz"), lit("oz"), lit("xz"), lit("bz"), lit("cz"), lit("rz"),
+ lit("res"),
+ nil
+ };
+ autoload_sys_set(al_struct, sys_sname, fun);
+ autoload_set(al_fun, name, fun);
+ intern_only(name_noload);
+ return nil;
+}
+
+static val awk_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("awk")));
+ return nil;
+}
+
+static val build_set_entries(val fun)
+{
+ val sname[] = {
+ lit("list-builder"), nil
+ };
+ val name[] = {
+ lit("build-list"), lit("build"), lit("buildn"), nil
+ };
+ val name_noload[] = {
+ lit("head"), lit("tail"), lit("add"), lit("add*"), lit("pend"),
+ lit("pend*"), lit("ncon"), lit("ncon*"), lit("get"),
+ lit("del"), lit("del*"), lit("oust"),
+ nil
+ };
+ autoload_set(al_struct, sname, fun);
+ autoload_set(al_fun, name, fun);
+ intern_only(name_noload);
+ return nil;
+}
+
+static val build_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("build")));
+ return nil;
+}
+
+static val trace_set_entries(val fun)
+{
+ val sys_name[] = {
+ lit("trace"), lit("untrace"), nil
+ };
+ val vname[] = {
+ lit("*trace-output*"), nil
+ };
+ val name[] = {
+ lit("trace"), lit("untrace"), nil
+ };
+ autoload_sys_set(al_fun, sys_name, fun);
+ autoload_set(al_var, vname, fun);
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val trace_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("trace")));
+ trace_loaded = t;
+ return nil;
+}
+
+static val getopts_set_entries(val fun)
+{
+ val sname[] = {
+ lit("opt-desc"), lit("opts"), nil
+ };
+ val name[] = {
+ lit("opt"), lit("getopts"), lit("opthelp"), lit("opthelp-conventions"),
+ lit("opthelp-types"), lit("define-option-struct"),
+ nil
+ };
+ val name_noload[] = {
+ lit("short"), lit("long"), lit("helptext"), lit("type"),
+ lit("in-args"), lit("out-args"), lit("cumul"), lit("opt-error"), nil
+ };
+ autoload_set(al_struct, sname, fun);
+ autoload_set(al_fun, name, fun);
+ intern_only(name_noload);
+ return nil;
+}
+
+static val getopts_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("getopts")));
+ return nil;
+}
+
+static val package_set_entries(val fun)
+{
+ val name[] = {
+ lit("defpackage"), lit("in-package"),
+ nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val package_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("package")));
+ return nil;
+}
+
+static val getput_set_entries(val fun)
+{
+ val name[] = {
+ lit("get-jsons"), lit("put-jsons"),
+ lit("file-get"), lit("file-put"), lit("file-append"),
+ lit("file-get-objects"), lit("file-put-objects"), lit("file-append-objects"),
+ lit("file-get-string"), lit("file-put-string"), lit("file-append-string"),
+ lit("file-get-lines"), lit("file-put-lines"), lit("file-append-lines"),
+ lit("file-get-buf"), lit("file-put-buf"),
+ lit("file-place-buf"), lit("file-append-buf"),
+ lit("file-get-json"), lit("file-put-json"), lit("file-append-json"),
+ lit("file-get-jsons"), lit("file-put-jsons"), lit("file-append-jsons"),
+ lit("command-get"), lit("command-put"),
+ lit("command-get-string"), lit("command-put-string"),
+ lit("command-get-lines"), lit("command-put-lines"),
+ lit("command-get-buf"), lit("command-put-buf"),
+ lit("command-get-json"), lit("command-put-json"),
+ lit("command-get-jsons"), lit("command-put-jsons"),
+ lit("close-lazy-streams"),
+ nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val getput_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("getput")));
+ return nil;
+}
+
+static val tagbody_set_entries(val fun)
+{
+ val name[] = {
+ lit("tagbody"), lit("go"), lit("prog"), lit("prog*"), nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val tagbody_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("tagbody")));
+ return nil;
+}
+
+static val pmac_set_entries(val fun)
+{
+ val name[] = {
+ lit("define-param-expander"), lit("macroexpand-params"), nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val pmac_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("pmac")));
+ return nil;
+}
+
+static val error_set_entries(val fun)
+{
+ val sys_name[] = {
+ lit("bind-mac-error"), lit("bind-mac-check"),
+ lit("lambda-too-many-args"), lit("lambda-too-few-args"),
+ lit("lambda-short-apply-list"), lit("lambda-excess-apply-list"),
+ nil
+ };
+ val name[] = {
+ lit("compile-error"), lit("compile-warning"), lit("compile-defr-warning"),
+ nil
+ };
+ autoload_sys_set(al_fun, sys_name, fun);
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val error_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("error")));
+ return nil;
+}
+
+static val keyparams_set_entries(val fun)
+{
+ val sys_name[] = {
+ lit("extract-keys"), nil
+ };
+ val sys_kname[] = {
+ lit("key"), nil
+ };
+ val name_noload[] = {
+ lit("--"),
+ nil
+ };
+ autoload_sys_set(al_fun, sys_name, fun);
+ autoload_key_set(al_key, sys_kname, fun);
+ intern_only(name_noload);
+ return nil;
+}
+
+static val keyparams_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("keyparams")));
+ return nil;
+}
+
+static val ffi_set_entries(val fun)
+{
+ val name[] = {
+ lit("with-dyn-lib"), lit("deffi"), lit("deffi-type"), lit("deffi-cb"),
+ lit("deffi-cb-unsafe"),
+ lit("deffi-sym"), lit("deffi-var"), lit("deffi-struct"),
+ lit("deffi-union"), lit("typedef"), lit("sizeof"),
+ lit("alignof"), lit("offsetof"), lit("arraysize"), lit("elemsize"),
+ lit("elemtype"), lit("ffi"), lit("carray-ref"), lit("carray-sub"),
+ lit("sub-buf"), lit("znew"), lit("setjmp"),
+ nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val ffi_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("ffi")));
+ return nil;
+}
+
+static val doloop_set_entries(val fun)
+{
+ val name[] = {
+ lit("doloop"), lit("doloop*"),
+ nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val doloop_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("doloop")));
+ return nil;
+}
+
+static val stream_wrap_set_entries(val fun)
+{
+ val sname[] = {
+ lit("stream-wrap"),
+ nil
+ };
+ val name_noload[] = {
+ lit("close"), lit("flush"), lit("seek"), lit("truncate"),
+ lit("get-prop"), lit("set-prop"), lit("get-fd"), nil
+ };
+ autoload_set(al_struct, sname, fun);
+ intern_only(name_noload);
+ return nil;
+}
+
+static val stream_wrap_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("stream-wrap")));
+ return nil;
+}
+
+static val asm_set_entries(val fun)
+{
+ val sys_sname[] = {
+ lit("assembler"),
+ nil
+ };
+ val name[] = {
+ lit("disassemble"),
+ nil
+ };
+ autoload_sys_set(al_struct, sys_sname, fun);
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val asm_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("asm")));
+ return nil;
+}
+
+static val compiler_set_entries(val fun)
+{
+ val sys_name[] = {
+ lit("compiler"), lit("*in-compilation-unit*"),
+ nil
+ };
+ val sname[] = {
+ lit("compile-opts"),
+ nil
+ };
+ val name[] = {
+ lit("compile-toplevel"), lit("compile"), lit("compile-file"),
+ lit("compile-update-file"), lit("clean-file"),
+ lit("with-compilation-unit"), lit("dump-compiled-objects"),
+ lit("with-compile-opts"), lit("compiler-let"),
+ nil
+ };
+ val sys_vname[] = {
+ lit("*in-compilation-unit*"),
+ nil
+ };
+ val vname[] = {
+ lit("*opt-level*"), lit("*compile-opts*"),
+ nil
+ };
+ val slname[] = {
+ lit("shadow-fun"), lit("shadow-var"), lit("shadow-cross"),
+ lit("unused"), lit("log-level"), nil
+ };
+ autoload_sys_set(al_struct, sys_name, fun);
+ autoload_set(al_struct, sname, fun);
+ autoload_set(al_fun, name, fun);
+ autoload_sys_set(al_var, sys_vname, fun);
+ autoload_set(al_var, vname, fun);
+ autoload_set(al_slot, slname, fun);
+ return nil;
+}
+
+static val compiler_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("compiler")));
+ return nil;
+}
+
+static val debugger_set_entries(val fun)
+{
+ val sys_name[] = {
+ lit("debugger"), lit("print-backtrace"),
+ nil
+ };
+ autoload_sys_set(al_fun, sys_name, fun);
+ return nil;
+}
+
+static val debugger_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("debugger")));
+ return nil;
+}
+
+static val op_set_entries(val fun)
+{
+ val name[] = {
+ lit("op"), lit("do"), lit("lop"), lit("ldo"), lit("ap"), lit("ip"),
+ lit("ado"), lit("ido"), lit("ret"), lit("aret"),
+ lit("opip"), lit("oand"), lit("lopip"), lit("loand"),
+ lit("opf"), lit("lopf"), lit("flow"), lit("lflow"), lit("tap"),
+ nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val op_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("op")));
+ return nil;
+}
+
+static val save_exe_set_entries(val fun)
+{
+ val name[] = {
+ lit("save-exe"),
+ nil
+ };
+
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val save_exe_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("save-exe")));
+ return nil;
+}
+
+static val defset_set_entries(val fun)
+{
+ val name[] = {
+ lit("defset"), lit("sub-list"), lit("sub-vec"), lit("sub-str"),
+ lit("left"), lit("right"), lit("key"),
+ lit("set-mask"), lit("clear-mask"),
+ nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val defset_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("defset")));
+ return nil;
+}
+
+static val copy_file_set_entries(val fun)
+{
+ val sname[] = {
+ lit("copy-path-opts"),
+ nil
+ };
+ val name[] = {
+ lit("copy-file"), lit("copy-files"), lit("cat-files"),
+ lit("copy-path-rec"), lit("remove-path-rec"),
+ lit("chown-rec"), lit("chmod-rec"), lit("touch"),
+ nil
+ };
+ autoload_set(al_struct, sname, fun);
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val copy_file_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("copy-file")));
+ return nil;
+}
+
+static val arith_each_set_entries(val fun)
+{
+ val name[] = {
+ lit("sum-each"), lit("mul-each"), lit("sum-each*"), lit("mul-each*"),
+ lit("each-true"), lit("some-true"), lit("each-false"), lit("some-false"),
+ nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val arith_each_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("arith-each")));
+ return nil;
+}
+
+static val each_prod_set_entries(val fun)
+{
+ val name[] = {
+ lit("each-prod"), lit("collect-each-prod"), lit("append-each-prod"),
+ lit("sum-each-prod"), lit("mul-each-prod"),
+ lit("each-prod*"), lit("collect-each-prod*"), lit("append-each-prod*"),
+ lit("sum-each-prod*"), lit("mul-each-prod*"),
+ nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val each_prod_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("each-prod")));
+ return nil;
+}
+
+static val quips_set_entries(val fun)
+{
+ val name[] = {
+ lit("quip"), nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val quips_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("quips")));
+ return nil;
+}
+
+static val match_set_entries(val fun)
+{
+ val name_noload[] = {
+ lit("all*"), lit("as"), lit("with"), lit("scan"), lit("sme"),
+ nil
+ };
+ val name[] = {
+ lit("when-match"), lit("match-case"), lit("match-cond"), lit("if-match"),
+ lit("match"), lit("match-ecase"),
+ lit("while-match"), lit("while-match-case"), lit("while-true-match-case"),
+ lit("lambda-match"), lit("defun-match"), lit("defmatch"),
+ lit("macroexpand-match"),
+ lit("each-match"), lit("append-matches"),
+ lit("keep-matches"), lit("each-match-product"),
+ lit("append-match-products"), lit("keep-match-products"),
+ lit("match-error"),
+ nil
+ };
+ val sys_name[] = {
+ lit("match-pat-error"),
+ nil
+ };
+ val vname[] = {
+ lit("*match-macro*"),
+ nil
+ };
+ val kname[] = {
+ lit("match"),
+ nil
+ };
+
+ autoload_set(al_fun, name, fun);
+ autoload_sys_set(al_fun, sys_name, fun);
+ autoload_set(al_var, vname, fun);
+ autoload_key_set(al_key, kname, fun);
+ intern_only(name_noload);
+ return nil;
+}
+
+static val match_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("match")));
+ return nil;
+}
+
+static val doc_set_entries(val fun)
+{
+ val name[] = {
+ lit("doc"), nil
+ };
+ val vname[] = {
+ lit("*doc-url*"), nil
+ };
+ autoload_set(al_fun, name, fun);
+ autoload_set(al_var, vname, fun);
+ return nil;
+}
+
+static val doc_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("doc-lookup")));
+ return nil;
+}
+
+static val pic_set_entries(val fun)
+{
+ val name[] = {
+ lit("pic"),
+ nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val pic_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("pic")));
+ return nil;
+}
+
+static val constfun_set_entries(val fun)
+{
+ val sys_vname[] = {
+ lit("%const-foldable%"),
+ nil
+ };
+ autoload_sys_set(al_var, sys_vname, fun);
+ return nil;
+}
+
+static val constfun_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("constfun")));
+ return nil;
+}
+
+static val expander_let_set_entries(val fun)
+{
+ val name[] = {
+ lit("expander-let"),
+ nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val expander_let_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("expander-let")));
+ return nil;
+}
+
+static val load_args_set_entries(val fun)
+{
+ val name[] = {
+ lit("load-args-recurse"), lit("load-args-process"),
+ nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val load_args_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("load-args")));
+ return nil;
+}
+
+static val csort_set_entries(val fun)
+{
+ val name[] = {
+ lit("csort"), lit("cnsort"), lit("cssort"), lit("csnsort"),
+ lit("csort-group"),
+ nil
+ };
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val csort_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("csort")));
+ return nil;
+}
+
+static val glob_set_entries(val fun)
+{
+ val sys_name[] = {
+ lit("brace-expand"),
+ nil
+ };
+ val name[] = {
+ lit("glob*"),
+ nil
+ };
+ autoload_sys_set(al_fun, sys_name, fun);
+ autoload_set(al_fun, name, fun);
+ return nil;
+}
+
+static val glob_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("glob")));
+ return nil;
+}
+
+
+val autoload_reg(val (*instantiate)(void),
+ val (*set_entries)(val))
+{
+ val fun = func_n0(instantiate);
+ set_entries(fun);
+ return sethash(autoload_reg_hash, fun, t);
+}
+
+static void autoload_init_tables(void)
+{
+ int i;
+
+ prot1(&autoload_reg_hash);
+
+ for (i = 0; i <= al_max; i++) {
+ autoload_hash[i] = make_hash(hash_weak_or, nil);
+ prot1(&autoload_hash[i]);
+ }
+
+ autoload_reg_hash = make_hash(hash_weak_none, nil);
+}
+
+void autoload_init(void)
+{
+ autoload_init_tables();
+ autoload_reg(place_instantiate, place_set_entries);
+ autoload_reg(ver_instantiate, ver_set_entries);
+ autoload_reg(ifa_instantiate, ifa_set_entries);
+ autoload_reg(txr_case_instantiate, txr_case_set_entries);
+ autoload_reg(with_resources_instantiate, with_resources_set_entries);
+ autoload_reg(path_test_instantiate, path_test_set_entries);
+ autoload_reg(struct_instantiate, struct_set_entries);
+ autoload_reg(with_stream_instantiate, with_stream_set_entries);
+ autoload_reg(hash_instantiate, hash_set_entries);
+ autoload_reg(except_instantiate, except_set_entries);
+ autoload_reg(type_instantiate, type_set_entries);
+ autoload_reg(yield_instantiate, yield_set_entries);
+ autoload_reg(awk_instantiate, awk_set_entries);
+ autoload_reg(build_instantiate, build_set_entries);
+ autoload_reg(trace_instantiate, trace_set_entries);
+ autoload_reg(getopts_instantiate, getopts_set_entries);
+ autoload_reg(package_instantiate, package_set_entries);
+ autoload_reg(getput_instantiate, getput_set_entries);
+ autoload_reg(tagbody_instantiate, tagbody_set_entries);
+ autoload_reg(pmac_instantiate, pmac_set_entries);
+ autoload_reg(error_instantiate, error_set_entries);
+ autoload_reg(keyparams_instantiate, keyparams_set_entries);
+ autoload_reg(ffi_instantiate, ffi_set_entries);
+ autoload_reg(doloop_instantiate, doloop_set_entries);
+ autoload_reg(stream_wrap_instantiate, stream_wrap_set_entries);
+ autoload_reg(asm_instantiate, asm_set_entries);
+ autoload_reg(compiler_instantiate, compiler_set_entries);
+ autoload_reg(debugger_instantiate, debugger_set_entries);
+
+ if (!opt_compat || opt_compat >= 185)
+ autoload_reg(op_instantiate, op_set_entries);
+
+ autoload_reg(save_exe_instantiate, save_exe_set_entries);
+ autoload_reg(defset_instantiate, defset_set_entries);
+ autoload_reg(copy_file_instantiate, copy_file_set_entries);
+ autoload_reg(arith_each_instantiate, arith_each_set_entries);
+ autoload_reg(each_prod_instantiate, each_prod_set_entries);
+ autoload_reg(quips_instantiate, quips_set_entries);
+ autoload_reg(match_instantiate, match_set_entries);
+ autoload_reg(doc_instantiate, doc_set_entries);
+ autoload_reg(pic_instantiate, pic_set_entries);
+ autoload_reg(constfun_instantiate, constfun_set_entries);
+ autoload_reg(expander_let_instantiate, expander_let_set_entries);
+ autoload_reg(load_args_instantiate, load_args_set_entries);
+ autoload_reg(csort_instantiate, csort_set_entries);
+ autoload_reg(glob_instantiate, glob_set_entries);
+
+ reg_fun(intern(lit("autoload-try-fun"), system_package), func_n1(autoload_try_fun));
+}
+
+static val autoload_try(al_ns_t ns, val sym)
+{
+ val fun = gethash(autoload_hash[ns], sym);
+
+ if (fun) {
+ val check = gethash(autoload_reg_hash, fun);
+
+ if (check) {
+ unsigned ds = debug_clear(opt_dbg_autoload ? 0 : DBG_ENABLE);
+ val saved_dyn_env = dyn_env;
+ int saved_compat = opt_compat;
+ remhash(autoload_reg_hash, fun);
+ dyn_env = make_env(nil, nil, dyn_env);
+ env_vbind(dyn_env, package_s, system_package);
+ env_vbind(dyn_env, package_alist_s, packages);
+ opt_compat = 0;
+ funcall(fun);
+ opt_compat = saved_compat;
+ dyn_env = saved_dyn_env;
+ debug_restore(ds);
+ return t;
+ }
+ }
+ return nil;
+}
+
+val autoload_try_fun(val sym)
+{
+ return autoload_try(al_fun, sym);
+}
+
+val autoload_try_var(val sym)
+{
+ return autoload_try(al_var, sym);
+}
+
+val autoload_try_fun_var(val sym)
+{
+ uses_or2;
+ return or2(autoload_try_fun(sym),
+ autoload_try_var(sym));
+}
+
+val autoload_try_slot(val sym)
+{
+ return autoload_try(al_slot, sym);
+}
+
+val autoload_try_struct(val sym)
+{
+ return autoload_try(al_struct, sym);
+}
+
+val autoload_try_keyword(val sym)
+{
+ return autoload_try(al_key, sym);
+}
+
+void autoload_intern(val *namearray)
+{
+ intern_only(namearray);
+}
diff --git a/autoload.h b/autoload.h
new file mode 100644
index 00000000..1d604082
--- /dev/null
+++ b/autoload.h
@@ -0,0 +1,44 @@
+/* Copyright 2015-2024
+ * Kaz Kylheku <kaz@kylheku.com>
+ * Vancouver, Canada
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ */
+
+typedef enum autoload_ns {
+ al_var, al_fun, al_slot, al_struct, al_key, al_max = al_key
+} al_ns_t;
+
+extern val trace_loaded;
+void autoload_init(void);
+val autoload_try_fun(val sym);
+val autoload_try_var(val sym);
+val autoload_try_fun_var(val sym);
+val autoload_try_slot(val sym);
+val autoload_try_struct(val sym);
+val autoload_try_keyword(val sym);
+void autoload_set(al_ns_t ns, val *name, val fun);
+val autoload_reg(val (*instantiate)(void),
+ val (*set_entries)(val));
+void autoload_intern(val *namearray);
diff --git a/buf.c b/buf.c
index 09bdd0ee..cc3bcda6 100644
--- a/buf.c
+++ b/buf.c
@@ -1,4 +1,4 @@
-/* Copyright 2017-2020
+/* Copyright 2017-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,26 +6,26 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
-#include <stddef.h>
#include <wchar.h>
#include <limits.h>
#include <float.h>
@@ -35,6 +35,9 @@
#include <signal.h>
#include <stdio.h>
#include "config.h"
+#if HAVE_ZLIB
+#include <zlib.h>
+#endif
#include "lib.h"
#include "gc.h"
#include "itypes.h"
@@ -44,11 +47,12 @@
#include "stream.h"
#include "arith.h"
#include "utf8.h"
+#include "txr.h"
#include "buf.h"
static cnum buf_check_len(val len, val self)
{
- cnum l = c_num(len);
+ cnum l = c_num(len, self);
if (l < 0)
uw_throwf(error_s, lit("~a: negative length ~s specified"),
self, len, nao);
@@ -57,7 +61,7 @@ static cnum buf_check_len(val len, val self)
static cnum buf_check_alloc_size(val alloc_size, cnum len, val self)
{
- cnum ah = c_num(alloc_size);
+ cnum ah = c_num(alloc_size, self);
if (ah < len)
uw_throwf(error_s, lit("~a: alloc size size ~s lower than length"),
self, alloc_size, nao);
@@ -66,9 +70,9 @@ static cnum buf_check_alloc_size(val alloc_size, cnum len, val self)
static cnum buf_check_index(struct buf *b, val index, val self)
{
- cnum ix = c_num(index);
+ cnum ix = c_num(index, self);
if (ix < 0)
- ix = c_num(plus(b->len, index));
+ ix = c_num(plus(b->len, index), self);
if (ix < 0)
uw_throwf(error_s, lit("~a: negative byte index ~s specified"),
self, index, nao);
@@ -120,17 +124,18 @@ val make_borrowed_buf(val len, mem_t *data)
val make_duplicate_buf(val len, mem_t *data)
{
+ val self = lit("make-duplicate-buf");
val obj = make_obj();
obj->b.type = BUF;
- obj->b.data = chk_copy_obj(data, c_num(len));
+ obj->b.data = chk_copy_obj(data, c_num(len, self));
obj->b.len = len;
obj->b.size = len;
return obj;
}
-static val make_owned_buf(val len, mem_t *data)
+val make_owned_buf(val len, mem_t *data)
{
val buf = make_borrowed_buf(len, data);
buf->b.size = len;
@@ -155,13 +160,14 @@ val copy_buf(val buf)
static void buf_shrink(struct buf *b)
{
+ val self = lit("buf-trim");
val len = b->len;
if (len == zero)
len = succ(len); /* avoid reallocing to zero length; i.e. freeing */
if (len != b->size) {
- b->data = chk_realloc(b->data, c_num(len));
+ b->data = chk_realloc(b->data, c_unum(len, self));
b->size = b->len;
}
}
@@ -182,8 +188,8 @@ static val buf_do_set_len(val buf, struct buf *b, val newlen,
val init_val, val self)
{
val oldlen = b->len;
- cnum olen = c_num(oldlen), len = c_num(newlen);
- cnum oldsize = c_num(b->size), size = oldsize;
+ cnum olen = c_num(oldlen, self), len = c_num(newlen, self);
+ cnum oldsize = c_num(b->size, self), size = oldsize;
cnum iv = c_u8(default_arg(init_val, zero), self);
if (!b->size)
@@ -221,6 +227,19 @@ val buf_set_length(val buf, val len, val init_val)
return buf_do_set_len(buf, b, len, init_val, self);
}
+val buf_free(val buf)
+{
+ val self = lit("buf-free");
+ struct buf *b = buf_handle(buf, self);
+ if (b->size) {
+ free(b->data);
+ b->data = 0;
+ b->len = b->size = zero;
+ return t;
+ }
+ return nil;
+}
+
val length_buf(val buf)
{
val self = lit("length-buf");
@@ -243,6 +262,7 @@ mem_t *buf_get(val buf, val self)
val sub_buf(val buf, val from, val to)
{
+ val self = lit("sub-buf");
struct buf *b = buf_handle(buf, lit("sub"));
val len = b->len;
@@ -269,7 +289,7 @@ val sub_buf(val buf, val from, val to)
} else if (from == 0 && to == len) {
return buf;
} else {
- return make_duplicate_buf(minus(to, from), b->data + c_num(from));
+ return make_duplicate_buf(minus(to, from), b->data + c_num(from, self));
}
}
@@ -284,6 +304,8 @@ val replace_buf(val buf, val items, val from, val to)
from = len;
} else if (!integerp(from)) {
seq_iter_t wh_iter, item_iter;
+ cnum offs = 0;
+ cnum l = c_num(len, self), ol = l;
val wh, item;
seq_iter_init(self, &wh_iter, from);
seq_iter_init(self, &item_iter, items);
@@ -293,12 +315,39 @@ val replace_buf(val buf, val items, val from, val to)
lit("~a: to-arg not applicable when from-arg is a list"),
self, nao);
- while (seq_get(&wh_iter, &wh) && seq_get(&item_iter, &item)) {
+ while (seq_get(&item_iter, &item) && seq_get(&wh_iter, &wh)) {
if (ge(wh, len))
break;
buf_put_uchar(buf, wh, item);
}
+ if (!opt_compat || opt_compat > 289) {
+ while (seq_get(&wh_iter, &wh)) {
+ cnum w = c_num(wh, self);
+
+ if (w < 0)
+ w += ol;
+
+ if (w < 0)
+ break;
+
+ w -= offs;
+
+ if (w >= l)
+ break;
+
+ memmove(buf->b.data + w,
+ buf->b.data + w + 1,
+ l - w - 1);
+ l--;
+ offs++;
+
+ }
+
+ if (offs > 0)
+ buf_set_length(buf, num_fast(l), zero);
+ }
+
return buf;
} else if (minusp(from)) {
from = plus(from, len);
@@ -320,10 +369,10 @@ val replace_buf(val buf, val items, val from, val to)
if (gt(len_rep, len_it)) {
val len_diff = minus(len_rep, len_it);
- cnum t = c_num(to);
- cnum l = c_num(len);
+ cnum t = c_num(to, self);
+ cnum l = c_num(len, self);
- memmove(buf->b.data + t - c_num(len_diff),
+ memmove(buf->b.data + t - c_num(len_diff, self),
buf->b.data + t,
l - t);
@@ -331,12 +380,12 @@ val replace_buf(val buf, val items, val from, val to)
to = plus(from, len_it);
} else if (lt(len_rep, len_it)) {
val len_diff = minus(len_it, len_rep);
- cnum t = c_num(to);
- cnum l = c_num(len);
+ cnum t = c_num(to, self);
+ cnum l = c_num(len, self);
buf_set_length(buf, plus(len, len_diff), zero);
- memmove(buf->b.data + t + c_num(len_diff),
+ memmove(buf->b.data + t + c_num(len_diff, self),
buf->b.data + t,
l - t);
to = plus(from, len_it);
@@ -345,12 +394,13 @@ val replace_buf(val buf, val items, val from, val to)
if (zerop(len_it))
return buf;
if (bufp(items)) {
- memmove(buf->b.data + c_num(from), items->b.data, c_num(len_it));
+ memmove(buf->b.data + c_num(from, self), items->b.data, c_num(len_it, self));
} else {
seq_iter_t item_iter;
+ cnum f = c_num(from, self);
+ cnum t = c_num(to, self);
+
seq_iter_init(self, &item_iter, items);
- cnum f = c_num(from);
- cnum t = c_num(to);
for (; f != t; f++) {
val item = seq_geti(&item_iter);
@@ -364,7 +414,7 @@ val replace_buf(val buf, val items, val from, val to)
val buf_list(val list)
{
- val self = lit("buf-list");;
+ val self = lit("buf-list");
val len = length(list);
val buf = make_buf(zero, zero, len);
seq_iter_t iter;
@@ -393,11 +443,11 @@ val buf_put_buf(val dbuf, val sbuf, val pos)
{
val self = lit("buf-put-buf");
struct buf *sb = buf_handle(sbuf, self);
- buf_move_bytes(dbuf, pos, sb->data, c_num(sb->len), self);
+ buf_move_bytes(dbuf, pos, sb->data, c_num(sb->len, self), self);
return sbuf;
}
-static void buf_put_bytes(val buf, val pos, mem_t *ptr, cnum size, val self)
+void buf_put_bytes(val buf, val pos, mem_t *ptr, cnum size, val self)
{
struct buf *b = buf_handle(buf, self);
cnum p = buf_check_index(b, pos, self);
@@ -414,7 +464,7 @@ val buf_put_i8(val buf, val pos, val num)
struct buf *b = buf_handle(buf, self);
cnum p = buf_check_index(b, pos, self);
i8_t v = c_i8(num, self);
- if (p >= c_num(b->len))
+ if (p >= c_num(b->len, self))
buf_do_set_len(buf, b, succ(pos), nil, self);
b->data[p] = v;
return num;
@@ -426,7 +476,7 @@ val buf_put_u8(val buf, val pos, val num)
struct buf *b = buf_handle(buf, self);
cnum p = buf_check_index(b, pos, self);
cnum v = c_u8(num, self);
- if (p >= c_num(b->len))
+ if (p >= c_num(b->len, self))
buf_do_set_len(buf, b, succ(pos), nil, self);
b->data[p] = v;
return num;
@@ -493,7 +543,7 @@ val buf_put_char(val buf, val pos, val num)
struct buf *b = buf_handle(buf, self);
cnum p = buf_check_index(b, pos, self);
char v = c_char(num, self);
- if (p >= c_num(b->len))
+ if (p >= c_num(b->len, self))
buf_do_set_len(buf, b, succ(pos), nil, self);
b->data[p] = v;
return num;
@@ -505,7 +555,7 @@ val buf_put_uchar(val buf, val pos, val num)
struct buf *b = buf_handle(buf, self);
cnum p = buf_check_index(b, pos, self);
unsigned char v = c_uchar(num, self);
- if (p >= c_num(b->len))
+ if (p >= c_num(b->len, self))
buf_do_set_len(buf, b, succ(pos), nil, self);
b->data[p] = v;
return num;
@@ -589,12 +639,12 @@ val buf_put_cptr(val buf, val pos, val cptr)
return cptr;
}
-static void buf_get_bytes(val buf, val pos, mem_t *ptr, cnum size, val self)
+void buf_get_bytes(val buf, val pos, mem_t *ptr, cnum size, val self)
{
struct buf *b = buf_handle(buf, self);
cnum p = buf_check_index(b, pos, self);
cnum e = p + size;
- cnum l = c_num(b->len);
+ cnum l = c_num(b->len, self);
if (e > l || e < 0)
uw_throwf(error_s, lit("~a: attempted read past buffer end"), self, nao);
@@ -608,7 +658,7 @@ val buf_get_i8(val buf, val pos)
val self = lit("buf-get-i8");
struct buf *b = buf_handle(buf, self);
cnum p = buf_check_index(b, pos, self);
- if (p >= c_num(b->len))
+ if (p >= c_num(b->len, self))
uw_throwf(error_s, lit("~a: attempted read past buffer end"), self, nao);
return num_fast(convert(i8_t, b->data[p]));
}
@@ -618,7 +668,7 @@ val buf_get_u8(val buf, val pos)
val self = lit("buf-get-u8");
struct buf *b = buf_handle(buf, self);
cnum p = buf_check_index(b, pos, self);
- if (p >= c_num(b->len))
+ if (p >= c_num(b->len, self))
uw_throwf(error_s, lit("~a: attempted read past buffer end"), self, nao);
return num_fast(convert(u8_t, b->data[p]));
}
@@ -788,9 +838,10 @@ val buf_get_cptr(val buf, val pos)
val buf_print(val buf, val stream_in)
{
+ val self = lit("buf-print");
val stream = default_arg(stream_in, std_output);
- struct buf *b = buf_handle(buf, lit("buf-print"));
- cnum len = c_num(b->len), count = 0;
+ struct buf *b = buf_handle(buf, self);
+ cnum len = c_num(b->len, self), count = 0;
mem_t *data = b->data;
val save_mode = test_neq_set_indent_mode(stream, num_fast(indent_foff),
num_fast(indent_data));
@@ -819,9 +870,10 @@ val buf_print(val buf, val stream_in)
val buf_pprint(val buf, val stream_in)
{
+ val self = lit("buf-pprint");
val stream = default_arg(stream_in, std_output);
- struct buf *b = buf_handle(buf, lit("buf-print"));
- cnum len = c_num(b->len);
+ struct buf *b = buf_handle(buf, self);
+ cnum len = c_num(b->len, self);
mem_t *data = b->data;
while (len-- > 0)
@@ -830,6 +882,20 @@ val buf_pprint(val buf, val stream_in)
return t;
}
+void buf_hex(val buf, char *hex, size_t sz, int caps)
+{
+ val self = lit("buf-hex");
+ struct buf *b = buf_handle(buf, self);
+ size_t i;
+ unsigned char *data = b->data;
+ const char *fmt = caps ? "%02X" : "%02x";
+
+ *hex = 0;
+
+ for (i = 0; i < sz - 1; i += 2)
+ hex += sprintf(hex, fmt, *data++);
+}
+
struct buf_strm {
struct strm_base a;
utf8_decoder_t ud;
@@ -858,8 +924,9 @@ static int buf_strm_put_byte_callback(int b, mem_t *ctx)
static val buf_strm_put_string(val stream, val str)
{
+ val self = lit("put-string");
struct buf_strm *s = coerce(struct buf_strm *, stream->co.handle);
- const wchar_t *p = c_str(str);
+ const wchar_t *p = c_str(str, self);
while (*p) {
(void) utf8_encode(*p++, buf_strm_put_byte_callback, coerce(mem_t *, s));
@@ -890,7 +957,7 @@ static int buf_strm_get_byte_callback(mem_t *ctx)
struct buf *b = buf_handle(s->buf, self);
cnum p = buf_check_index(b, s->pos, self);
s->pos = num(p + 1);
- return (p >= c_num(b->len)) ? EOF : b->data[p];
+ return (p >= c_num(b->len, self)) ? EOF : b->data[p];
}
static val buf_strm_get_char(val stream)
@@ -934,7 +1001,7 @@ static val buf_strm_unget_byte(val stream, int byte)
val self = lit("unget-byte");
struct buf_strm *s = coerce(struct buf_strm *, stream->co.handle);
struct buf *b = buf_handle(s->buf, self);
- cnum p = c_num(s->pos);
+ cnum p = c_num(s->pos, self);
if (p <= 0) {
uw_throwf(file_error_s,
@@ -1055,7 +1122,7 @@ static struct strm_ops buf_strm_ops =
static struct buf_strm *buf_strm(val stream, val self)
{
struct buf_strm *s = coerce(struct buf_strm *,
- cobj_handle(self, stream, stream_s));
+ cobj_handle(self, stream, stream_cls));
type_assert (stream->co.ops == &buf_strm_ops.cobj_ops,
(lit("~a: ~a is not a buffer stream"), self, stream, nao));
@@ -1074,7 +1141,7 @@ val make_buf_stream(val buf_opt)
s->pos = zero;
s->is_byte_oriented = 0;
s->unget_c = nil;
- stream = cobj(coerce(mem_t *, s), stream_s, &buf_strm_ops.cobj_ops);
+ stream = cobj(coerce(mem_t *, s), stream_cls, &buf_strm_ops.cobj_ops);
s->buf = buf;
return stream;
@@ -1091,7 +1158,7 @@ void buf_swap32(val buf)
{
val self = lit("buf-swap32");
struct buf *b = buf_handle(buf, self);
- mem_t *data = b->data, *end = data + c_num(b->len);
+ mem_t *data = b->data, *end = data + c_num(b->len, self);
for (; data + 3 < end; data += 4) {
u32_t sw32 = *coerce(u32_t *, data);
@@ -1103,9 +1170,10 @@ void buf_swap32(val buf)
static val buf_str(val str, val null_term)
{
+ val self = lit("buf-str");
size_t sz;
val nt = default_null_arg(null_term);
- unsigned char *u8 = utf8_dup_to_buf(c_str(str), &sz, nt != nil);
+ unsigned char *u8 = utf8_dup_to_buf(c_str(str, self), &sz, nt != nil);
return make_owned_buf(unum(sz), u8);
}
@@ -1114,7 +1182,7 @@ static val str_buf(val buf, val null_term)
val self = lit("str-buf");
struct buf *b = buf_handle(buf, self);
val nt = default_null_arg(null_term);
- size_t blen = c_unum(b->len);
+ size_t blen = c_unum(b->len, self);
size_t len = (nt && blen > 0 && !b->data[blen-1]) ? blen - 1 : blen;
wchar_t *str = utf8_dup_from_buf(coerce(const char *, b->data), len);
return string_own(str);
@@ -1125,8 +1193,10 @@ static val buf_int(val num)
val self = lit("buf-int");
switch (type(num)) {
- case NUM: case CHR:
- num = bignum(c_num(num));
+ case CHR:
+ return buf_int(num_fast(c_ch(num)));
+ case NUM:
+ num = bignum(c_num(num, self));
/* fallthrough */
case BGNUM:
{
@@ -1135,10 +1205,10 @@ static val buf_int(val num)
val bytes = ash(plus(bits, num_fast(7)), num_fast(-3));
val bitsround = ash(bytes, num_fast(3));
val un = logtrunc(num, bitsround);
- val ube = if3(bignump(un), un, bignum(c_num(un)));
+ val ube = if3(bignump(un), un, bignum(c_num(un, self)));
mp_int *m = mp(ube);
size_t numsize = mp_unsigned_bin_size(m);
- size_t bufsize = c_unum(bytes);
+ size_t bufsize = c_unum(bytes, self);
mem_t *data = chk_malloc(bufsize);
data[0] = 0;
mp_to_unsigned_bin(m, data + (bufsize - numsize));
@@ -1155,8 +1225,10 @@ static val buf_uint(val num)
val self = lit("buf-uint");
switch (type(num)) {
- case NUM: case CHR:
- num = bignum(c_num(num));
+ case CHR:
+ return buf_uint(num_fast(c_ch(num)));
+ case NUM:
+ num = bignum(c_num(num, self));
/* fallthrough */
case BGNUM:
{
@@ -1180,7 +1252,7 @@ static val int_buf(val buf)
{
val self = lit("int-buf");
struct buf *b = buf_handle(buf, self);
- ucnum size = c_unum(b->size);
+ ucnum size = c_unum(b->len, self);
ucnum bits = size * 8;
val ubn = make_bignum();
mp_err mpe = mp_read_unsigned_bin(mp(ubn), b->data, size);
@@ -1191,9 +1263,9 @@ static val int_buf(val buf)
static val uint_buf(val buf)
{
- val self = lit("int-buf");
+ val self = lit("uint-buf");
struct buf *b = buf_handle(buf, self);
- ucnum size = c_unum(b->size);
+ ucnum size = c_unum(b->len, self);
val ubn = make_bignum();
mp_err mpe = mp_read_unsigned_bin(mp(ubn), b->data, size);
if (mpe != MP_OKAY)
@@ -1201,8 +1273,69 @@ static val uint_buf(val buf)
return normalize(ubn);
}
-unsigned char *utf8_dup_to_buf(const wchar_t *, size_t *pnbytes,
- int null_term);
+#if HAVE_ZLIB
+
+static val buf_compress(val buf, val level_opt)
+{
+ val self = lit("buf-compress");
+ val level = default_arg(level_opt, negone);
+ int lev = c_int(level, self);
+ struct buf *b = buf_handle(buf, self);
+ ucnum size = c_unum(b->len, self);
+ uLong bound = compressBound(size), zsize = bound;
+ mem_t *zdata = chk_malloc(bound);
+
+ if (convert(uLong, size) != size) {
+ free(zdata);
+ uw_throwf(error_s, lit("~a: array size overflow"), self, nao);
+ }
+
+ if (compress2(zdata, &zsize, b->data, size, lev) != Z_OK) {
+ free(zdata);
+ uw_throwf(error_s, lit("~a: compression failed"), self, nao);
+ }
+
+ zdata = chk_realloc(zdata, zsize);
+ return make_owned_buf(unum(zsize), zdata);
+}
+
+static val buf_decompress(val buf)
+{
+ val self = lit("buf-decompress");
+ struct buf *b = buf_handle(buf, self);
+ ucnum zsize = c_unum(b->len, self);
+ uLong zsz10 = 10 * zsize;
+ uLong size = if3(zsz10 > zsize, zsz10, convert(uLong, -1));
+ mem_t *data = chk_malloc(size);
+
+ for (;;) {
+ switch (uncompress(data, &size, b->data, zsize)) {
+ case Z_OK:
+ data = chk_realloc(data, size);
+ return make_owned_buf(unum(size), data);
+ case Z_BUF_ERROR:
+ if (size == convert(uLong, -1))
+ break;
+ if (size * 2 > size)
+ size = size * 2;
+ else if (size == convert(uLong, -1))
+ break;
+ else
+ size = convert(uLong, -1);
+ data = chk_realloc(data, size);
+ continue;
+ default:
+ break;
+ }
+ break;
+ }
+
+ free(data);
+ uw_throwf(error_s, lit("~a: decompression failed"), self, nao);
+}
+
+#endif
+
void buf_init(void)
{
reg_fun(intern(lit("make-buf"), user_package), func_n3o(make_buf, 1));
@@ -1291,5 +1424,10 @@ void buf_init(void)
reg_fun(intern(lit("int-buf"), user_package), func_n1(int_buf));
reg_fun(intern(lit("uint-buf"), user_package), func_n1(uint_buf));
+#if HAVE_ZLIB
+ reg_fun(intern(lit("buf-compress"), user_package), func_n2o(buf_compress, 1));
+ reg_fun(intern(lit("buf-decompress"), user_package), func_n1(buf_decompress));
+#endif
+
fill_stream_ops(&buf_strm_ops);
}
diff --git a/buf.h b/buf.h
index 578bc5aa..3d2ebc01 100644
--- a/buf.h
+++ b/buf.h
@@ -1,4 +1,4 @@
-/* Copyright 2017-2020
+/* Copyright 2017-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,33 +6,36 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
val make_buf(val len, val init_val, val alloc_size);
val bufp(val object);
val make_borrowed_buf(val len, mem_t *data);
val init_borrowed_buf(obj_t *buf, val len, mem_t *data);
+val make_owned_buf(val len, mem_t *data);
val make_duplicate_buf(val len, mem_t *data);
val copy_buf(val buf);
val buf_trim(val buf);
val buf_set_length(val obj, val len, val init_val);
+val buf_free(val buf);
val length_buf(val buf);
val buf_alloc_size(val buf);
mem_t *buf_get(val buf, val self);
@@ -41,6 +44,8 @@ val replace_buf(val buf, val items, val from, val to);
val buf_list(val list);
val buf_put_buf(val dbuf, val sbuf, val pos);
+void buf_put_bytes(val buf, val pos, mem_t *ptr, cnum size, val self);
+
#if HAVE_I8
val buf_put_i8(val buf, val pos, val num);
val buf_put_u8(val buf, val pos, val num);
@@ -73,6 +78,8 @@ val buf_put_float(val buf, val pos, val num);
val buf_put_double(val buf, val pos, val num);
val buf_put_cptr(val buf, val pos, val cptr);
+void buf_get_bytes(val buf, val pos, mem_t *ptr, cnum size, val self);
+
#if HAVE_I8
val buf_get_i8(val buf, val pos);
val buf_get_u8(val buf, val pos);
@@ -108,6 +115,8 @@ val buf_get_cptr(val buf, val pos);
val buf_print(val buf, val stream);
val buf_pprint(val buf, val stream);
+void buf_hex(val buf, char *, size_t, int);
+
val make_buf_stream(val buf_opt);
val get_buf_from_stream(val stream);
diff --git a/cadr.c b/cadr.c
index 97cebedf..db95fc01 100644
--- a/cadr.c
+++ b/cadr.c
@@ -1,6 +1,6 @@
/* This file is generated by gencadr.txr */
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -8,35 +8,35 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stdio.h>
#include <stdarg.h>
#include <stdlib.h>
#include <limits.h>
-#include <signal.h>
#include "config.h"
#include "lib.h"
#include "eval.h"
#include "stream.h"
-#include "lisplib.h"
+#include "autoload.h"
#include "txr.h"
#include "cadr.h"
@@ -340,9 +340,8 @@ val cdddddr(val cons)
return cdr(cdr(cdr(cdr(cdr(cons)))));
}
-static val cadr_register(val set_fun)
+static val cadr_register(void)
{
- funcall1(set_fun, nil);
reg_fun(intern(lit("caar"), user_package), func_n1(caar));
reg_fun(intern(lit("cadr"), user_package), func_n1(cadr));
reg_fun(intern(lit("cdar"), user_package), func_n1(cdar));
@@ -403,11 +402,11 @@ static val cadr_register(val set_fun)
reg_fun(intern(lit("cdddadr"), user_package), func_n1(cdddadr));
reg_fun(intern(lit("cddddar"), user_package), func_n1(cddddar));
reg_fun(intern(lit("cdddddr"), user_package), func_n1(cdddddr));
- load(format(nil, lit("~acadr"), stdlib_path, nao));
+ load(scat2(stdlib_path, lit("cadr")));
return nil;
}
-static val cadr_set_entries(val dlt, val fun)
+static val cadr_set_entries(val fun)
{
val name[] = {
lit("caar"),
@@ -473,11 +472,11 @@ static val cadr_set_entries(val dlt, val fun)
nil
};
- set_dlt_entries(dlt, name, fun);
+ autoload_set(al_fun, name, fun);
return nil;
}
void cadr_init(void)
{
- dlt_register(dl_table, cadr_register, cadr_set_entries);
+ autoload_reg(cadr_register, cadr_set_entries);
}
diff --git a/cadr.h b/cadr.h
index fb5d937c..9366db71 100644
--- a/cadr.h
+++ b/cadr.h
@@ -1,6 +1,6 @@
/* This file is generated by gencadr.txr */
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -8,23 +8,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
val caar(val);
diff --git a/checkman.txr b/checkman.txr
index dcbf99e7..a1d03689 100644
--- a/checkman.txr
+++ b/checkman.txr
@@ -5,7 +5,7 @@
@(define check-synb ())
.synb
@ (assert bad ln `bad .synb block`)
-@ (repeat :gap 0 :min 1)
+@ (repeat :gap 0 :mintimes 1)
.mets @(skip)
@ (maybe)
@ (repeat :gap 0 :mintimes 1)
@@ -25,47 +25,57 @@
@/..*/
@(end)
@;;
-@;; Check variable description headings
+@;; Check variable/operator/function/... description headings
+@;; introduced by .coNP
@;;
-@(define check-var ())
+@(define check-coNP ())
@ (cases)
@; exception
-.coNP @/Variables|Special variables/ @@, s-ifmt @(skip)
+.coNP @/Variables|Special Variables/ @@, s-ifmt @(skip)
@ (or)
@; exception
-.coNP @/Variables|Special variables/ @@, *0 @(skip)
+.coNP @/Variables|Special Variables/ @@, *0 @(skip)
@ (or)
-.coNP @/Variables|Special variables/@(assert bad ln `bad Variables heading`)@(rep :gap 0) @@, @{x /\S+/}@(last :mandatory) @@ @y and @@ @{z /\S+/}@(end)
+.coNP @/Variables|Special Variables/@(assert bad ln `bad Variables heading`)@(rep :gap 0) @@, @{x /\S+/}@(last :mandatory) @@ @y and @@ @{z /\S+/}@(end)
@ (assert bad ln `no .desc after variables heading`)
.desc
@ (or)
-.coNP @/Variable|Special variable/@(assert bad ln `bad Variable heading`) @{x /\S+/}
+.coNP @/Variable|Special Variable/@(assert bad ln `bad Variable heading`) @@ @{x /\S+/}
@ (assert bad ln `no .desc after variable heading`)
.desc
-@ (end)
-@(end)
-@;;
-@;; Check function/macro/operator headings
-@;;
-@(define check-func ())
-@ (cases)
-.coNP Operator/function @(skip)
-@ (assert bad ln `no .synb after Operator/function heading`)
+@ (or)
+@; exception
+.coNP @/Accessors/ @@, caar @(skip)
+@ (or)
+.coNP @{type /Operator|Macro/}/function @(skip)
+@ (assert bad ln `no .synb after @type/function heading`)
@ (check-synb)
@ (or)
-.coNP Operator @@ @op and macro @@ @mac
+.coNP Operator @@ @op and Macro @@ @mac
@ (assert bad ln `no .synb after Operator and macro heading`)
@ (check-synb)
@ (or)
-.coNP @{type /Function|Operator|Macro|Accessor|Method|Structure/}s@(assert bad ln `bad @{type}s heading`)@(rep :gap 0) @@, @{x /\S+/}@(last :mandatory) @@ @y and @@ @{z /\S+/}@(end)
+.coNP @{type /Function|Operator|Macro|Accessor|Method|Structure|Pattern Operator|(Operators|Macros)\/Function/}s@(assert bad ln `bad @{type}s heading`)@(rep :gap 0) @@, @{x /\S+/}@(last :mandatory) @@ @y and @@ @{z /\S+/}@(end)
@ (assert bad ln `no .synb after @{type}s heading`)
@ (check-synb)
@ (or)
-.coNP @{type /Function|Operator|Macro|Accessor|Method|Structure|Parameter list macro/}@(assert bad ln `bad @type heading`) @@ @{x /\S+/}@junk
+.coNP @{type /Function|Operator|Macro|Accessor|Method|Structure|Pattern (Operator|Macro)|Parameter List Macro|(Operator|Macro)\/Function/}@(assert bad ln `bad @type heading`) @@ @{x /\S+/}@junk
@ (assert bad ln `extra elements in singular @type heading`)
@ (bind junk "")
@ (assert bad ln `no .synb after @type heading`)
@ (check-synb)
+@ (or)
+.coNP @/Argument Generation|Passing Options|The Lisp @|Keyword Param|\
+ The @ |Keyword Para|Keywords in|Lisp Forms in|Mandatory @|\
+ Specifying Variables in|@ catch Clauses|\
+ Interaction Between|Vertical-Horizontal|Horizontal-Horizontal|\
+ Nested @|@ repeat an|Conventions Used|Struct Clause Macro|\
+ Treatment of|Examples of|FFI type|Differences Due to|\
+ Unbound Symbols in|Bound symbols in|File-Wide|\
+ Delimited Continuations|Symbol Macro/@nil
+@ (or)
+.coNP @junk
+@ (throw bad ln `unrecognized .coNP arguments: @junk`)
@ (end)
@(end)
@;;
@@ -82,6 +92,9 @@
.@{type /codn|cod2|metn/} @(assert bad ln `.@type needs two arguments`)@(cases)"@x"@(or)@{x /\S+/}@(end) @{y /\S+/}@(eol)
@ (assert bad ln `.codn second argument doesn't begin with punctuation`)
@ (require (or (not (memqual type '("codn" "metn")))
+ (equal "s" y)
+ (and (starts-with "s" y)
+ (chr-ispunct [y 1]))
(chr-ispunct [y 0])))
@ (end)
@(end)
@@ -122,6 +135,28 @@
@ (throw bad ln `dangling @mac`)
@(end)
@;;
+@;; Check for .meti not wrapped in .mono/.onom macros.
+@;;
+@(define check-meti ())
+.meti @(skip)
+@ (throw bad ln ".meti not in .mono")
+@(end)
+@;;
+@;; Check for .IP, coIP or .meIP followed by blank line
+@;;
+@(define check-ip ())
+.@{ip /IP|coIP|meIP/}@(skip)
+
+@ (throw bad ln `.@ip followed by blank line`)
+@(end)
+@;;
+@;; Check for .meIP, .meti or .mets containing spurious spaces.
+@;;
+@(define check-spaces ())
+.@{mac /meIP|meti|mets/}@/(( \\)+ )?/@(skip) @(skip)
+@ (throw bad ln `.@mac contains spurious spaces`)
+@(end)
+@;;
@;; Main
@;;
@(bind errors 0)
@@ -129,9 +164,7 @@
@ (line ln)
@ (try)
@ (cases)
-@ (check-var)
-@ (or)
-@ (check-func)
+@ (check-coNP)
@ (or)
@ (check-code)
@ (or)
@@ -142,10 +175,24 @@
@ (check-synb)
@ (or)
@ (check-spurious)
+@ (or)
+@ (check-meti)
+@ (or)
+@ (check-ip)
@ (end)
@ (catch bad (line msg))
@ (do (inc errors)
(put-line `@file:@line:@msg`))
@ (end)
@(end)
+@(next file)
+@(repeat)
+@ (line ln)
+@ (try)
+@ (check-spaces)
+@ (catch bad (line msg))
+@ (do (inc errors)
+ (put-line `@file:@line:@msg`))
+@ (end)
+@(end)
@(do (exit (zerop errors)))
diff --git a/chksum.c b/chksum.c
index b4404c31..91b282e3 100644
--- a/chksum.c
+++ b/chksum.c
@@ -1,4 +1,6 @@
-/* Copyright 2019-2020
+/* This file is partially generated by genchksum.txr; see comment below. */
+
+/* Copyright 2019-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,27 +8,29 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
- * 2. Redistributions in binary form must reproduce the above copyright notice, * this list of conditions and the following disclaimer in the documentation * and/or other materials provided with the distribution.
+ * 2. Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stddef.h>
#include <wchar.h>
#include <limits.h>
-#include <float.h>
#include <string.h>
#include <stdlib.h>
#include <stdarg.h>
@@ -34,48 +38,86 @@
#include <stdio.h>
#include "config.h"
#include "lib.h"
-#include "gc.h"
#include "itypes.h"
#include "signal.h"
#include "unwind.h"
#include "eval.h"
#include "stream.h"
-#include "arith.h"
#include "utf8.h"
#include "buf.h"
+#include "chksums/sha1.h"
#include "chksums/sha256.h"
#include "chksums/crc32.h"
#include "chksums/md5.h"
#include "chksum.h"
-static val sha256_ctx_s, md5_ctx_s;
+/* This file is not entirely generated. Parts of it are maintained by
+ * hand. The genchksum.txr program will extract the hand-maintained
+ * parts, and merge it with the generated parts.
+ *
+ * After working on this file, save your work (perhaps into a commit).
+ * Then run txr ./genchksum.txr and ensure that the updated
+ * chksum.c file is identical to your saved copy.
+ *
+ * The generated parts are these:
+ *
+ * - everything starting with the declaration "static val sha1_ctx_s ..."
+ * up to just before the crc32 section: the crc32_stream function.
+ *
+ * - a portion of the chksum_init function, up to the line
+ * which registers the crc32-stream function.
+ *
+ * Thus, material outside of these sections is editable; but edits
+ * must be validated to make sure they don't break the generation
+ * program.
+ */
+
+static val chksum_ensure_buf(val self, val buf_in,
+ val len, unsigned char **phash,
+ val hash_name)
+{
+ if (null_or_missing_p(buf_in)) {
+ *phash = chk_malloc(c_unum(len, self));
+ return make_owned_buf(len, *phash);
+ } else {
+ *phash = buf_get(buf_in, self);
+ if (lt(length_buf(buf_in), len))
+ uw_throwf(error_s, lit("~s: buffer ~s too small for ~a hash"),
+ self, buf_in, hash_name, nao);
+ return buf_in;
+ }
+}
+
+static val sha1_ctx_s, sha256_ctx_s, md5_ctx_s;
+static struct cobj_class *sha1_ctx_cls, *sha256_ctx_cls, *md5_ctx_cls;
-static void sha256_stream_impl(val stream, val nbytes, unsigned char *hash)
+static void sha1_stream_impl(val stream, val nbytes,
+ unsigned char *hash, val self)
{
- SHA256_t s256;
+ SHA1_t ctx;
val buf = iobuf_get();
val bfsz = length_buf(buf);
- SHA256_init(&s256);
+ SHA1_init(&ctx);
if (null_or_missing_p(nbytes)) {
for (;;) {
val read = fill_buf(buf, zero, stream);
- cnum rd = c_num(read);
+ cnum rd = c_num(read, self);
if (!rd)
break;
- SHA256_update(&s256, buf->b.data, rd);
+ SHA1_update(&ctx, buf->b.data, rd);
}
} else {
while (ge(nbytes, bfsz)) {
val read = fill_buf(buf, zero, stream);
- cnum rd = c_num(read);
+ cnum rd = c_num(read, self);
if (zerop(read))
break;
- SHA256_update(&s256, buf->b.data, rd);
+ SHA1_update(&ctx, buf->b.data, rd);
nbytes = minus(nbytes, read);
}
@@ -83,191 +125,184 @@ static void sha256_stream_impl(val stream, val nbytes, unsigned char *hash)
{
val read = fill_buf(buf, zero, stream);
- cnum rd = c_num(read);
+ cnum rd = c_num(read, self);
if (rd)
- SHA256_update(&s256, buf->b.data, rd);
+ SHA1_update(&ctx, buf->b.data, rd);
}
}
- SHA256_final(&s256, hash);
+ SHA1_final(&ctx, hash);
iobuf_put(buf);
}
-static val chksum_ensure_buf(val self, val buf_in,
- val len, unsigned char **phash,
- val hash_name)
+val sha1_stream(val stream, val nbytes, val buf_in)
{
- if (null_or_missing_p(buf_in)) {
- *phash = chk_malloc(c_unum(len));
- return make_borrowed_buf(len, *phash);
- } else {
- *phash = buf_get(buf_in, self);
- if (lt(length_buf(buf_in), len))
- uw_throwf(error_s, lit("~s: buffer ~s too small for ~a hash"),
- self, buf_in, hash_name, nao);
- return buf_in;
- }
-}
-
-val sha256_stream(val stream, val nbytes, val buf_in)
-{
- val self = lit("sha256-stream");
+ val self = lit("sha1-stream");
unsigned char *hash;
- val buf = chksum_ensure_buf(self, buf_in, num_fast(SHA256_DIGEST_LENGTH),
- &hash, lit("SHA-256"));
- sha256_stream_impl(stream, nbytes, hash);
+ val buf = chksum_ensure_buf(self, buf_in,
+ num_fast(SHA1_DIGEST_LENGTH),
+ &hash, lit("SHA-1"));
+ sha1_stream_impl(stream, nbytes, hash, self);
return buf;
}
-static void sha256_szmax_upd(SHA256_t *ps256, mem_t *data, ucnum len)
+static void sha1_szmax_upd(SHA1_t *pctx, mem_t *data, ucnum len)
{
const size_t szmax = convert(size_t, -1) / 4 + 1;
while (len >= szmax) {
- SHA256_update(ps256, data, szmax);
+ SHA1_update(pctx, data, szmax);
data += szmax;
len -= szmax;
}
if (len > 0)
- SHA256_update(ps256, data, len);
+ SHA1_update(pctx, data, len);
}
-static void sha256_buf(val buf, unsigned char *hash)
+static void sha1_buf(val buf, unsigned char *hash, val self)
{
- SHA256_t s256;
- SHA256_init(&s256);
- sha256_szmax_upd(&s256, buf->b.data, c_unum(buf->b.len));
- SHA256_final(&s256, hash);
+ SHA1_t ctx;
+ SHA1_init(&ctx);
+ sha1_szmax_upd(&ctx, buf->b.data, c_unum(buf->b.len, self));
+ SHA1_final(&ctx, hash);
}
-static void sha256_str(val str, unsigned char *hash)
+static void sha1_str(val str, unsigned char *hash, val self)
{
- char *s = utf8_dup_to(c_str(str));
- SHA256_t s256;
- SHA256_init(&s256);
- SHA256_update(&s256, coerce(const unsigned char *, s), strlen(s));
+ char *s = utf8_dup_to(c_str(str, self));
+ SHA1_t ctx;
+ SHA1_init(&ctx);
+ SHA1_update(&ctx, coerce(const unsigned char *, s), strlen(s));
free(s);
- SHA256_final(&s256, hash);
+ SHA1_final(&ctx, hash);
}
-val sha256(val obj, val buf_in)
+val sha1(val obj, val buf_in)
{
- val self = lit("sha256");
+ val self = lit("sha1");
unsigned char *hash;
- val buf = chksum_ensure_buf(self, buf_in, num_fast(SHA256_DIGEST_LENGTH),
- &hash, lit("SHA-256"));
-
+ val buf = chksum_ensure_buf(self, buf_in,
+ num_fast(SHA1_DIGEST_LENGTH),
+ &hash, lit("SHA-1"));
switch (type(obj)) {
case STR:
case LSTR:
case LIT:
- sha256_str(obj, hash);
+ sha1_str(obj, hash, self);
return buf;
case BUF:
- sha256_buf(obj, hash);
+ sha1_buf(obj, hash, self);
return buf;
default:
- uw_throwf(error_s, lit("~a: cannot hash ~s, only buffer and strings"),
+ uw_throwf(error_s,
+ lit("~a: cannot hash ~s, "
+ "only buffer and strings"),
self, obj, nao);
}
}
-static struct cobj_ops sha256_ops = cobj_ops_init(cobj_equal_handle_op,
- cobj_print_op,
- cobj_destroy_free_op,
- cobj_mark_op,
- cobj_handle_hash_op);
-val sha256_begin(void)
+static struct cobj_ops sha1_ops = cobj_ops_init(cobj_equal_handle_op,
+ cobj_print_op,
+ cobj_destroy_free_op,
+ cobj_mark_op,
+ cobj_handle_hash_op);
+
+val sha1_begin(void)
{
- SHA256_t *ps256 = coerce(SHA256_t *, chk_malloc(sizeof *ps256));
- SHA256_init(ps256);
- return cobj(coerce(mem_t *, ps256), sha256_ctx_s, &sha256_ops);
+ SHA1_t *pctx = coerce(SHA1_t *, chk_malloc(sizeof *pctx));
+ SHA1_init(pctx);
+ return cobj(coerce(mem_t *, pctx), sha1_ctx_cls, &sha1_ops);
}
-static int sha256_utf8_byte_callback(int b, mem_t *ctx)
+static int sha1_utf8_byte_callback(int b, mem_t *ctx)
{
- SHA256_t *ps256 = coerce(SHA256_t *, ctx);
+ SHA1_t *pctx = coerce(SHA1_t *, ctx);
unsigned char uc = b;
- SHA256_update(ps256, &uc, 1);
+ SHA1_update(pctx, &uc, 1);
return 1;
}
-val sha256_hash(val ctx, val obj)
+val sha1_hash(val ctx, val obj)
{
- val self = lit("sha256-hash");
- SHA256_t *ps256 = coerce(SHA256_t *, cobj_handle(self, ctx, sha256_ctx_s));
-
+ val self = lit("sha1-hash");
+ SHA1_t *pctx = coerce(SHA1_t *,
+ cobj_handle(self, ctx, sha1_ctx_cls));
switch (type(obj)) {
case STR:
case LSTR:
case LIT:
{
- char *str = utf8_dup_to(c_str(obj));
- SHA256_update(ps256, coerce(const unsigned char *, str), strlen(str));
+ char *str = utf8_dup_to(c_str(obj, self));
+ SHA1_update(pctx, coerce(const unsigned char *, str), strlen(str));
free(str);
}
break;
case BUF:
- sha256_szmax_upd(ps256, obj->b.data, c_unum(obj->b.len));
+ sha1_szmax_upd(pctx, obj->b.data, c_unum(obj->b.len, self));
break;
case CHR:
- utf8_encode(c_chr(obj), sha256_utf8_byte_callback, coerce(mem_t *, ps256));
+ utf8_encode(c_ch(obj), sha1_utf8_byte_callback,
+ coerce(mem_t *, pctx));
break;
case NUM:
{
- cnum n = c_num(obj);
+ cnum n = c_num(obj, self);
unsigned char uc = n;
if (n < 0 || n > 255)
- uw_throwf(error_s, lit("~a: byte value ~s out of range"),
+ uw_throwf(error_s,
+ lit("~a: byte value ~s out of range"),
self, obj, nao);
- SHA256_update(ps256, &uc, 1);
+ SHA1_update(pctx, &uc, 1);
}
break;
default:
- uw_throwf(error_s, lit("~a: cannot hash ~s, only buffer and strings"),
+ uw_throwf(error_s, lit("~a: cannot hash ~s, "
+ "only buffer and strings"),
self, obj, nao);
}
return obj;
}
-val sha256_end(val ctx, val buf_in)
+val sha1_end(val ctx, val buf_in)
{
- val self = lit("sha256-end");
+ val self = lit("sha1-end");
unsigned char *hash;
- SHA256_t *ps256 = coerce(SHA256_t *, cobj_handle(self, ctx, sha256_ctx_s));
- val buf = chksum_ensure_buf(self, buf_in, num_fast(SHA256_DIGEST_LENGTH),
- &hash, lit("SHA-256"));
-
- SHA256_final(ps256, hash);
- SHA256_init(ps256);
+ SHA1_t *pctx = coerce(SHA1_t *,
+ cobj_handle(self, ctx, sha1_ctx_cls));
+ val buf = chksum_ensure_buf(self, buf_in, num_fast(SHA1_DIGEST_LENGTH),
+ &hash, lit("SHA-1"));
+ SHA1_final(pctx, hash);
+ SHA1_init(pctx);
return buf;
}
-val crc32_stream(val stream, val nbytes)
+static void sha256_stream_impl(val stream, val nbytes,
+ unsigned char *hash, val self)
{
- u32_t crc = 0;
+ SHA256_t ctx;
val buf = iobuf_get();
val bfsz = length_buf(buf);
+ SHA256_init(&ctx);
if (null_or_missing_p(nbytes)) {
for (;;) {
val read = fill_buf(buf, zero, stream);
- cnum rd = c_num(read);
+ cnum rd = c_num(read, self);
if (!rd)
break;
- crc = crc32_cont(buf->b.data, rd, crc);
+ SHA256_update(&ctx, buf->b.data, rd);
}
} else {
while (ge(nbytes, bfsz)) {
val read = fill_buf(buf, zero, stream);
- cnum rd = c_num(read);
+ cnum rd = c_num(read, self);
if (zerop(read))
break;
- crc = crc32_cont(buf->b.data, rd, crc);
+ SHA256_update(&ctx, buf->b.data, rd);
nbytes = minus(nbytes, read);
}
@@ -275,85 +310,184 @@ val crc32_stream(val stream, val nbytes)
{
val read = fill_buf(buf, zero, stream);
- cnum rd = c_num(read);
+ cnum rd = c_num(read, self);
if (rd)
- crc = crc32_cont(buf->b.data, rd, crc);
+ SHA256_update(&ctx, buf->b.data, rd);
}
}
+ SHA256_final(&ctx, hash);
iobuf_put(buf);
- return unum(crc);
}
-static val crc32_buf(val buf, val self)
+val sha256_stream(val stream, val nbytes, val buf_in)
{
- ucnum len = c_unum(buf->b.len);
- mem_t *data = buf->b.data;
- const size_t szmax = convert(size_t, -1) / 4 + 1;
- u32_t crc = 0;
+ val self = lit("sha256-stream");
+ unsigned char *hash;
+ val buf = chksum_ensure_buf(self, buf_in,
+ num_fast(SHA256_DIGEST_LENGTH),
+ &hash, lit("SHA-256"));
+ sha256_stream_impl(stream, nbytes, hash, self);
+ return buf;
+}
+static void sha256_szmax_upd(SHA256_t *pctx, mem_t *data, ucnum len)
+{
+ const size_t szmax = convert(size_t, -1) / 4 + 1;
while (len >= szmax) {
- crc = crc32_cont(data, szmax, crc);
+ SHA256_update(pctx, data, szmax);
data += szmax;
len -= szmax;
}
-
if (len > 0)
- crc = crc32_cont(data, len, crc);
-
- return unum(crc);
+ SHA256_update(pctx, data, len);
}
-static val crc32_str(val str, val self)
+static void sha256_buf(val buf, unsigned char *hash, val self)
{
- val s = make_byte_input_stream(str);
- return crc32_stream(s, nil);
+ SHA256_t ctx;
+ SHA256_init(&ctx);
+ sha256_szmax_upd(&ctx, buf->b.data, c_unum(buf->b.len, self));
+ SHA256_final(&ctx, hash);
}
+static void sha256_str(val str, unsigned char *hash, val self)
+{
+ char *s = utf8_dup_to(c_str(str, self));
+ SHA256_t ctx;
+ SHA256_init(&ctx);
+ SHA256_update(&ctx, coerce(const unsigned char *, s), strlen(s));
+ free(s);
+ SHA256_final(&ctx, hash);
+}
-val crc32(val obj)
+val sha256(val obj, val buf_in)
{
val self = lit("sha256");
+ unsigned char *hash;
+ val buf = chksum_ensure_buf(self, buf_in,
+ num_fast(SHA256_DIGEST_LENGTH),
+ &hash, lit("SHA-256"));
+ switch (type(obj)) {
+ case STR:
+ case LSTR:
+ case LIT:
+ sha256_str(obj, hash, self);
+ return buf;
+ case BUF:
+ sha256_buf(obj, hash, self);
+ return buf;
+ default:
+ uw_throwf(error_s,
+ lit("~a: cannot hash ~s, "
+ "only buffer and strings"),
+ self, obj, nao);
+ }
+}
+static struct cobj_ops sha256_ops = cobj_ops_init(cobj_equal_handle_op,
+ cobj_print_op,
+ cobj_destroy_free_op,
+ cobj_mark_op,
+ cobj_handle_hash_op);
+
+val sha256_begin(void)
+{
+ SHA256_t *pctx = coerce(SHA256_t *, chk_malloc(sizeof *pctx));
+ SHA256_init(pctx);
+ return cobj(coerce(mem_t *, pctx), sha256_ctx_cls, &sha256_ops);
+}
+
+static int sha256_utf8_byte_callback(int b, mem_t *ctx)
+{
+ SHA256_t *pctx = coerce(SHA256_t *, ctx);
+ unsigned char uc = b;
+ SHA256_update(pctx, &uc, 1);
+ return 1;
+}
+
+val sha256_hash(val ctx, val obj)
+{
+ val self = lit("sha256-hash");
+ SHA256_t *pctx = coerce(SHA256_t *,
+ cobj_handle(self, ctx, sha256_ctx_cls));
switch (type(obj)) {
case STR:
case LSTR:
case LIT:
- return crc32_str(obj, self);
+ {
+ char *str = utf8_dup_to(c_str(obj, self));
+ SHA256_update(pctx, coerce(const unsigned char *, str), strlen(str));
+ free(str);
+ }
+ break;
case BUF:
- return crc32_buf(obj, self);
+ sha256_szmax_upd(pctx, obj->b.data, c_unum(obj->b.len, self));
+ break;
+ case CHR:
+ utf8_encode(c_ch(obj), sha256_utf8_byte_callback,
+ coerce(mem_t *, pctx));
+ break;
+ case NUM:
+ {
+ cnum n = c_num(obj, self);
+ unsigned char uc = n;
+ if (n < 0 || n > 255)
+ uw_throwf(error_s,
+ lit("~a: byte value ~s out of range"),
+ self, obj, nao);
+ SHA256_update(pctx, &uc, 1);
+ }
+ break;
default:
- uw_throwf(error_s, lit("~a: cannot hash ~s, only buffer and strings"),
+ uw_throwf(error_s, lit("~a: cannot hash ~s, "
+ "only buffer and strings"),
self, obj, nao);
}
+
+ return obj;
+}
+
+val sha256_end(val ctx, val buf_in)
+{
+ val self = lit("sha256-end");
+ unsigned char *hash;
+ SHA256_t *pctx = coerce(SHA256_t *,
+ cobj_handle(self, ctx, sha256_ctx_cls));
+ val buf = chksum_ensure_buf(self, buf_in, num_fast(SHA256_DIGEST_LENGTH),
+ &hash, lit("SHA-256"));
+ SHA256_final(pctx, hash);
+ SHA256_init(pctx);
+ return buf;
}
-static void md5_stream_impl(val stream, val nbytes, unsigned char *hash)
+static void md5_stream_impl(val stream, val nbytes,
+ unsigned char *hash, val self)
{
- MD5_t md5;
+ MD5_t ctx;
val buf = iobuf_get();
val bfsz = length_buf(buf);
- MD5_init(&md5);
+ MD5_init(&ctx);
if (null_or_missing_p(nbytes)) {
for (;;) {
val read = fill_buf(buf, zero, stream);
- cnum rd = c_num(read);
+ cnum rd = c_num(read, self);
if (!rd)
break;
- MD5_update(&md5, buf->b.data, rd);
+ MD5_update(&ctx, buf->b.data, rd);
}
} else {
while (ge(nbytes, bfsz)) {
val read = fill_buf(buf, zero, stream);
- cnum rd = c_num(read);
+ cnum rd = c_num(read, self);
if (zerop(read))
break;
- MD5_update(&md5, buf->b.data, rd);
+ MD5_update(&ctx, buf->b.data, rd);
nbytes = minus(nbytes, read);
}
@@ -361,13 +495,13 @@ static void md5_stream_impl(val stream, val nbytes, unsigned char *hash)
{
val read = fill_buf(buf, zero, stream);
- cnum rd = c_num(read);
+ cnum rd = c_num(read, self);
if (rd)
- MD5_update(&md5, buf->b.data, rd);
+ MD5_update(&ctx, buf->b.data, rd);
}
}
- MD5_final(&md5, hash);
+ MD5_final(&ctx, hash);
iobuf_put(buf);
}
@@ -375,117 +509,124 @@ val md5_stream(val stream, val nbytes, val buf_in)
{
val self = lit("md5-stream");
unsigned char *hash;
- val buf = chksum_ensure_buf(self, buf_in, num_fast(MD5_DIGEST_LENGTH),
+ val buf = chksum_ensure_buf(self, buf_in,
+ num_fast(MD5_DIGEST_LENGTH),
&hash, lit("MD5"));
- md5_stream_impl(stream, nbytes, hash);
+ md5_stream_impl(stream, nbytes, hash, self);
return buf;
}
-static void md5_szmax_upd(MD5_t *pmd5, mem_t *data, ucnum len)
+static void md5_szmax_upd(MD5_t *pctx, mem_t *data, ucnum len)
{
const size_t szmax = convert(size_t, -1) / 4 + 1;
while (len >= szmax) {
- MD5_update(pmd5, data, szmax);
+ MD5_update(pctx, data, szmax);
data += szmax;
len -= szmax;
}
if (len > 0)
- MD5_update(pmd5, data, len);
+ MD5_update(pctx, data, len);
}
-static void md5_buf(val buf, unsigned char *hash)
+static void md5_buf(val buf, unsigned char *hash, val self)
{
- MD5_t md5;
- MD5_init(&md5);
- md5_szmax_upd(&md5, buf->b.data, c_unum(buf->b.len));
- MD5_final(&md5, hash);
+ MD5_t ctx;
+ MD5_init(&ctx);
+ md5_szmax_upd(&ctx, buf->b.data, c_unum(buf->b.len, self));
+ MD5_final(&ctx, hash);
}
-static void md5_str(val str, unsigned char *hash)
+static void md5_str(val str, unsigned char *hash, val self)
{
- char *s = utf8_dup_to(c_str(str));
- MD5_t md5;
- MD5_init(&md5);
- MD5_update(&md5, coerce(const unsigned char *, s), strlen(s));
+ char *s = utf8_dup_to(c_str(str, self));
+ MD5_t ctx;
+ MD5_init(&ctx);
+ MD5_update(&ctx, coerce(const unsigned char *, s), strlen(s));
free(s);
- MD5_final(&md5, hash);
+ MD5_final(&ctx, hash);
}
val md5(val obj, val buf_in)
{
val self = lit("md5");
unsigned char *hash;
- val buf = chksum_ensure_buf(self, buf_in, num_fast(MD5_DIGEST_LENGTH),
+ val buf = chksum_ensure_buf(self, buf_in,
+ num_fast(MD5_DIGEST_LENGTH),
&hash, lit("MD5"));
-
switch (type(obj)) {
case STR:
case LSTR:
case LIT:
- md5_str(obj, hash);
+ md5_str(obj, hash, self);
return buf;
case BUF:
- md5_buf(obj, hash);
+ md5_buf(obj, hash, self);
return buf;
default:
- uw_throwf(error_s, lit("~a: cannot hash ~s, only buffer and strings"),
+ uw_throwf(error_s,
+ lit("~a: cannot hash ~s, "
+ "only buffer and strings"),
self, obj, nao);
}
}
static struct cobj_ops md5_ops = cobj_ops_init(cobj_equal_handle_op,
- cobj_print_op,
- cobj_destroy_free_op,
- cobj_mark_op,
- cobj_handle_hash_op);
+ cobj_print_op,
+ cobj_destroy_free_op,
+ cobj_mark_op,
+ cobj_handle_hash_op);
+
val md5_begin(void)
{
- MD5_t *pmd5 = coerce(MD5_t *, chk_malloc(sizeof *pmd5));
- MD5_init(pmd5);
- return cobj(coerce(mem_t *, pmd5), md5_ctx_s, &md5_ops);
+ MD5_t *pctx = coerce(MD5_t *, chk_malloc(sizeof *pctx));
+ MD5_init(pctx);
+ return cobj(coerce(mem_t *, pctx), md5_ctx_cls, &md5_ops);
}
static int md5_utf8_byte_callback(int b, mem_t *ctx)
{
- MD5_t *ps256 = coerce(MD5_t *, ctx);
+ MD5_t *pctx = coerce(MD5_t *, ctx);
unsigned char uc = b;
- MD5_update(ps256, &uc, 1);
+ MD5_update(pctx, &uc, 1);
return 1;
}
val md5_hash(val ctx, val obj)
{
val self = lit("md5-hash");
- MD5_t *pmd5 = coerce(MD5_t *, cobj_handle(self, ctx, md5_ctx_s));
-
+ MD5_t *pctx = coerce(MD5_t *,
+ cobj_handle(self, ctx, md5_ctx_cls));
switch (type(obj)) {
case STR:
case LSTR:
case LIT:
{
- char *str = utf8_dup_to(c_str(obj));
- MD5_update(pmd5, coerce(const unsigned char *, str), strlen(str));
+ char *str = utf8_dup_to(c_str(obj, self));
+ MD5_update(pctx, coerce(const unsigned char *, str), strlen(str));
free(str);
}
break;
case BUF:
- md5_szmax_upd(pmd5, obj->b.data, c_unum(obj->b.len));
+ md5_szmax_upd(pctx, obj->b.data, c_unum(obj->b.len, self));
break;
case CHR:
- utf8_encode(c_chr(obj), md5_utf8_byte_callback, coerce(mem_t *, pmd5));
+ utf8_encode(c_ch(obj), md5_utf8_byte_callback,
+ coerce(mem_t *, pctx));
break;
case NUM:
{
- cnum n = c_num(obj);
+ cnum n = c_num(obj, self);
unsigned char uc = n;
if (n < 0 || n > 255)
- uw_throwf(error_s, lit("~a: byte value ~s out of range"),
+ uw_throwf(error_s,
+ lit("~a: byte value ~s out of range"),
self, obj, nao);
- MD5_update(pmd5, &uc, 1);
+ MD5_update(pctx, &uc, 1);
}
break;
default:
- uw_throwf(error_s, lit("~a: cannot hash ~s, only buffer and strings"),
+ uw_throwf(error_s, lit("~a: cannot hash ~s, "
+ "only buffer and strings"),
self, obj, nao);
}
@@ -496,29 +637,124 @@ val md5_end(val ctx, val buf_in)
{
val self = lit("md5-end");
unsigned char *hash;
- MD5_t *pmd5 = coerce(MD5_t *, cobj_handle(self, ctx, md5_ctx_s));
+ MD5_t *pctx = coerce(MD5_t *,
+ cobj_handle(self, ctx, md5_ctx_cls));
val buf = chksum_ensure_buf(self, buf_in, num_fast(MD5_DIGEST_LENGTH),
- &hash, lit("SHA-256"));
-
- MD5_final(pmd5, hash);
- MD5_init(pmd5);
+ &hash, lit("MD5"));
+ MD5_final(pctx, hash);
+ MD5_init(pctx);
return buf;
}
+val crc32_stream(val stream, val nbytes, val init)
+{
+ val self = lit("crc32-stream");
+ val buf = iobuf_get();
+ val bfsz = length_buf(buf);
+ u32_t crc = if3(missingp(init), 0, c_u32(init, self));
+
+ if (null_or_missing_p(nbytes)) {
+ for (;;) {
+ val read = fill_buf(buf, zero, stream);
+ cnum rd = c_num(read, self);
+
+ if (!rd)
+ break;
+
+ crc = crc32_cont(buf->b.data, rd, crc);
+ }
+ } else {
+ while (ge(nbytes, bfsz)) {
+ val read = fill_buf(buf, zero, stream);
+ cnum rd = c_num(read, self);
+
+ if (zerop(read))
+ break;
+
+ crc = crc32_cont(buf->b.data, rd, crc);
+ nbytes = minus(nbytes, read);
+ }
+
+ buf_set_length(buf, nbytes, nil);
+
+ {
+ val read = fill_buf(buf, zero, stream);
+ cnum rd = c_num(read, self);
+ if (rd)
+ crc = crc32_cont(buf->b.data, rd, crc);
+ }
+ }
+
+ iobuf_put(buf);
+ return unum(crc);
+}
+
+static val crc32_buf(val buf, val init, val self)
+{
+ ucnum len = c_unum(buf->b.len, self);
+ mem_t *data = buf->b.data;
+ const size_t szmax = convert(size_t, -1) / 4 + 1;
+ u32_t crc = if3(missingp(init), 0, c_u32(init, self));
+
+ while (len >= szmax) {
+ crc = crc32_cont(data, szmax, crc);
+ data += szmax;
+ len -= szmax;
+ }
+
+ if (len > 0)
+ crc = crc32_cont(data, len, crc);
+
+ return unum(crc);
+}
+
+static val crc32_str(val str, val init)
+{
+ val s = make_byte_input_stream(str);
+ return crc32_stream(s, nil, init);
+}
+
+
+static val crc32(val obj, val init)
+{
+ val self = lit("crc32");
+
+ switch (type(obj)) {
+ case STR:
+ case LSTR:
+ case LIT:
+ return crc32_str(obj, init);
+ case BUF:
+ return crc32_buf(obj, init, self);
+ default:
+ uw_throwf(error_s, lit("~a: cannot hash ~s, only buffer and strings"),
+ self, obj, nao);
+ }
+}
+
void chksum_init(void)
{
+ sha1_ctx_s = intern(lit("sha1-ctx"), user_package);
sha256_ctx_s = intern(lit("sha256-ctx"), user_package);
md5_ctx_s = intern(lit("md5-ctx"), user_package);
+ sha1_ctx_cls = cobj_register(sha1_ctx_s);
+ sha256_ctx_cls = cobj_register(sha256_ctx_s);
+ md5_ctx_cls = cobj_register(md5_ctx_s);
+ reg_fun(intern(lit("sha1-stream"), user_package), func_n3o(sha1_stream, 1));
+ reg_fun(intern(lit("sha1"), user_package), func_n2o(sha1, 1));
+ reg_fun(intern(lit("sha1-begin"), user_package), func_n0(sha1_begin));
+ reg_fun(intern(lit("sha1-hash"), user_package), func_n2(sha1_hash));
+ reg_fun(intern(lit("sha1-end"), user_package), func_n2o(sha1_end, 1));
reg_fun(intern(lit("sha256-stream"), user_package), func_n3o(sha256_stream, 1));
reg_fun(intern(lit("sha256"), user_package), func_n2o(sha256, 1));
reg_fun(intern(lit("sha256-begin"), user_package), func_n0(sha256_begin));
reg_fun(intern(lit("sha256-hash"), user_package), func_n2(sha256_hash));
reg_fun(intern(lit("sha256-end"), user_package), func_n2o(sha256_end, 1));
- reg_fun(intern(lit("crc32-stream"), user_package), func_n2o(crc32_stream, 1));
- reg_fun(intern(lit("crc32"), user_package), func_n1(crc32));
reg_fun(intern(lit("md5-stream"), user_package), func_n3o(md5_stream, 1));
reg_fun(intern(lit("md5"), user_package), func_n2o(md5, 1));
reg_fun(intern(lit("md5-begin"), user_package), func_n0(md5_begin));
reg_fun(intern(lit("md5-hash"), user_package), func_n2(md5_hash));
reg_fun(intern(lit("md5-end"), user_package), func_n2o(md5_end, 1));
+ reg_fun(intern(lit("crc32-stream"), user_package), func_n3o(crc32_stream, 1));
+ reg_fun(intern(lit("crc32"), user_package), func_n2o(crc32, 1));
}
diff --git a/chksum.h b/chksum.h
index 6ec364e5..ac1364ba 100644
--- a/chksum.h
+++ b/chksum.h
@@ -1,4 +1,4 @@
-/* Copyright 2019-2020
+/* Copyright 2019-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,32 +6,37 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
+val sha1_stream(val stream, val nbytes, val buf);
+val sha1(val obj, val buf);
+val sha1_begin(void);
+val sha1_hash(val ctx, val obj);
+val sha1_end(val ctx, val buf);
val sha256_stream(val stream, val nbytes, val buf);
val sha256(val obj, val buf);
val sha256_begin(void);
val sha256_hash(val ctx, val obj);
val sha256_end(val ctx, val buf);
-val crc32_stream(val stream, val nbytes);
-val crc32(val obj);
+val crc32_stream(val stream, val nbytes, val init);
val md5_stream(val stream, val nbytes, val buf);
val md5(val obj, val buf_in);
val md5_begin(void);
diff --git a/chksums/crc32.c b/chksums/crc32.c
index a9aa4e81..3f0915e4 100644
--- a/chksums/crc32.c
+++ b/chksums/crc32.c
@@ -1,4 +1,4 @@
-/* Copyright 2019-2020
+/* Copyright 2019-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <string.h>
diff --git a/chksums/crc32.h b/chksums/crc32.h
index b764b10a..ac485bbc 100644
--- a/chksums/crc32.h
+++ b/chksums/crc32.h
@@ -1,4 +1,4 @@
-/* Copyright 2019-2020
+/* Copyright 2019-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
u32_t crc32_cont(const u8_t *p, size_t size, u32_t crc_prev);
diff --git a/chksums/md5.c b/chksums/md5.c
index b5fdb76d..11c6dd37 100644
--- a/chksums/md5.c
+++ b/chksums/md5.c
@@ -56,10 +56,10 @@ static void encode(unsigned char *output, u32_t *input, unsigned int len)
for (i = 0; i < len; i += 4) {
u32_t iw = input[i/4];
- output[i] = (iw >> 24) & 0xff;
- output[i+1] = (iw >> 16) & 0xff;
- output[i+2] = (iw >> 8) & 0xff;
- output[i+3] = iw & 0xff;
+ output[i] = iw & 0xff;
+ output[i+1] = (iw >> 8) & 0xff;
+ output[i+2] = (iw >> 16) & 0xff;
+ output[i+3] = (iw >> 24) & 0xff;
}
}
@@ -72,10 +72,10 @@ static void decode(u32_t *output, const unsigned char *input, unsigned int len)
unsigned int i;
for (i = 0; i < len; i += 4) {
- u32_t ow = convert(u32_t, input[i]) << 24;
- ow |= convert(u32_t, input[i+1]) << 16;
- ow |= convert(u32_t, input[i+2]) << 8;
- ow |= convert(u32_t, input[i+3]);
+ u32_t ow = convert(u32_t, input[i]);
+ ow |= convert(u32_t, input[i+1]) << 8;
+ ow |= convert(u32_t, input[i+2]) << 16;
+ ow |= convert(u32_t, input[i+3]) << 24;
output[i/4] = ow;
}
}
diff --git a/chksums/sha1.c b/chksums/sha1.c
new file mode 100644
index 00000000..7c432715
--- /dev/null
+++ b/chksums/sha1.c
@@ -0,0 +1,321 @@
+/* Copyright (C) 1995, 1996, 1997, and 1998 WIDE Project.
+ * All rights reserved.
+ *
+ * Implemented by Jun-ichiro itojun Itoh <itojun@itojun.org>
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ * 3. Neither the name of the project nor the names of its contributors
+ * may be used to endorse or promote products derived from this software
+ * without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE PROJECT AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE PROJECT OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ */
+
+#include <string.h>
+#include <limits.h>
+#include <wchar.h>
+#include "config.h"
+#include "lib.h"
+#include "itypes.h"
+#include "sha1.h"
+
+/* constant table */
+static u32_t _K[] = {0x5a827999, 0x6ed9eba1, 0x8f1bbcdc, 0xca62c1d6};
+
+#define K(t) _K[(t) / 20]
+
+#define F0(b, c, d) (((b) & (c)) | ((~(b)) & (d)))
+#define F1(b, c, d) (((b) ^ (c)) ^ (d))
+#define F2(b, c, d) (((b) & (c)) | ((b) & (d)) | ((c) & (d)))
+#define F3(b, c, d) (((b) ^ (c)) ^ (d))
+
+#define S(n, x) (((x) << (n)) | ((x) >> (32 - (n))))
+
+#define H(n) (ctxt->h.b32[(n)])
+#define COUNT (ctxt->count)
+#define BCOUNT (ctxt->c.b64[0] / 8)
+#define W(n) (ctxt->m.b32[(n)])
+
+#define PUTBYTE(x) \
+ do { \
+ ctxt->m.b8[(COUNT % 64)] = (x); \
+ COUNT++; \
+ COUNT %= 64; \
+ ctxt->c.b64[0] += 8; \
+ if (COUNT % 64 == 0) \
+ SHA1_step(ctxt); \
+ } while (0)
+
+#define PUTPAD(x) \
+ do { \
+ ctxt->m.b8[(COUNT % 64)] = (x); \
+ COUNT++; \
+ COUNT %= 64; \
+ if (COUNT % 64 == 0) \
+ SHA1_step(ctxt); \
+ } while (0)
+
+static void SHA1_step(SHA1_t *ctxt)
+{
+ u32_t a, b, c, d, e;
+ size_t t, s;
+ u32_t tmp;
+
+#if HAVE_LITTLE_ENDIAN
+ SHA1_t tctxt;
+
+ memmove(&tctxt.m.b8[0], &ctxt->m.b8[0], 64);
+ ctxt->m.b8[0] = tctxt.m.b8[3];
+ ctxt->m.b8[1] = tctxt.m.b8[2];
+ ctxt->m.b8[2] = tctxt.m.b8[1];
+ ctxt->m.b8[3] = tctxt.m.b8[0];
+
+ ctxt->m.b8[4] = tctxt.m.b8[7];
+ ctxt->m.b8[5] = tctxt.m.b8[6];
+ ctxt->m.b8[6] = tctxt.m.b8[5];
+ ctxt->m.b8[7] = tctxt.m.b8[4];
+ ctxt->m.b8[8] = tctxt.m.b8[11];
+ ctxt->m.b8[9] = tctxt.m.b8[10];
+ ctxt->m.b8[10] = tctxt.m.b8[9];
+ ctxt->m.b8[11] = tctxt.m.b8[8];
+ ctxt->m.b8[12] = tctxt.m.b8[15];
+ ctxt->m.b8[13] = tctxt.m.b8[14];
+ ctxt->m.b8[14] = tctxt.m.b8[13];
+ ctxt->m.b8[15] = tctxt.m.b8[12];
+ ctxt->m.b8[16] = tctxt.m.b8[19];
+ ctxt->m.b8[17] = tctxt.m.b8[18];
+ ctxt->m.b8[18] = tctxt.m.b8[17];
+ ctxt->m.b8[19] = tctxt.m.b8[16];
+ ctxt->m.b8[20] = tctxt.m.b8[23];
+ ctxt->m.b8[21] = tctxt.m.b8[22];
+ ctxt->m.b8[22] = tctxt.m.b8[21];
+ ctxt->m.b8[23] = tctxt.m.b8[20];
+ ctxt->m.b8[24] = tctxt.m.b8[27];
+ ctxt->m.b8[25] = tctxt.m.b8[26];
+ ctxt->m.b8[26] = tctxt.m.b8[25];
+ ctxt->m.b8[27] = tctxt.m.b8[24];
+ ctxt->m.b8[28] = tctxt.m.b8[31];
+ ctxt->m.b8[29] = tctxt.m.b8[30];
+ ctxt->m.b8[30] = tctxt.m.b8[29];
+ ctxt->m.b8[31] = tctxt.m.b8[28];
+ ctxt->m.b8[32] = tctxt.m.b8[35];
+ ctxt->m.b8[33] = tctxt.m.b8[34];
+ ctxt->m.b8[34] = tctxt.m.b8[33];
+ ctxt->m.b8[35] = tctxt.m.b8[32];
+ ctxt->m.b8[36] = tctxt.m.b8[39];
+ ctxt->m.b8[37] = tctxt.m.b8[38];
+ ctxt->m.b8[38] = tctxt.m.b8[37];
+ ctxt->m.b8[39] = tctxt.m.b8[36];
+ ctxt->m.b8[40] = tctxt.m.b8[43];
+ ctxt->m.b8[41] = tctxt.m.b8[42];
+ ctxt->m.b8[42] = tctxt.m.b8[41];
+ ctxt->m.b8[43] = tctxt.m.b8[40];
+ ctxt->m.b8[44] = tctxt.m.b8[47];
+ ctxt->m.b8[45] = tctxt.m.b8[46];
+ ctxt->m.b8[46] = tctxt.m.b8[45];
+ ctxt->m.b8[47] = tctxt.m.b8[44];
+ ctxt->m.b8[48] = tctxt.m.b8[51];
+ ctxt->m.b8[49] = tctxt.m.b8[50];
+ ctxt->m.b8[50] = tctxt.m.b8[49];
+ ctxt->m.b8[51] = tctxt.m.b8[48];
+ ctxt->m.b8[52] = tctxt.m.b8[55];
+ ctxt->m.b8[53] = tctxt.m.b8[54];
+ ctxt->m.b8[54] = tctxt.m.b8[53];
+ ctxt->m.b8[55] = tctxt.m.b8[52];
+ ctxt->m.b8[56] = tctxt.m.b8[59];
+ ctxt->m.b8[57] = tctxt.m.b8[58];
+ ctxt->m.b8[58] = tctxt.m.b8[57];
+ ctxt->m.b8[59] = tctxt.m.b8[56];
+ ctxt->m.b8[60] = tctxt.m.b8[63];
+ ctxt->m.b8[61] = tctxt.m.b8[62];
+ ctxt->m.b8[62] = tctxt.m.b8[61];
+ ctxt->m.b8[63] = tctxt.m.b8[60];
+#endif
+
+ a = H(0);
+ b = H(1);
+ c = H(2);
+ d = H(3);
+ e = H(4);
+
+ for (t = 0; t < 20; t++) {
+ s = t & 0x0f;
+ if (t >= 16)
+ W(s) = S(1, W((s + 13) & 0x0f) ^ W((s + 8) & 0x0f) ^ W((s + 2) & 0x0f) ^ W(s));
+ tmp = S(5, a) + F0(b, c, d) + e + W(s) + K(t);
+ e = d;
+ d = c;
+ c = S(30, b);
+ b = a;
+ a = tmp;
+ }
+
+ for (t = 20; t < 40; t++) {
+ s = t & 0x0f;
+ W(s) = S(1, W((s + 13) & 0x0f) ^ W((s + 8) & 0x0f) ^ W((s + 2) & 0x0f) ^ W(s));
+ tmp = S(5, a) + F1(b, c, d) + e + W(s) + K(t);
+ e = d;
+ d = c;
+ c = S(30, b);
+ b = a;
+ a = tmp;
+ }
+
+ for (t = 40; t < 60; t++) {
+ s = t & 0x0f;
+ W(s) = S(1, W((s + 13) & 0x0f) ^ W((s + 8) & 0x0f) ^ W((s + 2) & 0x0f) ^ W(s));
+ tmp = S(5, a) + F2(b, c, d) + e + W(s) + K(t);
+ e = d;
+ d = c;
+ c = S(30, b);
+ b = a;
+ a = tmp;
+ }
+
+ for (t = 60; t < 80; t++) {
+ s = t & 0x0f;
+ W(s) = S(1, W((s + 13) & 0x0f) ^ W((s + 8) & 0x0f) ^ W((s + 2) & 0x0f) ^ W(s));
+ tmp = S(5, a) + F3(b, c, d) + e + W(s) + K(t);
+ e = d;
+ d = c;
+ c = S(30, b);
+ b = a;
+ a = tmp;
+ }
+
+ H(0) = H(0) + a;
+ H(1) = H(1) + b;
+ H(2) = H(2) + c;
+ H(3) = H(3) + d;
+ H(4) = H(4) + e;
+
+ memset(&ctxt->m.b8[0], 0, 64);
+}
+
+void SHA1_init(SHA1_t *ctxt)
+{
+ memset(ctxt, 0, sizeof *ctxt);
+ H(0) = 0x67452301;
+ H(1) = 0xefcdab89;
+ H(2) = 0x98badcfe;
+ H(3) = 0x10325476;
+ H(4) = 0xc3d2e1f0;
+}
+
+static void SHA1_pad(SHA1_t *ctxt)
+{
+ size_t padlen;
+ size_t padstart;
+
+ PUTPAD(0x80);
+
+ padstart = COUNT % 64;
+ padlen = 64 - padstart;
+ if (padlen < 8)
+ {
+ memset(&ctxt->m.b8[padstart], 0, padlen);
+ COUNT += padlen;
+ COUNT %= 64;
+ SHA1_step(ctxt);
+ padstart = COUNT % 64; /* should be 0 */
+ padlen = 64 - padstart; /* should be 64 */
+ }
+ memset(&ctxt->m.b8[padstart], 0, padlen - 8);
+ COUNT += (padlen - 8);
+ COUNT %= 64;
+#if HAVE_LITTLE_ENDIAN
+ PUTPAD(ctxt->c.b8[7]);
+ PUTPAD(ctxt->c.b8[6]);
+ PUTPAD(ctxt->c.b8[5]);
+ PUTPAD(ctxt->c.b8[4]);
+ PUTPAD(ctxt->c.b8[3]);
+ PUTPAD(ctxt->c.b8[2]);
+ PUTPAD(ctxt->c.b8[1]);
+ PUTPAD(ctxt->c.b8[0]);
+#else
+ PUTPAD(ctxt->c.b8[0]);
+ PUTPAD(ctxt->c.b8[1]);
+ PUTPAD(ctxt->c.b8[2]);
+ PUTPAD(ctxt->c.b8[3]);
+ PUTPAD(ctxt->c.b8[4]);
+ PUTPAD(ctxt->c.b8[5]);
+ PUTPAD(ctxt->c.b8[6]);
+ PUTPAD(ctxt->c.b8[7]);
+#endif
+}
+
+void SHA1_update(SHA1_t *ctxt, const unsigned char *input0, size_t len)
+{
+ const unsigned char *input = input0;
+ size_t gaplen;
+ size_t gapstart;
+ size_t off;
+ size_t copysiz;
+
+ off = 0;
+
+ while (off < len)
+ {
+ gapstart = COUNT % 64;
+ gaplen = 64 - gapstart;
+
+ copysiz = (gaplen < len - off) ? gaplen : len - off;
+ memmove(&ctxt->m.b8[gapstart], &input[off], copysiz);
+ COUNT += copysiz;
+ COUNT %= 64;
+ ctxt->c.b64[0] += copysiz * 8;
+ if (COUNT % 64 == 0)
+ SHA1_step(ctxt);
+ off += copysiz;
+ }
+}
+
+void SHA1_final(SHA1_t *ctxt, unsigned char *digest0)
+{
+ unsigned char *digest;
+
+ digest = digest0;
+ SHA1_pad(ctxt);
+#if HAVE_LITTLE_ENDIAN
+ digest[0] = ctxt->h.b8[3];
+ digest[1] = ctxt->h.b8[2];
+ digest[2] = ctxt->h.b8[1];
+ digest[3] = ctxt->h.b8[0];
+ digest[4] = ctxt->h.b8[7];
+ digest[5] = ctxt->h.b8[6];
+ digest[6] = ctxt->h.b8[5];
+ digest[7] = ctxt->h.b8[4];
+ digest[8] = ctxt->h.b8[11];
+ digest[9] = ctxt->h.b8[10];
+ digest[10] = ctxt->h.b8[9];
+ digest[11] = ctxt->h.b8[8];
+ digest[12] = ctxt->h.b8[15];
+ digest[13] = ctxt->h.b8[14];
+ digest[14] = ctxt->h.b8[13];
+ digest[15] = ctxt->h.b8[12];
+ digest[16] = ctxt->h.b8[19];
+ digest[17] = ctxt->h.b8[18];
+ digest[18] = ctxt->h.b8[17];
+ digest[19] = ctxt->h.b8[16];
+#else
+ memmove(digest, &ctxt->h.b8[0], 20);
+#endif
+}
diff --git a/chksums/sha1.h b/chksums/sha1.h
new file mode 100644
index 00000000..7619536f
--- /dev/null
+++ b/chksums/sha1.h
@@ -0,0 +1,53 @@
+/* Copyright (C) 1995, 1996, 1997, and 1998 WIDE Project.
+ * All rights reserved.
+ *
+ * Implemented by Jun-ichiro itojun Itoh <itojun@itojun.org>
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ * 3. Neither the name of the project nor the names of its contributors
+ * may be used to endorse or promote products derived from this software
+ * without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE PROJECT AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE PROJECT OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ */
+
+#define SHA1_DIGEST_LENGTH 20
+#define SHA1_DIGEST_STRING_LENGTH (SHA1_DIGEST_LENGTH * 2 + 1)
+
+typedef struct SHA1 {
+ union {
+ unsigned char b8[20];
+ u32_t b32[5];
+ } h;
+ union {
+ unsigned char b8[8];
+ u64_t b64[1];
+ } c;
+ union {
+ unsigned char b8[64];
+ u32_t b32[16];
+ } m;
+ int count;
+} SHA1_t;
+
+extern void SHA1_init(SHA1_t *);
+extern void SHA1_update(SHA1_t *, const unsigned char *, size_t);
+extern void SHA1_final(SHA1_t *, unsigned char *);
diff --git a/combi.c b/combi.c
index 75a98956..b979d047 100644
--- a/combi.c
+++ b/combi.c
@@ -1,4 +1,4 @@
-/* Copyright 2010-2020
+/* Copyright 2010-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <wctype.h>
@@ -38,14 +39,15 @@
static val perm_while_fun(val state)
{
- val p = vecref(state, zero);
- cnum k = c_num(vecref(state, one));
+ val self = lit("perm");
+ val vec = vecref(state, zero);
+ cnum k = c_num(vecref(state, one), self);
val c = vecref(state, two);
- cnum n = c_num(length(p));
+ cnum n = c_num(length(vec), self);
cnum i, j;
for (i = k - 1, j = n - k + 1; i >= 0; i--, j++) {
- cnum ci = c_num(c->v.vec[i]) + 1;
+ cnum ci = c_num(c->v.vec[i], self) + 1;
if (ci >= j) {
if (i == 0)
@@ -78,26 +80,27 @@ static cnum perm_index(cnum n, val b)
static void perm_gen_fun_common(val state, val out,
void (*fill)(val out, cnum i, val v))
{
- val p = vecref(state, zero);
+ val self = lit("perm");
+ val vec = vecref(state, zero);
val kk = vecref(state, one);
val c = vecref(state, two);
- val nn = length(p);
+ val nn = length(vec);
val b = vector(nn, nil);
- cnum k = c_num(kk);
+ cnum k = c_num(kk, self);
cnum i;
for (i = 0; i < k; i++) {
- cnum ci = c_num(c->v.vec[i]);
+ cnum ci = c_num(c->v.vec[i], self);
cnum j = perm_index(ci, b);
- fill(out, i, p->v.vec[j]);
+ fill(out, i, vec->v.vec[j]);
b->v.vec[j] = t;
}
}
-static val perm_init_common(val p, val k_null)
+static val perm_init(val vec, val k_null, val seq)
{
uses_or2;
- val n = length(p);
+ val n = length(vec);
val k = or2(k_null, n);
if (!fixnump(n))
@@ -107,11 +110,12 @@ static val perm_init_common(val p, val k_null)
if (gt(k, n)) {
return nil;
} else {
- val state = vector(three, nil);
+ val state = vector(four, nil);
val c = vector(k, zero);
- set(vecref_l(state, zero), p);
+ set(vecref_l(state, zero), vec);
set(vecref_l(state, one), k);
set(vecref_l(state, two), c);
+ set(vecref_l(state, three), seq);
deref(vecref_l(c, negone)) = negone;
return state;
}
@@ -130,14 +134,14 @@ static val perm_vec_gen_fun(val state)
return out;
}
-static val perm_vec(val p, val k)
+static val perm_vec(val vec, val k)
{
- k = default_arg(k, length_vec(p));
+ k = default_arg(k, length_vec(vec));
if (k == zero) {
return cons(vector(zero, nil), nil);
} else {
- val state = perm_init_common(p, k);
+ val state = perm_init(vec, k, nil);
if (!state)
return nil;
return generate(func_f0(state, perm_while_fun),
@@ -149,6 +153,7 @@ static void perm_list_gen_fill(val out, cnum i, val v)
{
val tail = cdr(out);
val nc = cons(v, nil);
+ (void) i;
if (tail)
rplacd(tail, nc);
else
@@ -163,12 +168,12 @@ static val perm_list_gen_fun(val state)
return car(out);
}
-static val perm_list(val p, val k)
+static val perm_list(val list, val k)
{
- if (k == zero || (!k && !p)) {
+ if (k == zero || (!k && !list)) {
return cons(nil, nil);
} else {
- val state = perm_init_common(vec_list(p), k);
+ val state = perm_init(vec_list(list), k, nil);
if (!state)
return nil;
return generate(func_f0(state, perm_while_fun),
@@ -183,21 +188,22 @@ static void perm_str_gen_fill(val out, cnum i, val v)
static val perm_str_gen_fun(val state)
{
+ val self = lit("perm");
val kk = vecref(state, one);
val out = mkustring(kk);
perm_gen_fun_common(state, out, perm_str_gen_fill);
- out->st.str[c_num(kk)] = 0;
+ out->st.str[c_num(kk, self)] = 0;
return out;
}
-static val perm_str(val p, val k)
+static val perm_str(val str, val k)
{
- k = default_arg(k, length_str(p));
+ k = default_arg(k, length_str(str));
if (k == zero) {
return cons(string(L""), nil);
} else {
- val state = perm_init_common(vec_list(list_str(p)), k);
+ val state = perm_init(vec_list(list_str(str)), k, nil);
if (!state)
return nil;
return generate(func_f0(state, perm_while_fun),
@@ -205,6 +211,27 @@ static val perm_str(val p, val k)
}
}
+static val perm_seq_gen_fun(val state)
+{
+ val list = perm_list_gen_fun(state);
+ val seq = vecref(state, three);
+ return make_like(list, seq);
+}
+
+static val perm_seq(val seq, val k)
+{
+ if (k == zero) {
+ return cons(make_like(nil, seq), nil);
+ } else {
+ val vec = vec_seq(seq);
+ val state = perm_init(vec, k, seq);
+ if (!state)
+ return nil;
+ return generate(func_f0(state, perm_while_fun),
+ func_f0(state, perm_seq_gen_fun));
+ }
+}
+
val perm(val seq, val k)
{
if (null_or_missing_p(k)) {
@@ -230,22 +257,35 @@ val perm(val seq, val k)
case LIT:
return perm_str(seq, k);
default:
- type_mismatch(lit("perm: ~s is not a sequence"), seq, nao);
+ return perm_seq(seq, k);
}
}
+static val rperm_init(val list, val k, val extra)
+{
+ val vec = vector(k, list);
+ val env = vector(three, nil);
+ set(vecref_l(env, zero), list);
+ set(vecref_l(env, one), vec);
+ if (extra)
+ set(vecref_l(env, two), extra);
+ return env;
+}
+
static val rperm_while_fun(val env)
{
- val vec = cdr(env);
+ val vec = env->v.vec[1];
return consp(vecref(vec, zero));
}
static val rperm_gen_fun(val env)
{
- cons_bind (list, vec, env);
+ val self = lit("rperm");
+ val list = env->v.vec[0];
+ val vec = env->v.vec[1];
list_collect_decl(out, ptail);
cnum i;
- cnum len = c_num(length_vec(vec));
+ cnum len = c_num(length_vec(vec), self);
for (i = 0; i < len; i++)
ptail = list_collect(ptail, car(vec->v.vec[i]));
@@ -263,8 +303,7 @@ static val rperm_gen_fun(val env)
static val rperm_list(val list, val k)
{
- val vec = vector(k, list);
- val env = cons(list, vec);
+ val env = rperm_init(list, k, nil);
return generate(func_f0(env, rperm_while_fun),
func_f0(env, rperm_gen_fun));
}
@@ -278,8 +317,7 @@ static val rperm_vec_gen_fun(val env)
static val rperm_vec(val ve, val k)
{
val list = list_vec(ve);
- val vec = vector(k, list);
- val env = cons(list, vec);
+ val env = rperm_init(list, k, nil);
return generate(func_f0(env, rperm_while_fun),
func_f0(env, rperm_vec_gen_fun));
}
@@ -293,12 +331,26 @@ static val rperm_str_gen_fun(val env)
static val rperm_str(val str, val k)
{
val list = list_str(str);
- val vec = vector(k, list);
- val env = cons(list, vec);
+ val env = rperm_init(list, k, nil);
return generate(func_f0(env, rperm_while_fun),
func_f0(env, rperm_str_gen_fun));
}
+static val rperm_seq_gen_fun(val env)
+{
+ val list = rperm_gen_fun(env);
+ val seq = env->v.vec[2];
+ return make_like(list, seq);
+}
+
+static val rperm_seq(val seq, val k)
+{
+ val list = list_seq(seq);
+ val env = rperm_init(list, k, seq);
+ return generate(func_f0(env, rperm_while_fun),
+ func_f0(env, rperm_seq_gen_fun));
+}
+
val rperm(val seq, val k)
{
if (!integerp(k))
@@ -329,61 +381,77 @@ val rperm(val seq, val k)
return cons(string(L""), nil);
return rperm_str(seq, k);
default:
- type_mismatch(lit("rperm: ~s is not a sequence"), seq, nao);
+ return rperm_seq(seq, k);
}
}
-
-static val k_conses(val list, val k)
+static val k_conses(val list, val k, val self)
{
- val iter = list, i = k;
- list_collect_decl (out, ptail);
+ cnum i, n = c_num(k, self);
+ val iter, out = vector(num(n), nil);
+
+ for (iter = list, i = 0; i < n && iter; iter = cdr(iter), i++)
+ out->v.vec[i] = iter;
- for (; consp(iter) && gt(i, zero); iter = cdr(iter), i = minus(i, one))
- ptail = list_collect(ptail, iter);
+ return (i >= n) ? out : nil;
+}
- return (i != zero) ? nil : out;
+static val comb_init(val list, val k)
+{
+ if (zerop(k))
+ return nil;
+ return k_conses(list, k, lit("comb"));
}
static val comb_while_fun(val state)
{
- return car(state);
+ if (state) {
+ cnum nn = c_num(length_vec(state), lit("comb"));
+ return tnil(nn > 0 && state->v.vec[0]);
+ }
+ return nil;
}
static void comb_gen_fun_common(val state)
{
- val iter;
- val prev = nil;
+ cnum i, nn = c_num(length_vec(state), lit("comb"));
- for (iter = state; consp(iter); iter = cdr(iter)) {
- val curr = first(iter);
- val curr_rest = rest(curr);
- if (curr_rest != prev && consp(curr_rest)) {
- rplaca(iter, curr_rest);
+ for (i = nn - 1; i >= 0; i--)
+ {
+ val cur = state->v.vec[i];
+ val re = rest(cur);
+
+ if ((i == nn - 1 && re) ||
+ (i < nn - 1 && re != state->v.vec[i + 1]))
+ {
+ state->v.vec[i] = re;
return;
- } else if (rest(iter)) {
- val next = second(iter);
- val next_rest = rest(next);
- val next_rest_rest = rest(next_rest);
- prev = curr;
- if (next_rest != curr && consp(next_rest_rest))
- prev = sys_rplaca(iter, next_rest_rest);
+ } else if (i > 0) {
+ val nxt = state->v.vec[i - 1];
+ val nxt_r = cdr(nxt);
+ val nxt_r_r = cdr(nxt_r);
+
+ if (nxt_r != cur && consp(nxt_r_r)) {
+ cnum j;
+ for (j = i; j < nn; j++, nxt_r_r = cdr(nxt_r_r))
+ state->v.vec[j] = nxt_r_r;
+ }
}
}
- rplaca(state, nil);
+ state->v.vec[0] = nil;
}
static val comb_list_gen_fun(val state)
{
- val out = nreverse(mapcar(car_f, state));
+ val out = mapcar_listout(car_f, state);
comb_gen_fun_common(state);
return out;
}
static val comb_list(val list, val k)
{
- val state = nreverse(k_conses(list, k));
+ val state = comb_init(list, k);
return state ? generate(func_f0(state, comb_while_fun),
func_f0(state, comb_list_gen_fun))
: nil;
@@ -391,12 +459,13 @@ static val comb_list(val list, val k)
static val comb_vec_gen_fun(val state)
{
- val nn = length_list(state);
- cnum i, n = c_num(nn);
- val iter, out = vector(nn, nil);
+ val self = lit("comb");
+ val nn = length_vec(state);
+ cnum i, n = c_num(nn, self);
+ val out = vector(nn, nil);
- for (iter = state, i = n - 1; i >= 0; iter = cdr(iter), i--)
- out->v.vec[i] = car(car(iter));
+ for (i = 0; i < n; i++)
+ out->v.vec[i] = car(state->v.vec[i]);
comb_gen_fun_common(state);
return out;
@@ -404,21 +473,22 @@ static val comb_vec_gen_fun(val state)
static val comb_vec(val vec, val k)
{
- val state = nreverse(k_conses(list_vec(vec), k));
+ val state = comb_init(list_vec(vec), k);
return generate(func_f0(state, comb_while_fun),
func_f0(state, comb_vec_gen_fun));
}
static val comb_str_gen_fun(val state)
{
- val nn = length_list(state);
- cnum i, n = c_num(nn);
- val iter, out = mkustring(nn);
+ val self = lit("comb");
+ val nn = length_vec(state);
+ cnum i, n = c_num(nn, self);
+ val out = mkustring(nn);
out->st.str[n] = 0;
- for (iter = state, i = n - 1; i >= 0; iter = cdr(iter), i--)
- out->st.str[i] = c_chr(car(car(iter)));
+ for (i = 0; i < n; i++)
+ out->st.str[i] = c_chr(car(state->v.vec[i]));
comb_gen_fun_common(state);
return out;
@@ -426,23 +496,21 @@ static val comb_str_gen_fun(val state)
static val comb_str(val str, val k)
{
- val state = nreverse(k_conses(list_str(str), k));
+ val state = comb_init(list_str(str), k);
return generate(func_f0(state, comb_while_fun),
func_f0(state, comb_str_gen_fun));
}
-static val comb_hash_while_fun(val state)
-{
- return car(car(state));
-}
-
static val comb_hash_gen_fun(val hstate)
{
+ val self = lit("comb");
cons_bind (state, hash, hstate);
- val iter, out = make_similar_hash(hash);
+ val nn = length_vec(state);
+ cnum i, n = c_num(nn, self);
+ val out = make_similar_hash(hash);
- for (iter = state; iter; iter = cdr(iter)) {
- val pair = car(car(iter));
+ for (i = 0; i < n; i++) {
+ val pair = car(state->v.vec[i]);
sethash(out, car(pair), cdr(pair));
}
@@ -450,14 +518,29 @@ static val comb_hash_gen_fun(val hstate)
return out;
}
-
static val comb_hash(val hash, val k)
{
- val hstate = cons(nreverse(k_conses(hash_alist(hash), k)), hash);
- return generate(func_f0(hstate, comb_hash_while_fun),
+ val state = comb_init(hash_alist(hash), k);
+ val hstate = cons(state, hash);
+ return generate(func_f0(state, comb_while_fun),
func_f0(hstate, comb_hash_gen_fun));
}
+static val comb_seq_gen_fun(val sstate)
+{
+ cons_bind (state, seq, sstate);
+ val list = comb_list_gen_fun(state);
+ return make_like(list, seq);
+}
+
+static val comb_seq(val seq, val k)
+{
+ val state = comb_init(list_seq(seq), k);
+ val sstate = cons(state, seq);
+ return generate(func_f0(state, comb_while_fun),
+ func_f0(sstate, comb_seq_gen_fun));
+}
+
val comb(val seq, val k)
{
if (!integerp(k))
@@ -496,7 +579,7 @@ val comb(val seq, val k)
return nil;
return comb_hash(seq, k);
}
- type_mismatch(lit("comb: ~s is not a sequence"), seq, nao);
+ return comb_seq(seq, k);
}
}
@@ -548,8 +631,9 @@ static val rcomb_list(val list, val k)
static val rcomb_vec_gen_fun(val state)
{
+ val self = lit("rcomb");
val nn = length_list(state);
- cnum i, n = c_num(nn);
+ cnum i, n = c_num(nn, self);
val iter, out = vector(nn, nil);
for (iter = state, i = n - 1; i >= 0; iter = cdr(iter), i--)
@@ -568,8 +652,9 @@ static val rcomb_vec(val vec, val k)
static val rcomb_str_gen_fun(val state)
{
+ val self = lit("rcomb");
val nn = length_list(state);
- cnum i, n = c_num(nn);
+ cnum i, n = c_num(nn, self);
val iter, out = mkustring(nn);
out->st.str[n] = 0;
@@ -588,6 +673,21 @@ static val rcomb_str(val str, val k)
func_f0(state, rcomb_str_gen_fun));
}
+static val rcomb_seq_gen_fun(val sstate)
+{
+ cons_bind (state, seq, sstate);
+ val list = rcomb_list_gen_fun(state);
+ return make_like(list, seq);
+}
+
+static val rcomb_seq(val seq, val k)
+{
+ val state = nreverse(list_vec(vector(k, list_seq(seq))));
+ val sstate = cons(state, seq);
+ return generate(func_f0(state, rcomb_while_fun),
+ func_f0(sstate, rcomb_seq_gen_fun));
+}
+
val rcomb(val seq, val k)
{
if (!integerp(k))
@@ -615,6 +715,6 @@ val rcomb(val seq, val k)
return cons(string(L""), nil);
return rcomb_str(seq, k);
default:
- type_mismatch(lit("rcomb: ~s is not a sequence"), seq, nao);
+ return rcomb_seq(seq, k);
}
}
diff --git a/combi.h b/combi.h
index d5e15b07..9302029a 100644
--- a/combi.h
+++ b/combi.h
@@ -1,4 +1,4 @@
-/* Copyright 2012-2020
+/* Copyright 2012-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
val perm(val seq, val k);
diff --git a/configure b/configure
index a32f5306..1e290def 100755
--- a/configure
+++ b/configure
@@ -1,6 +1,6 @@
#!/bin/sh
#
-# Copyright 2009-2020
+# Copyright 2009-2024
# Kaz Kylheku <kaz@kylheku.com>
# Vancouver, Canada
# All rights reserved.
@@ -27,29 +27,61 @@
# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
-# The #!/bin/sh might be some legacy piece of crap,
-# not even up to 1990 POSIX.2 spec. So the first step
-# is to look for a better shell in some known places
-# and re-execute ourselves with that interpreter.
+# The #!/bin/sh might be some legacy piece of junk, not even up to 1990 POSIX.2
+# spec. So the first step is to look for a better shell in some known places
+# and re-execute ourselves with that interpreter, unless there is evidence we
+# are already running in a usable shell.
#
-if test x$txr_shell = x ; then
- for shell in /bin/bash /usr/bin/bash /usr/xpg4/bin/sh ; do
- if test -x $shell ; then
+while true ; do
+ # we have already recursed into a desired shell
+ if test "x$txr_shell" != x ; then
+ break
+ fi
+
+ # If PS4 is set to "+ ", we are probably running on a good shell: GNU
+ # Bash sets it like this, as does late-model Ash, Dash, Korn Shell 93,
+ # and the XPG shell on Solaris 10. Zsh sets PS4 to "+ " this in its
+ # POSIX mode, which handles our script, but to some other value in its
+ # regular mode which doesn't handle our script.
+ if test "x$PS4" = "x+ " ; then
+ break
+ fi
+
+ # Slow path: find a suitable shell.
+ # First choice is $CONFIG_SHELL, a convention from GNU Autoconf.
+ for shell in "$CONFIG_SHELL" \
+ /bin/bash /usr/bin/bash /usr/local/bin/bash \
+ /bin/dash /usr/bin/dash /usr/local/bin/dash \
+ /bin/ksh /usr/bin/ksh /usr/local/bin/ksh \
+ /usr/xpg4/bin/sh
+ do
+ if test -x "$shell" ; then
txr_shell=$shell
break
fi
done
- if test x$txr_shell = x ; then
- echo "No known POSIX shell found: falling back on /bin/sh, which may not work"
- txr_shell=/bin/sh
+
+ if test "x$txr_shell" = x ; then
+ echo "No known modern shell found; sticking with this one."
+ break;
fi
+
+ # we export txr_shell because it acts as a flag indicating the recursed case
export txr_shell
- exec $txr_shell $0 ${@+"$@"}
-fi
+ echo "Re-executing using $txr_shell"
+ exec "$txr_shell" $0 ${@+"$@"}
+ break
+done
set -u
+if [ -n "${txr_shell+y}" ] ; then
+ printf "Now running in %s shell\n" $txr_shell
+else
+ printf "Running in original shell.\n"
+fi
+
#
# Save command line in a way that can be re-run.
#
@@ -60,7 +92,7 @@ for arg in "$0" ${@+"$@"} ; do
case $arg in
*"'"* )
case $arg in
- *'"'* | *'$'* )
+ *[\"\$\\]* )
cmdline="$cmdline'$(printf "%s" "$arg" | sed -e "s/'/'\\\\''/g")'"
;;
* )
@@ -68,9 +100,12 @@ for arg in "$0" ${@+"$@"} ; do
;;
esac
;;
- *'"'* | *['$*?[']* | '~'* )
+ *'"'* | *['$*?[(){};&|<>#']* | '~'* )
cmdline="$cmdline'$arg'"
;;
+ *' '* | *' '* )
+ cmdline="$cmdline\"$arg\""
+ ;;
* )
cmdline="$cmdline$arg"
;;
@@ -78,19 +113,11 @@ for arg in "$0" ${@+"$@"} ; do
done
#
-# Tentatively save configuration in config.log
-#
-cat > reconfigure <<!
-#!/bin/sh
-#
-# Configured on $(date) using:
-
-$cmdline
-
-# The above did not complete.
-!
+# Use the POSIX locale to suppress monkey business in the utilities
+#
-chmod a+x reconfigure
+export LC_ALL="C"
+export LANG="C"
#
# Establish default values for any variables that are not specified
@@ -113,11 +140,18 @@ install_prefix=
bindir='bin'
datadir='share/txr'
mandir='share/man'
+maintainer=
+parallelmake=
+parallelmake_given=
make=
cross=
compiler_prefix=
ccname='$(CC)'
cc='$(cross)$(compiler_prefix)$(ccname)'
+gcc_version=
+broken128=
+do_nopie=y
+cplusplus=
intptr=
exe=
tool_prefix=
@@ -129,11 +163,13 @@ yaccname_given=
yaccname='' # test tries $(YACC) first
yacc='$(cross)$(tool_prefix)$(yaccname)'
yacc_given=
-yacc_is_newer_bison=
nm='$(cross)$(tool_prefix)nm'
opt_flags='-O2 -fno-stack-protector'
-lang_flags='-ansi -D_XOPEN_SOURCE=700 -D_POSIX_C_SOURCE=200112 -D_GNU_SOURCE'
-diag_flags='-Wall -Werror=implicit-function-declaration -Werror=missing-prototypes -Werror=strict-prototypes'
+lang_flags='-D_XOPEN_SOURCE=700 -D_POSIX_C_SOURCE=200112 -D_GNU_SOURCE'
+diag_flags="-Wall -Wextra -Werror=implicit-function-declaration \
+ -Werror=missing-prototypes -Werror=strict-prototypes \
+ -Werror=old-style-definition"
+diag_flags_given=
debug_flags=-g
debug_only_flags=-DTXR_DEBUG
debug_also=
@@ -142,19 +178,25 @@ platform_cflags=
remove_flags=
lex_dbg_flags=
conf_ldflags=
+conf_ldlibs=
platform_ldflags=
+platform_ldlibs=
txr_dbg_opts=--gc-debug
valgrind=
-lit_align=
extra_debugging=
debug_support=y
+have_zlib=
+big_time=
+big_time_given=
gen_gc=y
small_mem=
+full_repl=y
have_dbl_decimal_dig=
have_unistd=
have_sys_stat=
have_sys_types=
have_sys_time=
+have_strerror_r=
have_makedev=
have_syslog=
have_glob=
@@ -163,8 +205,8 @@ have_windows_h=
have_windres=
have_posix_sigs=
have_sockets=
-need_darwin_c_source=
have_git=
+have_ubsan=
have_pwuid=
have_grgid=
have_alloca=
@@ -172,7 +214,14 @@ have_termios=
have_winsize=
termios_define=
have_pkgconfig=
+have_malloc_usable_size=
libffi_cflags=
+darwin_target=
+solaris_target=
+build_id=
+android_target=
+nan_boxing=
+nan_boxing_given=
#
# Parse configuration variables
@@ -224,7 +273,7 @@ while [ $# -gt 0 ] ; do
exit 1
fi
- eval "$var='$val'"
+ eval "$var='$(printf "%s" "$val" | sed -e "s/'/'\\\\''/g")'"
eval "var_given_exists=\${${var}_given+y}"
@@ -268,7 +317,7 @@ Canonical:
variable=value Defines the given variable as having the given value.
variable= Defines the variable as having an empty value.
- An empty value serves as boolean false.
+ An empty value serves as Boolean false.
Long-option style:
@@ -288,6 +337,22 @@ be used in paths. Default values are shown in [square brackets].
Variables are case-sensitive, but underscores and dashes are interchangeable.
+maintainer [$maintainer]
+
+ This a Boolean variable. If set to 'y', then it it specifies maintainer
+ mode, otherwise the build is configured for user mode. In maintainer mode,
+ the scanner and parser generator tools are expected to be available.
+ In user mode, the shipped parser and scanner are used. Changes to
+ the parser.l and parser.y files will have no effect. In maintainer mode,
+ also, c90 is used if compiling the code as C.
+
+parallelmake [$parallelmake]
+
+ Boolean. If set to 'y', it specifies that parallel building with make -j
+ is permitted. Otherwise the Makefile asserts no parallelism with
+ a .NOTOPARALLEL: directive. The above maintainer mode also implies
+ parallel building being permited.
+
prefix [$prefix]
Specifies root directory where the software will ultimately be installed and
@@ -348,7 +413,9 @@ cc [$cc]
compiling C sources to object files, and for linking object files to
executables. This becomes the TXR_CC variable in config.make.
Note that cross and compiler_prefix are empty by default and
- and so this expands to just ccname.
+ and so this expands to just ccname. Note also that if cc is specified in a
+ way that doesn't include \$(ccname), then that variable is not used,
+ even though it continues to be defined in config.make.
intptr [$intptr]
@@ -356,15 +423,6 @@ intptr [$intptr]
value can be converted to it. If this is blank, the configure script
will try to auto detect it.
-lit-align [$lit_align]
-
- Specifies alignment for wide string literals. This is guessed
- from the size of the wchar_t type. If your wchar_t type is two byte wide, but
- wide literals are aligned to four bytes, then you should specify this. This
- will eliminate some kludges in the program. There is no easy way to check
- for this withut generating and running a C program, which is unfriendly
- for cross-compiling!
-
inline [$inline]
Specifies the syntax for defining an inline function, in such
@@ -446,8 +504,15 @@ platform-cflags [$platform_cflags]
platform-ldflags [$platform_ldflags]
Specify additional linker flags for anything else, such as hardening,
+ linking as needed, et cetera. Flags specifying libraries (-l options)
+ should be specified using platform-ldlibs instead. Note that these are in
+ addition to any LDFLAGS from the environment or make command line.
+
+platform-ldlibs [$platform_ldlibs]
+
+ Specify additional linker flags for just libraries (-l options)
linking as needed, et cetera. Note that these are in addition to
- any LDFLAGS from the environment or make command line.
+ any LDLIBS from the environment or make command line.
remove-flags [$remove_flags]
@@ -477,6 +542,23 @@ extra-debugging [$extra_debugging]
Use --extra_debugging to configure some additional debugging features,
which incur a run-time penalty.
+big-time [$big_time]
+
+ Systems whose time_t type is 32 bits wide have a Y2038 problem.
+ On some of these systems, it is possible to specify some compiler option
+ to make time_t 64 bits wide. If this configure script detects this
+ situation: that time is 32 bits, but may be switched to 64, it
+ refuses to run. You must explicitly choose what will happen. Use
+ --big-time to choose the 64 bit time, or else --no-big-time.
+
+ If time_t is 64 bits by default then specifying --no-big-time is
+ erroneous. Downgrading from a 64 bit default is not supported by
+ this script, even if it is possible; if that is necessary, use external
+ options vial EXTRA_FLAGS or CFLAGS.
+
+ Specifying --big-time is erroneous if time_t is 32 bits, and there is no way
+ to enable 64.
+
gen-gc [$gen_gc]
Use --no-gen-gc to disable the generational garbage collector which
@@ -493,16 +575,63 @@ small-mem [$small_mem]
and certain global book-keeping arrays in the generational garbage
collector are smaller, resulting in more frequent collections.
+full-repl [$full_repl]
+
+ Support the full listener with editing features. If this is disabled,
+ only the plain-mode listener is available. Failure to detect the
+ presence of termios at build configuration time time also disables it.
+
+build-id [$build_id]
+
+ This option specifies the value of the build_id make variable.
+ The argument is GNU make syntax which calculates a string
+ that is inserted into the TXR executable. The string is reproduced
+ by reproduced using the txr --build-id. The default is that there
+ no build-id, and the --build-id option produces empty output.
+
+ If the argument value "git" is given, then the value is replaced
+ by syntax which takes the value of the output of the command
+ "git describe --tags --dirty",
+ executed in the source directory. This is recalculated each time
+ the txr.c source file is compiled.
+
+ The build_id variable can be overridden from the make command line.
+
+nan-boxing [$nan_boxing]
+
+ This option specifies whether NaN-boxing representation is used
+ for Lisp values. This is good for floating-point work because
+ floating-point values do not require heap allocation.
+ It is enabled automatically on targets with 64 bit pointers,
+ and is not supported on targets with 32 bit pointers.
+ Disable it to select the regular tagged pointer representation.
!
exit 1
fi
#
+# Tentatively save configuration in config.log
+#
+rm -rf reconfigure
+cat > reconfigure <<!
+#!/bin/sh
+#
+# Configured on $(date) using:
+
+$cmdline "\$@"
+
+# The above did not complete.
+!
+
+chmod a+x reconfigure
+
+
+#
# Variables are read, --help wasn't given, so let's configure!
#
-txr_ver=233
+txr_ver=294
#
# The all important banner.
@@ -523,8 +652,6 @@ printf "+%s+\n|%s|\n+%s+\n" $banner_box "$banner_text" $banner_box
set -e
-printf "We are using this shell: %s\n" $txr_shell
-
#
# Check for GNU make
#
@@ -634,7 +761,7 @@ else
top_srcdir="$(cd "$source_dir" ; pwd -P)"/
fi
-printf "Checking source directory \"%s\" ..." "$top_srcdir"
+printf "Checking source directory \"%s\" ... " "$top_srcdir"
lndir()
{
@@ -676,11 +803,11 @@ inode()
case "$top_srcdir" in
" "* | *" "* | *" " )
- printf " bad (contains spaces)\n"
+ printf "bad (contains spaces)\n"
exit 1
;;
* )
- printf " okay\n"
+ printf "okay\n"
;;
esac
@@ -689,7 +816,7 @@ if [ $(inode "$source_dir") != $(inode ".") ] ; then
printf "Symlinking %s -> $source_dir/%s\n" $x $x
ln -sf "$source_dir/$x" .
done
- for x in share tests; do
+ for x in stdlib tests; do
printf "Tree symlinking %s -> $source_dir/%s\n" $x $x
lndir $source_dir/$x $x
done
@@ -698,6 +825,47 @@ else
build_in_srcdir=y
fi
+printf "Are we using a C++ compiler ... "
+
+case $ccname in
+*'++' | *'$(CXX)' )
+ cplusplus=y
+ ;;
+esac
+
+case $cc in
+*'++' | '$(CXX)' )
+ cplusplus=y
+ ;;
+esac
+
+if [ $cplusplus ] ; then
+ printf "yes\n"
+ set -- $diag_flags
+ diag_flags=''
+ for flag in "$@" ; do
+ case $flag in
+ *=declaration-after-statement | \
+ *=implicit-function-declaration | \
+ *=missing-prototypes | \
+ *=old-style-* | \
+ *=strict-prototypes )
+ continue
+ ;;
+ esac
+ diag_flags="$diag_flags $flag"
+ done
+ diag_flags=${diag_flags# }
+ lang_flags="-std=c++98 $lang_flags"
+else
+ printf "no\n"
+ if [ $maintainer ] ; then
+ lang_flags="-ansi $lang_flags"
+ else
+ lang_flags="-std=c99 $lang_flags"
+ fi
+fi
+
gen_config_make()
{
cat > config.make <<!
@@ -706,14 +874,18 @@ gen_config_make()
# Changes to this file are lost when the above is re-run.
#
-# Shell used by make for running recipes; this
+${txr_shell:+# Shell used by make for running recipes; this
# is the as the shell we chose for the configure script,
# derived from the txr_shell variable.
-SHELL := $txr_shell
+SHELL := $txr_shell}
txr_ver := $txr_ver
-# absolute path to source code directory
+# is this configuration in maintainer mode
+maintainer := $maintainer
+
+# absolute path to source code directory or blank if
+# not building in a separate directory
top_srcdir := $top_srcdir
# build directory is top_srcdir
@@ -759,6 +931,19 @@ compiler_prefix := $compiler_prefix
# prefix for non-compiler toolchain commands
tool_prefix := $tool_prefix
+# build_id
+$(gitcmd='git describe --tags --dirty';
+ if [ "$build_id" = "git" ] ; then
+ if [ $build_in_srcdir ] ; then
+ printf 'build_id ?= $(shell %s)\n' "$gitcmd"
+ else
+ printf 'build_id ?= $(shell cd $(top_srcdir); %s)\n' "$gitcmd"
+ fi
+ else
+ printf 'build_id = %s\n' "$build_id"
+ fi)
+build_id_exp := \$(build_id)
+
# do we compile in syslog support?
have_syslog := $have_syslog
@@ -778,14 +963,20 @@ termios_define := $termios_define
# do we compile in debug support?
debug_support := $debug_support
+# do we compile in zlib?
+have_zlib := $have_zlib
+
+# allow parallel make?
+parallelmake := $parallelmake
+
# EXE suffix
EXE := $exe
have_git := $have_git
-add_win_res := $([ -n "$have_windows_h" -a -n "$have_windres" ] && echo "y")
+have_ubsan := $have_ubsan
-yacc_is_newer_bison := $yacc_is_newer_bison
+add_win_res := $([ -n "$have_windows_h" -a -n "$have_windres" ] && echo "y")
TXR_CC := $cc
TXR_LEX := $lex
@@ -805,7 +996,9 @@ BUILD_TARGETS := $(if [ $debug_also ] ; then
echo '$(PROG)'; fi)
PLATFORM_CFLAGS := $platform_cflags
PLATFORM_LDFLAGS := $platform_ldflags
+PLATFORM_LDLIBS := $platform_ldlibs
CONF_LDFLAGS := $conf_ldflags
+CONF_LDLIBS := $conf_ldlibs
REMOVE_FLAGS := $remove_flags
LEX_DBG_FLAGS := $lex_dbg_flags
TXR_DBG_OPTS := $txr_dbg_opts
@@ -856,15 +1049,6 @@ conftest_o()
}
#
-# Like conftest but make conftest.syms
-#
-conftest_syms()
-{
- rm -f conftest.o conftest.syms
- $make conftest.syms ${@+"$@"} > conftest.err 2>&1
-}
-
-#
# Check for git because we use it out of the Makefile
# But this is pointless if we have no git repo.
# "have_git" means we have a repo, and git.
@@ -902,7 +1086,6 @@ if ! conftest ; then
lang_flags="$(echo "$lang_flags" | sed -e 's/-ansi/-std=c99/')"
else
printf "no\n\n"
- conftest && true
printf "Errors from compilation: \n\n"
cat conftest.err
exit 1
@@ -911,42 +1094,47 @@ else
printf "okay\n"
fi
-printf "Checking whether executables have that idiotic .exe suffix ... "
+if ! [ $diag_flags_given ] ; then
+ for opt in -Werror=vla -Werror=declaration-after-statement ; do
+ printf "Checking for %s ... " $opt
-if ls conftest.exe > /dev/null 2>&1 ; then
- echo "yes"
- exe=.exe
-else
- echo "no"
+ if conftest EXTRA_FLAGS="-Werror $opt" ; then
+ printf "yes\n"
+ diag_flags="$diag_flags $opt"
+ else
+ printf "no\n"
+ fi
+ done
fi
-rm -f conftest$exe
-
-printf "Checking how to disable PIE ..."
-
-nopie_flags=
+printf "Checking compiler version for various workarounds ... "
-for flag in -nopie -no-pie ; do
- if conftest EXTRA_FLAGS=$flag && ! grep -q option conftest.err ; then
- nopie_flags=" $flag"
- break
+output=$($make conftest.ccver)
+set -- $output
+if [ "$1" = "gcc" ] ; then
+ gcc_version=$3
+ save_ifs=$IFS ; IFS=. ; set -- $gcc_version ; IFS=$save_ifs
+ if [ $1 -lt 4 ] || [ $1 -eq 4 -a $2 -le 3 ] ; then
+ broken128=y
fi
-done
+ [ $1 -lt 5 ] && do_nopie=
+elif [ "$1" = "clang" -o "$2" = "clang" ] ; then
+ do_nopie=
+fi
-for flag in -fnopie -fno-pie ; do
- if conftest EXTRA_FLAGS="$flag$nopie_flags" && ! grep -q option conftest.err ; then
- nopie_flags="$nopie_flags $flag"
- break
- fi
-done
+printf "done\n"
+
+printf "Checking whether executables require an .exe suffix ... "
-if [ -n "$nopie_flags" ]; then
- printf "%s\n" "$nopie_flags"
- opt_flags="$opt_flags$nopie_flags"
+if ls conftest.exe > /dev/null 2>&1 ; then
+ echo "yes"
+ exe=.exe
else
- printf " n/a\n"
+ echo "no"
fi
+rm -f conftest$exe
+
printf "Checking for disabling source code quoting in compiler errors ... "
cat > conftest.c <<!
@@ -981,7 +1169,7 @@ fi
printf "Checking for name clashes caused by nonconforming toolchains ... "
-for ident in trunc floorf random longlong_t ; do
+for ident in trunc floorf random longlong_t mergesort ; do
cat > conftest.c <<!
#include <assert.h>
#include <ctype.h>
@@ -1036,27 +1224,64 @@ if conftest EXTRA_FLAGS=-Werror ; then
else
printf "no\n"
lang_flags="$lang_flags -U__STRICT_ANSI__"
- printf "Regenerating config.make ..."
+ printf "Regenerating config.make ... "
gen_config_make
printf "done\n"
fi
+printf "Checking for undefined behavior sanitizer (\"ubsan\") being in effect ... "
+
+cat > conftest.c <<!
+#include <stdio.h>
+
+int main(void)
+{
+ return 0;
+}
+!
+if conftest ; then
+ if strings conftest | grep -q -i ubsan ; then
+ printf "yes\n"
+ printf "#define HAVE_UBSAN 1\n" >> config.h
+ have_ubsan=y
+ else
+ printf "no\n"
+ fi
+else
+ printf "failed\n"
+fi
+
#
# Detect Apple environment. We need _DARWIN_C_SOURCE.
#
printf "Checking for Apple environment ... "
-if [ "$(make conftest.darwin)" = "yes" ] ; then
+if [ "$($make conftest.darwin)" = "yes" ] ; then
printf "yes\n"
- need_darwin_c_source=y
+ darwin_target=y
lang_flags="$lang_flags -D_DARWIN_C_SOURCE"
- printf "Regenerating config.make ..."
+ printf "Regenerating config.make ... "
gen_config_make
printf "done\n"
else
printf "no\n"
fi
+if ! [ $darwin_target ] ; then
+ printf "Checking for Android environment ... "
+
+ if [ "$($make conftest.android)" = "yes" ] ; then
+ printf "yes\n"
+ android_target=y
+ lang_flags="$lang_flags --target=aarch64-unknown-linux-android26 -D_BSD_SOURCE"
+ printf "Regenerating config.make ... "
+ gen_config_make
+ printf "done\n"
+ else
+ printf "no\n"
+ fi
+fi
+
#
# Detect stupid FreeBSD problem: no defined way to reveal
# traditional BSD functions if Unix compliance is selected with
@@ -1093,6 +1318,33 @@ else
done
fi
+
+if [ $do_nopie ] ; then
+ printf "Checking how to disable PIE ... "
+ nopie_flags=
+
+ for flag in -nopie -no-pie ; do
+ if conftest EXTRA_FLAGS=$flag && ! grep -q option conftest.err ; then
+ nopie_flags=" $flag"
+ break
+ fi
+ done
+
+ for flag in -fnopie -fno-pie ; do
+ if conftest EXTRA_FLAGS="$flag$nopie_flags" && ! grep -q option conftest.err ; then
+ nopie_flags="$nopie_flags $flag"
+ break
+ fi
+ done
+
+ if [ -n "$nopie_flags" ]; then
+ printf "%s\n" "$nopie_flags"
+ opt_flags="$opt_flags$nopie_flags"
+ else
+ printf "n/a\n"
+ fi
+fi
+
#
# Check for annoying warnings from ctype.h macros
#
@@ -1140,6 +1392,7 @@ done
if [ -n "$longlong" ] ; then
printf '"%s"\n' "$longlong"
printf "#define HAVE_LONGLONG_T 1\n" >> config.h
+ printf "#define LONGLONG_TYPE \"%s\"\n" "$longlong" >> config.h
printf "typedef $longlong longlong_t;\n" >> config.h
else
printf "none\n"
@@ -1169,17 +1422,6 @@ fi
printf "Checking what C type we have for integers wider than \"long long\" ... "
-broken128=
-output=$($make conftest.ccver)
-set -- $output
-if [ "$1" = "gcc" ] ; then
- gcc_version=$3
- save_ifs=$IFS ; IFS=. ; set -- $gcc_version ; IFS=$save_ifs
- if [ $1 -lt 4 ] || [ $1 -eq 4 -a $2 -le 3 ] ; then
- broken128=y
- fi
-fi
-
superlong=
if [ -z "$broken128" ] ; then
@@ -1244,67 +1486,49 @@ fi
printf "Checking what C integer type can hold a pointer ... "
-read_syms()
-{
- print_into_config=${1-}
- deferred_offset=
-
- while read symbol type offset size ; do
- size=$(( 0$size + 0 ))
- offset=$(( 0$offset + 0 ))
- symbol=${symbol#_}
- case "$type" in
- C )
- size=$(( offset + 0 ))
- ;;
- S )
- if [ -n "$deferred_offset" ] ; then
- size=$(( offset - deferred_offset ))
- case "$deferred_sym" in
- SIZEOF* )
- eval $(printf "%s=%d\n" "$deferred_sym" "$size")
- if [ -n "$print_into_config" ] ; then
- printf "#define %s %s\n" "$deferred_sym" "$size" >> config.h
- fi
- ;;
- esac
- fi
- deferred_sym=$symbol
- deferred_offset=$offset
- continue
- ;;
- esac
- case "$symbol" in
- SIZEOF* )
- eval $(printf "%s=%d\n" "$symbol" "$size")
- if [ -n "$print_into_config" ] ; then
- printf "#define %s %s\n" "$symbol" "$size" >> config.h
- fi
- ;;
- esac
- done < conftest.syms
-}
-
if [ -z "$intptr" ] ; then
cat > conftest.c <<!
#include <stddef.h>
#include <limits.h>
#include "config.h"
-char SIZEOF_BYTE[CHAR_BIT];
+
+#define D(N, Z) ((N) ? (N) + '0' : Z)
+#define UD(S) D((S) / 10, ' ')
+#define LD(S) D((S) % 10, '0')
+#define DEC(S) { UD(S), LD(S) }
+
+struct sizes {
+ char h_BYTE[32], s_BYTE[2];
#if HAVE_SUPERLONG_T
-char SIZEOF_SUPERLONG_T[sizeof (superlong_t)];
+ char h_SUPERLONG[32], s_SUPERLONG[2];
#endif
#if HAVE_LONGLONG_T
-char SIZEOF_LONGLONG_T[sizeof (longlong_t)];
+ char h_LONGLONG[32], s_LONGLONG[2];
#endif
-char SIZEOF_PTR[sizeof (char *)];
-char SIZEOF_LONG[sizeof (long)];
-char SIZEOF_INT[sizeof (int)];
-char SIZEOF_SHORT[sizeof (short)];
-char SIZEOF_WCHAR_T[sizeof (wchar_t)];
-char DUMMY;
-!
- if ! conftest_syms ; then
+ char h_PTR[32], s_PTR[2];
+ char h_LONG[32], s_LONG[2];
+ char h_INT[32], s_INT[2];
+ char h_SHORT[32], s_SHORT[2];
+ char h_WCHAR[32], s_WCHAR[2];
+ char nl[2];
+} foo = {
+ "\nSIZEOF_BYTE=", DEC(CHAR_BIT),
+#if HAVE_SUPERLONG_T
+ "\nSIZEOF_SUPERLONG_T=", DEC(sizeof (superlong_t)),
+#endif
+#if HAVE_LONGLONG_T
+ "\nSIZEOF_LONGLONG_T=", DEC(sizeof (longlong_t)),
+#endif
+ "\nSIZEOF_PTR=", DEC(sizeof (char *)),
+ "\nSIZEOF_LONG=", DEC(sizeof (long)),
+ "\nSIZEOF_INT=", DEC(sizeof (int)),
+ "\nSIZEOF_SHORT=", DEC(sizeof (short)),
+ "\nSIZEOF_WCHAR_T=", DEC(sizeof (wchar_t)),
+ "\n"
+};
+!
+
+ if ! conftest_o ; then
printf "failed\n\n"
printf "Errors from compilation: \n\n"
@@ -1312,15 +1536,9 @@ char DUMMY;
exit 1
fi
- SIZEOF_BYTE=0
- SIZEOF_PTR=0
- SIZEOF_SHORT=0
- SIZEOF_INT=0
- SIZEOF_LONG=0
- SIZEOF_LONGLONG_T=0
- SIZEOF_SUPERLONG_T=0
+ eval $(tr '\0' ' ' < conftest.o | grep SIZEOF | sed -e 's/ *//')
- read_syms y
+ tr '\0' ' ' < conftest.o | grep SIZEOF | sed -e 's/= */ /' -e 's/^/#define /' >> config.h
if [ $SIZEOF_PTR -eq 0 -o $SIZEOF_BYTE -eq 0 ] ; then
printf "failed\n"
@@ -1346,6 +1564,7 @@ fi
printf '"%s"\n' "$intptr"
printf "typedef $intptr int_ptr_t;\n" >> config.h
printf "typedef unsigned $intptr uint_ptr_t;\n" >> config.h
+printf "#define INTPTR_TYPE \"%s\"\n" "$intptr" >> config.h
intptr_max_expr="((((convert(int_ptr_t, 1) << $((SIZEOF_PTR * SIZEOF_BYTE - 2))) - 1) << 1) + 1)"
printf "#define INT_PTR_MAX %s\n" "$intptr_max_expr" >> config.h
printf "#define INT_PTR_MIN (-INT_PTR_MAX-1)\n" >> config.h
@@ -1368,38 +1587,46 @@ then
printf "typedef superulong_t double_uintptr_t;\n" >> config.h
fi
-#if HAVE_LONGLONG_T &&
-
-#
-# Alignment of wchar_t
-#
-# What we really want to know is the alignment of wide string literals
-# like L"wide literal".
-#
-# We make pessimistic assumption that the size of the wchar_t type is this
-# alignment.
-#
-# There is no easy way to get the information without running a compiled
-# program.
-#
-
-printf "Conservatively guessing the alignment of wide literals ... "
+if ! [ $nan_boxing_given ] ; then
+ printf "Checking whether to use NaN boxing ... "
-if [ -z "$lit_align" ] ; then
- if [ $SIZEOF_WCHAR_T -eq 0 ] ; then
- printf "failed\n"
- exit 1
+ if [ $SIZEOF_PTR -eq 8 ] ; then
+ nan_boxing=y
+ printf "yes\n"
+ else
+ printf "no\n"
fi
+fi
- if [ -n "$need_darwin_c_source" ] ; then
- lit_align=2
+if [ -n "$nan_boxing" ] ; then
+ if [ $SIZEOF_PTR -ne 8 ] ; then
+ printf "Warning: NaN boxing disabled: it requires 64 bit pointers\n"
else
- lit_align=$SIZEOF_WCHAR_T
+ printf "#define CONFIG_NAN_BOXING 1\n" >> config.h
+ if [ -n "$android_target" ] ; then
+ printf "#define CONFIG_NAN_BOXING_STRIP_TAG 1\n" >> config.h
+ fi
fi
fi
-printf "%d\n" "$lit_align"
-printf "#define LIT_ALIGN %d\n" "$lit_align" >> config.h
+printf "Checking for intmax_t ... "
+cat > conftest.c <<!
+#include <inttypes.h>
+
+int main(void)
+{
+ intmax_t i = 0;
+ untmax_t u = 0;
+ return (uintmax_t) i + u;
+}
+!
+
+if conftest ; then
+ printf "yes\n"
+ printf "#define HAVE_INTMAX_T 1\n" >> config.h
+else
+ printf "no\n"
+fi
#
# Endianness.
@@ -1426,10 +1653,10 @@ if ! conftest_o ; then
printf "failed\n";
exit 1;
else
- if grep -q 'PSILXINUEROCMIWD' conftest.o ; then
+ if strings conftest.o | grep -q 'PSILXINUEROCMIWD' ; then
printf "little\n";
printf "#define HAVE_LITTLE_ENDIAN 1\n" >> config.h
- elif grep -q 'LISPUNIXCOREDWIM' conftest.o ; then
+ elif strings conftest.o | grep -q 'LISPUNIXCOREDWIM' ; then
printf "big\n";
printf "#define HAVE_LITTLE_ENDIAN 0\n" >> config.h
else
@@ -1446,9 +1673,8 @@ printf "Checking how to declare inline functions ... "
if [ -z "$inline" ] ; then
for inline in \
- "inline" "static inline" "extern inline" \
- "__inline__" "static __inline__" "extern __inline__" \
- "static"
+ "${cplusplus:+inline}" "static inline" \
+ "static __inline__" "static"
do
cat > conftest1.c <<!
$inline int func(void)
@@ -1536,7 +1762,7 @@ else
printf "no\n"
fi
-printf "Checking for fpclassify ..."
+printf "Checking for fpclassify ... "
cat > conftest.c <<!
#include <math.h>
@@ -1599,81 +1825,93 @@ fi
# Lex and Yacc tests
#
-printf "Checking for lex ... "
+if [ $maintainer ] ; then
+ printf "Checking for lex ... "
-if [ -z "$lex_given" -a -z "$lexname_given" ] ; then
- for lexname in '$(LEX)' "lex" "flex" "" ; do
+ if [ -z "$lex_given" -a -z "$lexname_given" ] ; then
+ for lexname in '$(LEX)' "lex" "flex" "" ; do
+ rm -f lex.yy.c
+ if $make lexname="$lexname" lex.yy.c > /dev/null 2>&1; then
+ break;
+ fi
+ done
+ if [ -z "$lexname" ] ; then
+ printf "not found\n"
+ exit 1
+ fi
+ else
rm -f lex.yy.c
- if make lexname="$lexname" lex.yy.c > /dev/null 2>&1; then
- break;
+ if ! $make lexname="$lexname" lex.yy.c > /dev/null 2>&1; then
+ printf "error\n\n"
+ printf 'values --lexname="%s" --lex="%s" are not working\n\n' "$lexname" "$lex"
+ printf 'A GNU Flex compatible lex is required\n\n'
+ exit 1
fi
- done
- if [ -z "$lexname" ] ; then
- printf "not found\n"
- exit 1
fi
-else
+
rm -f lex.yy.c
- if ! make lexname="$lexname" lex.yy.c > /dev/null 2>&1; then
- printf "error\n\n"
- printf 'values --lexname="%s" --lex="%s" are not working\n\n' "$lexname" "$lex"
- printf 'A GNU Flex compatible lex is required\n\n'
- exit 1
- fi
-fi
-rm -f lex.yy.c
+ printf '"%s"\n' "$lexname"
-printf '"%s"\n' "$lexname"
+ printf "Checking for yacc program ... "
-printf "Checking for yacc program ... "
+ if [ -z "$yacc_given" -a -z "$yaccname_given" ] ; then
+ for yaccname in '$(YACC)' "yacc" "byacc" "bison -y" "" ; do
+ yaccpath=$($make yaccname="$yaccname" conftest.yacc)
+ if command -v $yaccpath > /dev/null ; then
+ break;
+ fi
+ done
-if [ -z "$yacc_given" -a -z "$yaccname_given" ] ; then
- for yaccname in '$(YACC)' "yacc" "byacc" "bison -y" "" ; do
- yaccpath=$($make yaccname="$yaccname" conftest.yacc)
- if command -v $yaccpath > /dev/null ; then
- break;
+ if [ -z "$yaccname" ] ; then
+ printf "not found\n"
+ exit 1
fi
- done
- if [ -z "$yaccname" ] ; then
- printf "not found\n"
- exit 1
+ printf '"%s" (path "%s")\n' "$yaccname" "$yaccpath"
+ else
+ yaccpath=$($make conftest.yacc)
+ case $yaccpath in
+ *bison )
+ printf "error\n\n"
+ printf "GNU Bison needs -y to behave like yacc\n\n"
+ printf "This needs to be specified in the --yaccname or --yacc option\n\n"
+ exit 1
+ ;;
+ * )
+ if ! command -v $yaccpath > /dev/null ; then
+ printf "not found\n\n"
+ exit 1
+ fi
+ printf "given\n"
+ ;;
+ esac
fi
- printf '"%s" (path "%s")\n' "$yaccname" "$yaccpath"
-else
- yaccpath=$($make conftest.yacc)
- case $yaccpath in
- *bison )
- printf "error\n\n"
- printf "GNU Bison needs -y to behave like yacc\n\n"
- printf "This needs to be specified in the --yaccname or --yacc option\n\n"
- exit 1
- ;;
- * )
- if ! command -v $yaccpath > /dev/null ; then
- printf "not found\n\n"
- exit 1
- fi
- printf "given\n"
- ;;
- esac
-fi
+ printf "Checking if yacc program is GNU Bison ... "
-printf "Checking if yacc program is GNU Bison ... "
+ gen_config_make
-gen_config_make
+ bison_version="$($make conftest.yacc-version | grep -E '[Bb]ison')" || true
-bison_version="$($make conftest.yacc-version | grep -E '[Bb]ison')" || true
+ if [ -n "$bison_version" ] ; then
+ set -- $bison_version
+ printf "yes (%s)\n" "$4"
+ save_ifs=$IFS ; IFS=. ; set -- $4 ; IFS=$save_ifs
+ if [ "$1.$2" != "2.5" ] ; then
+ echo "GNU Bison 2.5 is required"
+ exit 1
+ fi
+ else
+ printf "no\n"
+ fi
+fi
-if [ -n "$bison_version" ] ; then
- set -- $bison_version
- printf "yes (%s)\n" "$4"
- save_ifs=$IFS ; IFS=. ; set -- $4 ; IFS=$save_ifs
- [ $1 -ge 3 ] && yacc_is_newer_bison=y
-else
- printf "no\n"
+#
+# Check for parallel build
+#
+if [ $maintainer ] && ! [ $parallelmake_given ] ; then
+ parallelmake=y
fi
#
@@ -1955,6 +2193,37 @@ else
fi
#
+# errno stuff
+#
+
+printf "Checking for strerror_r ... "
+
+for type in int 'char *' ; do
+ cat > conftest.c <<!
+#include <string.h>
+
+int main(int argc, char **argv)
+{
+ $type (*fp)(int, char *, size_t) = strerror_r;
+ return 0;
+}
+!
+ if conftest EXTRA_FLAGS=-Werror=incompatible-pointer-types ; then
+ if [ "$type" = int ] ; then
+ printf "yes (POSIX)\n"
+ printf "#define HAVE_STRERROR_POSIX 1\n" >> config.h
+ else
+ printf "yes (GNU)\n"
+ printf "#define HAVE_STRERROR_GNU 1\n" >> config.h
+ fi
+ have_strerror_r=y
+ break
+ fi
+done
+
+[ $have_strerror_r ] || printf "no\n"
+
+#
# fcntl
#
@@ -2008,7 +2277,7 @@ fi
# Check for fields inside struct tm
#
-printf "detecting timezone fields in struct tm ... "
+printf "Detecting timezone fields in struct tm ... "
for try_field in tm_gmtoff __tm_gmtoff ; do
cat > conftest.c <<!
@@ -2298,6 +2567,25 @@ else
printf "no\n"
fi
+printf "Checking for strsignal ... "
+
+cat > conftest.c <<!
+#include <string.h>
+#include <signal.h>
+
+int main(void)
+{
+ const char *s = strsignal(SIGABRT);
+ return 0;
+}
+!
+if conftest ; then
+ printf "yes\n"
+ printf "#define HAVE_STRSIGNAL 1\n" >> config.h
+else
+ printf "no\n"
+fi
+
printf "Checking for setitimer/getitimer ... "
cat > conftest.c <<!
@@ -2377,6 +2665,26 @@ else
printf "no\n"
fi
+printf "Checking for linkat ... "
+
+cat > conftest.c <<!
+#include <unistd.h>
+#include <fcntl.h>
+
+int main(void)
+{
+ int e1 = linkat(AT_FDCWD, "foo", AT_FDCWD, "bar", AT_SYMLINK_FOLLOW);
+ return 0;
+}
+!
+if conftest ; then
+ printf "yes\n"
+ printf "#define HAVE_LINKAT 1\n" >> config.h
+ have_unistd=y
+else
+ printf "no\n"
+fi
+
printf "Checking for POSIX mkdir ... "
cat > conftest.c <<!
@@ -2572,6 +2880,22 @@ else
printf "no\n"
fi
+printf "Checking for fchdir ... "
+cat > conftest.c <<!
+#include <unistd.h>
+
+int main(void)
+{
+ int e = fchdir(1);
+ return 0;
+}
+!
+if conftest ; then
+ printf "yes\n"
+ printf "#define HAVE_FCHDIR 1\n" >> config.h
+else
+ printf "no\n"
+fi
printf "Checking for log2 ... "
@@ -2630,6 +2954,50 @@ else
printf "no\n"
fi
+for fun in cbrt erf erfc exp10 exp2 expm1 \
+ gamma j0 j1 lgamma log1p logb \
+ nearbyint pow10 rint significand tgamma y0 y1
+do
+ printf "Checking for %s function ... " $fun
+ cat > conftest.c <<!
+#include <math.h>
+
+int main(void)
+{
+ double a = $fun(0.5);
+ return 0;
+}
+!
+ if conftest ; then
+ printf "yes\n"
+ printf "#define HAVE_%s 1\n" $(echo $fun | tr '[a-z]' '[A-Z]') >> config.h
+ else
+ printf "no\n"
+ fi
+done
+
+for fun in copysign drem fdim fmax fmin \
+ frexp hypot jn ldexp modf \
+ nextafter nexttoward remainder scalb scalbln yn
+do
+ printf "Checking for %s function ... " $fun
+ cat > conftest.c <<!
+#include <math.h>
+
+int main(void)
+{
+ double a = $fun(0.5, 0.5);
+ return 0;
+}
+!
+ if conftest ; then
+ printf "yes\n"
+ printf "#define HAVE_%s 1\n" $(echo $fun | tr '[a-z]' '[A-Z]') >> config.h
+ else
+ printf "no\n"
+ fi
+done
+
printf "Checking for glob ... "
cat > conftest.c <<!
@@ -2802,6 +3170,7 @@ elif conftest EXTRA_FLAGS=-D__EXTENSIONS__=1 ; then
gen_config_make
have_unistd=y
have_sys_types=y
+ solaris_target=y
else
printf "no\n"
fi
@@ -2927,11 +3296,11 @@ for try_lcrypt in "" "-lcrypt" "no" ; do
printf "no\n"
break
fi
- if conftest EXTRA_LDFLAGS=$try_lcrypt; then
+ if conftest EXTRA_LDLIBS=$try_lcrypt; then
printf "yes\n"
printf "#define HAVE_CRYPT 1\n" >> config.h
if [ -n "$try_lcrypt" ] ; then
- conf_ldflags="${conf_ldflags:+"$conf_ldflags "}-lcrypt"
+ conf_ldlibs="${conf_ldlibs:+"$conf_ldlibs "}-lcrypt"
fi
break;
fi
@@ -2955,11 +3324,11 @@ for try_lcrypt in "" "-lcrypt" "no" ; do
printf "no\n"
break
fi
- if conftest EXTRA_LDFLAGS=$try_lcrypt; then
+ if conftest EXTRA_LDLIBS=$try_lcrypt; then
printf "yes\n"
printf "#define HAVE_CRYPT_R 1\n" >> config.h
if [ -n "$try_lcrypt" ] ; then
- conf_ldflags="${conf_ldflags:+"$conf_ldflags "}-lcrypt"
+ conf_ldlibs="${conf_ldlibs:+"$conf_ldlibs "}-lcrypt"
fi
break;
fi
@@ -3008,7 +3377,7 @@ int main(void)
if conftest ; then
printf "memalign\n"
- printf "#define HAVE_MEMALIGN 1\n" $try_header >> config.h
+ printf "#define HAVE_MEMALIGN 1\n" >> config.h
break;
fi
@@ -3024,8 +3393,8 @@ int main(void)
if conftest ; then
printf "memalign\n"
- printf "#define HAVE_MEMALIGN 1\n" $try_header >> config.h
- printf "#define HAVE_MALLOC_H 1\n" $try_header >> config.h
+ printf "#define HAVE_MEMALIGN 1\n" >> config.h
+ printf "#define HAVE_MALLOC_H 1\n" >> config.h
break;
fi
@@ -3041,7 +3410,7 @@ int main(void)
!
if conftest ; then
printf "posix_memalign\n"
- printf "#define HAVE_POSIX_MEMALIGN 1\n" $try_header >> config.h
+ printf "#define HAVE_POSIX_MEMALIGN 1\n" >> config.h
break;
fi
@@ -3049,6 +3418,34 @@ int main(void)
break
done
+printf "Checking for malloc_usable_size ... "
+
+for header in stdlib malloc malloc_np ; do
+ cat > conftest.c <<!
+#include <$header.h>
+
+int main(int argc, char **argv)
+{
+ void *p = malloc(42);
+ size_t s = malloc_usable_size(p);
+ return 0;
+}
+!
+
+ if conftest ; then
+ printf "yes (<%s.h>)\n" $header
+ printf "#define HAVE_MALLOC_USABLE_SIZE 1\n" >> config.h
+ if [ $header != stdlib ] ; then
+ header=$(printf "%s" $header | tr '[a-z]' '[A-Z]')
+ printf "#define HAVE_%s_H 1\n" $header >> config.h
+ fi
+ have_malloc_usable_size=y
+ break
+ fi
+done
+
+[ "$have_malloc_usable_size" ] || printf "no\n"
+
printf "Checking for termios ... "
cat > conftest.c <<!
@@ -3067,6 +3464,7 @@ if conftest ; then
have_termios=y
else
printf "no\n"
+ full_repl=
fi
printf "Checking for struct winsize ... "
@@ -3087,6 +3485,9 @@ int main(int argc, char **argv)
printf "yes\n"
printf "#define HAVE_WINSIZE 1\n" >> config.h
have_winsize=y
+ if [ "$termios_define" = __EXTENSIONS__ ] ; then
+ solaris_target=y
+ fi
break;
fi
done
@@ -3095,6 +3496,46 @@ if [ -z "$have_winsize" ] ; then
printf "no\n"
fi
+printf "Checking for mkstemp ... "
+
+cat > conftest.c <<!
+#include <stdlib.h>
+
+int main(int argc, char **argv)
+{
+ char templ[] = "abcXXXXXX";
+ int fd = mkstemp(templ);
+ return 0;
+}
+!
+
+if conftest ; then
+ printf "yes\n"
+ printf "#define HAVE_MKSTEMP 1\n" >> config.h
+else
+ printf "no\n"
+fi
+
+printf "Checking for mkdtemp ... "
+
+cat > conftest.c <<!
+#include <stdlib.h>
+
+int main(int argc, char **argv)
+{
+ char templ[] = "abcXXXXXX";
+ char *s = mkdtemp(templ);
+ return 0;
+}
+!
+
+if conftest ; then
+ printf "yes\n"
+ printf "#define HAVE_MKDTEMP 1\n" >> config.h
+else
+ printf "no\n"
+fi
+
printf "Checking for mkstemps ... "
cat > conftest.c <<!
@@ -3159,54 +3600,157 @@ else
printf "no\n"
fi
-printf "Checking how to enable 64 bit file offsets ... "
+printf "Checking how to enable 64 bit off_t and time_t ..."
+file_offset_only_define=none
+time_bits_only_define=none
file_offset_define=none
+time_bits_define=none
-for try in NOTHING _LARGE_FILES=1 _FILE_OFFSET_BITS=64 ; do
+# We have a nested loop over pairs of options for off_t and time_t
+# because in Glibc, they are not independent. _TIME_BITS=64 cannot
+# be enabled if _FILE_OFFSET_BITS=64 isn't.
+for try_f in NOTHING _LARGE_FILES=1 _FILE_OFFSET_BITS=64; do
+ for try_t in NOTHING _TIME_BITS=64; do
cat > conftest.c <<!
#include <limits.h>
+#include <time.h>
#include <sys/types.h>
-char SIZEOF_BYTE[CHAR_BIT];
-char SIZEOF_OFF_T[sizeof (off_t)];
-char DUMMY;
+
+#define D(N, Z) ((N) ? (N) + '0' : Z)
+#define UD(S) D((S) / 10, ' ')
+#define LD(S) D((S) % 10, '0')
+#define DEC(S) { UD(S), LD(S) }
+
+struct sizes {
+ char h_BYTE[32], s_BYTE[2];
+ char h_OFF_T[32], s_OFF_T[2];
+ char h_TIME_T[32], s_TIME_T[2];
+ char nl[2];
+} foo = {
+ "\nSIZEOF_BYTE=", DEC(CHAR_BIT),
+ "\nSIZEOF_OFF_T=", DEC(sizeof (off_t)),
+ "\nSIZEOF_TIME_T=", DEC(sizeof (time_t)),
+ "\n"
+};
!
- if ! conftest_syms VERBOSE=y EXTRA_FLAGS=-D$try ; then
- printf "failed\n\n"
+ if ! conftest_o EXTRA_FLAGS="-D$try_f -D$try_t" ; then
+ continue
+ fi
- printf "Errors from compilation: \n\n"
- cat conftest.err
- exit 1
- fi
+ eval $(tr '\0' ' ' < conftest.o | grep SIZEOF | sed -e 's/ *//')
- SIZEOF_BYTE=0
- SIZEOF_OFF_T=0
+ if [ $SIZEOF_OFF_T -eq 0 -o $SIZEOF_BYTE -eq 0 ] ; then
+ printf " failed\n"
+ exit 1
+ fi
- read_syms
+ # Regardless of what happens with time_t, if we detect the
+ # enabling of 64 bit off_t, we record then in the
+ # file_offset_only_define variable, and keep going.
+
+ if [ "$file_offset_only_define" = none ] ; then
+ if [ $(( SIZEOF_BYTE * SIZEOF_OFF_T )) -eq 64 ] ; then
+ if [ $try_f = NOTHING ] ; then
+ file_offset_only_define=
+ else
+ file_offset_only_define=$try_f
+ fi
+ fi
+ fi
- if [ $SIZEOF_OFF_T -eq 0 -o $SIZEOF_BYTE -eq 0 ] ; then
- printf "failed\n"
+ # Regardless of what happens with off_t, if we detect the
+ # enabling of 64 bit time_t, we record then in the
+ # time_bits_only_define variable, and keep going.
+
+ if [ "$time_bits_only_define" = none ] ; then
+ if [ $(( SIZEOF_BYTE * SIZEOF_TIME_T )) -eq 64 ] ; then
+ if [ $try_t = NOTHING ] ; then
+ time_bits_only_define=
+ else
+ time_bits_only_define=$try_t
+ fi
+ fi
+ fi
+
+ # If we get a combination of options (or lack thereof) that results in
+ # both 64 bit off_t and time_t, then we record those and are done.
+
+ if [ $(( SIZEOF_BYTE * SIZEOF_OFF_T )) -eq 64 ] && \
+ [ $(( SIZEOF_BYTE * SIZEOF_TIME_T )) -eq 64 ]
+ then
+ if [ $try_f = NOTHING ] ; then
+ file_offset_define=
+ else
+ file_offset_define=$try_f
+ fi
+ if [ $try_t = NOTHING ] ; then
+ time_bits_define=
+ else
+ time_bits_define=$try_t
+ fi
+
+ break
+ fi
+ done
+done
+
+# If 64 bit time_t was not detected, here we check whether we did
+# detect 64 bit off_t in above loop; and copy that auxiliary variable.
+if [ "$time_bits_define" = none -a -n "$file_offset_only_define" ] ; then
+ file_offset_define=$file_offset_only_define
+fi
+
+# Vice versa, if 64 bit off_t was not detected, here we check whether we did
+# detect 64 bit time_t in above loop; and copy that auxiliary variable.
+if [ "$file_offset_define" = none -a -n "$time_bits_only_define" ] ; then
+ time_bits_define=$time_bits_only_define
+fi
+
+case "$time_bits_define" in
+none )
+ if [ "$big_time" ] ; then
+ printf "\n$0: --big-time specified, yet no way to enable 64 bit time_t found\n"
exit 1
fi
-
- if [ $(( SIZEOF_BYTE * SIZEOF_OFF_T )) -eq 64 ] ; then
- if [ $try = NOTHING ] ; then
- printf "default\n"
- file_offset_define=
- else
- printf -- "-D%s\n" $try
- file_offset_define=$try
+ ;;
+"" )
+ if [ $big_time_given ] && [ -z "$big_time" ] ; then
+ printf "\n$0: --no-big-time specified, yet time_t is 64 bits in this system\n"
+ exit 1
+ fi
+ ;;
+* )
+ if [ -n "$big_time_given" ] ; then
+ printf "\n$0: this system has a 32 bit time_t that can be overriden to 64\n"
+ printf "$0: specify --big-time to do this, or --no-big-time not to do it\n"
+ exit 1
+ else
+ if [ -z "$big_time" ]; then
+ printf " (%s disabled by --no-big-time)" "$time_bits_define"
+ time_bits_define=
fi
- break;
fi
-done
+ ;;
+esac
if [ "$file_offset_define" = none ] ; then
- printf "unable\n"
+ printf " (no 64 bit off_t)"
elif [ -n "$file_offset_define" ] ; then
+ printf -- " -D%s" "$file_offset_define"
+ printf "#define CONFIG_LARGE_FILE_OFFSET 1\n" >> config.h
lang_flags="$lang_flags -D$file_offset_define"
fi
+if [ "$time_bits_define" = none ] ; then
+ printf " (no 64 bit time_t)"
+elif [ -n "$time_bits_define" ] ; then
+ printf -- " -D%s" "$time_bits_define"
+ lang_flags="$lang_flags -D$time_bits_define"
+fi
+
+printf "\n"
+
printf "Checking for socket API ... "
cat > conftest.c <<!
@@ -3246,13 +3790,13 @@ if conftest ; then
printf "#define HAVE_SOCKETS 1\n" >> config.h
have_sockets=y
have_sys_types=y
-elif conftest EXTRA_LDFLAGS="-lsocket -lnsl" ; then
+elif conftest EXTRA_LDLIBS="-lsocket -lnsl" ; then
printf "yes\n"
printf "#define HAVE_SOCKETS 1\n" >> config.h
have_sockets=y
have_sys_types=y
- conf_ldflags="${conf_ldflags:+"$conf_ldflags "}-lsocket -lnsl"
- printf "Need libs for sockets: regenerating config.make ..."
+ conf_ldlibs="${conf_ldlibs:+"$conf_ldlibs "}-lsocket -lnsl"
+ printf "Need libs for sockets: regenerating config.make ... "
gen_config_make
printf "done\n"
else
@@ -3260,10 +3804,11 @@ else
fi
if [ $have_sockets ] ; then
- printf "Checking whether we have <sys/select.h> ... "
+ printf "Checking for select ... "
cat > conftest.c <<!
#include <sys/select.h>
+#include <sys/time.h>
int main(int argc, char **argv)
{
@@ -3277,7 +3822,8 @@ int main(int argc, char **argv)
!
if conftest; then
printf "yes\n"
- printf "#define HAVE_SYS_SELECT_H 1\n" >> config.h
+ printf "#define HAVE_SELECT 1\n" >> config.h
+ have_sys_time=y
else
printf "no\n"
fi
@@ -3374,16 +3920,16 @@ int main(void)
if conftest ; then
printf "yes\n"
printf "#define HAVE_DLOPEN 1\n" >> config.h
-elif conftest EXTRA_LDFLAGS=-ldl ; then
+elif conftest EXTRA_LDLIBS=-ldl ; then
printf "yes\n"
printf "#define HAVE_DLOPEN 1\n" >> config.h
- conf_ldflags="${conf_ldflags:+"$conf_ldflags "}-ldl"
+ conf_ldlibs="${conf_ldlibs:+"$conf_ldlibs "}-ldl"
else
printf "no\n"
fi
printf "Checking for dlvsym ... "
-if conftest CONF_LDFLAGS="$conf_ldflags" EXTRA_FLAGS=-DTEST_DLVSYM=1 ; then
+if conftest CONF_LDLIBS="$conf_ldlibs" EXTRA_FLAGS=-DTEST_DLVSYM=1 ; then
printf "yes\n"
printf "#define HAVE_DLVSYM 1\n" >> config.h
else
@@ -3420,16 +3966,19 @@ int main(void)
if conftest ; then
printf "yes\n"
printf "#define HAVE_LIBFFI 1\n" >> config.h
-elif conftest EXTRA_LDFLAGS=-lffi ; then
+elif conftest EXTRA_LDLIBS=-lffi ; then
printf "yes\n"
printf "#define HAVE_LIBFFI 1\n" >> config.h
- conf_ldflags="${conf_ldflags:+"$conf_ldflags "}-lffi"
+ conf_ldlibs="${conf_ldlibs:+"$conf_ldlibs "}-lffi"
elif [ -n "$have_pkgconfig" ] && pkg-config --exists libffi ; then
libffi_cflags=$(pkg-config --cflags libffi)
- libffi_ldflags=$(pkg-config --libs libffi)
- if conftest EXTRA_FLAGS="$libffi_cflags" EXTRA_LDFLAGS="$libffi_ldflags" ; then
+ libffi_ldlibs=$(pkg-config --libs-only-l libffi)
+ libffi_ldflags=$(pkg-config --libs-only-L libffi)
+ if conftest EXTRA_FLAGS="$libffi_cflags" EXTRA_LDFLAGS="$libffi_ldflags" \
+ EXTRA_LDLIBS="$libffi_ldlibs"; then
printf "yes\n"
printf "#define HAVE_LIBFFI 1\n" >> config.h
+ conf_ldlibs="${conf_ldlibs:+"$conf_ldlibs "}$libffi_ldlibs"
conf_ldflags="${conf_ldflags:+"$conf_ldflags "}$libffi_ldflags"
else
printf "no\n"
@@ -3458,6 +4007,26 @@ else
printf "no\n"
fi
+printf "Checking for clock_gettime ... "
+cat > conftest.c <<!
+#include <time.h>
+
+int main(void)
+{
+ struct timespec ts;
+ (void) clock_gettime(CLOCK_REALTIME, &ts);
+ return 0;
+}
+!
+
+if conftest ; then
+ printf "yes\n"
+ printf "#define HAVE_CLOCK_GETTIME 1\n" >> config.h
+ have_sys_types=y
+else
+ printf "no\n"
+fi
+
printf "Checking for loff_t ... "
cat > conftest.c <<!
#include <sys/types.h>
@@ -3513,6 +4082,91 @@ else
printf "no\n"
fi
+printf "Checking for getrlimit ... "
+cat > conftest.c <<!
+#include <sys/resource.h>
+
+int main(void)
+{
+ struct rlimit rl;
+ int res = getrlimit(RLIMIT_STACK, &rl);
+ return 0;
+}
+!
+
+if conftest ; then
+ printf "yes\n"
+ printf "#define HAVE_RLIMIT 1\n" >> config.h
+else
+ printf "no\n"
+fi
+
+if [ $solaris_target ] ; then
+ cat >> config.h <<!
+#include <stddef.h>
+#ifdef __sun__
+#ifdef __cplusplus
+extern "C"
+#endif
+int madvise(void *addr, size_t len, int behav);
+#endif
+!
+fi
+
+printf "Checking for mmap ... "
+cat > conftest.c <<!
+#include <sys/mman.h>
+#include <unistd.h>
+#include <stdlib.h>
+#include "config.h"
+
+int main(void)
+{
+ size_t pgsz = sysconf(_SC_PAGE_SIZE);
+ void *addr = mmap(0, pgsz, PROT_READ | PROT_WRITE | PROT_EXEC,
+ MAP_PRIVATE | MAP_SHARED, -1, 0);
+ if (addr == MAP_FAILED)
+ return EXIT_FAILURE;
+ mprotect(addr, pgsz, PROT_WRITE);
+ madvise(addr, pgsz, MADV_SEQUENTIAL);
+ msync(addr, pgsz, MS_SYNC);
+ munmap(addr, pgsz);
+ return 0;
+}
+!
+
+if conftest ; then
+ printf "yes\n"
+ printf "#define HAVE_MMAP 1\n" >> config.h
+else
+ printf "no\n"
+fi
+
+printf "Checking for zlib ... "
+cat > conftest.c <<!
+#include <zlib.h>
+
+int main(void)
+{
+ gzFile gf = gzopen("foo.gz", "r");
+ gzclose(gf);
+ return 0;
+}
+!
+
+if conftest ; then
+ printf "yes\n"
+ printf "#define HAVE_ZLIB 1\n" >> config.h
+ have_zlib=y
+elif conftest EXTRA_LDLIBS="-lz" ; then
+ printf "yes\n"
+ printf "#define HAVE_ZLIB 1\n" >> config.h
+ conf_ldlibs="${conf_ldlibs:+"$conf_ldlibs "}-lz"
+ have_zlib=y
+else
+ printf "no\n"
+fi
+
#
# Dependent variables
#
@@ -3556,6 +4210,12 @@ $make conftest.clean
[ -n "$gen_gc" ] && printf "#define CONFIG_GEN_GC 1\n" >> config.h
[ "$small_mem" ] && printf "#define CONFIG_SMALL_MEM 1\n" >> config.h
+[ "$full_repl" ] && cat >> config.h <<!
+#if HAVE_TERMIOS
+#define CONFIG_FULL_REPL 1
+#endif
+!
+
#
# Regenerate config.make
#
@@ -3570,9 +4230,9 @@ printf "done\n"
cat > reconfigure <<!
#!/bin/sh
#
-# Configured on $(date) using:
+# Configured on $(date) using these parameters:
-$cmdline
+$cmdline "\$@"
!
#
@@ -3585,11 +4245,12 @@ correct! Please check the above output for any problems, and verify that the
contents of the generated files config.make and config.h are sane for the
target platform.
-The next step is to build the program with $make.
+For details, see the INSTALL guide.
-If that is successful, please follow the INSTALL guide.
+The next step is to build the software by running "$make all".
+The "all" target is the default one, thus it can be omitted.
-Usually, most users just need to "$make tests" and "$make install",
+If that works, most users just need to "$make tests" and "$make install",
possibly switching to superuser for "$make install" if the prefix
points to a privileged location like /usr/local/.
diff --git a/debug.c b/debug.c
index 47672366..1e1e81eb 100644
--- a/debug.c
+++ b/debug.c
@@ -1,4 +1,4 @@
-/* Copyright 2011-2020
+/* Copyright 2011-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,42 +6,33 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stdio.h>
-#include <stdlib.h>
#include <stdarg.h>
#include <wchar.h>
-#include <signal.h>
#include "config.h"
#include "lib.h"
-#include "gc.h"
-#include "args.h"
-#include "signal.h"
-#include "unwind.h"
#include "stream.h"
-#include "parser.h"
-#include "struct.h"
#include "eval.h"
-#include "arith.h"
-#include "txr.h"
#include "debug.h"
int opt_debugger;
@@ -51,17 +42,20 @@ static val sys_print_backtrace_s;
static val dbg_clear(val mask)
{
- return unum(debug_clear(c_unum(mask)));
+ val self = lit("dbg-clear");
+ return unum(debug_clear(c_unum(mask, self)));
}
static val dbg_set(val mask)
{
- return unum(debug_set(c_unum(mask)));
+ val self = lit("dbg-set");
+ return unum(debug_set(c_unum(mask, self)));
}
static val dbg_restore(val state)
{
- debug_restore(c_unum(state));
+ val self = lit("dbg-restore");
+ debug_restore(c_unum(state, self));
return nil;
}
diff --git a/debug.h b/debug.h
index 2294c50a..ee713cbe 100644
--- a/debug.h
+++ b/debug.h
@@ -1,4 +1,4 @@
-/* Copyright 2012-2020
+/* Copyright 2012-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
@@ -73,6 +74,7 @@ void debug_dump_backtrace(val stream, val prefix);
#else
+#define debug_init() ((void) 0)
#define debug_clear(mask) 0
#define debug_set(mask) 0
#define debug_restore(state) ((void) 0)
diff --git a/eval.c b/eval.c
index 805805b3..095313ac 100644
--- a/eval.c
+++ b/eval.c
@@ -1,4 +1,4 @@
-/* Copyright 2010-2020
+/* Copyright 2010-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stddef.h>
@@ -50,17 +51,24 @@
#include "match.h"
#include "txr.h"
#include "combi.h"
-#include "lisplib.h"
+#include "autoload.h"
#include "struct.h"
#include "cadr.h"
#include "filter.h"
#include "tree.h"
#include "vm.h"
+#include "buf.h"
#include "eval.h"
#define max(a, b) ((a) > (b) ? (a) : (b))
#define min(a, b) ((a) < (b) ? (a) : (b))
+#if CONFIG_SMALL_MEM
+#define MAP_ALLOCA_LIMIT 1024
+#else
+#define MAP_ALLOCA_LIMIT 4096
+#endif
+
typedef val (*opfun_t)(val, val);
struct c_var {
@@ -72,11 +80,12 @@ val top_vb, top_fb, top_mb, top_smb, special, builtin;
val op_table, pm_table;
val dyn_env;
-val eval_error_s;
-val dwim_s, progn_s, prog1_s, let_s, let_star_s, lambda_s, call_s, dvbind_s;
+val eval_error_s, case_error_s;
+val dwim_s, progn_s, prog1_s, prog2_s, progv_s, sys_blk_s;
+val let_s, let_star_s, lambda_s, call_s, dvbind_s;
val sys_catch_s, handler_bind_s, cond_s, if_s, iflet_s, when_s, usr_var_s;
val defvar_s, defvarl_s, defparm_s, defparml_s, defun_s, defmacro_s, macro_s;
-val tree_case_s, tree_bind_s, mac_param_bind_s;
+val tree_case_s, tree_bind_s, mac_param_bind_s, mac_env_param_bind_s;
val sys_mark_special_s;
val caseq_s, caseql_s, casequal_s;
val caseq_star_s, caseql_star_s, casequal_star_s;
@@ -85,7 +94,7 @@ val eq_s, eql_s, equal_s, less_s;
val car_s, cdr_s, not_s, vecref_s;
val setq_s, setqf_s, sys_lisp1_value_s, sys_lisp1_setq_s;
val sys_l1_val_s, sys_l1_setq_s;
-val inc_s, zap_s;
+val inc_s;
val for_s, for_star_s, each_s, each_star_s, collect_each_s, collect_each_star_s;
val for_op_s, each_op_s;
val append_each_s, append_each_star_s, while_s, while_star_s, until_star_s;
@@ -100,19 +109,26 @@ val vector_lit_s, vec_list_s, tree_lit_s, tree_construct_s;
val macro_time_s, macrolet_s;
val defsymacro_s, symacrolet_s, prof_s, switch_s, struct_s;
val fbind_s, lbind_s, flet_s, labels_s;
-val load_path_s, load_recursive_s;
-val load_time_s, load_time_lit_s;
-val eval_only_s, compile_only_s;
+val load_path_s, load_hooks_s, load_recursive_s, load_search_dirs_s;
+val load_args_s, load_time_s, load_time_lit_s;
+val eval_only_s, compile_only_s, compiler_let_s;
+val const_foldable_s;
+val pct_fun_s;
val special_s, unbound_s;
-val whole_k, form_k, symacro_k;
+val whole_k, form_k, symacro_k, macro_k;
val last_form_evaled;
-val call_f;
+val call_f, iter_begin_f, iter_from_binding_f, iter_more_f;
+val iter_item_f, iter_step_f;
+val join_f;
val origin_hash;
+static val unused_arg_s;
+static val const_foldable_hash;
+
val make_env(val vbindings, val fbindings, val up_env)
{
val env = make_obj();
@@ -128,11 +144,13 @@ val copy_env(val oenv)
type_check(lit("copy-env"), oenv, ENV);
{
+ val vb = copy_alist(oenv->e.vbindings);
+ val fb = copy_alist(oenv->e.fbindings);
val nenv = make_obj();
nenv->e.type = ENV;
- nenv->e.vbindings = copy_alist(oenv->e.vbindings);
- nenv->e.fbindings = copy_alist(oenv->e.fbindings);
+ nenv->e.vbindings = vb;
+ nenv->e.fbindings = fb;
nenv->e.up_env = oenv->e.up_env;
return nenv;
}
@@ -143,13 +161,16 @@ val deep_copy_env(val oenv)
type_check(lit("deep-copy-env"), oenv, ENV);
{
+ val vb = copy_alist(oenv->e.vbindings);
+ val fb = copy_alist(oenv->e.fbindings);
+ val up_env = if2(oenv->e.up_env != nil,
+ deep_copy_env(oenv->e.up_env));
val nenv = make_obj();
- nenv->e.type = ENV;
- nenv->e.vbindings = copy_alist(oenv->e.vbindings);
- nenv->e.fbindings = copy_alist(oenv->e.fbindings);
- nenv->e.up_env = if2(oenv->e.up_env != nil,
- deep_copy_env(oenv->e.up_env));
+ nenv->e.type = ENV;
+ nenv->e.vbindings = vb;
+ nenv->e.fbindings = fb;
+ nenv->e.up_env = up_env;
return nenv;
}
}
@@ -176,11 +197,7 @@ val env_fbind(val env, val sym, val fun)
cell = acons_new_c(sym, nulloc, mkloc(env->e.fbindings, env));
return rplacd(cell, fun);
} else {
- loc pcdr = gethash_l(self, top_fb, sym, nulloc);
- val cell = deref(pcdr);
- if (cell)
- return rplacd(cell, fun);
- return set(pcdr, cons(sym, fun));
+ return sethash(top_fb, sym, fun);
}
}
@@ -194,11 +211,7 @@ val env_vbind(val env, val sym, val obj)
cell = acons_new_c(sym, nulloc, mkloc(env->e.vbindings, env));
return rplacd(cell, obj);
} else {
- loc pcdr = gethash_l(self, top_vb, sym, nulloc);
- val cell = deref(pcdr);
- if (cell)
- return rplacd(cell, obj);
- return set(pcdr, cons(sym, obj));
+ return sethash(top_vb, sym, obj);
}
}
@@ -283,29 +296,40 @@ val ctx_name(val obj)
return nil;
}
-noreturn static void eval_exception(val sym, val ctx, val fmt, va_list vl)
+static void eval_exception(val sym, val ctx, val fmt, int ex_time, va_list vl)
{
uses_or2;
val form = ctx_form(ctx);
val stream = make_string_output_stream();
val loc = or2(source_loc_str(form, nil),
source_loc_str(last_form_evaled, nil));
+ val msg;
if (loc)
- format(stream, lit("(~a) "), loc, nao);
+ format(stream, lit("~a: "), loc, nao);
(void) vformat(stream, fmt, vl);
- uw_release_deferred_warnings();
+ msg = get_string_from_stream(stream);
+
+ if (ex_time) {
+ val loading = cdr(lookup_var(nil, load_recursive_s));
+ val error_caught = uw_find_frame(error_s, catch_frame_s);
+
+ if (loading && !error_caught) {
+ uw_dump_deferred_warnings(std_error);
+ put_line(msg, std_error);
+ }
+ }
- uw_throw(sym, get_string_from_stream(stream));
+ uw_rthrow(sym, msg);
}
-noreturn val eval_error(val ctx, val fmt, ...)
+NORETURN val eval_error(val ctx, val fmt, ...)
{
va_list vl;
va_start (vl, fmt);
- eval_exception(eval_error_s, ctx, fmt, vl);
+ eval_exception(eval_error_s, ctx, fmt, 0, vl);
va_end (vl);
abort();
}
@@ -317,7 +341,7 @@ static val eval_warn(val ctx, val fmt, ...)
uw_catch_begin (cons(continue_s, nil), exsym, exvals);
va_start (vl, fmt);
- eval_exception(warning_s, ctx, fmt, vl);
+ eval_exception(warning_s, ctx, scat2(lit("warning: "), fmt), 0, vl);
va_end (vl);
uw_catch(exsym, exvals) { (void) exsym; (void) exvals; }
@@ -345,12 +369,12 @@ static val eval_defr_warn(val ctx, val tag, val fmt, ...)
source_loc_str(last_form_evaled, nil));
if (loc)
- format(stream, lit("(~a) "), loc, nao);
+ format(stream, lit("~a: "), loc, nao);
- (void) vformat(stream, fmt, vl);
+ (void) vformat(stream, scat2(lit("warning: "), fmt), vl);
- uw_throw(defr_warning_s,
- cons(get_string_from_stream(stream), cons(tag, nil)));
+ uw_rthrow(defr_warning_s,
+ cons(get_string_from_stream(stream), cons(tag, nil)));
}
uw_catch(exsym, exvals) { (void) exsym; (void) exvals; }
@@ -364,6 +388,15 @@ static val eval_defr_warn(val ctx, val tag, val fmt, ...)
return nil;
}
+static NORETURN val expand_error(val ctx, val fmt, ...)
+{
+ va_list vl;
+ va_start (vl, fmt);
+ eval_exception(eval_error_s, ctx, fmt, 1, vl);
+ va_end (vl);
+ abort();
+}
+
val lookup_origin(val form)
{
return gethash(origin_hash, form);
@@ -390,6 +423,17 @@ void error_trace(val exsym, val exvals, val out_stream, val prefix)
val last = last_form_evaled;
val xlast = uw_last_form_expanded();
val info = source_loc_str(last, nil);
+ val max_length = nil, max_depth = nil;
+ val saved_de = set_dyn_env(make_env(nil, nil, dyn_env));
+
+ env_vbind(dyn_env, print_circle_s, t);
+
+ uw_dump_deferred_warnings(out_stream);
+
+ if (uw_exception_subtype_p(exsym, stack_overflow_s)) {
+ max_length = set_max_length(out_stream, num_fast(5));
+ max_depth = set_max_depth(out_stream, num_fast(5));
+ }
if (cdr(exvals) || !stringp(car(exvals)))
format(out_stream, lit("~a exception args: ~!~s\n"),
@@ -473,19 +517,27 @@ void error_trace(val exsym, val exvals, val out_stream, val prefix)
if (dbg_backtrace) {
format(out_stream, lit("~a backtrace:\n"), prefix, nao);
debug_dump_backtrace(out_stream, prefix);
- } else {
- format(std_error, lit("~a run with --backtrace to enable backtraces\n"), prefix, nao);
}
-#else
- format(std_error, lit("~a not compiled with backtrace support\n"), prefix, nao);
#endif
+
+ if (max_length) {
+ set_max_length(out_stream, max_length);
+ set_max_depth(out_stream, max_depth);
+ }
+
+ dyn_env = saved_de;
}
val lookup_global_var(val sym)
{
uses_or2;
- return or2(gethash(top_vb, sym),
- if2(lisplib_try_load(sym), gethash(top_vb, sym)));
+ return or2(gethash_d(top_vb, sym),
+ if2(autoload_try_var(sym), gethash_d(top_vb, sym)));
+}
+
+val lookup_global_fun(val sym)
+{
+ return lookup_fun(nil, sym);
}
val lookup_var(val env, val sym)
@@ -537,22 +589,28 @@ val lookup_sym_lisp1(val env, val sym)
return binding;
}
- return or3(gethash(top_vb, sym),
- if2(lisplib_try_load(sym),
- gethash(top_vb, sym)),
- gethash(top_fb, sym));
+ return or3(gethash_d(top_vb, sym),
+ if2(autoload_try_fun_var(sym),
+ gethash_d(top_vb, sym)),
+ gethash_d(top_fb, sym));
}
loc lookup_var_l(val env, val sym)
{
val binding = lookup_var(env, sym);
- return if3(binding, cdr_l(binding), nulloc);
+ if (binding)
+ return cdr_l(binding);
+ uw_throwf(error_s, lit("variable ~s unexpectedly unbound"), sym, nao);
+}
+
+val lookup_dynamic_var(val sym)
+{
+ return lookup_var(nil, sym);
}
-loc lookup_global_var_l(val sym)
+val lookup_dynamic_sym_lisp1(val sym)
{
- val binding = lookup_global_var(sym);
- return if3(binding, cdr_l(binding), nulloc);
+ return lookup_sym_lisp1(nil, sym);
}
static val lookup_mac(val menv, val sym);
@@ -566,7 +624,7 @@ val lookup_fun(val env, val sym)
val strct = cadr(sym);
val slot = caddr(sym);
val type = or2(find_struct_type(strct),
- if2(lisplib_try_load(strct),
+ if2(autoload_try_struct(strct),
find_struct_type(strct)));
if (slot == init_k) {
return cons(sym, struct_get_initfun(type));
@@ -579,7 +637,7 @@ val lookup_fun(val env, val sym)
} else if (car(sym) == macro_s) {
return lookup_mac(nil, cadr(sym));
} else if (car(sym) == lambda_s) {
- return cons(sym, func_interp(env, sym));
+ return cons(sym, func_interp(env, expand(sym, nil)));
} else {
return nil;
}
@@ -595,8 +653,8 @@ val lookup_fun(val env, val sym)
}
}
- return or2(gethash(top_fb, sym),
- if2(lisplib_try_load(sym), gethash(top_fb, sym)));
+ return or2(gethash_d(top_fb, sym),
+ if2(autoload_try_fun(sym), gethash_d(top_fb, sym)));
}
val func_get_name(val fun, val env)
@@ -624,10 +682,10 @@ val func_get_name(val fun, val env)
{
val name;
- if ((name = hash_revget(top_fb, fun, eq_f, cdr_f)))
+ if ((name = hash_revget(top_fb, fun, eq_f, nil)))
return name;
- if ((name = hash_revget(top_mb, fun, eq_f, cdr_f)))
+ if ((name = hash_revget(top_mb, fun, eq_f, nil)))
return list(macro_s, name, nao);
if ((name = method_name(fun)))
@@ -645,8 +703,8 @@ static val lookup_mac(val menv, val sym)
uses_or2;
if (nilp(menv)) {
- return or2(gethash(top_mb, sym),
- if2(lisplib_try_load(sym), gethash(top_mb, sym)));
+ return or2(gethash_d(top_mb, sym),
+ if2(autoload_try_fun(sym), gethash_d(top_mb, sym)));
} else {
type_check(lit("macro lookup"), menv, ENV);
@@ -664,8 +722,8 @@ static val lookup_symac(val menv, val sym)
uses_or2;
if (nilp(menv)) {
- return or2(gethash(top_smb, sym),
- if2(lisplib_try_load(sym), gethash(top_smb, sym)));
+ return or2(gethash_d(top_smb, sym),
+ if2(autoload_try_var(sym), gethash_d(top_smb, sym)));
} else {
type_check(lit("symacro lookup"), menv, ENV);
@@ -683,8 +741,8 @@ static val lookup_symac_lisp1(val menv, val sym)
uses_or2;
if (nilp(menv)) {
- return or2(gethash(top_smb, sym),
- if2(lisplib_try_load(sym), gethash(top_smb, sym)));
+ return or2(gethash_d(top_smb, sym),
+ if2(autoload_try_var(sym), gethash_d(top_smb, sym)));
} else {
type_check(lit("symacro lookup"), menv, ENV);
@@ -709,44 +767,98 @@ static val lookup_symac_lisp1(val menv, val sym)
static val reparent_env(val child, val parent)
{
- child->e.up_env = parent;
+ set(mkloc(child->e.up_env, child), parent);
return child;
}
-static val lexical_var_p(val menv, val sym)
+static val special_var_p(val sym)
+{
+ uses_or2;
+ return or2(gethash(special, sym),
+ if2(autoload_try_var(sym), gethash(special, sym)));
+}
+
+static val lexical_binding_kind(val menv, val sym)
{
if (nilp(menv)) {
return nil;
} else {
- type_check(lit("lexical-var-p"), menv, ENV);
+ type_check(lit("lexical-binding-kind"), menv, ENV);
{
val binding = assoc(sym, menv->e.vbindings);
- if (binding) /* special_s: see make_var_shadowing_env */
- return tnil(cdr(binding) == special_s);
- return lexical_var_p(menv->e.up_env, sym);
+ if (binding) {
+ /* special_s: see make_var_shadowing_env */
+ if (cdr(binding) != special_s)
+ return symacro_k;
+ else if (special_var_p(sym))
+ return nil;
+ return var_k;
+ }
}
+
+ return lexical_binding_kind(menv->e.up_env, sym);
}
}
-static val lexical_fun_p(val menv, val sym)
+static val lexical_fun_binding_kind(val menv, val sym)
{
if (nilp(menv)) {
return nil;
} else {
- type_check(lit("lexical-fun-p"), menv, ENV);
+ type_check(lit("lexical-fun-binding-kind"), menv, ENV);
{
val binding = assoc(sym, menv->e.fbindings);
- if (binding) /* special_s: see make_var_shadowing_env */
+ /* special_s: see make_var_shadowing_env */
+ if (binding)
+ return if3(cdr(binding) == special_s,
+ fun_k, macro_k);
+ }
+
+ return lexical_fun_binding_kind(menv->e.up_env, sym);
+ }
+}
+
+static val lexical_var_p(val menv, val sym)
+{
+ return eq(lexical_binding_kind(menv, sym), var_k);
+}
+
+static val lexical_symacro_p(val menv, val sym)
+{
+ return eq(lexical_binding_kind(menv, sym), symacro_k);
+}
+
+static val old_lexical_var_p(val menv, val sym)
+{
+ if (nilp(menv)) {
+ return nil;
+ } else {
+ type_check(lit("lexical-var-p"), menv, ENV);
+
+ {
+ val binding = assoc(sym, menv->e.vbindings);
+
+ if (binding)
return tnil(cdr(binding) == special_s);
- return lexical_fun_p(menv->e.up_env, sym);
+ return lexical_var_p(menv->e.up_env, sym);
}
}
}
+static val lexical_fun_p(val menv, val sym)
+{
+ return eq(lexical_fun_binding_kind(menv, sym), fun_k);
+}
+
+static val lexical_macro_p(val menv, val sym)
+{
+ return eq(lexical_fun_binding_kind(menv, sym), macro_k);
+}
+
static val lexical_lisp1_binding(val menv, val sym)
{
if (nilp(menv)) {
@@ -757,9 +869,14 @@ static val lexical_lisp1_binding(val menv, val sym)
{
val binding = assoc(sym, menv->e.vbindings);
- if (binding) /* special_s: see make_var_shadowing_env */
- return if3(cdr(binding) == special_s,
- var_k, symacro_k);
+ if (binding) {
+ /* special_s: see make_var_shadowing_env */
+ if (cdr(binding) != special_s)
+ return symacro_k;
+ else if (special_var_p(sym))
+ return nil;
+ return var_k;
+ }
}
{
@@ -778,14 +895,7 @@ static val mark_special(val sym)
return sethash(special, sym, t);
}
-static val special_var_p(val sym)
-{
- uses_or2;
- return or2(gethash(special, sym),
- if2(lisplib_try_load(sym), gethash(special, sym)));
-}
-
-static void copy_env_handler(mem_t *ptr, int parent)
+static void copy_env_handler(mem_t *ptr)
{
val *penv = coerce(val *, ptr);
*penv = copy_env(*penv);
@@ -870,7 +980,7 @@ INLINE void lex_or_dyn_bind(val *dyn_made, val lex_env, val sym, val obj)
}
}
-static val bind_args(val env, val params, struct args *args, val ctx)
+static val bind_args(val env, val params, varg args, val ctx)
{
val new_env = make_env(nil, nil, env);
val dyn_env_made = nil;
@@ -910,11 +1020,10 @@ static val bind_args(val env, val params, struct args *args, val ctx)
val present = nil;
if (arg == colon_k) {
- if (initform) {
+ if (initform)
initval = eval(initform, new_env, ctx);
- new_env = lex_or_dyn_bind_seq(&dyn_env_made, new_env,
- param, initval);
- }
+ new_env = lex_or_dyn_bind_seq(&dyn_env_made, new_env,
+ param, initval);
} else {
lex_or_dyn_bind(&dyn_env_made, new_env, param, arg);
present = t;
@@ -967,10 +1076,38 @@ static val bind_args(val env, val params, struct args *args, val ctx)
return new_env;
}
-noreturn static val not_bindable_error(val form, val sym)
+static void missing_arg_error(val form, val sym)
+{
+ expand_error(form, lit("~s: missing argument material"), sym, nao);
+}
+
+static void excess_args_error(val form, val sym)
{
- eval_error(form, lit("~s: ~s is not a bindable symbol"),
- car(form), sym, nao);
+ expand_error(form, lit("~s: excess arguments"), sym, nao);
+}
+
+static void no_dot_check(val form, val sym)
+{
+ if (!proper_list_p(form))
+ expand_error(form, lit("~s: dotted argument list not supported"), sym, nao);
+}
+
+static void syn_check(val form, val sym,
+ val (*have_required_p)(val),
+ val (*have_excess_p)(val))
+{
+ no_dot_check(form, sym);
+ if (!have_required_p(form))
+ missing_arg_error(form, sym);
+ if (have_excess_p && have_excess_p(form))
+ excess_args_error(form, sym);
+}
+
+
+NORETURN static val not_bindable_error(val form, val sym)
+{
+ expand_error(form, lit("~s: ~s is not a bindable symbol"),
+ car(form), sym, nao);
}
static val not_bindable_warning(val form, val sym)
@@ -983,18 +1120,20 @@ static val make_var_shadowing_env(val menv, val vars);
static val get_param_syms(val params);
-static val expand_params_rec(val params, val menv,
- val macro_style_p, val form);
+static val expand_params_rec(val params, val menv, val macro_style_p,
+ val body, val form);
+
+static val expand_param_macro(val params, val body, val menv, val form);
static val expand_opt_params_rec(val params, val menv,
- val macro_style_p, val form)
+ val macro_style_p, val body, val form)
{
- if (!params) {
- return params;
+ if (!params || (params == t && macro_style_p)) {
+ return cons(params, body);
} else if (atom(params)) {
if (!bindable(params))
not_bindable_error(form, params);
- return params;
+ return cons(params, body);
} else {
val pair = car(params);
if (atom(pair)) {
@@ -1002,40 +1141,42 @@ static val expand_opt_params_rec(val params, val menv,
if (pair == whole_k || pair == form_k || pair == env_k) {
if (!macro_style_p)
- eval_error(form, lit("~s: ~s not usable in function parameter list"),
- car(form), pair, nao);
+ expand_error(form, lit("~s: ~s not usable in function parameter list"),
+ car(form), pair, nao);
if (!consp(cdr(params)))
- eval_error(form, lit("~s: ~s parameter requires name"),
- car(form), pair, nao);
+ expand_error(form, lit("~s: ~s parameter requires name"),
+ car(form), pair, nao);
if (pair == env_k && !bindable(cadr(params)))
- eval_error(form, lit("~s: ~s parameter requires bindable symbol"),
- car(form), pair, nao);
- } else if (!bindable(pair)) {
+ expand_error(form, lit("~s: ~s parameter requires bindable symbol"),
+ car(form), pair, nao);
+ } else if (!bindable(pair) && (!macro_style_p || pair != t)) {
if (pair == colon_k)
- eval_error(form, lit("~s: multiple colons in parameter list"),
- car(form), nao);
+ expand_error(form, lit("~s: multiple colons in parameter list"),
+ car(form), nao);
not_bindable_error(form, pair);
- } else {
- new_menv = make_var_shadowing_env(menv, pair);
+ } else if (pair != t) {
+ new_menv = make_var_shadowing_env(menv, pair);
}
{
- val params_ex = expand_opt_params_rec(cdr(params), new_menv,
- macro_style_p, form);
-
-
- if (params_ex == cdr(params))
- return params;
- return rlcp(cons(pair, params_ex), cdr(params));
+ val rest_params = cdr(params);
+ cons_bind (params_ex, body_ex,
+ expand_opt_params_rec(rest_params, new_menv,
+ macro_style_p, body, form));
+ if (params_ex == rest_params && body_ex == body)
+ return cons(params, body);
+ return cons(rlcp(cons(pair, params_ex), rest_params), body_ex);
}
} else if (!macro_style_p && !bindable(car(pair))) {
- eval_error(form, lit("~s: parameter symbol expected, not ~s"),
- car(form), car(pair), nao);
+ expand_error(form, lit("~s: parameter symbol expected, not ~s"),
+ car(form), car(pair), nao);
} else {
val param = car(pair);
- val param_ex = expand_params_rec(param, menv,
- macro_style_p,
- form);
+ cons_bind (param_ex0, body_ex0,
+ expand_param_macro(param, body, menv, form));
+ cons_bind (param_ex, body_ex,
+ expand_params_rec(param_ex0, menv, macro_style_p,
+ body_ex0, form));
val initform = cadr(pair);
val initform_ex = rlcp(expand(initform, menv), initform);
val opt_sym = caddr(pair);
@@ -1045,39 +1186,47 @@ static val expand_opt_params_rec(val params, val menv,
val new_menv = make_var_shadowing_env(menv, get_param_syms(param_ex));
if (cdddr(pair))
- eval_error(form, lit("~s: extra forms ~s in ~s"),
- car(form), pair, cdddr(pair), nao);
+ expand_error(form, lit("~s: extra forms ~s in ~s"),
+ car(form), pair, cdddr(pair), nao);
if (opt_sym) {
- if (!bindable(opt_sym))
+ if (!bindable(opt_sym) && (!macro_style_p || opt_sym != t))
not_bindable_error(form, opt_sym);
}
- return rlcp(cons(form_ex, expand_opt_params_rec(rest(params), new_menv,
- macro_style_p, form)),
- cdr(params));
+ {
+ val rest_params = cdr(params);
+ cons_bind (rest_params_ex, body_ex,
+ expand_opt_params_rec(rest_params, new_menv,
+ macro_style_p, body_ex, form));
+
+ return cons(rlcp(cons(form_ex, rest_params_ex), rest_params),
+ body_ex);
+ }
}
}
}
static val expand_params_rec(val params, val menv,
- val macro_style_p, val form)
+ val macro_style_p, val body, val form)
{
if (!params) {
- return params;
+ return cons(params, body);
} else if (atom(params)) {
- if (!bindable(params))
+ if (!bindable(params) && (!macro_style_p || params != t))
not_bindable_error(form, params);
- return params;
+ return cons(params, body);
} else if (car(params) == colon_k) {
- val params_ex = expand_opt_params_rec(cdr(params), menv,
- macro_style_p, form);
- if (params_ex == cdr(params))
- return params;
- return rlcp(cons(colon_k, params_ex), cdr(params));
+ cons_bind (params_ex, body_ex,
+ expand_opt_params_rec(cdr(params), menv,
+ macro_style_p, body, form));
+ if (params_ex == cdr(params) && body_ex == body)
+ return cons(params, body);
+ return cons(rlcp(cons(colon_k, params_ex), cdr(params)),
+ body_ex);
} else if (!macro_style_p && consp(car(params))) {
- eval_error(form, lit("~s: parameter symbol expected, not ~s"),
- car(form), car(params), nao);
+ expand_error(form, lit("~s: parameter symbol expected, not ~s"),
+ car(form), car(params), nao);
} else {
val param = car(params);
val param_ex;
@@ -1085,29 +1234,40 @@ static val expand_params_rec(val params, val menv,
if (param == whole_k || param == form_k || param == env_k) {
if (!macro_style_p)
- eval_error(form, lit("~s: ~s not usable in function parameter list"),
- car(form), param, nao);
+ expand_error(form, lit("~s: ~s not usable in function parameter list"),
+ car(form), param, nao);
if (!consp(cdr(params)))
- eval_error(form, lit("~s: ~s parameter requires name"),
- car(form), param, nao);
+ expand_error(form, lit("~s: ~s parameter requires name"),
+ car(form), param, nao);
if (param == env_k && !bindable(cadr(params)))
- eval_error(form, lit("~s: ~s parameter requires bindable symbol"),
- car(form), param, nao);
+ expand_error(form, lit("~s: ~s parameter requires bindable symbol"),
+ car(form), param, nao);
param_ex = param;
- } else if (bindable(param) || (macro_style_p && listp(param))) {
- param_ex = expand_params_rec(param, menv, t, form);
+ } else if (bindable(param) || (macro_style_p &&
+ (listp(param) || param == t)))
+ {
+ cons_bind (param_ex0, body_ex0,
+ expand_param_macro(param, body, menv, form));
+ cons_bind (param_ex1, body_ex1,
+ expand_params_rec(param_ex0, menv, t, body_ex0, form));
+ param_ex = param_ex1;
+ body = body_ex1;
new_menv = make_var_shadowing_env(menv, get_param_syms(param_ex));
} else {
not_bindable_error(form, param);
}
{
- val params_ex = expand_params_rec(cdr(params), new_menv,
- macro_style_p,
- form);
- if (param_ex == car(params) && params_ex == cdr(params))
- return params;
- return rlcp(cons(param_ex, params_ex), params);
+ cons_bind (params_ex, body_ex,
+ expand_params_rec(cdr(params), new_menv, macro_style_p,
+ body, form));
+
+ if (param_ex == car(params) && params_ex == cdr(params) &&
+ body_ex == body)
+ {
+ return cons(params, body);
+ }
+ return cons(rlcp(cons(param_ex, params_ex), params), body_ex);
}
}
}
@@ -1125,11 +1285,11 @@ static val expand_param_macro(val params, val body, val menv, val form)
return cons(params, body);
if (!pmac) {
- lisplib_try_load(sym);
+ autoload_try_keyword(sym);
pmac = gethash(pm_table, sym);
if (!pmac)
- eval_error(form, lit("~s: keyword ~s has no param macro binding"),
- car(form), sym, nao);
+ expand_error(form, lit("~s: keyword ~s has no param macro binding"),
+ car(form), sym, nao);
}
{
@@ -1148,9 +1308,8 @@ static val expand_param_macro(val params, val body, val menv, val form)
static val expand_params(val params, val body, val menv,
val macro_style_p, val form)
{
- cons_bind (params_ex0, body_ex, expand_param_macro(params, body, menv, form));
- val params_ex = expand_params_rec(params_ex0, menv, macro_style_p, form);
- return cons(params_ex, body_ex);
+ cons_bind (params_ex, body_ex, expand_param_macro(params, body, menv, form));
+ return expand_params_rec(params_ex, menv, macro_style_p, body_ex, form);
}
static val get_opt_param_syms(val params)
@@ -1233,7 +1392,7 @@ static val apply_intrinsic_frob_args(val args)
}
}
-val applyv(val fun, struct args *args)
+val applyv(val fun, varg args)
{
args_normalize_least(args, 1);
@@ -1255,7 +1414,7 @@ static loc term(loc head)
return head;
}
-static val iapply(val fun, struct args *args)
+static val iapply(val fun, varg args)
{
cnum index = 0;
list_collect_decl (mod_args, ptail);
@@ -1286,13 +1445,14 @@ static val iapply(val fun, struct args *args)
return apply(fun, z(mod_args));
}
-static val list_star_intrinsic(struct args *args)
+static val list_star_intrinsic(varg args)
{
return apply_frob_args(args_get_list(args));
}
static val bind_macro_params(val env, val menv, val params, val form,
- val loose_p, val ctx_form)
+ val loose_p, val ctx_form,
+ val (*error_fn)(val ctx, val fmt, ...))
{
val new_env = make_env(nil, nil, env);
val dyn_env_made = nil;
@@ -1312,16 +1472,15 @@ static val bind_macro_params(val env, val menv, val params, val form,
if3(param == form_k,
ctx_form, menv));
if (!consp(next))
- eval_error(ctx_form, lit("~s: dangling ~s in param list"),
- car(ctx_form), param, nao);
+ error_fn(ctx_form, lit("~s: dangling ~s in param list"),
+ car(ctx_form), param, nao);
nparam = car(next);
if (atom(nparam)) {
lex_or_dyn_bind(&dyn_env_made, new_env, nparam, bform);
- } else {
- new_env = bind_macro_params(new_env, menv,
- nparam, bform,
- loose_p, ctx_form);
+ } else if (param != t) {
+ new_env = bind_macro_params(new_env, menv, nparam, bform,
+ loose_p, ctx_form, error_fn);
if (!new_env)
goto nil_out;
}
@@ -1343,7 +1502,7 @@ static val bind_macro_params(val env, val menv, val params, val form,
if (!listp(param)) {
lex_or_dyn_bind(&dyn_env_made, new_env, param, car(form));
- } else {
+ } else if (param != t) {
if (optargs) {
val nparam = pop(&param);
val initform = pop(&param);
@@ -1351,15 +1510,14 @@ static val bind_macro_params(val env, val menv, val params, val form,
(void) initform;
- new_env = bind_macro_params(new_env, menv,
- nparam, car(form), t, ctx_form);
+ new_env = bind_macro_params(new_env, menv, nparam, car(form),
+ t, ctx_form, error_fn);
if (presentsym)
lex_or_dyn_bind(&dyn_env_made, new_env, presentsym, t);
} else {
- new_env = bind_macro_params(new_env, menv,
- param, car(form),
- loose_p, ctx_form);
+ new_env = bind_macro_params(new_env, menv, param, car(form),
+ loose_p, ctx_form, error_fn);
if (!new_env)
goto nil_out;
}
@@ -1372,14 +1530,14 @@ static val bind_macro_params(val env, val menv, val params, val form,
if (form) {
if (loose_p == colon_k)
goto nil_out;
- eval_error(ctx_form, lit("~s: atom ~s not matched by params ~s"),
- car(ctx_form), form, params, nao);
+ error_fn(ctx_form, lit("~s: atom ~s not matched by params ~s"),
+ car(ctx_form), form, params, nao);
}
if (!optargs) {
if (!loose_p)
- eval_error(ctx_form, lit("~s: missing arguments for params ~s"),
- car(ctx_form), params, nao);
+ error_fn(ctx_form, lit("~s: missing arguments for params ~s"),
+ car(ctx_form), params, nao);
if (loose_p == colon_k)
goto nil_out;
}
@@ -1387,18 +1545,18 @@ static val bind_macro_params(val env, val menv, val params, val form,
noarg:
if (!listp(param)) {
lex_or_dyn_bind(&dyn_env_made, new_env, param, nil);
- } else {
+ } else if (param != t) {
val nparam = pop(&param);
val initform = pop(&param);
val presentsym = pop(&param);
if (initform) {
val initval = eval(initform, new_env, ctx_form);
- new_env = bind_macro_params(new_env, menv,
- nparam, initval, t, ctx_form);
+ new_env = bind_macro_params(new_env, menv, nparam, initval,
+ t, ctx_form, error_fn);
} else {
- new_env = bind_macro_params(new_env, menv,
- nparam, nil, t, ctx_form);
+ new_env = bind_macro_params(new_env, menv, nparam, nil,
+ t, ctx_form, error_fn);
}
if (presentsym)
@@ -1408,6 +1566,9 @@ noarg:
params = cdr(params);
}
+ if (params == t)
+ goto out;
+
if (params) {
lex_or_dyn_bind(&dyn_env_made, new_env, params, form);
goto out;
@@ -1416,9 +1577,9 @@ noarg:
if (form) {
if (loose_p == colon_k)
goto nil_out;
- eval_error(ctx_form,
- lit("~s: extra form part ~s not matched by parameter list"),
- car(ctx_form), form, nao);
+ error_fn(ctx_form,
+ lit("~s: extra form part ~s not matched by parameter list"),
+ car(ctx_form), form, nao);
}
out:
@@ -1430,12 +1591,12 @@ nil_out:
return nil;
}
-static val do_eval(val form, val env, val ctx,
- val (*lookup)(val env, val sym));
+static val do_eval(val form, val env,
+ val ctx, val (*lookup)(val env, val sym));
static void do_eval_args(val form, val env, val ctx,
val (*lookup)(val env, val sym),
- struct args *args)
+ varg args)
{
for (; form; form = cdr(form))
args_add(args, do_eval(car(form), env, ctx, lookup));
@@ -1448,7 +1609,7 @@ val set_dyn_env(val de)
return old;
}
-val funcall_interp(val interp_fun, struct args *args)
+val funcall_interp(val interp_fun, varg args)
{
val env = interp_fun->f.env;
val fun = interp_fun->f.f.interp_fun;
@@ -1467,7 +1628,7 @@ static val expand_eval(val form, val env, val menv)
val lfe_save = last_form_evaled;
val form_ex = (last_form_evaled = nil,
expand(form, menv));
- val loading = cdr(lookup_var(dyn_env, load_recursive_s));
+ val loading = cdr(lookup_var(nil, load_recursive_s));
val ret = ((void) (loading || uw_release_deferred_warnings()),
eval(form_ex, default_null_arg(env), form));
last_form_evaled = lfe_save;
@@ -1476,9 +1637,9 @@ static val expand_eval(val form, val env, val menv)
static val macroexpand(val form, val menv);
-val eval_intrinsic(val form, val env)
+val eval_intrinsic(val form, val env, val menv_in)
{
- val menv = env_to_menv(default_null_arg(env), lit("eval"), nil);
+ val menv = env_to_menv(default_null_arg(env), lit("eval"), menv_in);
val form_ex = macroexpand(form, menv);
val op;
@@ -1508,7 +1669,7 @@ val eval_intrinsic_noerr(val form, val env, val *error_p)
uw_catch_begin (cons(t, nil), exsym, exvals);
- result = eval_intrinsic(form, env);
+ result = eval_intrinsic(form, env, nil);
uw_catch(exsym, exvals) {
(void) exsym; (void) exvals;
@@ -1528,16 +1689,23 @@ val eval_intrinsic_noerr(val form, val env, val *error_p)
static val do_eval(val form, val env, val ctx,
val (*lookup)(val env, val sym))
{
+ val self = lit("eval");
+#if CONFIG_DEBUG_SUPPORT
uw_frame_t *ev = 0;
+#endif
val ret = nil;
+#if CONFIG_DEBUG_SUPPORT
if (dbg_backtrace) {
ev = coerce(uw_frame_t *, alloca(sizeof *ev));
uw_push_eval(ev, form, env);
}
+#endif
sig_check_fast();
+ gc_stack_check();
+
if (form && symbolp(form)) {
if (!bindable(form)) {
ret = form;
@@ -1569,7 +1737,7 @@ static val do_eval(val form, val env, val ctx,
abort();
} else {
val arglist = rest(form);
- cnum alen = if3(consp(arglist), c_num(length(arglist)), 0);
+ cnum alen = if3(consp(arglist), c_num(length(arglist), self), 0);
cnum argc = max(alen, ARGS_MIN);
val lfe_save = last_form_evaled;
args_decl(args, argc);
@@ -1586,8 +1754,10 @@ static val do_eval(val form, val env, val ctx,
ret = form;
}
+#if CONFIG_DEBUG_SUPPORT
if (ev != 0)
uw_pop_frame(ev);
+#endif
return ret;
}
@@ -1597,7 +1767,7 @@ val eval(val form, val env, val ctx)
return do_eval(form, env, ctx, &lookup_var);
}
-static void eval_args_lisp1(val form, val env, val ctx, struct args *args)
+static void eval_args_lisp1(val form, val env, val ctx, varg args)
{
do_eval_args(form, env, ctx, &lookup_sym_lisp1, args);
}
@@ -1644,18 +1814,21 @@ static val eval_prog1(val forms, val env, val ctx)
static val op_error(val form, val env)
{
+ (void) env;
eval_error(form, lit("unexpanded ~s encountered"), car(form), nao);
abort();
}
static val op_meta_error(val form, val env)
{
+ (void) env;
eval_error(form, lit("meta with no meaning: ~s"), form, nao);
}
static val op_quote(val form, val env)
{
val d = cdr(form);
+ (void) env;
if (!consp(d) || cdr(d))
eval_error(form, lit("bad quote syntax: ~s"), form, nao);
@@ -1664,21 +1837,21 @@ static val op_quote(val form, val env)
static val op_qquote_error(val form, val env)
{
+ (void) env;
eval_error(form, lit("unexpanded quasiquote encountered"), nao);
- return second(form);
}
static val op_unquote_error(val form, val env)
{
+ (void) env;
eval_error(form, lit("unquote/splice without matching quote"), nao);
- return second(form);
}
struct bindings_helper_vars {
val ne;
};
-static void copy_bh_env_handler(mem_t *ptr, int parent)
+static void copy_bh_env_handler(mem_t *ptr)
{
struct bindings_helper_vars *pv = coerce(struct bindings_helper_vars *, ptr);
pv->ne = copy_env(pv->ne);
@@ -1783,14 +1956,51 @@ static val op_prog1(val form, val env)
return eval_prog1(rest(form), env, form);
}
+static val op_progv(val form, val env)
+{
+ val args = cdr(form);
+ val vars_expr = pop(&args);
+ val vals_expr = pop(&args);
+ val body = args;
+ val vars = eval(vars_expr, env, form);
+ val vals = eval(vals_expr, env, form);
+ val saved_de = dyn_env;
+ val new_env = dyn_env = make_env(nil, nil, saved_de);
+ val ret, vari, vali;
+
+ for (vari = vars, vali = vals; vari && vali;
+ vari = cdr(vari), vali = cdr(vali))
+ {
+ val var = car(vari);
+ if (!bindable(var))
+ not_bindable_error(form, var);
+ env_vbind(new_env, var, car(vali));
+ }
+
+ for (; vari; vari = cdr(vari)) {
+ val var = car(vari);
+ if (!bindable(var))
+ not_bindable_error(form, var);
+ env_vbind(new_env, var, unbound_s);
+ }
+
+ ret = eval_progn(body, env, form);
+
+ dyn_env = saved_de;
+
+ return ret;
+}
+
static val op_let(val form, val env)
{
+ uses_or2;
val let = first(form);
val args = rest(form);
val vars = first(args);
val body = rest(args);
val saved_de = dyn_env;
- val new_env = bindings_helper(vars, env, eq(let, let_star_s), nil, form);
+ val sequential = or2(eq(let, let_star_s), eq(let, compiler_let_s));
+ val new_env = bindings_helper(vars, env, sequential, nil, form);
val ret = eval_progn(body, new_env, form);
dyn_env = saved_de;
return ret;
@@ -1834,26 +2044,26 @@ static val op_each(val form, val env)
val body = args;
val collect = eq(each, collect_each_s);
val append = eq(each, append_each_s);
- val bindings = if3(vars,
- get_bindings(vars, env),
- env->e.vbindings);
- val lists = mapcar(cdr_f, bindings);
+ val bindings = if3(vars == t,
+ env->e.vbindings,
+ get_bindings(vars, env));
+ val iters = mapcar(iter_from_binding_f, bindings);
list_collect_decl (collection, ptail);
uw_block_begin (nil, result);
for (;;) {
- val biter, liter;
+ val biter, iiter;
- for (biter = bindings, liter = lists; biter;
- biter = cdr(biter), liter = cdr(liter))
+ for (biter = bindings, iiter = iters; biter;
+ biter = cdr(biter), iiter = cdr(iiter))
{
val binding = car(biter);
- val list = car(liter);
- if (!list)
+ val iter = car(iiter);
+ if (!iter_more(iter))
goto out;
- rplacd(binding, car(list));
- rplaca(liter, cdr(list));
+ rplacd(binding, iter_item(iter));
+ rplaca(iiter, iter_step(iter));
}
{
@@ -1940,9 +2150,10 @@ static val op_or(val form, val env)
static val rt_defvarl(val sym)
{
- val self = lit("defvar");
+ val self = lit("sys:defvarl");
val new_p;
- val cell = gethash_c(self, top_vb, sym, mkcloc(new_p));
+ val cell = (autoload_try_var(sym),
+ gethash_c(self, top_vb, sym, mkcloc(new_p)));
if (new_p || !cdr(cell)) {
uw_purge_deferred_warning(cons(var_s, sym));
@@ -1954,15 +2165,32 @@ static val rt_defvarl(val sym)
return nil;
}
+static val rt_defv(val sym)
+{
+ val self = lit("sys:rt-defv");
+ val new_p;
+ val cell = (autoload_try_var(sym),
+ gethash_c(self, top_vb, sym, mkcloc(new_p)));
+
+ if (new_p) {
+ uw_purge_deferred_warning(cons(var_s, sym));
+ uw_purge_deferred_warning(cons(sym_s, sym));
+ remhash(top_smb, sym);
+ return cell;
+ }
+
+ return nil;
+}
+
static val op_defvarl(val form, val env)
{
val args = rest(form);
val sym = first(args);
- val cell = rt_defvarl(sym);
+ val bind = rt_defv(sym);
- if (cell) {
+ if (bind) {
val value = eval(second(args), env, form);
- rplacd(cell, cons(sym, value));
+ rplacd(bind, value);
}
return sym;
@@ -1972,21 +2200,29 @@ static val op_defsymacro(val form, val env)
{
val args = rest(form);
val sym = first(args);
+ val varexisted = gethash_d(top_vb, sym);
(void) env;
+ autoload_try_var(sym);
remhash(top_vb, sym);
if (!opt_compat || opt_compat > 143)
remhash(special, sym);
- sethash(top_smb, sym, cons(sym, second(args)));
+ sethash(top_smb, sym, second(args));
+ if (varexisted)
+ vm_invalidate_binding(sym);
return sym;
}
static val rt_defsymacro(val sym, val def)
{
+ val varexisted = gethash_d(top_vb, sym);
+ autoload_try_var(sym);
remhash(top_vb, sym);
remhash(special, sym);
- sethash(top_smb, sym, cons(sym, def));
+ sethash(top_smb, sym, def);
+ if (varexisted)
+ vm_invalidate_binding(sym);
return sym;
}
@@ -2005,7 +2241,8 @@ void trace_check(val name)
static val rt_defun(val name, val function)
{
- sethash(top_fb, name, cons(name, function));
+ autoload_try_fun(name);
+ sethash(top_fb, name, function);
uw_purge_deferred_warning(cons(fun_s, name));
uw_purge_deferred_warning(cons(sym_s, name));
return name;
@@ -2013,7 +2250,8 @@ static val rt_defun(val name, val function)
static val rt_defmacro(val sym, val name, val function)
{
- sethash(top_mb, sym, cons(name, function));
+ autoload_try_fun(sym);
+ sethash(top_mb, sym, function);
return name;
}
@@ -2027,7 +2265,7 @@ static val op_defun(val form, val env)
trace_check(name);
if (!consp(name)) {
- val block = cons(block_s, cons(name, body));
+ val block = cons(sys_blk_s, cons(name, body));
val fun = rlcp(cons(name, cons(params, cons(block, nil))), form);
return rt_defun(name, func_interp(env, fun));
} else if (car(name) == meth_s) {
@@ -2042,7 +2280,7 @@ static val op_defun(val form, val env)
return funcall3(cdr(binding), type_sym, meth_name, func_interp(env, fun));
} else if (car(name) == macro_s) {
val sym = cadr(name);
- val block = cons(block_s, cons(sym, body));
+ val block = cons(sys_blk_s, cons(sym, body));
val fun = rlcp(cons(name, cons(params, cons(block, nil))), form);
if (!bindable(sym))
@@ -2067,7 +2305,8 @@ static val me_interp_macro(val expander, val form, val menv)
val params = cadr(expander);
val body = cddr(expander);
val saved_de = set_dyn_env(make_env(nil, nil, dyn_env));
- val exp_env = bind_macro_params(env, menv, params, arglist, nil, form);
+ val exp_env = bind_macro_params(env, menv, params, arglist,
+ nil, form, expand_error);
val result = eval_progn(body, exp_env, body);
set_dyn_env(saved_de);
set_origin(result, form);
@@ -2089,8 +2328,8 @@ static val op_defmacro(val form, val env)
/* defmacro captures lexical environment, so env is passed */
sethash(top_mb, name,
- rlcp_tree(cons(name, func_f2(cons(env, cons(params, cons(block, nil))),
- me_interp_macro)),
+ rlcp_tree(func_f2(cons(env, cons(params, cons(block, nil))),
+ me_interp_macro),
block));
return name;
}
@@ -2182,7 +2421,7 @@ static void builtin_reject_test(val op, val sym, val form, val def_kind)
static val make_var_shadowing_env(val menv, val vars)
{
if (nilp(vars)) {
- return menv;
+ return make_env(nil, nil, menv);
} else if (atom(vars)) {
return make_env(cons(cons(vars, special_s), nil), nil, menv);
} else {
@@ -2269,7 +2508,7 @@ static val op_tree_case(val form, val env)
cons_bind (params, forms, onecase);
val saved_de = dyn_env;
val new_env = bind_macro_params(env, nil, params, expr_val,
- colon_k, onecase);
+ colon_k, onecase, eval_error);
if (new_env) {
val ret = eval_progn(forms, new_env, forms);
dyn_env = saved_de;
@@ -2333,7 +2572,8 @@ static val op_tree_bind(val form, val env)
val body = rest(rest(rest(form)));
val expr_val = eval(expr, env, expr);
val saved_de = dyn_env;
- val new_env = bind_macro_params(env, nil, params, expr_val, nil, form);
+ val new_env = bind_macro_params(env, nil, params, expr_val,
+ nil, form, eval_error);
val ret = eval_progn(body, new_env, body);
dyn_env = saved_de;
return ret;
@@ -2348,7 +2588,26 @@ static val op_mac_param_bind(val form, val env)
val ctx_val = eval(ctx_form, env, ctx_form);
val expr_val = eval(expr, env, expr);
val saved_de = dyn_env;
- val new_env = bind_macro_params(env, nil, params, expr_val, nil, ctx_val);
+ val new_env = bind_macro_params(env, nil, params, expr_val,
+ nil, ctx_val, expand_error);
+ val ret = eval_progn(body, new_env, body);
+ dyn_env = saved_de;
+ return ret;
+}
+
+static val op_mac_env_param_bind(val form, val env)
+{
+ val body = cdr(form);
+ val ctx_form = pop(&body);
+ val menv = pop(&body);
+ val params = pop(&body);
+ val expr = pop(&body);
+ val ctx_val = eval(ctx_form, env, ctx_form);
+ val menv_val = eval(menv, env, menv);
+ val expr_val = eval(expr, env, expr);
+ val saved_de = dyn_env;
+ val new_env = bind_macro_params(env, menv_val, params, expr_val,
+ nil, ctx_val, expand_error);
val ret = eval_progn(body, new_env, body);
dyn_env = saved_de;
return ret;
@@ -2381,8 +2640,7 @@ static val expand_lisp1(val form, val menv);
static val expand_lisp1_value(val form, val menv)
{
- if (length(form) != two)
- eval_error(form, lit("~s: invalid syntax"), first(form), nao);
+ syn_check(form, car(form), cdr, cddr);
{
val sym = cadr(form);
@@ -2391,8 +2649,8 @@ static val expand_lisp1_value(val form, val menv)
if (nilp(binding_type)) {
if (!bindable(sym_ex))
- eval_error(form, lit("~s: misapplied to form ~s"),
- first(form), sym_ex, nao);
+ expand_error(form, lit("~s: misapplied to form ~s"),
+ first(form), sym_ex, nao);
return form;
}
@@ -2402,15 +2660,14 @@ static val expand_lisp1_value(val form, val menv)
if (binding_type == fun_k)
return rlcp(cons(fun_s, cons(sym_ex, nil)), form);
- eval_error(form, lit("~s: applied to unexpanded symbol macro ~s"),
- first(form), sym_ex, nao);
+ expand_error(form, lit("~s: applied to unexpanded symbol macro ~s"),
+ first(form), sym_ex, nao);
}
}
static val expand_lisp1_setq(val form, val menv)
{
- if (!consp(cdr(form)) || !consp(cddr(form)) || cdddr(form))
- eval_error(form, lit("~s: invalid syntax"), car(form), nao);
+ syn_check(form, car(form), cddr, cdddr);
{
val op = car(form);
@@ -2421,8 +2678,8 @@ static val expand_lisp1_setq(val form, val menv)
if (nilp(binding_type)) {
if (!bindable(sym_ex))
- eval_error(form, lit("~s: misapplied to form ~s"),
- op, sym_ex, nao);
+ expand_error(form, lit("~s: misapplied to form ~s"),
+ op, sym_ex, nao);
return rlcp(cons(op, cons(sym_ex, cons(expand(newval, menv), nil))),
form);
}
@@ -2431,16 +2688,17 @@ static val expand_lisp1_setq(val form, val menv)
return expand(rlcp(cons(setq_s, cons(sym_ex, cddr(form))), form), menv);
if (binding_type == fun_k)
- eval_error(form, lit("~s: cannot assign lexical function ~s"), op, sym_ex, nao);
+ expand_error(form, lit("~s: cannot assign lexical function ~s"),
+ op, sym_ex, nao);
- eval_error(form, lit("~s: applied to unexpanded symbol macro ~s"), op, sym_ex, nao);
+ expand_error(form, lit("~s: applied to unexpanded symbol macro ~s"),
+ op, sym_ex, nao);
}
}
static val expand_setqf(val form, val menv)
{
- if (!consp(cdr(form)) || !consp(cddr(form)) || cdddr(form))
- eval_error(form, lit("~s: invalid syntax"), car(form), nao);
+ syn_check(form, car(form), cddr, cdddr);
{
val op = car(form);
@@ -2448,7 +2706,8 @@ static val expand_setqf(val form, val menv)
val newval = caddr(form);
if (lexical_fun_p(menv, sym))
- eval_error(form, lit("~s: cannot assign lexical function ~s"), op, sym, nao);
+ expand_error(form, lit("~s: cannot assign lexical function ~s"),
+ op, sym, nao);
if (!lookup_fun(nil, sym))
eval_defr_warn(uw_last_form_expanded(),
@@ -2532,11 +2791,12 @@ static val op_dohash(val form, val env)
val valvar = cons(valsym, nil);
val new_env = make_env(cons(keyvar, cons(valvar, nil)), nil, env);
val cell;
+ val result = nil;
struct hash_iter hi;
hash_iter_init(&hi, eval(hashform, env, hashform), op);
- uw_block_begin (nil, result);
+ uw_block_beg (nil, result);
while ((cell = hash_iter_next(&hi)) != nil) {
/* These assignments are gc-safe, because keyvar and valvar
@@ -2633,7 +2893,7 @@ static val op_dwim(val form, val env)
{
val argexps = rest(form);
val objexpr = pop(&argexps);
- cnum alen = if3(consp(argexps), c_num(length(argexps)), 0);
+ cnum alen = if3(consp(argexps), c_num(length(argexps), car(form)), 0);
cnum argc = max(alen, ARGS_MIN);
args_decl(args, argc);
@@ -2661,7 +2921,7 @@ static val op_catch(val form, val env)
result = eval(try_form, env, try_form);
uw_catch(exsym, exvals) {
- args_decl(args, ARGS_MIN);
+ args_decl_constsize(args, ARGS_MIN);
val iter;
args_add(args, exsym);
@@ -2838,7 +3098,7 @@ static val fmt_simple(val obj, val n, val sep,
nil);
}
-static val fmt_flex(val obj, val plist, struct args *args)
+static val fmt_flex(val obj, val plist, varg args)
{
cnum ix = 0;
val n = zero, sep = lit(" ");
@@ -2862,11 +3122,6 @@ static val fmt_flex(val obj, val plist, struct args *args)
return do_format_field(fmt_tostring(obj), n, sep, range_ix, plist, nil);
}
-static val fmt_join(struct args *args)
-{
- return cat_str(args_get_list(args), lit(""));
-}
-
val subst_vars(val forms, val env, val filter)
{
list_collect_decl(out, iter);
@@ -2937,11 +3192,11 @@ val prof_call(val (*fun)(mem_t *ctx), mem_t *ctx)
alloc_bytes_t delta_mlbytes = malloc_bytes - start_mlbytes;
alloc_bytes_t delta_gcbytes = gc_bytes - start_gcbytes;
#if SIZEOF_ALLOC_BYTES_T > SIZEOF_PTR
- val dmb = if3(delta_mlbytes <= (alloc_bytes_t) INT_PTR_MAX,
+ val dmb = if3(delta_mlbytes <= convert(alloc_bytes_t, INT_PTR_MAX),
unum(delta_mlbytes),
logior(ash(unum(delta_mlbytes >> 32), num_fast(32)),
unum(delta_mlbytes & 0xFFFFFFFF)));
- val dgc = if3(delta_gcbytes <= (alloc_bytes_t) INT_PTR_MAX,
+ val dgc = if3(delta_gcbytes <= convert(alloc_bytes_t, INT_PTR_MAX),
unum(delta_gcbytes),
logior(ash(unum(delta_gcbytes >> 32), num_fast(32)),
unum(delta_gcbytes & 0xFFFFFFFF)));
@@ -2993,6 +3248,8 @@ static val op_upenv(val form, val env)
static val op_load_time_lit(val form, val env)
{
val args = cdr(form);
+ (void) env;
+
if (car(args)) {
return cadr(args);
} else {
@@ -3002,24 +3259,36 @@ static val op_load_time_lit(val form, val env)
}
}
+static val me_macro_time(val form, val menv)
+{
+ val args = rest(form);
+ val result = nil;
+
+ for (; args; args = cdr(args)) {
+ val arg = car(args);
+ val arg_ex = expand(arg, menv);
+ result = eval(arg_ex, nil, args);
+ }
+
+ return maybe_quote(result);
+}
+
static val me_def_variable(val form, val menv)
{
val args = rest(form);
val op = first(form);
- val sym = first(args);
+ val sym = (syn_check(form, op, if3(op == defvar_s, cdr, cddr), cdddr),
+ first(args));
val initform = second(args);
val mkspecial = if2(op == defvar_s || op == defparm_s,
cons(list(sys_mark_special_s,
list(quote_s, sym, nao), nao), nil));
val setval = if2(op == defparm_s || op == defparml_s,
- cons(list(set_s, sym, initform, nao), nil));
+ cons(list(setq_s, sym, initform, nao), nil));
val mksv = nappend2(mkspecial, setval);
(void) menv;
- if (op != defvar_s && length(args) != two)
- eval_error(form, lit("~s: two arguments expected"), op, nao);
-
if (!bindable(sym))
not_bindable_error(form, sym);
@@ -3054,7 +3323,8 @@ static val me_each(val form, val menv)
{
uses_or2;
val each = first(form);
- val args = rest(form);
+ val args = (syn_check(form, each, cdr, 0),
+ rest(form));
val vars = pop(&args);
val star = or3(eq(each, each_star_s),
eq(each, collect_each_star_s),
@@ -3065,22 +3335,24 @@ static val me_each(val form, val menv)
val append = or2(eq(each, append_each_s), eq(each, append_each_star_s));
val eff_each = if3(collect, collect_each_s,
if3(append, append_each_s, each_s));
-
+ (void) menv;
return list(if3(star, let_star_s, let_s), vars,
cons(each_op_s, cons(eff_each,
- cons(if2(star || specials_occur, var_syms),
+ cons(if3(!vars || star || specials_occur,
+ var_syms, t),
args))), nao);
}
static val me_for(val form, val menv)
{
val forsym = first(form);
- val args = rest(form);
+ val args = (syn_check(form, forsym, cddr, 0), rest(form));
val vars = first(args);
val body = rest(args);
int oldscope = opt_compat && opt_compat <= 123;
val basic = list(if3(forsym == for_star_s, let_star_s, let_s),
vars, cons(for_op_s, cons(nil, body)), nao);
+ (void) menv;
return if3(oldscope,
basic,
list(block_s, nil, basic, nao));
@@ -3089,6 +3361,7 @@ static val me_for(val form, val menv)
static val me_gen(val form, val menv)
{
(void) menv;
+ syn_check(form, car(form), cddr, cdddr);
return list(generate_s,
list(lambda_s, nil, second(form), nao),
list(lambda_s, nil, third(form), nao), nao);
@@ -3097,15 +3370,16 @@ static val me_gen(val form, val menv)
static val me_gun(val form, val menv)
{
val var = gensym(nil);
- val expr = second(form);
+ val expr = (syn_check(form, car(form), cdr, cddr), second(form));
(void) menv;
return list(let_s, cons(var, nil),
- list(gen_s, list(set_s, var, expr, nao), var, nao), nao);
+ list(gen_s, list(setq_s, var, expr, nao), var, nao), nao);
}
static val me_delay(val form, val menv)
{
(void) menv;
+ syn_check(form, car(form), cdr, cddr);
rlcp_tree(rest(form), second(form));
return list(cons_s,
cons(quote_s, cons(promise_s, nil)),
@@ -3117,6 +3391,7 @@ static val me_delay(val form, val menv)
static val me_pprof(val form, val menv)
{
(void) menv;
+ no_dot_check(form, car(form));
return list(intern(lit("rt-pprof"), system_package),
cons(prof_s, rest(form)), nao);
}
@@ -3139,10 +3414,22 @@ static val rt_pprof(val prof_list)
return retval;
}
-static val me_when(val form, val menv)
+static val me_nand(val form, val menv)
{
(void) menv;
+ return list(not_s, cons(and_s, cdr(form)), nao);
+}
+
+static val me_nor(val form, val menv)
+{
+ (void) menv;
+ return list(not_s, cons(or_s, cdr(form)), nao);
+}
+static val me_when(val form, val menv)
+{
+ (void) menv;
+ syn_check(form, car(form), cdr, 0);
return if3(cdddr(form),
cons(cond_s, cons(cdr(form), nil)),
cons(if_s, cdr(form)));
@@ -3150,19 +3437,16 @@ static val me_when(val form, val menv)
static val me_unless(val form, val menv)
{
- val test = cadr(form);
+ val test = (syn_check(form, car(form), cdr, 0), cadr(form));
val body = cddr(form);
-
(void) menv;
-
return list(if_s, test, nil, maybe_progn(body), nao);
}
static val me_while_until(val form, val menv)
{
- val cond = cadr(form);
+ val cond = (syn_check(form, car(form), cdr, 0), cadr(form));
val test = if3(car(form) == until_s, cons(not_s, cons(cond, nil)), cond);
-
(void) menv;
return apply_frob_args(list(for_s, nil, cons(test, nil), nil,
rest(rest(form)), nao));
@@ -3171,19 +3455,19 @@ static val me_while_until(val form, val menv)
static val me_while_until_star(val form, val menv)
{
val once = gensym(lit("once-"));
- val cond = cadr(form);
+ val cond = (syn_check(form, car(form), cdr, 0), cadr(form));
val test = if3(car(form) == until_star_s, cons(not_s, cons(cond, nil)), cond);
-
(void) menv;
return apply_frob_args(list(for_s, cons(list(once, t, nao), nil),
cons(list(or_s, once, test, nao), nil),
- cons(list(set_s, once, nil, nao), nil),
+ cons(list(setq_s, once, nil, nao), nil),
rest(rest(form)), nao));
}
static val me_quasilist(val form, val menv)
{
+ (void) menv;
return cons(list_s, cdr(form));
}
@@ -3250,10 +3534,12 @@ static val dot_to_apply(val form, val lisp1_p)
return form;
}
-noreturn static void dotted_form_error(val form)
+NORETURN static void dotted_form_error(val form)
{
- uw_throwf(error_s, lit("dotted argument ~!~s not supported by form"),
- form, nao);
+ if (atom(form))
+ expand_error(form, lit("dotted argument ~!~s not allowed here"), form, nao);
+ else
+ expand_error(form, lit("dotted syntax ~!~s not allowed here"), form, nao);
}
val expand_forms(val form, val menv)
@@ -3265,13 +3551,18 @@ val expand_forms(val form, val menv)
} else {
val f = car(form);
val r = cdr(form);
- val ex_f = expand(f, menv);
- val ex_r = expand_forms(r, menv);
- if (ex_f == f && ex_r == r)
- return form;
+ if (atom(r) && r && !(opt_compat && opt_compat <= 137)) {
+ dotted_form_error(form);
+ } else {
+ val ex_f = expand(f, menv);
+ val ex_r = expand_forms(r, menv);
- return rlcp(cons(ex_f, ex_r), form);
+ if (ex_f == f && ex_r == r)
+ return form;
+
+ return rlcp(cons(ex_f, ex_r), form);
+ }
}
}
@@ -3288,17 +3579,21 @@ static val expand_forms_ss(val forms, val menv, val ss_hash)
} else {
val f = car(forms);
val r = cdr(forms);
- val ex_f = expand(f, menv);
- val ex_r = expand_forms_ss(r, menv, ss_hash);
+ if (atom(r) && r && !(opt_compat && opt_compat <= 137)) {
+ dotted_form_error(forms);
+ } else {
+ val ex_f = expand(f, menv);
+ val ex_r = expand_forms_ss(r, menv, ss_hash);
- if (ex_f == f && ex_r == r)
- return sethash(ss_hash, forms, forms);
+ if (ex_f == f && ex_r == r)
+ return sethash(ss_hash, forms, forms);
- return sethash(ss_hash, forms, rlcp(cons(ex_f, ex_r), forms));
+ return sethash(ss_hash, forms, rlcp(cons(ex_f, ex_r), forms));
+ }
}
}
-static val constantp(val form, val env_in);
+static val constantp_noex(val form);
static val expand_progn(val form, val menv)
{
@@ -3316,7 +3611,7 @@ static val expand_progn(val form, val menv)
return rlcp(cdr(ex_f), form);
}
- if ((symbolp(ex_f) || constantp(ex_f, menv)) && ex_r)
+ if ((symbolp(ex_f) || constantp_noex(ex_f)) && ex_r)
return rlcp(ex_r, form);
if (ex_f == f && ex_r == r)
@@ -3365,12 +3660,17 @@ static val expand_forms_lisp1(val form, val menv)
} else {
val f = car(form);
val r = cdr(form);
- val ex_f = expand_lisp1(f, menv);
- val ex_r = expand_forms_lisp1(r, menv);
- if (ex_f == f && ex_r == r)
- return form;
- return rlcp(cons(ex_f, ex_r), form);
+ if (atom(r) && r && !(opt_compat && opt_compat <= 137)) {
+ dotted_form_error(form);
+ } else {
+ val ex_f = expand_lisp1(f, menv);
+ val ex_r = expand_forms_lisp1(r, menv);
+
+ if (ex_f == f && ex_r == r)
+ return form;
+ return rlcp(cons(ex_f, ex_r), form);
+ }
}
}
@@ -3489,6 +3789,14 @@ static val optimize_qquote(val form)
return optimize_qquote_args(optimize_qquote_form(form));
}
+static val is_meta_unquote(val args, val unq)
+{
+ val uqform;
+ return tnil(consp(args) && !cdr(args) &&
+ consp((uqform = car(args))) &&
+ car(uqform) == unq && consp(cdr(uqform)) && !cddr(uqform));
+}
+
static val expand_qquote(val qquoted_form, val qq, val unq, val spl);
static val expand_qquote_rec(val qquoted_form, val qq, val unq, val spl)
@@ -3515,8 +3823,7 @@ static val expand_qquote_rec(val qquoted_form, val qq, val unq, val spl)
"or in the dotted position of a list"),
lit("(splice ~s) cannot occur outside of a list "
"or in the dotted position of a list"));
- eval_error(qquoted_form, error_msg,
- second(qquoted_form), nao);
+ expand_error(qquoted_form, error_msg, second(qquoted_form), nao);
} else if (sym == unq) {
return second(qquoted_form);
} else if (sym == qq) {
@@ -3539,6 +3846,15 @@ static val expand_qquote_rec(val qquoted_form, val qq, val unq, val spl)
val opts = expand_qquote(second(qquoted_form), qq, unq, spl);
val keys = expand_qquote(rest(rest(qquoted_form)), qq, unq, spl);
return rlcp(list(tree_construct_s, opts, keys, nao), qquoted_form);
+ } else if (sym == expr_s && is_meta_unquote(cdr(qquoted_form), unq)) {
+ val gs = gensym(nil);
+ val ret = list(let_s, cons(list(gs, cadadr(qquoted_form), nao), nil),
+ list(if_s, list(atom_s, gs, nao),
+ list(list_s, list(quote_s, var_s, nao),
+ gs, nao),
+ list(list_s, list(quote_s, expr_s, nao),
+ gs, nao), nao), nao);
+ return rlcp_tree(ret, qquoted_form);
} else {
val f = sym;
val r = cdr(qquoted_form);
@@ -3565,7 +3881,10 @@ static val expand_qquote_rec(val qquoted_form, val qq, val unq, val spl)
if (nilp(r_ex)) {
return rlcp_tree(cons(append_s, cons(f_ex, nil)), qquoted_form);
- } else if (atom(r_ex)) {
+ } else if (atom(r_ex) ||
+ (consp(r) && car(r) == expr_s &&
+ is_meta_unquote(cdr(r), unq)))
+ {
return rlcp_tree(cons(append_s, cons(f_ex, cons(r_ex, nil))), qquoted_form);
} else {
if (consp(r) && car(r) == unq)
@@ -3599,9 +3918,7 @@ static val me_qquote(val form, val menv)
static val me_equot(val form, val menv)
{
- if (!cdr(form) || cddr(form))
- eval_error(form, lit("~s: one argument required"), car(form), nao);
-
+ syn_check(form, car(form), cdr, cddr);
return rlcp(cons(quote_s, cons(expand(cadr(form), menv), nil)), form);
}
@@ -3612,8 +3929,8 @@ static val expand_vars(val vars, val menv, val form, int seq_p)
if (nilp(vars)) {
return nil;
} else if (atom(vars)) {
- eval_error(form, lit("~a is an invalid variable binding syntax"),
- vars, nao);
+ expand_error(form, lit("~a is an invalid variable binding syntax"),
+ vars, nao);
return vars;
} else if (symbolp(sym = car(vars))) {
val rest_vars = rest(vars);
@@ -3656,7 +3973,7 @@ static val expand_vars(val vars, val menv, val form, int seq_p)
}
return rlcp(cons(cons(var, cons(init_ex, nil)), rest_vars_ex), vars);
} else {
- eval_error(form, lit("variable binding expected, not ~s"), sym, nao);
+ expand_error(form, lit("variable binding expected, not ~s"), sym, nao);
}
}
@@ -3667,11 +3984,11 @@ static val expand_fbind_vars(val vars, val menv, val form)
if (nilp(vars)) {
return nil;
} else if (atom(vars)) {
- eval_error(form, lit("~a is an invalid function binding syntax"),
- vars, nao);
+ expand_error(form, lit("~a is an invalid function binding syntax"),
+ vars, nao);
return vars;
} else if (symbolp(sym = car(vars))) {
- eval_error(form, lit("symbols in this construct require initforms"), nao);
+ expand_error(form, lit("symbols in this construct require initforms"), nao);
} else {
cons_bind (var, init, sym);
val rest_vars = rest(vars);
@@ -3744,6 +4061,9 @@ val expand_quasi(val quasi_forms, val menv)
if (comp_184)
form_ex = expand(form, menv);
}
+
+ if (atom(form_ex) && !bindable(form_ex))
+ form_ex = list(var_s, form_ex, nao);
}
{
@@ -3830,19 +4150,7 @@ static val transform_op(val forms, val syms, val rg)
}
}
-static val cons_find(val obj, val structure, val test)
-{
- uses_or2;
-
- if (funcall2(test, obj, structure))
- return structure;
- if (atom(structure))
- return nil;
- return or2(cons_find(obj, car(structure), test),
- cons_find(obj, cdr(structure), test));
-}
-
-static val supplement_op_syms(val ssyms, val max)
+static val supplement_op_syms(val ssyms)
{
list_collect_decl (outsyms, tl);
val si, ni;
@@ -3872,7 +4180,7 @@ static val me_op(val form, val menv)
expand(body, new_menv)));
val rest_gensym = gensym(lit("rest-"));
cons_bind (syms, body_trans, transform_op(body_ex, nil, rest_gensym));
- val ssyms = sort(syms, func_n2(lt), car_f);
+ val ssyms = nsort(syms, func_n2(lt), car_f);
val nums = mapcar(car_f, ssyms);
val max = if3(nums, maxl(car(nums), cdr(nums)), zero);
val min = if3(nums, minl(car(nums), cdr(nums)), zero);
@@ -3881,12 +4189,12 @@ static val me_op(val form, val menv)
gethash(op_table, car(body_trans)));
uw_pop_frame(&uw_handler);
- if (c_num(max) > 1024)
+ if (c_num(max, sym) > 1024)
eval_error(form, lit("~a: @~a calls for function with too many arguments"),
sym, max, nao);
if (!eql(max, length(nums)) && !zerop(min))
- ssyms = supplement_op_syms(ssyms, max);
+ ssyms = supplement_op_syms(ssyms);
rlcp(body_trans, body);
@@ -3917,6 +4225,8 @@ static val me_flet_labels(val form, val menv)
val funcs = pop(&body);
list_collect_decl (lambdas, ptail);
+ (void) menv;
+
for (; funcs; funcs = cdr(funcs)) {
val func = car(funcs);
val name = pop(&func);
@@ -3938,6 +4248,7 @@ static val compares_with_eq(val obj)
static val hash_min_max(val env, val key, val value)
{
cons_bind (minkey, maxkey, env);
+ (void) value;
if (!minkey || lt(key, minkey))
minkey = key;
if (!maxkey || gt(key, maxkey))
@@ -3971,21 +4282,23 @@ static val me_case(val form, val menv)
list_collect_decl (condpairs, ptail);
list_collect_decl (hashforms, qtail);
+ (void) menv;
+
if (atom(cdr(form_orig)))
- eval_error(form_orig, lit("~s: missing test form"), casesym, nao);
+ expand_error(form_orig, lit("~s: missing test form"), casesym, nao);
if (casesym == caseq_s || casesym == caseq_star_s) {
memfuncsym = memq_s;
eqfuncsym = eq_s;
- hash = make_hash(nil, nil, nil);
+ hash = make_hash(hash_weak_none, nil);
} else if (casesym == caseql_s || casesym == caseql_star_s) {
memfuncsym = memql_s;
eqfuncsym = eql_s;
- hash = make_hash(nil, nil, nil);
+ hash = make_hash(hash_weak_none, nil);
} else {
memfuncsym = memqual_s;
eqfuncsym = equal_s;
- hash = make_hash(nil, nil, t);
+ hash = make_hash(hash_weak_none, t);
}
for (; consp(form); form = cdr(form)) {
@@ -4000,16 +4313,16 @@ static val me_case(val form, val menv)
}
if (keys == t)
- eval_error(form_orig, lit("~s: symbol t used as key"), casesym, nao);
+ expand_error(form_orig, lit("~s: symbol t used as key"), casesym, nao);
if (star) {
if (atom(keys))
- hash_keys = cons(keys = eval(keys, nil, form), nil);
+ hash_keys = cons(keys = expand_eval(keys, nil, menv), nil);
else
- hash_keys = keys = eval(cons(list_s, keys), nil, form);
+ hash_keys = keys = expand_eval(cons(list_s, keys), nil, menv);
}
- if (consp(keys) && !cdr(keys))
+ if (consp(keys) && atom(car(keys)) && !cdr(keys))
keys = car(keys);
if (atom(keys)) {
@@ -4056,7 +4369,8 @@ static val me_case(val form, val menv)
}
if (form && atom(form))
- eval_error(form_orig, lit("~s: improper form terminated by ~s"), casesym, form, nao);
+ expand_error(form_orig, lit("~s: improper form terminated by ~s"),
+ casesym, form, nao);
if (!compat && (all_keys_integer || all_keys_chr)) {
val minmax = cons(nil, nil);
@@ -4093,7 +4407,7 @@ static val me_case(val form, val menv)
tformsym, nao),
list(intern(lit("<="), user_package),
minkey, tformsym, maxkey, nao),
- list(set_s,
+ list(setq_s,
swres,
list(switch_s,
if3(minkey == 0,
@@ -4131,6 +4445,49 @@ static val me_case(val form, val menv)
cons(cond_s, condpairs), nao);
}
+static val me_ecase(val form, val menv)
+{
+ val form_orig = form;
+ val casesym = pop(&form);
+ val orig_args = form;
+ val testform = pop(&form);
+ val tgtsym = intern(cdr(symbol_name(casesym)), user_package);
+ val clauses = form;
+ val lastclause = car(lastcons(clauses));
+
+ if (!orig_args)
+ expand_error(form_orig, lit("~s: missing test form"), casesym, nao);
+
+ if (consp(lastclause) && car(lastclause) == t) {
+ return cons(tgtsym, orig_args);
+ } else {
+ val nform = apply_frob_args(list(tgtsym,
+ testform,
+ append2(clauses,
+ cons(list(t, list(throw_s,
+ list(quote_s,
+ case_error_s,
+ nao),
+ lit("unhandled case"),
+ nao),
+ nao),
+ nil)),
+ nao));
+ return me_case(nform, menv);
+ }
+}
+
+static val me_prog2(val form, val menv)
+{
+ val arg1 = cadr(form);
+ no_dot_check(form, car(form));
+
+ (void) menv;
+
+ return list(progn_s, arg1,
+ cons(prog1_s, cddr(form)), nao);
+}
+
static val me_tb(val form, val menv)
{
val opsym = pop(&form);
@@ -4160,8 +4517,9 @@ static val me_tc(val form, val menv)
static val me_ignerr(val form, val menv)
{
+ (void) menv;
return list(catch_s, cons(progn_s, rest(form)),
- list(error_s, error_s, nao), nao);
+ list(error_s, unused_arg_s, nao), nao);
}
static val me_whilet(val form, val env)
@@ -4173,8 +4531,10 @@ static val me_whilet(val form, val env)
val lastlet = car(lastlet_cons);
val not_done = gensym(lit("not-done"));
+ (void) env;
+
if (nilp(lastlet_cons))
- eval_error(form, lit("~s: empty binding list"), sym, nao);
+ expand_error(form, lit("~s: empty binding list"), sym, nao);
if (!cdr(lastlet)) {
val var = car(lastlet);
@@ -4190,7 +4550,7 @@ static val me_whilet(val form, val env)
list(let_star_s, lets,
list(if_s, car(lastlet),
cons(progn_s, body),
- list(set_s, not_done, nil, nao), nao), nao), nao), nao);
+ list(setq_s, not_done, nil, nao), nao), nao), nao), nao);
}
static val me_iflet_whenlet(val form, val env)
@@ -4199,6 +4559,8 @@ static val me_iflet_whenlet(val form, val env)
val sym = pop(&args);
val lets = pop(&args);
+ (void) env;
+
if (atom(lets)) {
return apply_frob_args(list(if3(sym == iflet_s, if_s, when_s),
lets, args, nao));
@@ -4207,10 +4569,10 @@ static val me_iflet_whenlet(val form, val env)
val lastlet = car(lastlet_cons);
if (nilp(lastlet))
- eval_error(form, lit("~s: empty binding list"), sym, nao);
+ expand_error(form, lit("~s: empty binding list"), sym, nao);
if (!consp(lastlet))
- eval_error(form, lit("~s: bad binding syntax ~s"), sym, lastlet, nao);
+ expand_error(form, lit("~s: bad binding syntax ~s"), sym, lastlet, nao);
{
val var = car(lastlet);
@@ -4233,9 +4595,10 @@ static val me_iflet_whenlet(val form, val env)
static val me_dotimes(val form, val env)
{
val count = gensym(lit("count-"));
- val args = rest(form);
+ val sym = car(form);
+ val args = (syn_check(form, sym, cdr, 0), rest(form));
val spec = pop(&args);
- val counter = pop(&spec);
+ val counter = (syn_check(spec, sym, cdr, cdddr), pop(&spec));
val count_form = pop(&spec);
val result = pop(&spec);
val body = args;
@@ -4246,13 +4609,14 @@ static val me_dotimes(val form, val env)
list(list(lt, counter, count, nao), result, nao),
list(list(inc_s, counter, nao), nao),
body, nao);
+ (void) env;
return apply_frob_args(raw);
}
static val me_lcons(val form, val menv)
{
- val car_form = second(form);
+ val car_form = (syn_check(form, car(form), cddr, cdddr), second(form));
val cdr_form = third(form);
val lc_sym = gensym(lit("lcons-"));
val make_lazy_cons = intern(lit("make-lazy-cons"), user_package);
@@ -4269,7 +4633,7 @@ static val me_lcons(val form, val menv)
static val me_mlet(val form, val menv)
{
uses_or2;
- val body = cdr(form);
+ val body = (syn_check(form, car(form), cdr, 0), cdr(form));
val bindings = pop(&body);
val symacrolet = intern(lit("symacrolet"), user_package);
val delay = intern(lit("delay"), user_package);
@@ -4281,6 +4645,8 @@ static val me_mlet(val form, val menv)
list_collect_decl (smacs, ptail_smacs);
list_collect_decl (sets, ptail_sets);
+ (void) menv;
+
for (; consp(bindings); bindings = cdr(bindings)) {
val binding = car(bindings);
@@ -4303,7 +4669,7 @@ static val me_mlet(val form, val menv)
ptail_smacs = list_collect(ptail_smacs,
list(sym, list(force_s, gen, nao), nao));
ptail_sets = list_collect(ptail_sets,
- list(set_s, gen,
+ list(setq_s, gen,
list(delay, init, nao), nao));
} else {
ptail_osyms = list_collect(ptail_osyms, sym);
@@ -4323,7 +4689,8 @@ static val me_mlet(val form, val menv)
static val me_load_time(val form, val menv)
{
- val expr = cadr(form);
+ val expr = (syn_check(form, car(form), cdr, cddr), cadr(form));
+ (void) menv;
return list(load_time_lit_s, nil, expr, nao);
}
@@ -4335,28 +4702,35 @@ static val me_load_for(val form, val menv)
list_collect_decl (out, ptail);
val iter;
+ (void) menv;
+
for (iter = args; iter; iter = cdr(iter)) {
val arg = car(iter);
if (consp(arg)) {
val kind = car(arg);
+ if (!symbolp(kind))
+ expand_error(form, lit("~s: clause symbol expected, not ~s"),
+ sym, kind, nao);
if (kind != usr_var_s && kind != fun_s && kind != macro_s
&& kind != struct_s && kind != pkg_s)
- eval_error(form, lit("~s: unrecognized clause symbol ~s"),
- sym, kind, nao);
+ expand_error(form, lit("~s: unrecognized clause symbol ~s"),
+ sym, kind, nao);
if (!bindable(cadr(arg)))
- eval_error(form, lit("~s: first argument in ~s must be bindable symbol"),
- sym, arg, nao);
- if (length(arg) != three)
- eval_error(form, lit("~s: clause ~s expected to have two arguments"),
- sym, arg, nao);
- ptail = list_collect(ptail, list(list_s,
- list(quote_s, car(arg), nao),
- list(quote_s, cadr(arg), nao),
- caddr(arg),
- nao));
+ expand_error(form, lit("~s: first argument in ~s must be bindable symbol"),
+ sym, arg, nao);
+ if (lt(length(arg), three))
+ expand_error(form, lit("~s: clause ~s needs at least two arguments"),
+ sym, arg, nao);
+ ptail = list_collect(ptail,
+ apply_frob_args(list(list_s,
+ list(quote_s, car(arg), nao),
+ list(quote_s, cadr(arg), nao),
+ caddr(arg),
+ cdddr(arg),
+ nao)));
} else {
- eval_error(form, lit("~s: invalid clause ~s"), sym, arg, nao);
+ expand_error(form, lit("~s: invalid clause ~s"), sym, arg, nao);
}
}
@@ -4366,36 +4740,77 @@ static val me_load_for(val form, val menv)
return cons(rt_load_for_s, out);
}
-val load(val target)
+static val me_push_after_load(val form, val menv)
+{
+ (void) menv;
+ return list(setq_s,
+ load_hooks_s,
+ list(cons_s,
+ cons(lambda_s, cons(nil, cdr(form))),
+ load_hooks_s,
+ nao), nao);
+}
+
+static val me_pop_after_load(val form, val menv)
+{
+ (void) menv;
+ if (cdr(form))
+ expand_error(form, lit("~s: no arguments required"), car(form), nao);
+ return list(setq_s, load_hooks_s, list(cdr_s, load_hooks_s, nao), nao);
+}
+
+void run_load_hooks(val load_dyn_env)
+{
+ val saved_de = set_dyn_env(load_dyn_env);
+ val hooks_binding = lookup_var(nil, load_hooks_s);
+ val hooks = cdr(hooks_binding);
+
+ if (hooks) {
+ for (; hooks; hooks = cdr(hooks))
+ funcall(car(hooks));
+ rplacd(hooks_binding, nil);
+ }
+
+ set_dyn_env(saved_de);
+}
+
+static void run_load_hooks_atexit(void)
+{
+ run_load_hooks(dyn_env);
+}
+
+val loadv(val target, varg load_args)
{
val self = lit("load");
uses_or2;
val parent = or2(load_path, null_string);
val path = if3(!pure_rel_path_p(target),
target,
- cat_str(nappend2(sub_list(split_str(parent, lit("/")),
- zero, negone),
- cons(target, nil)), lit("/")));
- val name, stream;
+ path_cat(dir_name(parent), target));
+ val name = target, stream;
val txr_lisp_p = t;
val saved_dyn_env = dyn_env;
- val rec = cdr(lookup_var(saved_dyn_env, load_recursive_s));
+ val load_dyn_env = make_env(nil, nil, dyn_env);
+ val rec = cdr(lookup_var(nil, load_recursive_s));
+ uw_block_begin (load_s, ret);
- open_txr_file(path, &txr_lisp_p, &name, &stream);
+ open_txr_file(path, &txr_lisp_p, &name, &stream, t, self);
- if (match_str(or2(get_line(stream), lit("")), lit("#!"), nil))
+ if (match_str(or2(get_line(stream), null_string), lit("#!"), nil))
parser_set_lineno(self, stream, two);
else
seek_stream(stream, zero, from_start_k);
uw_simple_catch_begin;
- dyn_env = make_env(nil, nil, dyn_env);
+ dyn_env = load_dyn_env;
env_vbind(dyn_env, load_path_s, if3(opt_compat && opt_compat <= 215,
path,
stream_get_prop(stream, name_k)));
env_vbind(dyn_env, load_recursive_s, t);
+ env_vbind(dyn_env, load_hooks_s, nil);
env_vbind(dyn_env, package_s, cur_package);
+ env_vbind(dyn_env, load_args_s, args_get_list(load_args));
if (txr_lisp_p == t) {
if (!read_eval_stream(self, stream, std_error)) {
@@ -4417,11 +4832,12 @@ val load(val target)
close_stream(stream, nil);
- uw_release_deferred_warnings();
-
- if (parser->errors)
+ if (parser->errors) {
+ uw_release_deferred_warnings();
uw_throwf(query_error_s, lit("~a: parser errors in ~a"),
self, path, nao);
+ }
+
{
val match_ctx = uw_get_match_context();
val bindings = cdr(match_ctx);
@@ -4439,25 +4855,35 @@ val load(val target)
uw_unwind {
close_stream(stream, nil);
+ run_load_hooks(load_dyn_env);
if (!rec)
uw_dump_deferred_warnings(std_null);
}
uw_catch_end;
+ uw_block_end;
- return nil;
+ return ret;
}
-static val rt_load_for(struct args *args)
+val load(val target)
+{
+ args_decl_list(load_args, ARGS_MIN, nil);
+ return loadv(target, load_args);
+}
+
+static val rt_load_for(varg args)
{
val self = lit("sys:rt-load-for");
cnum index = 0;
+ val ret = nil;
while (args_more(args, index)) {
val clause = args_get(args, &index);
val kind = pop(&clause);
val sym = pop(&clause);
val file = car(clause);
+ val load_args_list = cdr(clause);
val (*testfun)(val);
if (kind == usr_var_s)
@@ -4475,14 +4901,21 @@ static val rt_load_for(struct args *args)
self, kind, nao);
if (!testfun(sym)) {
- load(file);
+ args_decl_list(load_args, ARGS_MIN, load_args_list);
+ ret = loadv(file, load_args);
if (!testfun(sym))
uw_throwf(error_s, lit("~a: file ~s didn't define ~a ~s"),
self, file, kind, sym, nao);
}
}
- return nil;
+ return ret;
+}
+
+static val fun_macro_env(val menv, val name)
+{
+ val qname = list(quote_s, name, nao);
+ return make_env(cons(cons(pct_fun_s, qname), nil), nil, menv);
}
static val expand_catch_clause(val form, val menv)
@@ -4495,7 +4928,7 @@ static val expand_catch_clause(val form, val menv)
val new_menv = make_var_shadowing_env(menv, get_param_syms(params_ex));
val body_ex = expand_forms(body_ex0, new_menv);
if (!symbolp(sym))
- eval_error(form, lit("catch: ~s isn't a symbol"), sym, nao);
+ expand_error(form, lit("catch: ~s isn't a symbol"), sym, nao);
if (body == body_ex && params == params_ex)
return form;
return rlcp(cons(sym, cons(params_ex, body_ex)), form);
@@ -4547,7 +4980,7 @@ static val expand_switch(val form, val menv)
val branches = second(args);
val expr_ex = expand(expr, menv);
val branches_ex;
- val ss_hash = make_hash(nil, nil, nil);
+ val ss_hash = make_hash(hash_weak_none, nil);
if (listp(branches)) {
branches_ex = expand_list_of_form_lists(branches, menv, ss_hash);
@@ -4555,7 +4988,7 @@ static val expand_switch(val form, val menv)
branches_ex = vec_list(expand_list_of_form_lists(list_vec(branches),
menv, ss_hash));
} else {
- eval_error(form, lit("~s: representation of branches"), sym, nao);
+ expand_error(form, lit("~s: representation of branches"), sym, nao);
}
return rlcp(cons(sym, cons(expr_ex, cons(branches_ex, nil))), form);
}
@@ -4564,6 +4997,8 @@ static val do_expand(val form, val menv)
{
val macro = nil;
+ gc_stack_check();
+
menv = default_null_arg(menv);
again:
@@ -4590,7 +5025,7 @@ again:
if (sym == let_s || sym == let_star_s)
{
- val body = rest(rest(form));
+ val body = (syn_check(form, sym, cdr, 0), rest(rest(form)));
val vars = second(form);
int seq_p = sym == let_star_s;
val new_menv = make_var_shadowing_env(menv, vars);
@@ -4600,7 +5035,7 @@ again:
return form;
return rlcp(cons(sym, cons(vars_ex, body_ex)), form);
} else if (sym == each_op_s) {
- val args = rest(form);
+ val args = (syn_check(form, sym, cdr, 0), rest(form));
val eachsym = first(args);
val vars = second(args);
val body = rest(rest(args));
@@ -4611,7 +5046,7 @@ again:
return rlcp(cons(sym, cons(eachsym, cons(vars, body_ex))), form);
} else if (sym == fbind_s || sym == lbind_s) {
- val body = rest(rest(form));
+ val body = (syn_check(form, sym, cdr, 0), rest(rest(form)));
val funcs = second(form);
val new_menv = make_fun_shadowing_env(menv, funcs);
val body_ex = expand_progn(body, new_menv);
@@ -4623,14 +5058,14 @@ again:
return rlcp(cons(sym, cons(funcs_ex, body_ex)), form);
}
} else if (sym == block_s) {
- val name = second(form);
+ val name = (syn_check(form, sym, cdr, 0), second(form));
val body = rest(rest(form));
val body_ex = expand_progn(body, menv);
if (body == body_ex)
return form;
return rlcp(cons(sym, cons(name, body_ex)), form);
} else if (sym == return_from_s || sym == sys_abscond_from_s) {
- val name = second(form);
+ val name = (syn_check(form, sym, cdr, cdddr), second(form));
val ret = third(form);
val ret_ex = expand(ret, menv);
if (ret == ret_ex)
@@ -4643,38 +5078,51 @@ again:
if (pairs == pairs_ex)
return form;
return rlcp(cons(cond_s, pairs_ex), form);
- } else if (sym == defvarl_s || sym == defsymacro_s) {
+ } else if (sym == defvarl_s) {
val name = second(form);
val init = third(form);
val init_ex = expand(init, menv);
val form_ex = form;
- if (sym == defsymacro_s && length(form) != three)
- eval_error(form, lit("~s: two arguments expected"), sym, nao);
-
if (!bindable(name))
not_bindable_error(form, name);
- if (sym == defvarl_s)
- uw_register_tentative_def(cons(var_s, name));
+ if (cdddr(form))
+ excess_args_error(form, sym);
+
+ uw_register_tentative_def(cons(var_s, name));
if (init != init_ex)
form_ex = rlcp(cons(sym, cons(name, cons(init_ex, nil))), form);
- if (opt_compat && opt_compat <= 190 && sym == defsymacro_s) {
- val result = eval(if3(opt_compat && opt_compat <= 137,
- form_ex, form),
- make_env(nil, nil, nil), form);
- return cons(quote_s, cons(result, nil));
+ return form_ex;
+ } else if (sym == defsymacro_s) {
+ val name = (syn_check(form, sym, cddr, cdddr), second(form));
+ val init = third(form);
+
+ if (!bindable(name))
+ not_bindable_error(form, name);
+
+ if (opt_compat && opt_compat <= 262) {
+ val init_ex = expand(init, menv);
+ val form_ex = form;
+
+ if (init != init_ex)
+ form_ex = rlcp(cons(sym, cons(name, cons(init_ex, nil))), form);
+
+ if (opt_compat <= 190 && sym == defsymacro_s) {
+ val result = eval(if3(opt_compat && opt_compat <= 137,
+ form_ex, form),
+ make_env(nil, nil, nil), form);
+ return cons(quote_s, cons(result, nil));
+ }
+
+ return form_ex;
}
- return form_ex;
+ return form;
} else if (sym == lambda_s) {
- if (!cdr(form))
- eval_error(form, lit("~s: missing argument list"), sym, nao);
-
- if (atom(cdr(form)))
- eval_error(form, lit("~s: bad syntax"), sym, nao);
+ syn_check(form, sym, cdr, 0);
{
val params = second(form);
@@ -4689,7 +5137,7 @@ again:
return rlcp(cons(sym, cons(params_ex, body_ex)), form);
}
} else if (sym == defun_s || sym == defmacro_s) {
- val name = second(form);
+ val name = (syn_check(form, sym, cddr, 0), second(form));
val params = third(form);
builtin_reject_test(sym, name, form, sym);
@@ -4699,14 +5147,12 @@ again:
{
val body = rest(rest(rest(form)));
+ val menv0 = fun_macro_env(menv, name);
cons_bind (params_ex, body_ex0,
- expand_params(params, body, menv,
+ expand_params(params, body, menv0,
eq(sym, defmacro_s), form));
- val inter_env = make_var_shadowing_env(menv, get_param_syms(params_ex));
- val new_menv = if3(sym == defun_s,
- make_fun_shadowing_env(inter_env, cons(name, nil)),
- inter_env);
- val body_ex = expand_progn(body_ex0, new_menv);
+ val menv1 = make_var_shadowing_env(menv0, get_param_syms(params_ex));
+ val body_ex = expand_progn(body_ex0, menv1);
val form_ex = form;
if (body != body_ex || params != params_ex)
@@ -4721,9 +5167,13 @@ again:
}
} else if (sym == tree_case_s) {
return expand_tree_case(form, menv);
- } else if (sym == tree_bind_s || sym == mac_param_bind_s) {
+ } else if (sym == tree_bind_s || sym == mac_param_bind_s ||
+ sym == mac_env_param_bind_s)
+ {
val args = rest(form);
- val ctx_expr = if3(sym == mac_param_bind_s, pop(&args), nil);
+ val ctx_expr = if3(sym == mac_param_bind_s || sym == mac_env_param_bind_s,
+ pop(&args), nil);
+ val menvarg = if3(sym == mac_env_param_bind_s, pop(&args), nil);
val params = pop(&args);
val expr = pop(&args);
val body = args;
@@ -4731,9 +5181,20 @@ again:
expand_params(params, body, menv, t, form));
val new_menv = make_var_shadowing_env(menv, get_param_syms(params_ex));
val ctx_expr_ex = expand(ctx_expr, menv);
+ val menvarg_ex = expand(menvarg, menv);
val body_ex = expand_progn(body_ex0, new_menv);
val expr_ex = expand(expr, new_menv);
+ if (sym == mac_env_param_bind_s) {
+ if (ctx_expr_ex == ctx_expr && params_ex == params &&
+ menvarg_ex == menvarg && expr_ex == expr && body_ex == body)
+ return form;
+ return rlcp(cons(sym, cons(ctx_expr_ex,
+ cons(menvarg_ex,
+ cons(params_ex,
+ cons(expr_ex, body_ex))))), form);
+ }
+
if (sym == mac_param_bind_s) {
if (ctx_expr_ex == ctx_expr && params_ex == params &&
expr_ex == expr && body_ex == body)
@@ -4758,7 +5219,7 @@ again:
lit("fun used on special operator ~s"), arg, nao);
else if (!bindable(arg))
eval_warn(uw_last_form_expanded(),
- lit("~s appears in operator position"), arg, nao);
+ lit("fun expects function, not ~s"), arg, nao);
else
eval_defr_warn(uw_last_form_expanded(),
cons(fun_s, arg),
@@ -4766,7 +5227,10 @@ again:
arg, nao);
}
return form;
- } else if (sym == quote_s || sym == dvbind_s) {
+ } else if (sym == quote_s) {
+ syn_check(form, sym, cdr, cddr);
+ return form;
+ } else if (sym == dvbind_s) {
return form;
} else if (sym == for_op_s) {
val inits = second(form);
@@ -4788,8 +5252,8 @@ again:
forms_ex)))), form);
}
} else if (sym == dohash_s) {
- val spec = second(form);
- val keysym = first(spec);
+ val spec = (syn_check(form, sym, cdr, 0), second(form));
+ val keysym = (syn_check(spec, sym, cddr, cddddr), first(spec));
val valsym = second(spec);
val hashform = third(spec);
val resform = fourth(spec);
@@ -4816,14 +5280,14 @@ again:
return expand_catch(form, menv);
} else if (sym == handler_bind_s) {
val args = rest(form);
- val fun = pop(&args);
+ val fun = (syn_check(args, sym, cdr, 0), pop(&args));
val handle_syms = pop(&args);
val body = args;
val fun_ex = expand(fun, menv);
val body_ex = expand_forms(body, menv);
if (!cddr(form))
- eval_error(form, lit("~s: missing arguments"), sym, nao);
+ missing_arg_error(form, sym);
if (fun == fun_ex && body == body_ex)
return form;
@@ -4833,15 +5297,6 @@ again:
cons(handle_syms,
if3(body == body_ex,
body, body_ex)))), form);
- } else if (sym == macro_time_s) {
- val args = rest(form);
- val result = nil;
- for (; args; args = cdr(args)) {
- val arg = car(args);
- val arg_ex = expand(arg, menv);
- result = eval(arg_ex, nil, args);
- }
- return maybe_quote(result);
} else if (sym == macrolet_s) {
return expand_macrolet(form, menv);
} else if (sym == symacrolet_s) {
@@ -4875,6 +5330,17 @@ again:
return car(args_ex);
}
return expand(first(args), menv);
+ } else if (sym == progv_s) {
+ val body = (syn_check(form, sym, cddr, 0), cdddr(form));
+ val vars = cadr(form);
+ val vals = caddr(form);
+ val vars_ex = expand(vars, menv);
+ val vals_ex = expand(vals, menv);
+ val body_ex = expand_forms(body, menv);
+
+ if (vars_ex == vars && vals_ex == vals && body_ex == body)
+ return form;
+ return rlcp(cons(sym, cons(vars_ex, cons(vals_ex, body_ex))), form);
} else if (sym == sys_lisp1_value_s) {
return expand_lisp1_value(form, menv);
} else if (sym == sys_lisp1_setq_s) {
@@ -4883,6 +5349,26 @@ again:
return expand_setqf(form, menv);
} else if (sym == var_s || sym == expr_s) {
return form;
+ } else if (sym == compiler_let_s) {
+ val body = (syn_check(form, sym, cdr, 0), rest(rest(form)));
+ val vars = second(form);
+ val body_ex = expand_progn(body, menv);
+ val vars_ex = expand_vars(vars, nil, form, 0);
+ {
+ val var;
+ for (var = vars_ex; var; var = cdr(var)) {
+ val var_init = car(var);
+ if (!consp(var_init))
+ eval_warn(form, lit("~s: not a var-init form: ~s"),
+ sym, var_init, nao);
+ else if (!special_var_p(car(var_init)))
+ eval_warn(form, lit("~s: ~s is required to be a special variable"),
+ sym, car(var_init), nao);
+ }
+ }
+ if (body == body_ex)
+ return form;
+ return rlcp(cons(sym, cons(vars_ex, body_ex)), form);
} else {
/* funtion call expansion also handles: prog1, call, if, and, or,
unwind-protect, return and other special forms whose arguments
@@ -4896,11 +5382,7 @@ again:
val args_ex = expand_forms(args, menv);
if (sym == setq_s) {
- if (!args)
- eval_error(form, lit("~s: missing argument"), sym, nao);
-
- if (cddr(args))
- eval_error(form, lit("~s: excess arguments"), sym, nao);
+ syn_check(form, sym, cddr, cdddr);
{
val target = car(args_ex);
@@ -4912,6 +5394,9 @@ again:
}
}
+ if (sym == return_s)
+ syn_check(form, sym, identity, cddr);
+
if (consp(insym) && car(insym) == lambda_s) {
insym_ex = expand(insym, menv);
} else if (!lookup_fun(menv, insym) && !special_operator_p(insym)) {
@@ -4927,8 +5412,8 @@ again:
if (insym_ex == rcons_s &&
proper_list_p(args_ex) && length(args_ex) == two &&
- constantp(car(args_ex), menv) &&
- constantp(cadr(args_ex), menv))
+ constantp_noex(car(args_ex)) &&
+ constantp_noex(cadr(args_ex)))
{
return rlcp(rcons(eval(car(args_ex), menv, form),
eval(cadr(args_ex), menv, form)), form);
@@ -4940,7 +5425,12 @@ again:
return form_ex;
}
- return rlcp(cons(insym_ex, args_ex), form);
+ form = rlcp(cons(insym_ex, args_ex), form);
+ if (macro) {
+ macro = nil;
+ goto again;
+ }
+ return form;
}
abort();
}
@@ -4970,24 +5460,44 @@ val expand(val form, val menv)
return ret;
}
+static val muffle_unbound_warning(val exc, varg args)
+{
+ (void) exc;
+
+ args_normalize_least(args, 2);
+
+ if (args->fill >= 2) {
+ val tag = args->arg[1];
+
+ if (consp(tag)) {
+ val type = car(tag);
+ if (type == var_s || type == fun_s || type == sym_s)
+ uw_rthrow(continue_s, nil);
+ }
+ }
+
+ return nil;
+}
+
static val no_warn_expand(val form, val menv)
{
val ret;
uw_frame_t uw_handler;
uw_push_handler(&uw_handler, cons(defr_warning_s, nil),
- func_n1v(uw_muffle_warning));
+ func_n1v(muffle_unbound_warning));
ret = expand(form, menv);
uw_pop_frame(&uw_handler);
return ret;
}
-static val gather_free_refs(val info_cons, val exc, struct args *args)
+static val gather_free_refs(val info_cons, val exc, varg args)
{
+ val self = lit("expand-with-free-refs");
(void) exc;
args_normalize_least(args, 2);
- if (args_count(args) == 2) {
+ if (args_count(args, self) == 2) {
val tag = args_at(args, 1);
cons_bind (kind, sym, tag);
@@ -5000,20 +5510,20 @@ static val gather_free_refs(val info_cons, val exc, struct args *args)
if (!memq(sym, deref(dl)))
mpush(sym, dl);
}
- uw_throw(continue_s, nil);
+ uw_rthrow(continue_s, nil);
}
return nil;
}
static val gather_free_refs_nw(val info_cons, val exc,
- struct args *args)
+ varg args)
{
gather_free_refs(info_cons, exc, args);
- uw_throw(continue_s, nil);
+ return uw_rthrow(continue_s, nil);
}
-static val expand_with_free_refs(val form, val menv_in, val upto_menv_in)
+val expand_with_free_refs(val form, val menv_in, val upto_menv_in)
{
val ret;
val menv = default_null_arg(menv_in);
@@ -5104,7 +5614,27 @@ static val macroexpand_lisp1(val form, val menv)
static val constantp_noex(val form)
{
if (consp(form)) {
- return eq(car(form), quote_s);
+ val sym = car(form);
+ val args = cdr(form);
+ if (eq(sym, quote_s))
+ return t;
+ if (!proper_list_p(args))
+ return nil;
+ if (eq(sym, dwim_s)) {
+ sym = us_car(args);
+ args = us_cdr(args);
+ }
+ if (!symbolp(sym))
+ return nil;
+ if (!const_foldable_hash)
+ const_foldable_hash = cdr(lookup_var(nil, const_foldable_s));
+ if (!gethash(const_foldable_hash, sym))
+ return nil;
+ for (; args; args = us_cdr(args)) {
+ if (!constantp_noex(us_car(args)))
+ return nil;
+ }
+ return t;
} else {
if (bindable(form))
return nil;
@@ -5117,21 +5647,15 @@ static val constantp(val form, val env_in)
val env = default_null_arg(env_in);
if (consp(form)) {
- if (car(form) == quote_s) {
+ if (car(form) == quote_s)
return t;
- } else if (macro_form_p(form, env)) {
- return constantp_noex(macroexpand(form, env));
- } else {
- return nil;
- }
+ else
+ return constantp_noex(no_warn_expand(form, env));
} else if (symbolp(form)) {
- if (!bindable(form)) {
+ if (!bindable(form))
return t;
- } else if (macro_form_p(form, env)) {
- return constantp_noex(macroexpand(form, env));
- } else {
- return nil;
- }
+ else
+ return constantp_noex(no_warn_expand(form, env));
} else {
return t;
}
@@ -5139,8 +5663,7 @@ static val constantp(val form, val env_in)
static val me_l1_val(val form, val menv)
{
- if (length(form) != two)
- eval_error(form, lit("~s: invalid syntax"), first(form), nao);
+ syn_check(form, car(form), cdr, cddr);
{
val expr = cadr(form);
@@ -5158,7 +5681,7 @@ static val me_l1_val(val form, val menv)
return expr;
return list(sys_lisp1_value_s, expr_ex, nao);
} else {
- eval_error(form, lit("~s: invalid case"), car(form), nao);
+ expand_error(form, lit("~s: invalid case"), car(form), nao);
}
}
@@ -5168,8 +5691,7 @@ static val me_l1_val(val form, val menv)
static val me_l1_setq(val form, val menv)
{
- if (!consp(cdr(form)) || !consp(cddr(form)) || cdddr(form))
- eval_error(form, lit("~s: invalid syntax"), car(form), nao);
+ syn_check(form, car(form), cddr, cdddr);
{
val expr = cadr(form);
@@ -5182,7 +5704,7 @@ static val me_l1_setq(val form, val menv)
if (binding_type == var_k) {
return list(setq_s, expr_ex, new_val, nao);
} else if (binding_type == symacro_k) {
- eval_error(form, lit("~s: invalid use on symacro"), car(form), nao);
+ expand_error(form, lit("~s: invalid use on symacro"), car(form), nao);
} else if (boundp(expr_ex)) {
return list(setq_s, expr_ex, new_val, nao);
} else {
@@ -5194,6 +5716,48 @@ static val me_l1_setq(val form, val menv)
}
}
+static val rt_assert_fail(val file, val line, val expr,
+ val fmt, varg args)
+{
+ val str_stream = make_string_output_stream();
+
+ if (!missingp(fmt)) {
+ if (line && file) {
+ format(str_stream, lit("assertion ~s failed in ~a:~a: "),
+ expr, file, line, nao);
+ } else {
+ format(str_stream, lit("assertion ~s failed: "), expr, nao);
+ }
+ formatv(str_stream, fmt, args);
+ } else {
+ if (line && file) {
+ format(str_stream, lit("assertion ~s failed in ~a:~a\n"),
+ expr, file, line, nao);
+ } else {
+ format(str_stream, lit("assertion ~s failed"), expr, nao);
+ }
+ }
+
+ uw_throw(assert_s, get_string_from_stream(str_stream));
+ return nil;
+}
+
+static val me_assert(val form, val menv)
+{
+ cons_bind (line, file, source_loc(form));
+ val extra_args = (syn_check(form, car(form), cdr, 0), cddr(form));
+ val rt_assert_fail = intern(lit("rt-assert-fail"), system_package);
+
+ (void) menv;
+
+ return list(or_s, cadr(form),
+ apply_frob_args(list(rt_assert_fail, file, line,
+ list(quote_s, cadr(form), nao),
+ extra_args, nao)),
+ nao);
+}
+
+
static val return_star(val name, val retval)
{
uw_block_return(name, retval);
@@ -5209,82 +5773,139 @@ static val abscond_star(val name, val retval)
abort();
}
-val mapcarv(val fun, struct args *lists)
+static val map_common(val self, val fun, varg lists,
+ void (*collect_fn)(seq_build_t *, val),
+ val (*map_fn)(val fun, val seq))
{
if (!args_more(lists, 0)) {
return nil;
} else if (!args_two_more(lists, 0)) {
- return mapcar(fun, nullify(args_atz(lists, 0)));
+ return map_fn(fun, args_atz(lists, 0));
} else {
- val list_of_lists = args_get_list(lists);
- val lofl = mapcar_listout(func_n1(nullify), list_of_lists);
- val list_orig = car(list_of_lists);
- list_collect_decl (out, otail);
+ cnum i, idx, argc = args_count(lists, self);
+ int over_limit = (argc > MAP_ALLOCA_LIMIT);
+ val arg0 = args_at(lists, 0);
+ seq_iter_t *iter_array = coerce(seq_iter_t *,
+ if3(over_limit,
+ chk_malloc(argc * sizeof *iter_array),
+ alloca(argc * sizeof *iter_array)));
+ val buf = if2(over_limit, make_owned_buf(one, coerce(mem_t *, iter_array)));
+ seq_build_t out = { 0 };
+ args_decl(args_fun, max(argc, ARGS_MIN));
+
+ if (collect_fn != 0)
+ seq_build_init(self, &out, arg0);
+
+ for (i = 0, idx = 0; i < argc; i++)
+ {
+ val arg = args_get(lists, &idx);
+ seq_iter_init(self, &iter_array[i], arg);
+ }
for (;;) {
- val iter;
- list_collect_decl (args, atail);
+ val fun_ret;
+
+ for (i = 0; i < argc; i++) {
+ val elem;
+ seq_iter_t *iter = &iter_array[i];
- for (iter = lofl; iter; iter = cdr(iter)) {
- val list = car(iter);
- if (!list) {
- rcyc_list(lofl);
- return make_like(out, list_orig);
+ if (!seq_get(iter, &elem)) {
+ if (buf)
+ buf_free(buf);
+ return collect_fn != 0 ? seq_finish(&out) : nil;
}
- atail = list_collect(atail, car(list));
- deref(car_l(iter)) = cdr(list);
+
+ args_fun->arg[i] = elem;
}
- otail = list_collect(otail, apply(fun, z(args)));
+ args_fun->fill = argc;
+ args_fun->list = 0;
+
+ fun_ret = generic_funcall(fun, args_fun);
+
+ if (collect_fn != 0)
+ collect_fn(&out, fun_ret);
}
}
}
+val mapcarv(val fun, varg lists)
+{
+ return map_common(lit("mapcar"), fun, lists, seq_add, mapcar);
+}
+
val mapcarl(val fun, val list_of_lists)
{
args_decl_list(args, ARGS_MIN, list_of_lists);
return mapcarv(fun, args);
}
-static val mappendv(val fun, struct args *lists)
+static val mappendv(val fun, varg lists)
{
- if (!args_more(lists, 0)) {
- return nil;
- } else if (!args_two_more(lists, 0)) {
- return mappend(fun, args_atz(lists, 0));
- } else {
- val list_of_lists = args_get_list(lists);
- val lofl = mapcar(func_n1(nullify), list_of_lists);
- val list_orig = car(list_of_lists);
- list_collect_decl (out, otail);
+ return map_common(lit("mappend"), fun, lists, seq_pend, mappend);
+}
- for (;;) {
- val iter;
- list_collect_decl (args, atail);
+static val mapdov(val fun, varg lists)
+{
+ return map_common(lit("mapdo"), fun, lists, 0, mapdo);
+}
- for (iter = lofl; iter; iter = cdr(iter)) {
- val list = car(iter);
- if (!list) {
- rcyc_list(lofl);
- return make_like(out, list_orig);
- }
- atail = list_collect(atail, car(list));
- rplaca(iter, cdr(list));
- }
+static val zip_fun(val ziparg0, varg args)
+{
+ seq_build_t bu;
+ cnum index = 0;
+ seq_build_init(lit("zip"), &bu, ziparg0);
+ while (args_more(args, index))
+ seq_add(&bu, args_get(args, &index));
+ return seq_finish(&bu);
+}
- otail = list_collect_append(otail, apply(fun, z(args)));
+static val zipv(varg zipargs)
+{
+ if (!args_more(zipargs, 0))
+ return nil;
+
+ {
+ val ziparg0 = args_at(zipargs, 0);
+ val func = nil;
+
+ switch (type(ziparg0)) {
+ case NIL:
+ case CONS:
+ case LCONS:
+ func = list_f;
+ break;
+ case STR:
+ case LSTR:
+ case LIT:
+ func = join_f;
+ break;
+ case VEC:
+ func = func_n0v(vectorv);
+ break;
+ default:
+ func = func_f0v(ziparg0, zip_fun);
+ break;
}
+
+ return mapcarv(func, zipargs);
}
}
+static val transpose(val seq)
+{
+ args_decl_list(args, ARGS_MIN, tolist(seq));
+ return make_like(zipv(args), seq);
+}
+
static val lazy_mapcar_func(val env, val lcons)
{
- us_cons_bind (fun, list, env);
+ us_cons_bind (fun, iter, env);
- us_rplaca(lcons, funcall1(fun, car(list)));
- us_rplacd(env, cdr(list));
+ us_rplaca(lcons, funcall1(fun, iter_item(iter)));
+ us_rplacd(env, iter = iter_step(iter));
- if (cdr(list))
+ if (iter_more(iter))
us_rplacd(lcons, make_lazy_cons(us_lcons_fun(lcons)));
else
us_rplacd(lcons, nil);
@@ -5293,29 +5914,29 @@ static val lazy_mapcar_func(val env, val lcons)
val lazy_mapcar(val fun, val list)
{
- list = nullify(list);
- if (!list)
+ val iter = iter_begin(list);
+ if (!iter_more(iter))
return nil;
- return make_lazy_cons(func_f1(cons(fun, list), lazy_mapcar_func));
+ return make_lazy_cons(func_f1(cons(fun, iter), lazy_mapcar_func));
}
static val lazy_mapcarv_func(val env, val lcons)
{
- us_cons_bind (fun, lofl, env);
- val args = mapcar(car_f, lofl);
- val next = mapcar(cdr_f, lofl);
+ us_cons_bind (fun, list_of_iters, env);
+ val args = mapcar(iter_item_f, list_of_iters);
+ val next = mapcar(iter_step_f, list_of_iters);
us_rplaca(lcons, apply(fun, z(args)));
us_rplacd(env, next);
- if (all_satisfy(next, identity_f, identity_f))
+ if (all_satisfy(next, iter_more_f, identity_f))
us_rplacd(lcons, make_lazy_cons(us_lcons_fun(lcons)));
else
us_rplacd(lcons, nil);
return nil;
}
-static val lazy_mapcarv(val fun, struct args *lists)
+static val lazy_mapcarv(val fun, varg lists)
{
if (!args_more(lists, 0)) {
return nil;
@@ -5323,11 +5944,12 @@ static val lazy_mapcarv(val fun, struct args *lists)
return lazy_mapcar(fun, args_atz(lists, 0));
} else {
val list_of_lists = args_get_list(lists);
- if (some_satisfy(list_of_lists, null_f, identity_f)) {
+ if (!all_satisfy(list_of_lists, iter_more_f, identity_f)) {
return nil;
} else {
- val lofl = mapcar(func_n1(nullify), list_of_lists);
- return make_lazy_cons(func_f1(cons(fun, lofl), lazy_mapcarv_func));
+ val list_of_iters = mapcar(iter_begin_f, list_of_lists);
+ return make_lazy_cons(func_f1(cons(fun, list_of_iters),
+ lazy_mapcarv_func));
}
}
}
@@ -5338,95 +5960,76 @@ static val lazy_mapcarl(val fun, val list_of_lists)
return lazy_mapcarv(fun, args);
}
-static val lazy_mappendv(val fun, struct args *lists)
+static val lazy_mappendv(val fun, varg lists)
{
return lazy_appendl(lazy_mapcarv(fun, lists));
}
-static val mapdov(val fun, struct args *lists)
+static val prod_common(val self, val fun, varg lists,
+ loc (*collect_fn)(loc ptail, val obj),
+ val (*mapv_fn)(val fun, varg lists))
{
if (!args_more(lists, 0)) {
return nil;
} else if (!args_two_more(lists, 0)) {
- return mapdo(fun, args_atz(lists, 0));
+ return mapv_fn(fun, lists);
} else {
- val list_of_lists = args_get_list(lists);
- val lofl = mapcar_listout(func_n1(nullify), list_of_lists);
-
- for (;;) {
- val iter;
- list_collect_decl (args, atail);
-
- for (iter = lofl; iter; iter = cdr(iter)) {
- val list = car(iter);
- if (!list) {
- rcyc_list(lofl);
- return nil;
- }
- atail = list_collect(atail, car(list));
- rplaca(iter, cdr(list));
- }
-
- apply(fun, z(args));
- }
- }
-}
-
-static val prod_common(val fun, struct args *lists,
- loc (*collect_fptr)(loc ptail, val obj))
-{
- if (!args_more(lists, 0)) {
- return nil;
- } else if (!args_two_more(lists, 0)) {
- return mappendv(fun, lists);
- } else {
- cnum argc = args_count(lists), i;
+ cnum argc = args_count(lists, self), i;
+ list_collect_decl (out, ptail);
args_decl(args_reset, max(argc, ARGS_MIN));
args_decl(args_work, max(argc, ARGS_MIN));
+ args_decl(args_fun, max(argc, ARGS_MIN));
args_copy(args_reset, lists);
args_normalize_exact(args_reset, argc);
- args_copy(args_work, args_reset);
- list_collect_decl (out, ptail);
+ args_work->fill = argc;
for (i = 0; i < argc; i++)
- args_work->arg[i] = nullify(args_work->arg[i]);
+ if (!iter_more((args_work->arg[i] = iter_begin(args_reset->arg[i]))))
+ goto out;
for (;;) {
- args_decl(args_fun, max(argc, ARGS_MIN));
- for (i = 0; i < argc; i++) {
- val seq_i = args_work->arg[i];
- if (!seq_i)
- goto out;
- args_fun->arg[i] = car(seq_i);
- }
+ val ret;
+
+ for (i = 0; i < argc; i++)
+ args_fun->arg[i] = iter_item(args_work->arg[i]);
args_fun->fill = argc;
- ptail = collect_fptr(ptail, generic_funcall(fun, args_fun));
+ args_fun->list = 0;
+
+ ret = generic_funcall(fun, args_fun);
+
+ if (collect_fn)
+ ptail = collect_fn(ptail, ret);
for (i = argc - 1; ; i--) {
- val cdr_i = cdr(args_work->arg[i]);
- if (cdr_i) {
- args_work->arg[i] = cdr_i;
+ val step_i = iter_step(args_work->arg[i]);
+ if (iter_more(step_i)) {
+ args_work->arg[i] = step_i;
break;
}
if (i == 0)
goto out;
- args_work->arg[i] = args_reset->arg[i];
+ args_work->arg[i] = iter_begin(args_reset->arg[i]);
}
}
out:
- return make_like(out, args_reset->arg[0]);
+ return collect_fn ? make_like(out, args_at(lists, 0)) : nil;
}
}
-val maprodv(val fun, struct args *lists)
+val maprodv(val fun, varg lists)
+{
+ return prod_common(lit("maprod"), fun, lists, list_collect, mapcarv);
+}
+
+val maprendv(val fun, varg lists)
{
- return prod_common(fun, lists, list_collect);
+ return prod_common(lit("maprend"), fun, lists, list_collect_append, mappendv);
}
-val maprendv(val fun, struct args *lists)
+static val maprodo(val fun, varg lists)
{
- return prod_common(fun, lists, list_collect_append);
+ return prod_common(lit("maprodo"), fun, lists, 0, mapdov);
}
static val symbol_value(val sym)
@@ -5437,6 +6040,34 @@ static val symbol_value(val sym)
lookup_symac(nil, sym)));
}
+static val set_symbol_value(val sym, val value)
+{
+ val vbind = lookup_var(nil, sym);
+
+ if (vbind)
+ rplacd(vbind, value);
+ else
+ sethash(top_vb, sym, value);
+
+ return value;
+}
+
+static val rt_progv(val syms, val values)
+{
+ val env = dyn_env;
+
+ for (; syms; syms = cdr(syms), values = cdr(values))
+ {
+ val sym = car(syms);
+ val value = if3(values, car(values), unbound_s);
+ if (!bindable(sym))
+ uw_throwf(error_s, lit("progv: ~s isn't a bindable symbol"), sym, nao);
+ env_vbind(env, sym, value);
+ }
+
+ return nil;
+}
+
static val symbol_function(val sym)
{
uses_or2;
@@ -5480,7 +6111,7 @@ static val makunbound(val sym)
{
val env;
- lisplib_try_load(sym);
+ autoload_try_var(sym);
if (!opt_compat || opt_compat > 143) {
for (env = dyn_env; env; env = env->e.up_env) {
@@ -5492,28 +6123,35 @@ static val makunbound(val sym)
}
}
- remhash(top_vb, sym);
+ if (gethash_d(top_vb, sym)) {
+ remhash(top_vb, sym);
+ vm_invalidate_binding(sym);
+ }
+
remhash(top_smb, sym);
remhash(special, sym);
- vm_invalidate_binding(sym);
-
return sym;
}
static val fmakunbound(val sym)
{
- lisplib_try_load(sym);
- remhash(top_fb, sym);
+ autoload_try_var(sym);
+
+ if (gethash_d(top_fb, sym)) {
+ remhash(top_fb, sym);
+ vm_invalidate_binding(sym);
+ }
+
if (opt_compat && opt_compat <= 127)
remhash(top_mb, sym);
- vm_invalidate_binding(sym);
+
return sym;
}
static val mmakunbound(val sym)
{
- lisplib_try_load(sym);
+ autoload_try_fun(sym);
remhash(top_mb, sym);
return sym;
}
@@ -5542,14 +6180,87 @@ static val range_func(val env, val lcons)
return nil;
}
+static val range_func_fstep(val env, val lcons)
+{
+ us_cons_bind (from, to_step, env);
+ us_cons_bind (to, stepfn, to_step);
+ val next = funcall1(stepfn, from);
+ us_rplaca(lcons, from);
+
+ if (equal(from, to))
+ {
+ us_rplacd(lcons, nil);
+ return nil;
+ }
+
+ us_rplacd(lcons, make_lazy_cons(us_lcons_fun(lcons)));
+ us_rplaca(env, next);
+ return nil;
+}
+
+static val range_func_fstep_inf(val env, val lcons)
+{
+ us_cons_bind (from, stepfn, env);
+ val next = funcall1(stepfn, from);
+ us_rplaca(lcons, from);
+ us_rplacd(lcons, make_lazy_cons(us_lcons_fun(lcons)));
+ us_rplaca(env, next);
+ return nil;
+}
+
+static val range_func_iter(val env, val lcons)
+{
+ us_cons_bind (iter, step, env);
+ val next = iter_item(iter);
+
+ us_rplaca(lcons, next);
+
+ while (plusp(step)) {
+ iter = iter_step(iter);
+ step = minus(step, one);
+ }
+
+ if (!iter_more(iter)) {
+ us_rplacd(lcons, nil);
+ return nil;
+ }
+
+ us_rplacd(lcons, make_lazy_cons(us_lcons_fun(lcons)));
+ us_rplaca(env, iter);
+ return nil;
+}
+
static val range(val from_in, val to_in, val step_in)
{
+ val self = lit("range");
val from = default_arg(from_in, zero);
val to = default_null_arg(to_in);
- val step = default_arg(step_in, if3(to && gt(from, to), negone, one));
- val env = cons(from, cons(to, step));
- return make_lazy_cons(func_f1(env, range_func));
+ if (arithp(from)) {
+ val step = default_arg(step_in, if3(to && gt(from, to), negone, one));
+ val env = cons(from, cons(to, step));
+ return make_lazy_cons(func_f1(env, range_func));
+ } else {
+ val step = default_arg(step_in, one);
+
+ if (functionp(step)){
+ if (missingp(to_in)) {
+ val env = cons(from, step);
+ return make_lazy_cons(func_f1(env, range_func_fstep_inf));
+ } else {
+ val env = cons(from, cons(to, step));
+ return make_lazy_cons(func_f1(env, range_func_fstep));
+ }
+ } else if (integerp(step) && plusp(step)) {
+ val iter = iter_begin(rcons(from, to));
+ val env = cons(iter, step);
+ return if2(iter_more(iter),
+ make_lazy_cons(func_f1(env, range_func_iter)));
+ } else {
+ uw_throwf(error_s, lit("~s: step must be positive integer, not ~s"),
+ self, step, nao);
+ }
+ }
}
static val range_star_func(val env, val lcons)
@@ -5576,18 +6287,85 @@ static val range_star_func(val env, val lcons)
return nil;
}
+static val range_star_func_fstep(val env, val lcons)
+{
+ us_cons_bind (from, to_step, env);
+ us_cons_bind (to, stepfn, to_step);
+ val next = funcall1(stepfn, from);
+ us_rplaca(lcons, from);
+
+ if (equal(next, to))
+ {
+ us_rplacd(lcons, nil);
+ return nil;
+ }
+
+ us_rplacd(lcons, make_lazy_cons(us_lcons_fun(lcons)));
+ us_rplaca(env, next);
+ return nil;
+}
+
+static val range_star_func_iter(val env, val lcons)
+{
+ us_cons_bind (iter, prev_step, env);
+ us_cons_bind (prev, step, prev_step);
+ val next = nil;
+ us_rplaca(lcons, prev);
+
+ while (plusp(step)) {
+ if (iter_more(iter))
+ next = iter_item(iter);
+ iter = iter_step(iter);
+ step = minus(step, one);
+ }
+
+ if (!iter_more(iter)) {
+ us_rplacd(lcons, nil);
+ return nil;
+ }
+
+ us_rplaca(prev_step, next);
+ us_rplacd(lcons, make_lazy_cons(us_lcons_fun(lcons)));
+ us_rplaca(env, iter);
+ return nil;
+}
+
static val range_star(val from_in, val to_in, val step_in)
{
+ val self = lit("range*");
val from = default_arg(from_in, zero);
val to = default_null_arg(to_in);
- if (eql(from, to)) {
+ if (equal(from, to)) {
return nil;
- } else {
+ } else if (arithp(from)) {
val step = default_arg(step_in, if3(to && gt(from, to), negone, one));
val env = cons(from, cons(to, step));
-
return make_lazy_cons(func_f1(env, range_star_func));
+ } else {
+ val step = default_arg(step_in, one);
+
+ if (functionp(step)){
+ if (missingp(to_in)) {
+ val env = cons(from, step);
+ return make_lazy_cons(func_f1(env, range_func_fstep_inf));
+ } else {
+ val env = cons(from, cons(to, step));
+ return make_lazy_cons(func_f1(env, range_star_func_fstep));
+ }
+ } else if (integerp(step) && plusp(step)) {
+ val iter = iter_begin(rcons(from, to));
+ if (iter_more(iter)) {
+ val next = iter_item(iter);
+ val nxiter = iter_step(iter);
+ val env = cons(nxiter, cons(next, step));
+ return make_lazy_cons(func_f1(env, range_star_func_iter));
+ }
+ return nil;
+ } else {
+ uw_throwf(error_s, lit("~s: step must be positive integer, not ~s"),
+ self, step, nao);
+ }
}
}
@@ -5615,14 +6393,14 @@ static val rlist_star_fun(val item)
return cons(item, nil);
}
-static val rlist(struct args *items)
+static val rlist(varg items)
{
args_decl_list(lists, ARGS_MIN,
lazy_mapcar(func_n1(rlist_fun), args_get_list(items)));
return lazy_appendv(lists);
}
-static val rlist_star(struct args *items)
+static val rlist_star(varg items)
{
args_decl_list(lists, ARGS_MIN,
lazy_mapcar(func_n1(rlist_star_fun), args_get_list(items)));
@@ -5886,7 +6664,7 @@ static val weave_gen(val env)
return ret;
}
-static val weavev(struct args *args)
+static val weavev(varg args)
{
val lists = args_get_list(args);
val uniq = cons(nil, nil);
@@ -5944,21 +6722,21 @@ static void reg_op(val sym, opfun_t fun)
void reg_fun(val sym, val fun)
{
assert (sym != 0);
- sethash(top_fb, sym, cons(sym, fun));
+ sethash(top_fb, sym, fun);
sethash(builtin, sym, defun_s);
}
void reg_mac(val sym, val fun)
{
assert (sym != 0);
- sethash(top_mb, sym, cons(sym, fun));
+ sethash(top_mb, sym, fun);
sethash(builtin, sym, defmacro_s);
}
void reg_varl(val sym, val val)
{
assert (sym != nil);
- sethash(top_vb, sym, cons(sym, val));
+ sethash(top_vb, sym, val);
}
void reg_var(val sym, val val)
@@ -5967,15 +6745,9 @@ void reg_var(val sym, val val)
mark_special(sym);
}
-static void reg_symacro(val sym, val form)
+void reg_symacro(val sym, val form)
{
- loc pcdr = gethash_l(lit("internal initialization"), top_smb, sym, nulloc);
- val binding = deref(pcdr);
-
- if (binding)
- rplacd(binding, form);
- else
- set(pcdr, cons(sym, form));
+ sethash(top_smb, sym, form);
}
static val if_fun(val cond, val then, val alt)
@@ -5983,7 +6755,7 @@ static val if_fun(val cond, val then, val alt)
return if3(cond, then, default_null_arg(alt));
}
-static val or_fun(struct args *vals)
+static val or_fun(varg vals)
{
cnum index = 0;
@@ -5995,7 +6767,12 @@ static val or_fun(struct args *vals)
return nil;
}
-static val and_fun(struct args *vals)
+static val nor_fun(varg vals)
+{
+ return tnil(!or_fun(vals));
+}
+
+static val and_fun(varg vals)
{
val item = t;
cnum index = 0;
@@ -6009,24 +6786,45 @@ static val and_fun(struct args *vals)
return item;
}
+static val nand_fun(varg vals)
+{
+ return tnil(!and_fun(vals));
+}
+
+static val progn_fun(varg vals)
+{
+ return if3(vals->list, car(lastcons(vals->list)), vals->arg[vals->fill - 1]);
+}
+
+static val prog1_fun(varg vals)
+{
+ return if2(args_more(vals, 0), args_at(vals, 0));
+}
+
+static val prog2_fun(varg vals)
+{
+ args_normalize_least(vals, 2);
+ return if2(vals->fill >= 2, vals->arg[1]);
+}
+
static val not_null(val obj)
{
return if3(nilp(obj), nil, t);
}
-static val tf(struct args *args)
+static val tf(varg args)
{
(void) args;
return t;
}
-static val nilf(struct args *args)
+static val nilf(varg args)
{
(void) args;
return nil;
}
-static val do_retf(val ret, struct args *args)
+static val do_retf(val ret, varg args)
{
(void) args;
return ret;
@@ -6037,16 +6835,17 @@ val retf(val ret)
return func_f0v(ret, do_retf);
}
-static val do_apf(val fun, struct args *args)
+static val do_apf(val fun, varg args)
{
return applyv(fun, args);
}
-static val do_args_apf(val dargs, struct args *args)
+static val do_args_apf(val dargs, varg args)
{
+ val self = lit("apf");
val fun = dargs->a.car;
- struct args *da = dargs->a.args;
- cnum da_nargs = da->fill + c_num(length(da->list));
+ varg da = dargs->a.args;
+ cnum da_nargs = da->fill + c_num(length(da->list), self);
args_decl(args_call, max(args->fill + da_nargs, ARGS_MIN));
args_copy(args_call, da);
args_normalize_exact(args_call, da_nargs);
@@ -6055,7 +6854,7 @@ static val do_args_apf(val dargs, struct args *args)
return applyv(fun, args_call);
}
-static val apf(val fun, struct args *args)
+static val apf(val fun, varg args)
{
if (!args || !args_more(args, 0))
return func_f0v(fun, do_apf);
@@ -6063,16 +6862,17 @@ static val apf(val fun, struct args *args)
return func_f0v(dyn_args(args, fun, nil), do_args_apf);
}
-static val do_ipf(val fun, struct args *args)
+static val do_ipf(val fun, varg args)
{
return iapply(fun, args);
}
-static val do_args_ipf(val dargs, struct args *args)
+static val do_args_ipf(val dargs, varg args)
{
+ val self = lit("ipf");
val fun = dargs->a.car;
- struct args *da = dargs->a.args;
- cnum da_nargs = da->fill + c_num(length(da->list));
+ varg da = dargs->a.args;
+ cnum da_nargs = da->fill + c_num(length(da->list), self);
args_decl(args_call, max(args->fill + da_nargs, ARGS_MIN));
args_copy(args_call, da);
args_normalize_exact(args_call, da_nargs);
@@ -6082,7 +6882,7 @@ static val do_args_ipf(val dargs, struct args *args)
}
-static val ipf(val fun, struct args *args)
+static val ipf(val fun, varg args)
{
if (!args || !args_more(args, 0))
return func_f0v(fun, do_ipf);
@@ -6090,35 +6890,37 @@ static val ipf(val fun, struct args *args)
return func_f0v(dyn_args(args, fun, nil), do_args_ipf);
}
-static val callf(val func, struct args *funlist)
+static val callf(val func, varg funlist)
{
val juxt_fun = juxtv(funlist);
val apf_fun = apf(func, 0);
return chain(juxt_fun, apf_fun, nao);
}
-static val do_mapf(val env, struct args *args)
+static val do_mapf(val env, varg args)
{
cons_bind (fun, funlist, env);
val mapped_args = mapcarl(call_f, cons(funlist, cons(args_get_list(args), nil)));
return apply(fun, z(mapped_args));
}
-static val mapf(val fun, struct args *funlist)
+static val mapf(val fun, varg funlist)
{
return func_f0v(cons(fun, args_get_list(funlist)), do_mapf);
}
-val prinl(val obj, val stream)
+val prinl(val obj, val stream_in)
{
- val ret = obj_print(obj, default_arg(stream, std_output), nil);
+ val stream = default_arg_strict(stream_in, std_output);
+ val ret = obj_print(obj, stream, nil);
put_char(chr('\n'), stream);
return ret;
}
-val pprinl(val obj, val stream)
+val pprinl(val obj, val stream_in)
{
- val ret = obj_print(obj, default_arg(stream, std_output), t);
+ val stream = default_arg_strict(stream_in, std_output);
+ val ret = obj_print(obj, stream, t);
put_char(chr('\n'), stream);
return ret;
}
@@ -6130,13 +6932,15 @@ val tprint(val obj, val out)
switch (si.kind) {
case SEQ_NIL:
- break;
+ return nil;
case SEQ_LISTLIKE:
+ if (consp(si.obj))
{
gc_hint(si.obj);
gc_hint(obj);
for (obj = z(si.obj); !endp(obj); obj = cdr(obj))
tprint(car(obj), out);
+ return nil;
}
break;
case SEQ_VECLIKE:
@@ -6145,23 +6949,27 @@ val tprint(val obj, val out)
case STR:
case LSTR:
put_line(obj, out);
- break;
+ return nil;
default:
- {
- val vec = si.obj;
- cnum i, len = c_fixnum(length(vec), self);
-
- for (i = 0; i < len; i++)
- tprint(ref(vec, num_fast(i)), out);
-
- }
break;
}
break;
- case SEQ_NOTSEQ:
+ case SEQ_TREELIKE:
+ break;
case SEQ_HASHLIKE:
+ case SEQ_NOTSEQ:
pprinl(obj, out);
- break;
+ return nil;
+ }
+
+ {
+ seq_iter_t iter;
+ val elem;
+
+ seq_iter_init_with_info(self, &iter, si, 0);
+
+ while (seq_get(&iter, &elem))
+ tprint(elem, out);
}
return nil;
@@ -6191,29 +6999,49 @@ static val merge_wrap(val seq1, val seq2, val lessfun, val keyfun)
void eval_init(void)
{
val not_null_f = func_n1(not_null);
+ val me_def_variable_f = func_n2(me_def_variable);
val me_each_f = func_n2(me_each);
val me_for_f = func_n2(me_for);
+ val me_qquote_f = func_n2(me_qquote);
val length_f = func_n1(length);
+ val me_flet_labels_f = func_n2(me_flet_labels);
+ val me_case_f = func_n2(me_case);
+ val me_ecase_f = func_n2(me_ecase);
+ val me_iflet_whenlet_f = func_n2(me_iflet_whenlet);
+ val me_while_until_f = func_n2(me_while_until);
+ val me_while_until_star_f = func_n2(me_while_until_star);
protect(&top_vb, &top_fb, &top_mb, &top_smb, &special, &builtin, &dyn_env,
&op_table, &pm_table, &last_form_evaled,
- &call_f, &unbound_s, &origin_hash, convert(val *, 0));
- top_fb = make_hash(t, nil, nil);
- top_vb = make_hash(t, nil, nil);
- top_mb = make_hash(t, nil, nil);
- top_smb = make_hash(t, nil, nil);
- special = make_hash(t, nil, nil);
- builtin = make_hash(t, nil, nil);
- op_table = make_hash(nil, nil, nil);
- pm_table = make_hash(nil, nil, nil);
+ &call_f, &iter_begin_f, &iter_from_binding_f, &iter_more_f,
+ &iter_item_f, &iter_step_f, &join_f,
+ &unbound_s, &origin_hash, &const_foldable_hash,
+ &unused_arg_s, convert(val *, 0));
+ top_fb = make_hash(hash_weak_and, nil);
+ top_vb = make_hash(hash_weak_and, nil);
+ top_mb = make_hash(hash_weak_and, nil);
+ top_smb = make_hash(hash_weak_and, nil);
+ special = make_hash(hash_weak_and, nil);
+ builtin = make_hash(hash_weak_and, nil);
+ op_table = make_hash(hash_weak_none, nil);
+ pm_table = make_hash(hash_weak_none, nil);
call_f = func_n1v(generic_funcall);
+ iter_begin_f = func_n1(iter_begin);
+ iter_from_binding_f = chain(cdr_f, iter_begin_f, nao);
+ iter_more_f = func_n1(iter_more);
+ iter_item_f = func_n1(iter_item);
+ iter_step_f = func_n1(iter_step);
+ join_f = func_n0v(fmt_join);
- origin_hash = make_eq_hash(t, nil);
+ origin_hash = make_eq_hash(hash_weak_keys);
dwim_s = intern(lit("dwim"), user_package);
progn_s = intern(lit("progn"), user_package);
prog1_s = intern(lit("prog1"), user_package);
+ prog2_s = intern(lit("prog2"), user_package);
+ progv_s = intern(lit("progv"), user_package);
+ sys_blk_s = intern(lit("blk"), system_package);
let_s = intern(lit("let"), user_package);
let_star_s = intern(lit("let*"), user_package);
lambda_s = intern(lit("lambda"), user_package);
@@ -6255,6 +7083,7 @@ void eval_init(void)
tree_case_s = intern(lit("tree-case"), user_package);
tree_bind_s = intern(lit("tree-bind"), user_package);
mac_param_bind_s = intern(lit("mac-param-bind"), user_package);
+ mac_env_param_bind_s = intern(lit("mac-env-param-bind"), user_package);
setq_s = intern(lit("setq"), system_package);
sys_lisp1_setq_s = intern(lit("lisp1-setq"), system_package);
sys_lisp1_value_s = intern(lit("lisp1-value"), system_package);
@@ -6262,7 +7091,6 @@ void eval_init(void)
sys_l1_val_s = intern(lit("l1-val"), system_package);
setqf_s = intern(lit("setqf"), system_package);
inc_s = intern(lit("inc"), user_package);
- zap_s = intern(lit("zap"), user_package);
for_s = intern(lit("for"), user_package);
for_star_s = intern(lit("for*"), user_package);
each_s = intern(lit("each"), user_package);
@@ -6320,21 +7148,27 @@ void eval_init(void)
special_s = intern(lit("special"), system_package);
unbound_s = make_sym(lit("unbound"));
symacro_k = intern(lit("symacro"), keyword_package);
+ macro_k = intern(lit("macro"), keyword_package);
prof_s = intern(lit("prof"), user_package);
switch_s = intern(lit("switch"), system_package);
struct_s = intern(lit("struct"), user_package);
load_path_s = intern(lit("*load-path*"), user_package);
+ load_hooks_s = intern(lit("*load-hooks*"), user_package);
load_recursive_s = intern(lit("*load-recursive*"), system_package);
+ load_search_dirs_s = intern(lit("*load-search-dirs*"), user_package);
+ load_args_s = intern(lit("*load-args*"), user_package);
load_time_s = intern(lit("load-time"), user_package);
load_time_lit_s = intern(lit("load-time-lit"), system_package);
eval_only_s = intern(lit("eval-only"), user_package);
compile_only_s = intern(lit("compile-only"), user_package);
+ compiler_let_s = intern(lit("compiler-let"), user_package);
+ const_foldable_s = intern(lit("%const-foldable%"), system_package);
+ pct_fun_s = intern(lit("%fun%"), user_package);
qquote_init();
reg_op(macrolet_s, op_error);
reg_op(symacrolet_s, op_error);
- reg_op(macro_time_s, op_error);
reg_op(var_s, op_meta_error);
reg_op(expr_s, op_meta_error);
reg_op(quote_s, op_quote);
@@ -6346,7 +7180,9 @@ void eval_init(void)
reg_op(sys_splice_s, op_unquote_error);
reg_op(progn_s, op_progn);
reg_op(prog1_s, op_prog1);
+ reg_op(progv_s, op_progv);
reg_op(let_s, op_let);
+ reg_op(compiler_let_s, op_let);
reg_op(each_op_s, op_each);
reg_op(let_star_s, op_let);
reg_op(fbind_s, op_fbind);
@@ -6365,6 +7201,7 @@ void eval_init(void)
reg_op(tree_case_s, op_tree_case);
reg_op(tree_bind_s, op_tree_bind);
reg_op(mac_param_bind_s, op_mac_param_bind);
+ reg_op(mac_env_param_bind_s, op_mac_env_param_bind);
reg_op(setq_s, op_setq);
reg_op(sys_lisp1_setq_s, op_lisp1_setq);
reg_op(sys_lisp1_value_s, op_lisp1_value);
@@ -6374,6 +7211,7 @@ void eval_init(void)
reg_op(uw_protect_s, op_unwind_protect);
reg_op(block_s, op_block);
reg_op(block_star_s, op_block_star);
+ reg_op(sys_blk_s, op_block);
reg_op(return_s, op_return);
reg_op(return_from_s, op_return_from);
reg_op(sys_abscond_from_s, op_abscond_from);
@@ -6388,9 +7226,10 @@ void eval_init(void)
reg_op(eval_only_s, op_progn);
reg_op(load_time_lit_s, op_load_time_lit);
- reg_mac(defvar_s, func_n2(me_def_variable));
- reg_mac(defparm_s, func_n2(me_def_variable));
- reg_mac(defparml_s, func_n2(me_def_variable));
+ reg_mac(macro_time_s, func_n2(me_macro_time));
+ reg_mac(defvar_s, me_def_variable_f);
+ reg_mac(defparm_s, me_def_variable_f);
+ reg_mac(defparml_s, me_def_variable_f);
reg_mac(each_s, me_each_f);
reg_mac(each_star_s, me_each_f);
reg_mac(collect_each_s, me_each_f);
@@ -6402,42 +7241,52 @@ void eval_init(void)
reg_mac(gen_s, func_n2(me_gen));
reg_mac(gun_s, func_n2(me_gun));
reg_mac(intern(lit("delay"), user_package), func_n2(me_delay));
- if (opt_compat && opt_compat <= 184) {
- reg_mac(op_s, func_n2(me_op));
- reg_mac(do_s, func_n2(me_op));
- }
reg_mac(sys_l1_val_s, func_n2(me_l1_val));
reg_mac(sys_l1_setq_s, func_n2(me_l1_setq));
- reg_mac(qquote_s, func_n2(me_qquote));
- reg_mac(sys_qquote_s, func_n2(me_qquote));
+ reg_mac(qquote_s, me_qquote_f);
+ reg_mac(sys_qquote_s, me_qquote_f);
reg_mac(intern(lit("equot"), user_package), func_n2(me_equot));
reg_mac(intern(lit("pprof"), user_package), func_n2(me_pprof));
+ reg_mac(intern(lit("nand"), user_package), func_n2(me_nand));
+ reg_mac(intern(lit("nor"), user_package), func_n2(me_nor));
reg_mac(when_s, func_n2(me_when));
reg_mac(intern(lit("unless"), user_package), func_n2(me_unless));
- reg_mac(while_s, func_n2(me_while_until));
- reg_mac(while_star_s, func_n2(me_while_until_star));
- reg_mac(until_s, func_n2(me_while_until));
- reg_mac(until_star_s, func_n2(me_while_until_star));
+ reg_mac(while_s, me_while_until_f);
+ reg_mac(until_s, me_while_until_f);
+ reg_mac(while_star_s, me_while_until_star_f);
+ reg_mac(until_star_s, me_while_until_star_f);
reg_mac(quasilist_s, func_n2(me_quasilist));
- reg_mac(flet_s, func_n2(me_flet_labels));
- reg_mac(labels_s, func_n2(me_flet_labels));
- reg_mac(caseq_s, func_n2(me_case));
- reg_mac(caseql_s, func_n2(me_case));
- reg_mac(casequal_s, func_n2(me_case));
- reg_mac(caseq_star_s, func_n2(me_case));
- reg_mac(caseql_star_s, func_n2(me_case));
- reg_mac(casequal_star_s, func_n2(me_case));
+ reg_mac(flet_s, me_flet_labels_f);
+ reg_mac(labels_s, me_flet_labels_f);
+ reg_mac(caseq_s, me_case_f);
+ reg_mac(caseql_s, me_case_f);
+ reg_mac(casequal_s, me_case_f);
+ reg_mac(caseq_star_s, me_case_f);
+ reg_mac(caseql_star_s, me_case_f);
+ reg_mac(casequal_star_s, me_case_f);
+ reg_mac(intern(lit("ecaseq"), user_package), me_ecase_f);
+ reg_mac(intern(lit("ecaseql"), user_package), me_ecase_f);
+ reg_mac(intern(lit("ecasequal"), user_package), me_ecase_f);
+ reg_mac(intern(lit("ecaseq*"), user_package), me_ecase_f);
+ reg_mac(intern(lit("ecaseql*"), user_package), me_ecase_f);
+ reg_mac(intern(lit("ecasequal*"), user_package), me_ecase_f);
+ reg_mac(prog2_s, func_n2(me_prog2));
reg_mac(intern(lit("tb"), user_package), func_n2(me_tb));
reg_mac(intern(lit("tc"), user_package), func_n2(me_tc));
reg_mac(intern(lit("ignerr"), user_package), func_n2(me_ignerr));
reg_mac(intern(lit("whilet"), user_package), func_n2(me_whilet));
- reg_mac(iflet_s, func_n2(me_iflet_whenlet));
- reg_mac(intern(lit("whenlet"), user_package), func_n2(me_iflet_whenlet));
+ reg_mac(iflet_s, me_iflet_whenlet_f);
+ reg_mac(intern(lit("whenlet"), user_package), me_iflet_whenlet_f);
reg_mac(intern(lit("dotimes"), user_package), func_n2(me_dotimes));
reg_mac(intern(lit("lcons"), user_package), func_n2(me_lcons));
reg_mac(intern(lit("mlet"), user_package), func_n2(me_mlet));
reg_mac(load_time_s, func_n2(me_load_time));
reg_mac(intern(lit("load-for"), user_package), func_n2(me_load_for));
+ reg_mac(intern(lit("push-after-load"), user_package),
+ func_n2(me_push_after_load));
+ reg_mac(intern(lit("pop-after-load"), user_package),
+ func_n2(me_pop_after_load));
+ reg_mac(intern(lit("assert"), user_package), func_n2(me_assert));
reg_fun(cons_s, func_n2(cons));
reg_fun(intern(lit("make-lazy-cons"), user_package),
@@ -6451,8 +7300,8 @@ void eval_init(void)
reg_fun(rplacd_s, func_n2(rplacd));
reg_fun(intern(lit("rplaca"), system_package), func_n2(sys_rplaca));
reg_fun(intern(lit("rplacd"), system_package), func_n2(sys_rplacd));
- reg_fun(intern(lit("first"), user_package), func_n1(car));
- reg_fun(rest_s, func_n1(cdr));
+ reg_fun(intern(lit("first"), user_package), car_f);
+ reg_fun(rest_s, cdr_f);
reg_fun(intern(lit("sub-list"), user_package), func_n3o(sub_list, 1));
reg_fun(intern(lit("replace-list"), user_package), func_n4o(replace_list, 2));
reg_fun(append_s, func_n0v(appendv));
@@ -6468,6 +7317,7 @@ void eval_init(void)
reg_fun(intern(lit("typeof"), user_package), func_n1(typeof));
reg_fun(intern(lit("subtypep"), user_package), func_n2(subtypep));
reg_fun(intern(lit("typep"), user_package), func_n2(typep));
+ reg_fun(intern(lit("built-in-type-p"), user_package), func_n1(built_in_type_p));
reg_fun(intern(lit("atom"), user_package), func_n1(atom));
reg_fun(intern(lit("null"), user_package), null_f);
@@ -6485,6 +7335,7 @@ void eval_init(void)
reg_fun(intern(lit("proper-list-p"), user_package), proper_list_p_f);
}
reg_fun(intern(lit("length-list"), user_package), func_n1(length_list));
+ reg_fun(intern(lit("length-list-<"), user_package), func_n2(length_list_lt));
reg_fun(intern(lit("mapcar"), user_package), func_n1v(mapcarv));
reg_fun(intern(lit("mapcar*"), user_package), func_n1v(lazy_mapcarv));
@@ -6493,6 +7344,7 @@ void eval_init(void)
reg_fun(intern(lit("mapdo"), user_package), func_n1v(mapdov));
reg_fun(intern(lit("maprod"), user_package), func_n1v(maprodv));
reg_fun(intern(lit("maprend"), user_package), func_n1v(maprendv));
+ reg_fun(intern(lit("maprodo"), user_package), func_n1v(maprodo));
reg_fun(intern(lit("window-map"), user_package), func_n4(window_map));
reg_fun(intern(lit("window-mappend"), user_package), func_n4(window_mappend));
reg_fun(intern(lit("window-mapdo"), user_package), func_n4(window_mapdo));
@@ -6506,7 +7358,7 @@ void eval_init(void)
reg_fun(intern(lit("reduce-left"), user_package), func_n4o(reduce_left, 2));
reg_fun(intern(lit("reduce-right"), user_package), func_n4o(reduce_right, 2));
reg_fun(intern(lit("transpose"), user_package), func_n1(transpose));
- reg_fun(intern(lit("zip"), user_package), func_n0v(transposev));
+ reg_fun(intern(lit("zip"), user_package), func_n0v(zipv));
reg_fun(intern(lit("interpose"), user_package), func_n2(interpose));
reg_fun(intern(lit("second"), user_package), second_f);
@@ -6518,13 +7370,14 @@ void eval_init(void)
reg_fun(intern(lit("eighth"), user_package), func_n1(eighth));
reg_fun(intern(lit("ninth"), user_package), func_n1(ninth));
reg_fun(intern(lit("tenth"), user_package), func_n1(tenth));
+ reg_fun(intern(lit("cxr"), user_package), func_n2(cxr));
+ reg_fun(intern(lit("cyr"), user_package), func_n2(cyr));
reg_fun(intern(lit("conses"), user_package), func_n1(conses));
reg_fun(intern(lit("conses*"), user_package), func_n1(lazy_conses));
reg_fun(intern(lit("copy-list"), user_package), func_n1(copy_list));
reg_fun(intern(lit("nreverse"), user_package), func_n1(nreverse));
reg_fun(intern(lit("reverse"), user_package), func_n1(reverse));
- reg_fun(intern(lit("ldiff"), user_package),
- func_n2(if3(opt_compat && opt_compat <= 190, ldiff_old, ldiff)));
+ reg_fun(intern(lit("ldiff"), user_package), func_n2(ldiff));
reg_fun(intern(lit("last"), user_package), func_n2o(last, 1));
reg_fun(intern(lit("butlast"), user_package), func_n2o(butlast, 1));
reg_fun(intern(lit("nthlast"), user_package), func_n2(nthlast));
@@ -6536,12 +7389,15 @@ void eval_init(void)
reg_fun(intern(lit("flatcar"), user_package), func_n1(flatcar));
reg_fun(intern(lit("flatcar*"), user_package), func_n1(lazy_flatcar));
reg_fun(intern(lit("tuples"), user_package), func_n3o(tuples, 2));
+ reg_fun(intern(lit("tuples*"), user_package), func_n3o(tuples_star, 2));
reg_fun(intern(lit("partition-by"), user_package), func_n2(partition_by));
+ reg_fun(intern(lit("partition-if"), user_package), func_n3o(partition_if, 2));
reg_fun(intern(lit("partition"), user_package), func_n2(partition));
reg_fun(intern(lit("split"), user_package), func_n2(split));
reg_fun(intern(lit("split*"), user_package), func_n2(split_star));
reg_fun(intern(lit("partition*"), user_package), func_n2(partition_star));
reg_fun(intern(lit("tailp"), user_package), func_n2(tailp));
+ reg_fun(intern(lit("delcons"), user_package), func_n2(delcons));
reg_fun(memq_s, func_n2(memq));
reg_fun(memql_s, func_n2(memql));
reg_fun(memqual_s, func_n2(memqual));
@@ -6560,16 +7416,22 @@ void eval_init(void)
reg_fun(intern(lit("keepql"), user_package), func_n3o(keepql, 2));
reg_fun(intern(lit("keepqual"), user_package), func_n3o(keepqual, 2));
reg_fun(intern(lit("keep-if"), user_package), func_n3o(keep_if, 2));
+ reg_fun(intern(lit("keep-keys-if"), user_package), func_n3o(keep_keys_if, 2));
+ reg_fun(intern(lit("separate"), user_package), func_n3o(separate, 2));
+ reg_fun(intern(lit("separate-keys"), user_package), func_n3o(separate_keys, 2));
reg_fun(intern(lit("remq*"), user_package), func_n2(remq_lazy));
reg_fun(intern(lit("remql*"), user_package), func_n2(remql_lazy));
reg_fun(intern(lit("remqual*"), user_package), func_n2(remqual_lazy));
reg_fun(intern(lit("remove-if*"), user_package), func_n3o(remove_if_lazy, 2));
reg_fun(intern(lit("keep-if*"), user_package), func_n3o(keep_if_lazy, 2));
reg_fun(intern(lit("tree-find"), user_package), func_n3o(tree_find, 2));
+ reg_fun(intern(lit("cons-find"), user_package), func_n3o(cons_find, 2));
reg_fun(intern(lit("countqual"), user_package), func_n2(countqual));
reg_fun(intern(lit("countql"), user_package), func_n2(countql));
reg_fun(intern(lit("countq"), user_package), func_n2(countq));
reg_fun(intern(lit("count-if"), user_package), func_n3o(count_if, 2));
+ reg_fun(intern(lit("count"), user_package), func_n4o(count, 2));
+ reg_fun(intern(lit("cons-count"), user_package), func_n3o(cons_count, 2));
reg_fun(intern(lit("posqual"), user_package), func_n2(posqual));
reg_fun(intern(lit("rposqual"), user_package), func_n2(rposqual));
reg_fun(intern(lit("posql"), user_package), func_n2(posql));
@@ -6580,6 +7442,10 @@ void eval_init(void)
reg_fun(intern(lit("rpos"), user_package), func_n4o(rpos, 2));
reg_fun(intern(lit("pos-if"), user_package), func_n3o(pos_if, 2));
reg_fun(intern(lit("rpos-if"), user_package), func_n3o(rpos_if, 2));
+ reg_fun(intern(lit("subq"), user_package), func_n3(subq));
+ reg_fun(intern(lit("subql"), user_package), func_n3(subql));
+ reg_fun(intern(lit("subqual"), user_package), func_n3(subqual));
+ reg_fun(intern(lit("subst"), user_package), func_n5o(subst, 3));
reg_fun(intern(lit("some"), user_package), func_n3o(some_satisfy, 1));
reg_fun(intern(lit("all"), user_package), func_n3o(all_satisfy, 1));
reg_fun(intern(lit("none"), user_package), func_n3o(none_satisfy, 1));
@@ -6616,17 +7482,28 @@ void eval_init(void)
reg_fun(intern(lit("unique"), user_package), func_n2ov(unique, 1));
reg_fun(intern(lit("uniq"), user_package), func_n1(uniq));
reg_fun(intern(lit("grade"), user_package), func_n3o(grade, 1));
+ reg_fun(intern(lit("hist-sort"), user_package), func_n1v(hist_sort));
+ reg_fun(intern(lit("hist-sort-by"), user_package), func_n2v(hist_sort_by));
+
+ reg_fun(intern(lit("nrot"), user_package), func_n2o(nrot, 1));
+ reg_fun(intern(lit("rot"), user_package), func_n2o(rot, 1));
reg_var(intern(lit("*param-macro*"), user_package), pm_table);
- reg_fun(intern(lit("eval"), user_package), func_n2o(eval_intrinsic, 1));
+ reg_fun(intern(lit("eval"), user_package), func_n3o(eval_intrinsic, 1));
reg_fun(intern(lit("lisp-parse"), user_package), func_n5o(nread, 0));
reg_fun(intern(lit("read"), user_package), func_n5o(nread, 0));
reg_fun(intern(lit("iread"), user_package), func_n5o(iread, 0));
- reg_fun(intern(lit("load"), user_package), func_n1(load));
+ reg_fun(intern(lit("read-objects"), user_package), func_n5o(read_objects, 0));
+ reg_fun(intern(lit("get-json"), user_package), func_n5o(get_json, 0));
+ reg_fun(intern(lit("txr-parse"), user_package), func_n4o(txr_parse, 0));
+ reg_fun(intern(lit("load"), user_package), func_n1v(loadv));
reg_var(load_path_s, nil);
reg_symacro(intern(lit("self-load-path"), user_package), load_path_s);
reg_var(load_recursive_s, nil);
+ reg_var(load_search_dirs_s, nil);
+ reg_var(load_args_s, nil);
+ reg_var(load_hooks_s, nil);
reg_fun(intern(lit("expand"), user_package), func_n2o(no_warn_expand, 1));
reg_fun(intern(lit("expand*"), user_package), func_n2o(expand, 1));
reg_fun(intern(lit("expand-with-free-refs"), user_package),
@@ -6641,6 +7518,7 @@ void eval_init(void)
reg_fun(intern(lit("macroexpand-lisp1"), user_package),
func_n2o(macroexpand_lisp1, 1));
reg_fun(intern(lit("expand-params"), system_package), func_n5(expand_params));
+ reg_fun(intern(lit("expand-param-macro"), system_package), func_n4(expand_param_macro));
reg_fun(intern(lit("constantp"), user_package), func_n2o(constantp, 1));
reg_fun(intern(lit("make-env"), user_package), func_n3o(make_env_intrinsic, 0));
reg_fun(intern(lit("env-fbind"), user_package), func_n3(env_fbind));
@@ -6649,7 +7527,13 @@ void eval_init(void)
reg_fun(intern(lit("env-fbindings"), user_package), func_n1(env_fbindings));
reg_fun(intern(lit("env-next"), user_package), func_n1(env_next));
reg_fun(intern(lit("lexical-var-p"), user_package), func_n2(lexical_var_p));
+ reg_fun(intern(lit("lexical-symacro-p"), user_package), func_n2(lexical_symacro_p));
reg_fun(intern(lit("lexical-fun-p"), user_package), func_n2(lexical_fun_p));
+ reg_fun(intern(lit("lexical-macro-p"), user_package), func_n2(lexical_macro_p));
+ reg_fun(intern(lit("lexical-binding-kind"), user_package),
+ func_n2(lexical_binding_kind));
+ reg_fun(intern(lit("lexical-fun-binding-kind"), user_package),
+ func_n2(lexical_fun_binding_kind));
reg_fun(intern(lit("lexical-lisp1-binding"), user_package),
func_n2(lexical_lisp1_binding));
reg_fun(intern(lit("chain"), user_package), func_n0v(chainv));
@@ -6658,20 +7542,32 @@ void eval_init(void)
reg_fun(intern(lit("andf"), user_package), func_n0v(andv));
reg_fun(intern(lit("orf"), user_package), func_n0v(orv));
reg_fun(intern(lit("notf"), user_package), func_n1(notf));
+ reg_fun(intern(lit("nandf"), user_package), func_n0v(nandv));
+ reg_fun(intern(lit("norf"), user_package), func_n0v(norv));
reg_fun(intern(lit("iff"), user_package), func_n3o(iff, 1));
reg_fun(intern(lit("iffi"), user_package), func_n3o(iffi, 2));
reg_fun(intern(lit("dup"), user_package), func_n1(dupl));
reg_fun(intern(lit("flipargs"), user_package), func_n1(swap_12_21));
- reg_fun(intern(lit("if"), user_package), func_n3o(if_fun, 2));
- reg_fun(intern(lit("or"), user_package), func_n0v(or_fun));
- reg_fun(intern(lit("and"), user_package), func_n0v(and_fun));
+ reg_fun(if_s, func_n3o(if_fun, 2));
+ reg_fun(or_s, func_n0v(or_fun));
+ reg_fun(intern(lit("nor"), user_package), func_n0v(nor_fun));
+ reg_fun(and_s, func_n0v(and_fun));
+ reg_fun(intern(lit("nand"), user_package), func_n0v(nand_fun));
+ reg_fun(progn_s, func_n0v(progn_fun));
+ reg_fun(prog1_s, func_n0v(prog1_fun));
+ reg_fun(prog2_s, func_n0v(prog2_fun));
reg_fun(intern(lit("retf"), user_package), func_n1(retf));
reg_fun(intern(lit("apf"), user_package), func_n1v(apf));
reg_fun(intern(lit("ipf"), user_package), func_n1v(ipf));
reg_fun(intern(lit("callf"), user_package), func_n1v(callf));
reg_fun(intern(lit("mapf"), user_package), func_n1v(mapf));
reg_fun(intern(lit("tf"), user_package), func_n0v(tf));
- reg_fun(intern(lit("nilf"), user_package), func_n0v(nilf));
+
+ {
+ val nilf_f = func_n0v(nilf);
+ reg_fun(intern(lit("nilf"), user_package), nilf_f);
+ reg_fun(intern(lit("ignore"), user_package), nilf_f);
+ }
reg_fun(intern(lit("print"), user_package), func_n3o(print, 1));
reg_fun(intern(lit("pprint"), user_package), func_n2o(pprint, 1));
@@ -6680,30 +7576,28 @@ void eval_init(void)
reg_fun(intern(lit("prinl"), user_package), func_n2o(prinl, 1));
reg_fun(intern(lit("pprinl"), user_package), func_n2o(pprinl, 1));
reg_fun(intern(lit("tprint"), user_package), func_n2o(tprint, 1));
+ reg_fun(intern(lit("tojson"), user_package), func_n2o(tojson, 1));
+ reg_fun(intern(lit("put-json"), user_package), func_n3o(put_json, 1));
+ reg_fun(intern(lit("put-jsonl"), user_package), func_n3o(put_jsonl, 1));
reg_fun(intern(lit("display-width"), user_package), func_n1(display_width));
reg_fun(intern(lit("fmt-simple"), system_package), func_n5o(fmt_simple, 1));
reg_fun(intern(lit("fmt-flex"), system_package), func_n2v(fmt_flex));
- reg_fun(intern(lit("fmt-join"), system_package), func_n0v(fmt_join));
+ reg_fun(intern(lit("fmt-join"), system_package), join_f);
+ reg_fun(intern(lit("join"), user_package), join_f);
+ reg_fun(intern(lit("join-with"), user_package), func_n1v(join_with));
reg_varl(user_package_s = intern(lit("user-package"), user_package), user_package);
reg_varl(system_package_s = intern(lit("system-package"), user_package), system_package);
reg_varl(keyword_package_s = intern(lit("keyword-package"), user_package), keyword_package);
- if (opt_compat && opt_compat <= 156) {
- reg_varl(intern(lit("*user-package*"), user_package), user_package);
- reg_varl(intern(lit("*system-package*"), user_package), system_package);
- reg_varl(intern(lit("*keyword-package*"), user_package), keyword_package);
- }
-
reg_fun(intern(lit("make-sym"), user_package), func_n1(make_sym));
reg_fun(intern(lit("gensym"), user_package), func_n1o(gensym, 0));
reg_var(gensym_counter_s = intern(lit("*gensym-counter*"), user_package), zero);
reg_var(package_alist_s = intern(lit("*package-alist*"), user_package), packages);
- reg_var(package_s = intern(lit("*package*"), user_package),
- (opt_compat && opt_compat <= 190) ? user_package : public_package);
- reg_fun(intern(lit("make-package"), user_package), func_n1(make_package));
- reg_fun(intern(lit("make-anon-package"), system_package), func_n0(make_anon_package));
+ reg_var(package_s = intern(lit("*package*"), user_package), public_package);
+ reg_fun(intern(lit("make-package"), user_package), func_n2o(make_package, 1));
+ reg_fun(intern(lit("make-anon-package"), system_package), func_n1o(make_anon_package, 0));
reg_fun(intern(lit("find-package"), user_package), func_n1(find_package));
reg_fun(intern(lit("delete-package"), user_package), func_n1(delete_package));
reg_fun(intern(lit("merge-delete-package"), user_package), func_n2o(merge_delete_package, 1));
@@ -6713,6 +7607,7 @@ void eval_init(void)
reg_fun(intern(lit("package-local-symbols"), user_package), func_n1o(package_local_symbols, 0));
reg_fun(intern(lit("package-foreign-symbols"), user_package), func_n1o(package_foreign_symbols, 0));
reg_fun(intern(lit("use-sym"), user_package), func_n2o(use_sym, 1));
+ reg_fun(intern(lit("use-sym-as"), user_package), func_n3o(use_sym_as, 2));
reg_fun(intern(lit("unuse-sym"), user_package), func_n2o(unuse_sym, 1));
reg_fun(intern(lit("use-package"), user_package), func_n2o(use_package, 1));
reg_fun(intern(lit("unuse-package"), user_package), func_n2o(unuse_package, 1));
@@ -6731,10 +7626,14 @@ void eval_init(void)
reg_fun(intern(lit("keywordp"), user_package), func_n1(keywordp));
reg_fun(intern(lit("bindable"), user_package), func_n1(bindable));
reg_fun(intern(lit("mkstring"), user_package), func_n2o(mkstring, 1));
+ reg_fun(intern(lit("str"), user_package), func_n2o(str, 1));
reg_fun(intern(lit("copy-str"), user_package), func_n1(copy_str));
reg_fun(intern(lit("upcase-str"), user_package), func_n1(upcase_str));
reg_fun(intern(lit("downcase-str"), user_package), func_n1(downcase_str));
- reg_fun(intern(lit("string-extend"), user_package), func_n2(string_extend));
+ reg_fun(intern(lit("string-extend"), user_package), func_n3o(string_extend, 2));
+ reg_fun(intern(lit("string-finish"), user_package), func_n1(string_finish));
+ reg_fun(intern(lit("string-set-code"), user_package), func_n2(string_set_code));
+ reg_fun(intern(lit("string-get-code"), user_package), func_n1(string_get_code));
reg_fun(intern(lit("stringp"), user_package), func_n1(stringp));
reg_fun(intern(lit("lazy-stringp"), user_package), func_n1(lazy_stringp));
reg_fun(intern(lit("length-str"), user_package), func_n1(length_str));
@@ -6746,14 +7645,18 @@ void eval_init(void)
reg_fun(intern(lit("sub-str"), user_package), func_n3o(sub_str, 1));
reg_fun(intern(lit("replace-str"), user_package), func_n4o(replace_str, 2));
reg_fun(intern(lit("cat-str"), user_package), func_n2o(cat_str, 1));
- reg_fun(intern(lit("split-str"), user_package), func_n3o(split_str_keep, 2));
+ reg_fun(intern(lit("split-str"), user_package), func_n4o(split_str_keep, 2));
reg_fun(intern(lit("spl"), user_package), func_n3o(spl, 2));
+ reg_fun(intern(lit("spln"), user_package), func_n4o(spln, 3));
reg_fun(intern(lit("split-str-set"), user_package), func_n2(split_str_set));
- reg_fun(intern(lit("tok-str"), user_package), func_n3o(tok_str, 2));
+ reg_fun(intern(lit("sspl"), user_package), func_n2(sspl));
+ reg_fun(intern(lit("tok-str"), user_package), func_n4o(tok_str, 2));
reg_fun(intern(lit("tok"), user_package), func_n3o(tok, 2));
+ reg_fun(intern(lit("tokn"), user_package), func_n4o(tokn, 3));
reg_fun(intern(lit("tok-where"), user_package), func_n2(tok_where));
reg_fun(intern(lit("list-str"), user_package), func_n1(list_str));
reg_fun(intern(lit("trim-str"), user_package), func_n1(trim_str));
+ reg_fun(intern(lit("str-esc"), user_package), func_n3(str_esc));
reg_fun(intern(lit("cmp-str"), user_package), func_n2(cmp_str));
reg_fun(intern(lit("string-lt"), user_package), func_n2(str_lt));
reg_fun(intern(lit("str="), user_package), func_n2(str_eq));
@@ -6766,10 +7669,6 @@ void eval_init(void)
reg_fun(intern(lit("num-str"), user_package), func_n1(num_str));
reg_fun(intern(lit("int-flo"), user_package), func_n1(int_flo));
reg_fun(intern(lit("flo-int"), user_package), func_n1(flo_int));
- reg_fun(intern(lit("tofloat"), user_package), func_n1(tofloat));
- reg_fun(intern(lit("toint"), user_package), func_n2o(toint, 1));
- reg_fun(intern(lit("tofloatz"), user_package), func_n1(tofloatz));
- reg_fun(intern(lit("tointz"), user_package), func_n2o(tointz, 1));
reg_fun(intern(lit("less"), user_package), func_n1v(lessv));
reg_fun(intern(lit("greater"), user_package), func_n1v(greaterv));
reg_fun(intern(lit("lequal"), user_package), func_n1v(lequalv));
@@ -6809,8 +7708,8 @@ void eval_init(void)
reg_fun(intern(lit("compl-span-str"), user_package), func_n2(compl_span_str));
reg_fun(intern(lit("break-str"), user_package), func_n2(break_str));
- reg_fun(intern(lit("lazy-stream-cons"), user_package), func_n1(lazy_stream_cons));
- reg_fun(intern(lit("get-lines"), user_package), func_n1o(lazy_stream_cons, 0));
+ reg_fun(intern(lit("lazy-stream-cons"), user_package), func_n2o(lazy_stream_cons, 1));
+ reg_fun(intern(lit("get-lines"), user_package), func_n2o(lazy_stream_cons, 0));
reg_fun(intern(lit("lazy-str"), user_package), func_n3o(lazy_str, 1));
reg_fun(intern(lit("lazy-stringp"), user_package), func_n1(lazy_stringp));
reg_fun(intern(lit("lazy-str-force-upto"), user_package), func_n2(lazy_str_force_upto));
@@ -6842,7 +7741,10 @@ void eval_init(void)
reg_fun(intern(lit("copy-vec"), user_package), func_n1(copy_vec));
reg_fun(intern(lit("sub-vec"), user_package), func_n3o(sub_vec, 1));
reg_fun(intern(lit("replace-vec"), user_package), func_n4o(replace_vec, 2));
+ reg_fun(intern(lit("fill-vec"), user_package), func_n4o(fill_vec, 2));
reg_fun(intern(lit("cat-vec"), user_package), func_n1(cat_vec));
+ reg_fun(intern(lit("nested-vec-of"), user_package), func_n1v(nested_vec_of_v));
+ reg_fun(intern(lit("nested-vec"), user_package), func_n0v(nested_vec_v));
reg_fun(intern(lit("assoc"), user_package), func_n2(assoc));
reg_fun(intern(lit("assql"), user_package), func_n2(assql));
@@ -6858,29 +7760,43 @@ void eval_init(void)
reg_fun(intern(lit("copy-cons"), user_package), func_n1(copy_cons));
reg_fun(intern(lit("copy-tree"), user_package), func_n1(copy_tree));
reg_fun(intern(lit("copy-alist"), user_package), func_n1(copy_alist));
+ reg_fun(intern(lit("pairlis"), user_package), func_n3o(pairlis, 2));
reg_fun(intern(lit("prop"), user_package), func_n2(getplist));
reg_fun(intern(lit("memp"), user_package), func_n2(memp));
reg_fun(intern(lit("plist-to-alist"), user_package), func_n1(plist_to_alist));
reg_fun(intern(lit("improper-plist-to-alist"), user_package), func_n2(improper_plist_to_alist));
reg_fun(intern(lit("merge"), user_package), func_n4o(merge_wrap, 2));
+ reg_fun(intern(lit("nsort"), user_package), func_n3o(nsort, 1));
reg_fun(intern(lit("sort"), user_package), func_n3o(sort, 1));
- reg_fun(intern(lit("shuffle"), user_package), func_n1(shuffle));
+ reg_fun(intern(lit("snsort"), user_package), func_n3o(snsort, 1));
+ reg_fun(intern(lit("ssort"), user_package), func_n3o(ssort, 1));
+ reg_fun(intern(lit("nshuffle"), user_package), func_n2o(nshuffle, 1));
+ reg_fun(intern(lit("shuffle"), user_package), func_n2o(shuffle, 1));
reg_fun(intern(lit("find"), user_package), func_n4o(find, 2));
reg_fun(intern(lit("rfind"), user_package), func_n4o(rfind, 2));
reg_fun(intern(lit("find-if"), user_package), func_n3o(find_if, 2));
reg_fun(intern(lit("rfind-if"), user_package), func_n3o(rfind_if, 2));
reg_fun(intern(lit("find-max"), user_package), func_n3o(find_max, 1));
+ reg_fun(intern(lit("find-max-key"), user_package), func_n3o(find_max_key, 1));
reg_fun(intern(lit("find-min"), user_package), func_n3o(find_min, 1));
+ reg_fun(intern(lit("find-min-key"), user_package), func_n3o(find_min_key, 1));
+ reg_fun(intern(lit("find-true"), user_package), func_n3o(find_true, 2));
reg_fun(intern(lit("multi-sort"), user_package), func_n3o(multi_sort, 2));
reg_fun(intern(lit("set-diff"), user_package), func_n4o(set_diff, 2));
reg_fun(intern(lit("diff"), user_package), func_n4o(diff, 2));
reg_fun(intern(lit("symdiff"), user_package), func_n4o(symdiff, 2));
reg_fun(intern(lit("isec"), user_package), func_n4o(isec, 2));
+ reg_fun(intern(lit("isecp"), user_package), func_n4o(isecp, 2));
reg_fun(intern(lit("uni"), user_package), func_n4o(uni, 2));
reg_fun(intern(lit("seqp"), user_package), func_n1(seqp));
+ reg_fun(intern(lit("iterable"), user_package), func_n1(iterable));
+ reg_fun(intern(lit("list-seq"), user_package), func_n1(list_seq));
+ reg_fun(intern(lit("vec-seq"), user_package), func_n1(vec_seq));
+ reg_fun(intern(lit("str-seq"), user_package), func_n1(str_seq));
reg_fun(intern(lit("length"), user_package), length_f);
reg_fun(intern(lit("len"), user_package), length_f);
+ reg_fun(length_lt_s, func_n2(length_lt));
reg_fun(intern(lit("empty"), user_package), func_n1(empty));
reg_fun(intern(lit("copy"), user_package), func_n1(copy));
reg_fun(intern(lit("sub"), user_package), func_n3o(sub, 1));
@@ -6889,16 +7805,24 @@ void eval_init(void)
reg_fun(intern(lit("replace"), user_package), func_n4o(replace, 2));
reg_fun(intern(lit("dwim-set"), system_package), func_n2v(dwim_set));
reg_fun(intern(lit("dwim-del"), system_package), func_n3(dwim_del));
+ reg_fun(intern(lit("mref"), user_package), func_n1v(mref));
reg_fun(intern(lit("update"), user_package), func_n2(update));
reg_fun(intern(lit("search"), user_package), func_n4o(search, 2));
reg_fun(intern(lit("rsearch"), user_package), func_n4o(rsearch, 2));
reg_fun(intern(lit("contains"), user_package), func_n4o(contains, 2));
+ reg_fun(intern(lit("search-all"), user_package), func_n4o(search_all, 2));
reg_fun(intern(lit("where"), user_package), func_n2(where));
reg_fun(intern(lit("select"), user_package), func_n2(sel));
+ reg_fun(intern(lit("reject"), user_package), func_n2(reject));
reg_fun(intern(lit("relate"), user_package), func_n3o(relate, 2));
reg_fun(intern(lit("seq-begin"), user_package), func_n1(seq_begin));
reg_fun(intern(lit("seq-next"), user_package), func_n2(seq_next));
reg_fun(intern(lit("seq-reset"), user_package), func_n2(seq_reset));
+ reg_fun(intern(lit("iter-begin"), user_package), func_n1(iter_begin));
+ reg_fun(intern(lit("iter-more"), user_package), func_n1(iter_more));
+ reg_fun(intern(lit("iter-item"), user_package), func_n1(iter_item));
+ reg_fun(intern(lit("iter-step"), user_package), func_n1(iter_step));
+ reg_fun(intern(lit("iter-reset"), user_package), func_n2(iter_reset));
reg_fun(intern(lit("rcons"), user_package), func_n2(rcons));
reg_fun(intern(lit("rangep"), user_package), func_n1(rangep));
@@ -6906,6 +7830,7 @@ void eval_init(void)
reg_fun(intern(lit("to"), user_package), func_n1(to));
reg_fun(intern(lit("in-range"), user_package), func_n2(in_range));
reg_fun(intern(lit("in-range*"), user_package), func_n2(in_range_star));
+ reg_fun(intern(lit("rangeref"), user_package), func_n2(rangeref));
reg_fun(intern(lit("make-like"), user_package), func_n2(make_like));
reg_fun(intern(lit("nullify"), user_package), func_n1(nullify));
@@ -6914,6 +7839,7 @@ void eval_init(void)
reg_varl(intern(lit("top-fb"), system_package), top_fb);
reg_varl(intern(lit("top-mb"), system_package), top_mb);
reg_fun(intern(lit("symbol-value"), user_package), func_n1(symbol_value));
+ reg_fun(intern(lit("set-symbol-value"), system_package), func_n2(set_symbol_value));
reg_fun(intern(lit("symbol-function"), user_package), func_n1(symbol_function));
reg_fun(intern(lit("symbol-macro"), user_package), func_n1(symbol_macro));
reg_fun(intern(lit("boundp"), user_package), func_n1(boundp));
@@ -6949,7 +7875,7 @@ void eval_init(void)
reg_fun(intern(lit("expand-right"), user_package), func_n2(expand_right));
reg_fun(intern(lit("expand-left"), user_package), func_n2(expand_left));
reg_fun(intern(lit("nexpand-left"), user_package), func_n2(nexpand_left));
- reg_fun(intern(lit("repeat"), user_package), func_n2o(repeat, 1));
+ reg_fun(repeat_s, func_n2o(repeat, 1));
reg_fun(intern(lit("pad"), user_package), func_n3o(pad, 1));
reg_fun(intern(lit("weave"), user_package), func_n0v(weavev));
reg_fun(force_s, func_n1(force));
@@ -6963,20 +7889,7 @@ void eval_init(void)
reg_fun(intern(lit("abscond*"), system_package), func_n2o(abscond_star, 1));
reg_fun(intern(lit("match-fun"), user_package), func_n4o(match_fun, 2));
-
- reg_fun(intern(lit("time"), user_package), func_n0(time_sec));
- reg_fun(intern(lit("time-usec"), user_package), func_n0(time_sec_usec));
- reg_fun(intern(lit("time-string-local"), user_package), func_n2(time_string_local));
- reg_fun(intern(lit("time-string-utc"), user_package), func_n2(time_string_utc));
- reg_fun(intern(lit("time-fields-local"), user_package), func_n1(time_fields_local));
- reg_fun(intern(lit("time-fields-utc"), user_package), func_n1(time_fields_utc));
- reg_fun(intern(lit("time-struct-local"), user_package), func_n1(time_struct_local));
- reg_fun(intern(lit("time-struct-utc"), user_package), func_n1(time_struct_utc));
- reg_fun(intern(lit("make-time"), user_package), func_n7(make_time));
- reg_fun(intern(lit("make-time-utc"), user_package), func_n7(make_time_utc));
- reg_fun(intern(lit("time-parse"), user_package), func_n2(time_parse));
- reg_fun(intern(lit("time-parse-local"), user_package), func_n2(time_parse_local));
- reg_fun(intern(lit("time-parse-utc"), user_package), func_n2(time_parse_utc));
+ reg_fun(intern(lit("match-fboundp"), user_package), func_n1(match_fboundp));
reg_fun(intern(lit("source-loc"), user_package), func_n1(source_loc));
reg_fun(intern(lit("source-loc-str"), user_package), func_n2o(source_loc_str, 1));
@@ -6991,6 +7904,7 @@ void eval_init(void)
reg_fun(intern(lit("cptr-zap"), user_package), func_n1(cptr_zap));
reg_fun(intern(lit("cptr-free"), user_package), func_n1(cptr_free));
reg_fun(intern(lit("cptr-cast"), user_package), func_n2(cptr_cast));
+ reg_fun(intern(lit("copy-cptr"), user_package), func_n1(copy_cptr));
reg_fun(intern(lit("int-cptr"), user_package), func_n1(int_cptr));
reg_fun(intern(lit("cptrp"), user_package), func_n1(cptrp));
reg_fun(intern(lit("cptr-type"), user_package), func_n1(cptr_type));
@@ -6998,20 +7912,61 @@ void eval_init(void)
reg_varl(intern(lit("cptr-null"), user_package), cptr(0));
reg_fun(intern(lit("rt-defvarl"), system_package), func_n1(rt_defvarl));
+ reg_fun(intern(lit("rt-defv"), system_package), func_n1(rt_defv));
+ reg_fun(intern(lit("rt-progv"), system_package), func_n2(rt_progv));
reg_fun(intern(lit("rt-defun"), system_package), func_n2(rt_defun));
reg_fun(intern(lit("rt-defmacro"), system_package), func_n3(rt_defmacro));
reg_fun(intern(lit("rt-defsymacro"), system_package), func_n2(rt_defsymacro));
reg_fun(intern(lit("rt-pprof"), system_package), func_n1(rt_pprof));
reg_fun(intern(lit("rt-load-for"), system_package), func_n0v(rt_load_for));
+ reg_fun(intern(lit("rt-assert-fail"), system_package), func_n4ov(rt_assert_fail, 3));
+
+ reg_var(lazy_streams_s, nil);
+
+ reg_symacro(pct_fun_s, nil);
+
eval_error_s = intern(lit("eval-error"), user_package);
+ case_error_s = intern(lit("case-error"), user_package);
uw_register_subtype(eval_error_s, error_s);
+ uw_register_subtype(case_error_s, error_s);
- lisplib_init();
+ atexit(run_load_hooks_atexit);
+ autoload_init();
+}
+
+void eval_late_init(void)
+{
+ unused_arg_s = gensym(lit("unused-arg"));
}
void eval_compat_fixup(int compat_ver)
{
+ if (compat_ver <= 257)
+ reg_fun(intern(lit("lexical-var-p"), user_package),
+ func_n2(old_lexical_var_p));
+
+ if (compat_ver <= 237) {
+ reg_fun(intern(lit("sort"), user_package), func_n3o(nsort, 1));
+ reg_fun(intern(lit("shuffle"), user_package), func_n2o(nshuffle, 1));
+ }
+
+ if (compat_ver <= 190) {
+ reg_var(package_s, user_package);
+ reg_fun(intern(lit("ldiff"), user_package), func_n2(ldiff_old));
+ }
+
+ if (compat_ver <= 184) {
+ reg_mac(op_s, func_n2(me_op));
+ reg_mac(do_s, func_n2(me_op));
+ }
+
+ if (compat_ver <= 156) {
+ reg_varl(intern(lit("*user-package*"), user_package), user_package);
+ reg_varl(intern(lit("*system-package*"), user_package), system_package);
+ reg_varl(intern(lit("*keyword-package*"), user_package), keyword_package);
+ }
+
if (compat_ver <= 107)
reg_fun(intern(lit("flip"), user_package), func_n1(swap_12_21));
}
diff --git a/eval.h b/eval.h
index ad817d99..0f5f5df7 100644
--- a/eval.h
+++ b/eval.h
@@ -1,4 +1,4 @@
-/* Copyright 2010-2020
+/* Copyright 2010-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,40 +6,43 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
extern val dwim_s, lambda_s, progn_s, vector_lit_s, vec_list_s, list_s;
extern val hash_lit_s, hash_construct_s, struct_lit_s, qref_s, uref_s;
extern val tree_lit_s, tree_construct_s;
+extern val macro_time_s;
extern val eval_error_s, if_s, call_s, identity_s;
extern val eq_s, eql_s, equal_s, less_s;
extern val car_s, cdr_s;
extern val last_form_evaled;
-extern val load_path_s, load_recursive_s;
+extern val load_path_s, load_hooks_s, load_recursive_s, load_search_dirs_s;
extern val special_s, struct_s;
extern val dyn_env;
#define load_path (deref(lookup_var_l(nil, load_path_s)))
+#define load_search_dirs (deref(lookup_var_l(nil, load_search_dirs_s)))
-noreturn val eval_error(val ctx, val fmt, ...);
+NORETURN val eval_error(val ctx, val fmt, ...);
val ctx_form(val obj);
val ctx_name(val obj);
val lookup_origin(val form);
@@ -51,9 +54,11 @@ val deep_copy_env(val oenv);
val env_fbind(val env, val sym, val fun);
val env_vbind(val env, val sym, val obj);
val lookup_var(val env, val sym);
+val lookup_dynamic_var(val sym);
+val lookup_dynamic_sym_lisp1(val sym);
val lookup_global_var(val sym);
+val lookup_global_fun(val sym);
loc lookup_var_l(val env, val sym);
-loc lookup_global_var_l(val sym);
val lookup_fun(val env, val sym);
val lookup_sym_lisp1(val env, val sym);
val set_dyn_env(val de);
@@ -66,6 +71,7 @@ val macro_form_p(val form, val menv);
val func_get_name(val fun, val env);
void reg_varl(val sym, val val);
void reg_var(val sym, val val);
+void reg_symacro(val sym, val val);
void reg_fun(val sym, val fun);
void reg_mac(val sym, val fun);
val set_get_symacro(val sym, val form);
@@ -73,15 +79,18 @@ val apply(val fun, val arglist);
val applyv(val fun, struct args *args);
val eval_progn(val forms, val env, val ctx_form);
val eval(val form, val env, val ctx_form);
-val eval_intrinsic(val form, val env);
+val eval_intrinsic(val form, val env, val menv);
val eval_intrinsic_noerr(val form, val env, val *error_p);
void trace_check(val name);
val format_field(val string_or_list, val modifier, val filter, val eval_fun);
val subst_vars(val forms, val env, val filter);
val expand_quasi(val quasi_forms, val menv);
+void run_load_hooks(val load_dyn_env);
+val loadv(val target, struct args *);
val load(val target);
val expand(val form, val menv);
val expand_forms(val forms, val menv);
+val expand_with_free_refs(val form, val menv_in, val upto_menv_in);
val prof_call(val (*fun)(mem_t *ctx), mem_t *ctx);
val bindable(val obj);
val mapcarv(val fun, struct args *lists);
@@ -96,4 +105,5 @@ val pprinl(val obj, val stream);
val tprint(val obj, val out);
void eval_init(void);
+void eval_late_init(void);
void eval_compat_fixup(int compat_ver);
diff --git a/ffi.c b/ffi.c
index 5b59e281..1a95ea80 100644
--- a/ffi.c
+++ b/ffi.c
@@ -1,4 +1,4 @@
-/* Copyright 2017-2020
+/* Copyright 2017-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <limits.h>
@@ -36,13 +37,22 @@
#include <signal.h>
#include <wchar.h>
#include <time.h>
+#include <setjmp.h>
#include "config.h"
+#if HAVE_INTMAX_T
+#include <stdint.h>
+#endif
#if HAVE_LIBFFI
#include <ffi.h>
#endif
#if HAVE_SYS_TYPES_H
#include <sys/types.h>
#endif
+#if HAVE_MMAP
+#include <sys/mman.h>
+#include <unistd.h>
+#include <errno.h>
+#endif
#include "alloca.h"
#include "lib.h"
#include "stream.h"
@@ -58,15 +68,16 @@
#include "args.h"
#include "utf8.h"
#include "hash.h"
+#if HAVE_MMAP
+#include "sysif.h"
+#endif
#include "ffi.h"
#include "txr.h"
-#define zalloca(size) memset(alloca(size), 0, size)
-
#define alignof(type) offsetof(struct {char x; type y;}, y)
-#define pad_retval(size) (!(size) || convert(size_t, size) > sizeof (ffi_arg) \
- ? (size) \
+#define pad_retval(size) (convert(size_t, size) > sizeof (ffi_arg) \
+ ? convert(size_t, size) \
: sizeof (ffi_arg))
#define min(a, b) ((a) < (b) ? (a) : (b))
@@ -89,8 +100,10 @@ typedef unsigned long ffi_arg;
typedef enum {
FFI_KIND_VOID,
- FFI_KIND_NUM,
+ FFI_KIND_INT,
+ FFI_KIND_UINT,
FFI_KIND_ENUM,
+ FFI_KIND_FLO,
FFI_KIND_PTR,
FFI_KIND_STRUCT,
FFI_KIND_UNION,
@@ -125,7 +138,7 @@ val array_s, zarray_s, carray_s;
val union_s;
-val str_d_s, wstr_s, wstr_d_s, bstr_s, bstr_d_s;
+val str_d_s, str_s_s, wstr_s, wstr_d_s, wstr_s_s, bstr_s, bstr_d_s, bstr_s_s;
val buf_d_s;
@@ -138,10 +151,12 @@ val sbit_s, ubit_s; /* bit_s is in arith.c */
val enum_s, enumed_s, elemtype_s;
-val align_s;
+val align_s, pack_s;
val bool_s;
+val jmp_buf_s;
+
val ffi_type_s, ffi_call_desc_s, ffi_closure_s;
static val ffi_typedef_hash, ffi_struct_tag_hash;
@@ -163,6 +178,10 @@ static ffi_type ffi_type_sint64, ffi_type_uint64;
static ffi_type ffi_type_float, ffi_type_double;
#endif
+static struct cobj_class *ffi_type_cls, *ffi_call_desc_cls;
+static struct cobj_class *ffi_closure_cls, *union_cls;
+struct cobj_class *carray_cls;
+
struct smemb {
val mname;
val mtype;
@@ -182,12 +201,18 @@ struct txr_ffi_type {
val self;
ffi_kind_t kind;
ffi_type *ft;
- ffi_type *elements[1];
+ ffi_type **elements;
val lt;
val syntax;
val eltype;
- cnum size, align;
- unsigned shift, mask;
+ cnum size, align, oalign;
+ unsigned shift;
+ union {
+ unsigned mask;
+#if HAVE_I64
+ u64_t fmask;
+#endif
+ } m;
cnum nelem;
struct smemb *memb;
val tag;
@@ -198,12 +223,17 @@ struct txr_ffi_type {
unsigned incomplete : 1;
unsigned flexible : 1;
unsigned bitfield : 1;
+ unsigned aligned : 1;
+ unsigned bigendian : 1;
struct txr_ffi_type *(*clone)(struct txr_ffi_type *);
+#if HAVE_LIBFFI
+ void (*calcft)(struct txr_ffi_type *);
+#endif
void (*put)(struct txr_ffi_type *, val obj, mem_t *dst, val self);
val (*get)(struct txr_ffi_type *, mem_t *src, val self);
val (*in)(struct txr_ffi_type *, int copy, mem_t *src, val obj, val self);
void (*out)(struct txr_ffi_type *, int copy, val obj, mem_t *dest, val self);
- void (*release)(struct txr_ffi_type *, val obj, mem_t *dst);
+ void (*release)(struct txr_ffi_type *, val obj, mem_t *dst, val self);
cnum (*dynsize)(struct txr_ffi_type *, val obj, val self);
mem_t *(*alloc)(struct txr_ffi_type *, val obj, val self);
void (*free)(void *);
@@ -218,15 +248,19 @@ static struct txr_ffi_type *ffi_type_struct(val obj)
return coerce(struct txr_ffi_type *, obj->co.handle);
}
-static struct txr_ffi_type *ffi_type_struct_checked(val self, val obj)
+struct txr_ffi_type *ffi_type_struct_checked(val self, val obj)
{
- return coerce(struct txr_ffi_type *, cobj_handle(self, obj, ffi_type_s));
+ return coerce(struct txr_ffi_type *, cobj_handle(self, obj, ffi_type_cls));
}
#if HAVE_LIBFFI
static ffi_type *ffi_get_type(val self, val obj)
{
struct txr_ffi_type *tffi = ffi_type_struct_checked(self, obj);
+ if (tffi->calcft != 0) {
+ tffi->calcft(tffi);
+ tffi->calcft = 0;
+ }
return tffi->ft;
}
#endif
@@ -241,20 +275,18 @@ static void ffi_type_print_op(val obj, val out, val pretty, struct strm_ctx *ctx
{
struct txr_ffi_type *tft = ffi_type_struct(obj);
put_string(lit("#<"), out);
- obj_print_impl(obj->co.cls, out, pretty, ctx);
+ obj_print_impl(obj->co.cls->cls_sym, out, pretty, ctx);
format(out, lit(" ~!~s>"), tft->syntax, nao);
}
static void ffi_type_struct_destroy_op(val obj)
{
struct txr_ffi_type *tft = ffi_type_struct(obj);
-#if HAVE_LIBFFI
- ffi_type *ft = tft->ft;
-#endif
#if HAVE_LIBFFI
- ft->elements = 0;
- free(ft);
+ free(tft->elements);
+ tft->elements = 0;
+ free(tft->ft);
tft->ft = 0;
#endif
@@ -306,6 +338,7 @@ static void ffi_enum_type_mark(val obj)
ffi_type_common_mark(tft);
gc_mark(tft->sym_num);
gc_mark(tft->num_sym);
+ gc_mark(tft->eltype);
}
static struct cobj_ops ffi_type_builtin_ops =
@@ -336,6 +369,21 @@ static struct cobj_ops ffi_type_enum_ops =
ffi_enum_type_mark,
cobj_eq_hash_op);
+cnum ffi_type_size(struct txr_ffi_type *tft)
+{
+ return tft->size;
+}
+
+void ffi_type_put(struct txr_ffi_type *tft, val obj, mem_t *dst, val self)
+{
+ tft->put(tft, obj, dst, self);
+}
+
+val ffi_type_get(struct txr_ffi_type *tft, mem_t *src, val self)
+{
+ return tft->get(tft, src, self);
+}
+
#if HAVE_LIBFFI
struct txr_ffi_closure {
@@ -355,7 +403,8 @@ static struct txr_ffi_closure *ffi_closure_struct(val obj)
static struct txr_ffi_closure *ffi_closure_struct_checked(val self, val obj)
{
- return coerce(struct txr_ffi_closure *, cobj_handle(self, obj, ffi_closure_s));
+ return coerce(struct txr_ffi_closure *, cobj_handle(self, obj,
+ ffi_closure_cls));
}
static void ffi_closure_print_op(val obj, val out,
@@ -363,7 +412,7 @@ static void ffi_closure_print_op(val obj, val out,
{
struct txr_ffi_closure *tfcl = ffi_closure_struct(obj);
put_string(lit("#<"), out);
- obj_print_impl(obj->co.cls, out, pretty, ctx);
+ obj_print_impl(obj->co.cls->cls_sym, out, pretty, ctx);
format(out, lit(" ~s ~s>"), tfcl->fun, tfcl->call_desc, nao);
}
@@ -397,15 +446,25 @@ static struct cobj_ops ffi_closure_ops =
static void ffi_void_put(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
+ (void) tft;
+ (void) n;
+ (void) dst;
+ (void) self;
}
static cnum ffi_fixed_dynsize(struct txr_ffi_type *tft, val obj, val self)
{
+ (void) tft;
+ (void) obj;
+ (void) self;
return tft->size;
}
static mem_t *ffi_fixed_alloc(struct txr_ffi_type *tft, val obj, val self)
{
+ (void) tft;
+ (void) obj;
+ (void) self;
return chk_calloc(1, tft->size);
}
@@ -414,13 +473,13 @@ static cnum ffi_varray_dynsize(struct txr_ffi_type *tft, val obj, val self)
switch (tft->ch_conv) {
case conv_char:
case conv_zchar:
- return utf8_to_buf(0, c_str(obj), tft->null_term);
+ return utf8_to_buf(0, c_str(obj, self), tft->null_term);
case conv_wchar:
case conv_bchar:
case conv_none:
default:
{
- cnum len = c_num(length(obj)) + tft->null_term;
+ cnum len = c_num(length(obj), self) + tft->null_term;
val eltype = tft->eltype;
struct txr_ffi_type *etft = ffi_type_struct(eltype);
if (etft->incomplete)
@@ -436,7 +495,7 @@ static mem_t *ffi_varray_alloc(struct txr_ffi_type *tft, val obj, val self)
{
cnum dynsize = ffi_varray_dynsize(tft, obj, self);
size_t size = dynsize;
- if ((cnum) size != dynsize)
+ if (convert(cnum, size) != dynsize)
uw_throwf(error_s, lit("~a: array too large"), self, nao);
return chk_calloc(size, 1);
}
@@ -461,26 +520,43 @@ static mem_t *ffi_flex_alloc(struct txr_ffi_type *tft, val obj, val self)
static void ffi_noop_free(void *ptr)
{
+ (void) ptr;
}
static val ffi_void_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
+ (void) tft;
+ (void) src;
+ (void) self;
return nil;
}
-static void ffi_simple_release(struct txr_ffi_type *tft, val obj, mem_t *dst)
+static void ffi_simple_release(struct txr_ffi_type *tft, val obj,
+ mem_t *dst, val self)
{
mem_t **loc = coerce(mem_t **, dst);
+ (void) tft;
+ (void) obj;
+ (void) self;
free(*loc);
*loc = 0;
}
+#if __i386__ || __x86_64__ || __PPC64__ || __ARM_FEATURE_UNALIGNED
+
+#define align_sw_get(type, src) enum { dummy ## __LINE__ }
+#define align_sw_end
+#define align_sw_put_end
+#define align_sw_put(type, dst, expr) (expr)
+
+#else
+
#define align_sw_get(type, src) { \
const int al = ((alignof (type) - 1) & coerce(uint_ptr_t, src)) == 0; \
const size_t sz = sizeof (type); \
mem_t *src_prev = src; \
mem_t *buf = al ? src : convert(mem_t *, alloca(sz)); \
- mem_t *src = al ? buf : (memcpy(buf, src_prev, sz), buf);
+ mem_t *src = al ? buf : (memcpy(buf, src_prev, sz), buf)
#define align_sw_end \
}
@@ -501,26 +577,34 @@ static void ffi_simple_release(struct txr_ffi_type *tft, val obj, mem_t *dst)
} \
}
+#endif
+
#if HAVE_I8
static void ffi_i8_put(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
i8_t v = c_i8(n, self);
+ (void) tft;
*coerce(i8_t *, dst) = v;
}
static val ffi_i8_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
+ (void) tft;
+ (void) self;
return num_fast(*src);
}
static void ffi_u8_put(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
u8_t v = c_u8(n, self);
+ (void) tft;
*coerce(u8_t *, dst) = v;
}
static val ffi_u8_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
+ (void) tft;
+ (void) self;
return num_fast(*coerce(u8_t *, src));
}
@@ -530,6 +614,7 @@ static val ffi_u8_get(struct txr_ffi_type *tft, mem_t *src, val self)
static void ffi_i16_put(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
i16_t v = c_i16(n, self);
+ (void) tft;
align_sw_put(i16_t, dst, *coerce(i16_t *, dst) = v);
}
@@ -537,6 +622,8 @@ static val ffi_i16_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
align_sw_get(i16_t, src);
i16_t n = *coerce(i16_t *, src);
+ (void) tft;
+ (void) self;
return num_fast(n);
align_sw_end;
}
@@ -544,6 +631,7 @@ static val ffi_i16_get(struct txr_ffi_type *tft, mem_t *src, val self)
static void ffi_u16_put(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
u16_t v = c_u16(n, self);
+ (void) tft;
align_sw_put(u16_t, dst, *coerce(u16_t *, dst) = v);
}
@@ -551,6 +639,8 @@ static val ffi_u16_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
align_sw_get(u16_t, src);
u16_t n = *coerce(u16_t *, src);
+ (void) tft;
+ (void) self;
return num_fast(n);
align_sw_end;
}
@@ -560,6 +650,7 @@ static val ffi_u16_get(struct txr_ffi_type *tft, mem_t *src, val self)
static void ffi_i32_put(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
i32_t v = c_i32(n, self);
+ (void) tft;
align_sw_put(i32_t, dst, *coerce(i32_t *, dst) = v);
}
@@ -567,6 +658,8 @@ static val ffi_i32_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
align_sw_get(i32_t, src);
i32_t n = *coerce(i32_t *, src);
+ (void) tft;
+ (void) self;
return num(n);
align_sw_end;
}
@@ -574,6 +667,7 @@ static val ffi_i32_get(struct txr_ffi_type *tft, mem_t *src, val self)
static void ffi_u32_put(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
u32_t v = c_u32(n, self);
+ (void) tft;
align_sw_put(u32_t, dst, *coerce(u32_t *, dst) = v);
}
@@ -581,6 +675,8 @@ static val ffi_u32_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
align_sw_get(u32_t, src);
u32_t n = *coerce(u32_t *, src);
+ (void) tft;
+ (void) self;
return unum(n);
align_sw_end;
}
@@ -590,6 +686,7 @@ static val ffi_u32_get(struct txr_ffi_type *tft, mem_t *src, val self)
static void ffi_i64_put(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
i64_t v = c_i64(n, self);
+ (void) tft;
align_sw_put(i64_t, dst, *coerce(i64_t *, dst) = v);
}
@@ -598,6 +695,9 @@ static val ffi_i64_get(struct txr_ffi_type *tft, mem_t *src, val self)
align_sw_get(i64_t, src);
i64_t n = *coerce(i64_t *, src);
+ (void) tft;
+ (void) self;
+
if (sizeof (i64_t) <= sizeof (cnum)) {
return num(n);
} else {
@@ -611,6 +711,7 @@ static val ffi_i64_get(struct txr_ffi_type *tft, mem_t *src, val self)
static void ffi_u64_put(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
u64_t v = c_u64(n, self);
+ (void) tft;
align_sw_put(u64_t, dst, *coerce(u64_t *, dst) = v);
}
@@ -619,6 +720,9 @@ static val ffi_u64_get(struct txr_ffi_type *tft, mem_t *src, val self)
align_sw_get(u64_t, src);
u64_t n = *coerce(u64_t *, src);
+ (void) tft;
+ (void) self;
+
if (sizeof (u64_t) <= sizeof (uint_ptr_t)) {
return unum(n);
} else {
@@ -634,11 +738,14 @@ static val ffi_u64_get(struct txr_ffi_type *tft, mem_t *src, val self)
static void ffi_char_put(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
char v = c_char(n, self);
+ (void) tft;
*coerce(char *, dst) = v;
}
static val ffi_char_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
+ (void) tft;
+ (void) self;
return chr(*coerce(char *, src));
}
@@ -646,16 +753,21 @@ static void ffi_uchar_put(struct txr_ffi_type *tft, val n, mem_t *dst,
val self)
{
unsigned char v = c_uchar(n, self);
+ (void) tft;
*coerce(unsigned char *, dst) = v;
}
static val ffi_uchar_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
+ (void) tft;
+ (void) self;
return num_fast(*src);
}
static val ffi_bchar_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
+ (void) tft;
+ (void) self;
return chr(*src);
}
@@ -663,6 +775,7 @@ static void ffi_short_put(struct txr_ffi_type *tft, val n, mem_t *dst,
val self)
{
short v = c_short(n, self);
+ (void) tft;
align_sw_put(short, dst, *coerce(short *, dst) = v);
}
@@ -670,6 +783,8 @@ static val ffi_short_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
align_sw_get(short, src);
short n = *coerce(short *, src);
+ (void) tft;
+ (void) self;
return num_fast(n);
align_sw_end;
}
@@ -678,18 +793,24 @@ static void ffi_ushort_put(struct txr_ffi_type *tft, val n, mem_t *dst,
val self)
{
unsigned short v = c_ushort(n, self);
+ (void) tft;
align_sw_put(unsigned, dst, *coerce(unsigned short *, dst) = v);
}
static val ffi_ushort_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
+ align_sw_get(unsigned short, src);
unsigned short n = *coerce(unsigned short *, src);
+ (void) tft;
+ (void) self;
return num_fast(n);
+ align_sw_end;
}
static void ffi_int_put(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
int v = c_int(n, self);
+ (void) tft;
align_sw_put(int, dst, *coerce(int *, dst) = v);
}
@@ -697,6 +818,8 @@ static val ffi_int_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
align_sw_get(int, src);
int n = *coerce(int *, src);
+ (void) tft;
+ (void) self;
return num(n);
align_sw_end;
}
@@ -704,6 +827,7 @@ static val ffi_int_get(struct txr_ffi_type *tft, mem_t *src, val self)
static void ffi_uint_put(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
unsigned v = c_uint(n, self);
+ (void) tft;
align_sw_put(unsigned, dst, *coerce(unsigned *, dst) = v);
}
@@ -711,6 +835,8 @@ static val ffi_uint_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
align_sw_get(unsigned, src);
unsigned n = *coerce(unsigned *, src);
+ (void) tft;
+ (void) self;
return unum(n);
align_sw_end;
}
@@ -718,6 +844,7 @@ static val ffi_uint_get(struct txr_ffi_type *tft, mem_t *src, val self)
static void ffi_long_put(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
long v = c_long(n, self);
+ (void) tft;
align_sw_put(long, dst, *coerce(long *, dst) = v);
}
@@ -725,6 +852,8 @@ static val ffi_long_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
align_sw_get(long, src);
long n = *coerce(long *, src);
+ (void) tft;
+ (void) self;
return num(n);
align_sw_end;
}
@@ -732,6 +861,7 @@ static val ffi_long_get(struct txr_ffi_type *tft, mem_t *src, val self)
static void ffi_ulong_put(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
unsigned long v = c_ulong(n, self);
+ (void) tft;
align_sw_put(unsigned long, dst, *coerce(unsigned long *, dst) = v);
}
@@ -739,6 +869,8 @@ static val ffi_ulong_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
align_sw_get(unsigned long, src);
unsigned long n = *coerce(unsigned long *, src);
+ (void) tft;
+ (void) self;
return unum(n);
align_sw_end;
}
@@ -747,10 +879,14 @@ static void ffi_float_put(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
double v;
+ (void) tft;
+
switch (type(n)) {
case NUM:
+ v = c_n(n);
+ break;
case CHR:
- v = c_num(n);
+ v = c_ch(n);
break;
case BGNUM:
n = int_flo(n);
@@ -773,6 +909,8 @@ static val ffi_float_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
align_sw_get(float, src);
float n = *coerce(float *, src);
+ (void) tft;
+ (void) self;
return flo(n);
align_sw_end;
}
@@ -782,10 +920,14 @@ static void ffi_double_put(struct txr_ffi_type *tft, val n, mem_t *dst,
{
double v;
+ (void) tft;
+
switch (type(n)) {
case NUM:
+ v = c_n(n);
+ break;
case CHR:
- v = c_num(n);
+ v = c_ch(n);
break;
case BGNUM:
n = int_flo(n);
@@ -802,12 +944,16 @@ static val ffi_double_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
align_sw_get(double, src);
double n = *coerce(double *, src);
+ (void) tft;
+ (void) self;
return flo(n);
align_sw_end;
}
static void ffi_val_put(struct txr_ffi_type *tft, val v, mem_t *dst, val self)
{
+ (void) tft;
+ (void) self;
align_sw_put(val *, dst, *coerce(val *, dst) = v);
}
@@ -815,6 +961,7 @@ static val ffi_val_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
align_sw_get(val, src);
val v = *coerce(val *, src);
+ (void) tft;
if (!valid_object_p(v))
uw_throwf(error_s, lit("~a: bit pattern ~0,0*x isn't a valid Lisp object"),
self, num_fast(sizeof (v) * 2), bits(v), nao);
@@ -822,274 +969,241 @@ static val ffi_val_get(struct txr_ffi_type *tft, mem_t *src, val self)
align_sw_end;
}
-static void ffi_be_i16_put(struct txr_ffi_type *tft, val n,
- mem_t *dst, val self)
+static u16_t ffi_swap_u16(u16_t n)
{
- cnum v = c_num(n);
-
- if (v < -32768 || v > 32767)
- uw_throwf(error_s, lit("~a: value ~s is out of signed 16 bit range"),
- self, n, nao);
-
- dst[0] = (v >> 8) & 0xff;
- dst[1] = v & 0xff;
+ return convert(u16_t, n << 8 | n >> 8);
}
-static val ffi_be_i16_get(struct txr_ffi_type *tft, mem_t *src, val self)
+static u32_t ffi_swap_u32(u32_t n)
{
- cnum n = (src[0] << 8) | src[1];
- if ((n & 0x8000) != 0)
- n = -((n ^ 0xFFFF) + 1);
- return num(n);
+ n = (n & 0xFF00FF00U) >> 8 | (n & 0x00FF00FF) << 8;
+ return n << 16 | n >> 16;
}
-static void ffi_be_u16_put(struct txr_ffi_type *tft, val n,
- mem_t *dst, val self)
+static u64_t ffi_swap_u64(u64_t n)
{
- cnum v = c_num(n);
-
- if (v < -32768 || v > 32767)
- uw_throwf(error_s, lit("~a: value ~s is out of signed 16 bit range"),
- self, n, nao);
-
- dst[0] = (v >> 8) & 0xff;
- dst[1] = v & 0xff;
+ n = (n & 0xFF00FF00FF00FF00U) >> 8 | (n & 0x00FF00FF00FF00FF) << 8;
+ n = (n & 0xFFFF0000FFFF0000U) >> 16 | (n & 0x0000FFFF0000FFFF) << 16;
+ return n << 32 | n >> 32;
}
-static val ffi_be_u16_get(struct txr_ffi_type *tft, mem_t *src, val self)
+#if HAVE_I16
+static i16_t ffi_swap_i16(i16_t n)
{
- cnum n = (src[0] << 8) | src[1];
- return num(n);
+ return convert(i16_t, ffi_swap_u16(convert(u16_t, n)));
}
+#endif
-static void ffi_le_i16_put(struct txr_ffi_type *tft, val n,
- mem_t *dst, val self)
+#if HAVE_I32
+static i32_t ffi_swap_i32(i32_t n)
{
- cnum v = c_num(n);
-
- if (v < -32768 || v > 32767)
- uw_throwf(error_s, lit("~a: value ~s is out of signed 16 bit range"),
- self, n, nao);
-
- dst[1] = (v >> 8) & 0xff;
- dst[0] = v & 0xff;
+ return convert(i32_t, ffi_swap_u32(convert(u32_t, n)));
}
+#endif
-static val ffi_le_i16_get(struct txr_ffi_type *tft, mem_t *src, val self)
+#if HAVE_I64
+static i64_t ffi_swap_i64(i64_t n)
{
- cnum n = (src[1] << 8) | src[0];
- if ((n & 0x8000) != 0)
- n = -((n ^ 0xFFFF) + 1);
- return num(n);
+ return convert(i64_t, ffi_swap_u64(convert(u64_t, n)));
}
+#endif
-static void ffi_le_u16_put(struct txr_ffi_type *tft, val n,
- mem_t *dst, val self)
+#if HAVE_I16
+static void ffi_swap_i16_put(struct txr_ffi_type *tft, val n,
+ mem_t *dst, val self)
{
- cnum v = c_num(n);
+ i16_t v = ffi_swap_i16(c_i16(n, self));
+ (void) tft;
+ align_sw_put(i16_t, dst, *coerce(i16_t *, dst) = v);
+}
- if (v < 0|| v > 65535)
- uw_throwf(error_s, lit("~a: value ~s is out of unsigned 16 bit range"),
- self, n, nao);
- dst[1] = (v >> 8) & 0xff;
- dst[0] = v & 0xff;
+static val ffi_swap_i16_get(struct txr_ffi_type *tft, mem_t *src, val self)
+{
+ align_sw_get(i16_t, src);
+ i16_t n = ffi_swap_i16(*coerce(i16_t *, src));
+ (void) tft;
+ (void) self;
+ return num_fast(n);
+ align_sw_end;
}
-static val ffi_le_u16_get(struct txr_ffi_type *tft, mem_t *src, val self)
+static void ffi_swap_u16_put(struct txr_ffi_type *tft, val n,
+ mem_t *dst, val self)
{
- cnum n = (src[1] << 8) | src[0];
- return num(n);
+ u16_t v = ffi_swap_u16(c_u16(n, self));
+ (void) tft;
+ align_sw_put(u16_t, dst, *coerce(u16_t *, dst) = v);
}
-static void ffi_be_i32_put(struct txr_ffi_type *tft, val n,
- mem_t *dst, val self)
+static val ffi_swap_u16_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
- cnum v = c_num(n);
-
- if (v < -convert(cnum, 0x7FFFFFFF) - 1 || v > 0x7FFFFFFF)
- uw_throwf(error_s, lit("~a: value ~s is out of signed 32 bit range"),
- self, n, nao);
+ align_sw_get(u16_t, src);
+ u16_t n = ffi_swap_u16(*coerce(u16_t *, src));
+ (void) tft;
+ (void) self;
+ return num_fast(n);
+ align_sw_end;
+}
+#endif
- dst[0] = (v >> 24) & 0xff;
- dst[1] = (v >> 16) & 0xff;
- dst[2] = (v >> 8) & 0xff;
- dst[3] = v & 0xff;
+#if HAVE_I32
+static void ffi_swap_i32_put(struct txr_ffi_type *tft, val n,
+ mem_t *dst, val self)
+{
+ i32_t v = ffi_swap_i32(c_i32(n, self));
+ (void) tft;
+ align_sw_put(i32_t, dst, *coerce(i32_t *, dst) = v);
}
-static val ffi_be_i32_get(struct txr_ffi_type *tft, mem_t *src, val self)
+static val ffi_swap_i32_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
- cnum n = (convert(cnum, src[0]) << 24 | convert(cnum, src[1]) << 16 |
- convert(cnum, src[2]) << 8 | src[3]);
- if ((n & 0x80000000) != 0)
- n = -((n ^ 0xFFFFFFFF) + 1);
+ align_sw_get(i32_t, src);
+ i32_t n = ffi_swap_i32(*coerce(i32_t *, src));
+ (void) tft;
+ (void) self;
return num(n);
+ align_sw_end;
}
-static void ffi_be_u32_put(struct txr_ffi_type *tft, val n,
- mem_t *dst, val self)
+static void ffi_swap_u32_put(struct txr_ffi_type *tft, val n,
+ mem_t *dst, val self)
{
- ucnum v = c_unum(n);
-
- if (v > 0xFFFFFFFF)
- uw_throwf(error_s, lit("~a: value ~s is out of unsigned 32 bit range"),
- self, n, nao);
-
- dst[0] = (v >> 24) & 0xff;
- dst[1] = (v >> 16) & 0xff;
- dst[2] = (v >> 8) & 0xff;
- dst[3] = v & 0xff;
+ u32_t v = ffi_swap_u32(c_u32(n, self));
+ (void) tft;
+ align_sw_put(u32_t, dst, *coerce(u32_t *, dst) = v);
}
-static val ffi_be_u32_get(struct txr_ffi_type *tft, mem_t *src, val self)
+static val ffi_swap_u32_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
- ucnum n = (convert(ucnum, src[0]) << 24 | convert(ucnum, src[1]) << 16 |
- convert(ucnum, src[2]) << 8 | src[3]);
+ align_sw_get(u32_t, src);
+ u32_t n = ffi_swap_u32(*coerce(u32_t *, src));
+ (void) tft;
+ (void) self;
return unum(n);
+ align_sw_end;
}
+#endif
-static void ffi_le_i32_put(struct txr_ffi_type *tft, val n,
- mem_t *dst, val self)
+#if HAVE_I64
+static void ffi_swap_i64_put(struct txr_ffi_type *tft, val n,
+ mem_t *dst, val self)
+{
+ i64_t v = ffi_swap_i64(c_i64(n, self));
+ (void) tft;
+ align_sw_put(i64_t, dst, *coerce(i64_t *, dst) = v);
+}
+
+static val ffi_swap_i64_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
- cnum v = c_num(n);
+ align_sw_get(i64_t, src);
+ i64_t n = ffi_swap_i64(*coerce(i64_t *, src));
- if (v < - convert(cnum, 0x7fffffff) - 1 || v > 0x7FFFFFFF)
- uw_throwf(error_s, lit("~a: value ~s is out of signed 32 bit range"),
- self, n, nao);
+ (void) tft;
+ (void) self;
- dst[3] = (v >> 24) & 0xff;
- dst[2] = (v >> 16) & 0xff;
- dst[1] = (v >> 8) & 0xff;
- dst[0] = v & 0xff;
+ if (sizeof (i64_t) <= sizeof (cnum)) {
+ return num(n);
+ } else {
+ val high = num(n >> 32);
+ val low = unum(n & 0xFFFFFFFF);
+ return logior(ash(high, num_fast(32)), low);
+ }
+ align_sw_end;
}
-static val ffi_le_i32_get(struct txr_ffi_type *tft, mem_t *src, val self)
+static void ffi_swap_u64_put(struct txr_ffi_type *tft, val n,
+ mem_t *dst, val self)
{
- cnum n = (convert(cnum, src[3]) << 24 | convert(cnum, src[2]) << 16 |
- convert(cnum, src[1]) << 8 | src[0]);
- if ((n & 0x80000000) != 0)
- n = -((n ^ 0xFFFFFFFF) + 1);
- return num(n);
+ u64_t v = ffi_swap_u64(c_u64(n, self));
+ (void) tft;
+ align_sw_put(u64_t, dst, *coerce(u64_t *, dst) = v);
}
-static void ffi_le_u32_put(struct txr_ffi_type *tft, val n,
- mem_t *dst, val self)
+static val ffi_swap_u64_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
- ucnum v = c_unum(n);
+ align_sw_get(u64_t, src);
+ u64_t n = ffi_swap_u64(*coerce(u64_t *, src));
- if (v > 0xFFFFFFFF)
- uw_throwf(error_s, lit("~a: value ~s is out of unsigned 32 bit range"),
- self, n, nao);
+ (void) tft;
+ (void) self;
- dst[3] = (v >> 24) & 0xff;
- dst[2] = (v >> 16) & 0xff;
- dst[1] = (v >> 8) & 0xff;
- dst[0] = v & 0xff;
+ if (sizeof (u64_t) <= sizeof (uint_ptr_t)) {
+ return unum(n);
+ } else {
+ val high = unum(n >> 32);
+ val low = unum(n & 0xFFFFFFFF);
+ return logior(ash(high, num_fast(32)), low);
+ }
+ align_sw_end;
}
+#endif
-static val ffi_le_u32_get(struct txr_ffi_type *tft, mem_t *src, val self)
-{
- ucnum n = (convert(ucnum, src[3]) << 24 | convert(ucnum, src[2]) << 16 |
- convert(ucnum, src[1]) << 8 | src[0]);
- return unum(n);
-}
+#if HAVE_LITTLE_ENDIAN
-static void ffi_be_i64_put(struct txr_ffi_type *tft, val n,
- mem_t *dst, val self)
-{
- i64_t v = c_i64(n, self);
+#define ffi_be_i16_put ffi_swap_i16_put
+#define ffi_be_i16_get ffi_swap_i16_get
+#define ffi_be_u16_put ffi_swap_u16_put
+#define ffi_be_u16_get ffi_swap_u16_get
- dst[0] = (v >> 56) & 0xff;
- dst[1] = (v >> 48) & 0xff;
- dst[2] = (v >> 40) & 0xff;
- dst[3] = (v >> 32) & 0xff;
- dst[4] = (v >> 24) & 0xff;
- dst[5] = (v >> 16) & 0xff;
- dst[6] = (v >> 8) & 0xff;
- dst[7] = v & 0xff;
-}
+#define ffi_be_i32_put ffi_swap_i32_put
+#define ffi_be_i32_get ffi_swap_i32_get
+#define ffi_be_u32_put ffi_swap_u32_put
+#define ffi_be_u32_get ffi_swap_u32_get
-static val ffi_be_i64_get(struct txr_ffi_type *tft, mem_t *src, val self)
-{
- i64_t n = (convert(i64_t, src[0]) << 56 | convert(i64_t, src[1]) << 48 |
- convert(i64_t, src[2]) << 40 | convert(i64_t, src[3]) << 32 |
- convert(i64_t, src[4]) << 24 | convert(i64_t, src[5]) << 16 |
- convert(i64_t, src[6]) << 8 | src[7]);
- return num_64(n);
-}
+#define ffi_be_i64_put ffi_swap_i64_put
+#define ffi_be_i64_get ffi_swap_i64_get
+#define ffi_be_u64_put ffi_swap_u64_put
+#define ffi_be_u64_get ffi_swap_u64_get
-static void ffi_be_u64_put(struct txr_ffi_type *tft, val n,
- mem_t *dst, val self)
-{
- u64_t v = c_u64(n, self);
+#define ffi_le_i16_put ffi_i16_put
+#define ffi_le_i16_get ffi_i16_get
+#define ffi_le_u16_put ffi_u16_put
+#define ffi_le_u16_get ffi_u16_get
- dst[0] = (v >> 56) & 0xff;
- dst[1] = (v >> 48) & 0xff;
- dst[2] = (v >> 40) & 0xff;
- dst[3] = (v >> 32) & 0xff;
- dst[4] = (v >> 24) & 0xff;
- dst[5] = (v >> 16) & 0xff;
- dst[6] = (v >> 8) & 0xff;
- dst[7] = v & 0xff;
- return;
-}
+#define ffi_le_i32_put ffi_i32_put
+#define ffi_le_i32_get ffi_i32_get
+#define ffi_le_u32_put ffi_u32_put
+#define ffi_le_u32_get ffi_u32_get
-static val ffi_be_u64_get(struct txr_ffi_type *tft, mem_t *src, val self)
-{
- u64_t n = (convert(u64_t, src[0]) << 56 | convert(u64_t, src[1]) << 48 |
- convert(u64_t, src[2]) << 40 | convert(u64_t, src[3]) << 32 |
- convert(u64_t, src[4]) << 24 | convert(u64_t, src[5]) << 16 |
- convert(u64_t, src[6]) << 8 | src[7]);
- return unum_64(n);
-}
+#define ffi_le_i64_put ffi_i64_put
+#define ffi_le_i64_get ffi_i64_get
+#define ffi_le_u64_put ffi_u64_put
+#define ffi_le_u64_get ffi_u64_get
-static void ffi_le_i64_put(struct txr_ffi_type *tft, val n,
- mem_t *dst, val self)
-{
- i64_t v = c_i64(n, self);
+#else
- dst[7] = (v >> 56) & 0xff;
- dst[6] = (v >> 48) & 0xff;
- dst[5] = (v >> 40) & 0xff;
- dst[4] = (v >> 32) & 0xff;
- dst[3] = (v >> 24) & 0xff;
- dst[2] = (v >> 16) & 0xff;
- dst[1] = (v >> 8) & 0xff;
- dst[0] = v & 0xff;
-}
+#define ffi_be_i16_put ffi_i16_put
+#define ffi_be_i16_get ffi_i16_get
+#define ffi_be_u16_put ffi_u16_put
+#define ffi_be_u16_get ffi_u16_get
-static val ffi_le_i64_get(struct txr_ffi_type *tft, mem_t *src, val self)
-{
- u64_t n = (convert(u64_t, src[7]) << 56 | convert(u64_t, src[6]) << 48 |
- convert(u64_t, src[5]) << 40 | convert(u64_t, src[4]) << 32 |
- convert(u64_t, src[3]) << 24 | convert(u64_t, src[2]) << 16 |
- convert(u64_t, src[1]) << 8 | src[0]);
- return num_64(n);
-}
+#define ffi_be_i32_put ffi_i32_put
+#define ffi_be_i32_get ffi_i32_get
+#define ffi_be_u32_put ffi_u32_put
+#define ffi_be_u32_get ffi_u32_get
-static void ffi_le_u64_put(struct txr_ffi_type *tft, val n,
- mem_t *dst, val self)
-{
- u64_t v = c_u64(n, self);
+#define ffi_be_i64_put ffi_i64_put
+#define ffi_be_i64_get ffi_i64_get
+#define ffi_be_u64_put ffi_u64_put
+#define ffi_be_u64_get ffi_u64_get
- dst[7] = (v >> 56) & 0xff;
- dst[6] = (v >> 48) & 0xff;
- dst[5] = (v >> 40) & 0xff;
- dst[4] = (v >> 32) & 0xff;
- dst[3] = (v >> 24) & 0xff;
- dst[2] = (v >> 16) & 0xff;
- dst[1] = (v >> 8) & 0xff;
- dst[0] = v & 0xff;
-}
+#define ffi_le_i16_put ffi_swap_i16_put
+#define ffi_le_i16_get ffi_swap_i16_get
+#define ffi_le_u16_put ffi_swap_u16_put
+#define ffi_le_u16_get ffi_swap_u16_get
-static val ffi_le_u64_get(struct txr_ffi_type *tft, mem_t *src, val self)
-{
- u64_t n = (convert(u64_t, src[7]) << 56 | convert(u64_t, src[6]) << 48 |
- convert(u64_t, src[5]) << 40 | convert(u64_t, src[4]) << 32 |
- convert(u64_t, src[3]) << 24 | convert(u64_t, src[2]) << 16 |
- convert(u64_t, src[1]) << 8 | src[0]);
- return unum_64(n);
-}
+#define ffi_le_i32_put ffi_swap_i32_put
+#define ffi_le_i32_get ffi_swap_i32_get
+#define ffi_le_u32_put ffi_swap_u32_put
+#define ffi_le_u32_get ffi_swap_u32_get
+
+#define ffi_le_i64_put ffi_swap_i64_put
+#define ffi_le_i64_get ffi_swap_i64_get
+#define ffi_le_u64_put ffi_swap_u64_put
+#define ffi_le_u64_get ffi_swap_u64_get
+
+#endif
static void ffi_be_float_put(struct txr_ffi_type *tft, val n,
mem_t *dst, val self)
@@ -1252,6 +1366,8 @@ static void ffi_wchar_put(struct txr_ffi_type *tft, val ch, mem_t *dst,
val self)
{
wchar_t c = c_chr(ch);
+ (void) tft;
+ (void) self;
align_sw_put(wchar_t, dst, *coerce(wchar_t *, dst) = c);
}
@@ -1259,6 +1375,11 @@ static val ffi_wchar_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
align_sw_get(wchar_t, src);
wchar_t c = *coerce(wchar_t *, src);
+ (void) tft;
+ (void) self;
+ if (c < 0 || c > 0x10FFFF)
+ uw_throwf(error_s, lit("~a: wchar_t value #x~X is out of character range"),
+ self, num(c), nao);
return chr(c);
align_sw_end;
}
@@ -1266,10 +1387,10 @@ static val ffi_wchar_get(struct txr_ffi_type *tft, mem_t *src, val self)
static void ffi_sbit_put(struct txr_ffi_type *tft, val n,
mem_t *dst, val self)
{
- unsigned mask = tft->mask;
+ unsigned mask = tft->m.mask;
unsigned sbmask = mask ^ (mask >> 1);
int shift = tft->shift;
- cnum cn = c_num(n);
+ cnum cn = c_num(n, self);
int in = cn;
unsigned uput = (convert(unsigned, in) << shift) & mask;
@@ -1303,11 +1424,13 @@ range:
static val ffi_sbit_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
align_sw_get(unsigned int, src);
- unsigned mask = tft->mask;
+ unsigned mask = tft->m.mask;
unsigned sbmask = mask ^ (mask >> 1);
int shift = tft->shift;
unsigned uget = *coerce(unsigned *, src) & mask;
+ (void) self;
+
if (uget & sbmask)
return num(-convert(int, ((uget ^ mask) >> shift) + 1));
return unum(uget >> shift);
@@ -1317,9 +1440,9 @@ static val ffi_sbit_get(struct txr_ffi_type *tft, mem_t *src, val self)
static void ffi_ubit_put(struct txr_ffi_type *tft, val n,
mem_t *dst, val self)
{
- unsigned mask = tft->mask;
+ unsigned mask = tft->m.mask;
int shift = tft->shift;
- ucnum cn = c_unum(n);
+ ucnum cn = c_unum(n, self);
unsigned un = cn;
unsigned uput = (un << shift) & mask;
@@ -1349,47 +1472,393 @@ range:
static val ffi_ubit_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
align_sw_get(unsigned, src);
- unsigned mask = tft->mask;
+ unsigned mask = tft->m.mask;
int shift = tft->shift;
unsigned uget = *coerce(unsigned *, src) & mask;
+ (void) self;
return unum(uget >> shift);
align_sw_end;
}
+#if HAVE_I64
+
+static void ffi_fat_sbit_put(struct txr_ffi_type *tft, val n,
+ mem_t *dst, val self)
+{
+ u64_t mask = tft->m.fmask;
+ u64_t sbmask = mask ^ (mask >> 1);
+ int shift = tft->shift;
+ i64_t in = c_i64(n, self);
+ u64_t uput = (convert(u64_t, in) << shift) & mask;
+
+ if (uput & sbmask) {
+ i64_t icheck = -convert(i64_t, ((uput ^ mask) >> shift) + 1);
+ if (icheck != in)
+ goto range;
+ } else if (convert(i64_t, uput >> shift) != in) {
+ goto range;
+ }
+
+ {
+ u64_t field = *coerce(u64_t *, dst);
+ field &= ~mask;
+ field |= uput;
+ *coerce(u64_t *, dst) = field;
+ }
+
+ return;
+range:
+ uw_throwf(error_s, lit("~a: value ~s is out of range of "
+ "signed ~s bit-field"),
+ self, n, num_fast(tft->nelem), nao);
+}
+
+static val ffi_fat_sbit_get(struct txr_ffi_type *tft, mem_t *src, val self)
+{
+ u64_t mask = tft->m.fmask;
+ u64_t sbmask = mask ^ (mask >> 1);
+ int shift = tft->shift;
+ u64_t uget = *coerce(u64_t *, src) & mask;
+
+ (void) self;
+
+ if (uget & sbmask)
+ return num(-convert(i64_t, ((uget ^ mask) >> shift) + 1));
+ return unum_64(uget >> shift);
+}
+
+static void ffi_fat_ubit_put(struct txr_ffi_type *tft, val n,
+ mem_t *dst, val self)
+{
+ u64_t mask = tft->m.fmask;
+ int shift = tft->shift;
+ u64_t un = c_u64(n, self);
+ u64_t uput = (un << shift) & mask;
+
+ if (uput >> shift != un)
+ goto range;
+
+ {
+ u64_t field = *coerce(u64_t *, dst);
+ field &= ~mask;
+ field |= uput;
+ *coerce(u64_t *, dst) = field;
+ }
+
+ return;
+
+range:
+ uw_throwf(error_s, lit("~a: value ~s is out of range of "
+ "unsigned ~s bit-field"),
+ self, n, num_fast(tft->nelem), nao);
+}
+
+static val ffi_fat_ubit_get(struct txr_ffi_type *tft, mem_t *src, val self)
+{
+ u64_t mask = tft->m.fmask;
+ int shift = tft->shift;
+ u64_t uget = *coerce(u64_t *, src) & mask;
+ (void) self;
+ return unum_64(uget >> shift);
+}
+
+#endif
+
static void ffi_generic_sbit_put(struct txr_ffi_type *tft, val n,
mem_t *dst, val self)
{
- mem_t *tmp = coerce(mem_t *, zalloca(sizeof (int)));
- memcpy(tmp, dst, tft->size);
- ffi_sbit_put(tft, n, tmp, self);
- memcpy(dst, tmp, tft->size);
+ int tmp = 0;
+ memcpy(&tmp, dst, tft->size);
+ ffi_sbit_put(tft, n, coerce(mem_t *, &tmp), self);
+ memcpy(dst, &tmp, tft->size);
}
static val ffi_generic_sbit_get(struct txr_ffi_type *tft,
mem_t *src, val self)
{
- mem_t *tmp = coerce(mem_t *, zalloca(sizeof (int)));
- memcpy(tmp, src, tft->size);
- return ffi_sbit_get(tft, tmp, self);
+ int tmp = 0;
+ memcpy(&tmp, src, tft->size);
+ return ffi_sbit_get(tft, coerce(mem_t *, &tmp), self);
}
static void ffi_generic_ubit_put(struct txr_ffi_type *tft, val n,
mem_t *dst, val self)
{
- mem_t *tmp = coerce(mem_t *, zalloca(sizeof (int)));
- memcpy(tmp, dst, tft->size);
- ffi_ubit_put(tft, n, tmp, self);
- memcpy(dst, tmp, tft->size);
+ int tmp = 0;
+ memcpy(&tmp, dst, tft->size);
+ ffi_ubit_put(tft, n, coerce(mem_t *, &tmp), self);
+ memcpy(dst, coerce(mem_t *, &tmp), tft->size);
}
static val ffi_generic_ubit_get(struct txr_ffi_type *tft,
mem_t *src, val self)
{
- mem_t *tmp = coerce(mem_t *, zalloca(sizeof (int)));
- memcpy(tmp, src, tft->size);
- return ffi_ubit_get(tft, tmp, self);
+ int tmp = 0;
+ memcpy(&tmp, src, tft->size);
+ return ffi_ubit_get(tft, coerce(mem_t *, &tmp), self);
+}
+
+#if HAVE_I64
+
+static void ffi_generic_fat_sbit_put(struct txr_ffi_type *tft, val n,
+ mem_t *dst, val self)
+{
+ i64_t tmp = 0;
+ memcpy(&tmp, dst, tft->size);
+ ffi_fat_sbit_put(tft, n, coerce(mem_t *, &tmp), self);
+ memcpy(dst, &tmp, tft->size);
}
+static val ffi_generic_fat_sbit_get(struct txr_ffi_type *tft,
+ mem_t *src, val self)
+{
+ i64_t tmp = 0;
+ memcpy(&tmp, src, tft->size);
+ return ffi_fat_sbit_get(tft, coerce(mem_t *, &tmp), self);
+}
+
+static void ffi_generic_fat_ubit_put(struct txr_ffi_type *tft, val n,
+ mem_t *dst, val self)
+{
+ i64_t tmp = 0;
+ memcpy(&tmp, dst, tft->size);
+ ffi_fat_ubit_put(tft, n, coerce(mem_t *, &tmp), self);
+ memcpy(dst, coerce(mem_t *, &tmp), tft->size);
+}
+
+static val ffi_generic_fat_ubit_get(struct txr_ffi_type *tft,
+ mem_t *src, val self)
+{
+ i64_t tmp = 0;
+ memcpy(&tmp, src, tft->size);
+ return ffi_fat_ubit_get(tft, coerce(mem_t *, &tmp), self);
+}
+
+#endif
+
+#if HAVE_LITTLE_ENDIAN
+
+static u32_t swap_get32(const mem_t *src, cnum size)
+{
+ u32_t val = 0;
+
+ if (size-- > 0)
+ val = convert(u32_t, src[0]) << 24;
+ if (size-- > 0)
+ val |= convert(u32_t, src[1]) << 16;
+ if (size-- > 0)
+ val |= convert(u32_t, src[2]) << 8;
+ if (size > 0)
+ val |= src[3];
+
+ return val;
+}
+
+static void swap_put32(mem_t *dst, u32_t val, cnum size)
+{
+ if (size-- > 0)
+ dst[0] = val >> 24;
+ if (size-- > 0)
+ dst[1] = val >> 16;
+ if (size-- > 0)
+ dst[2] = val >> 8;
+ if (size-- > 0)
+ dst[3] = val;
+}
+
+#if HAVE_I64
+
+static u64_t swap_get64(const mem_t *src, cnum size)
+{
+ u64_t val = 0;
+
+ if (size-- > 0)
+ val = convert(u64_t, src[0]) << 56;
+ if (size-- > 0)
+ val |= convert(u64_t, src[1]) << 48;
+ if (size-- > 0)
+ val |= convert(u64_t, src[2]) << 40;
+ if (size-- > 0)
+ val |= convert(u64_t, src[3]) << 32;
+ if (size-- > 0)
+ val |= convert(u64_t, src[4]) << 24;
+ if (size-- > 0)
+ val |= convert(u64_t, src[5]) << 16;
+ if (size-- > 0)
+ val |= convert(u64_t, src[6]) << 8;
+ if (size > 0)
+ val |= src[7];
+
+ return val;
+}
+
+static void swap_put64(mem_t *dst, u64_t val, cnum size)
+{
+ if (size-- > 0)
+ dst[0] = val >> 56;
+ if (size-- > 0)
+ dst[1] = val >> 48;
+ if (size-- > 0)
+ dst[2] = val >> 40;
+ if (size-- > 0)
+ dst[3] = val >> 32;
+ if (size-- > 0)
+ dst[4] = val >> 24;
+ if (size-- > 0)
+ dst[5] = val >> 16;
+ if (size-- > 0)
+ dst[6] = val >> 8;
+ if (size > 0)
+ dst[7] = val;
+}
+
+#endif
+
+#else
+
+static u32_t swap_get32(const mem_t *src, cnum size)
+{
+ u32_t val = 0;
+
+ if (size > 0)
+ val = src[0];
+ if (size-- > 0)
+ val |= convert(u32_t, src[1]) << 8;
+ if (size-- > 0)
+ val |= convert(u32_t, src[2]) << 16;
+ if (size-- > 0)
+ val |= convert(u32_t, src[3]) << 24;
+
+ return val;
+}
+
+static void swap_put32(mem_t *dst, u32_t val, cnum size)
+{
+ if (size-- > 0)
+ dst[0] = val;
+ if (size-- > 0)
+ dst[1] = val >> 8;
+ if (size-- > 0)
+ dst[2] = val >> 16;
+ if (size-- > 0)
+ dst[3] = val >> 24;
+}
+
+#if HAVE_I64
+
+static u64_t swap_get64(const mem_t *src, cnum size)
+{
+ u64_t val = 0;
+
+ if (size > 0)
+ val = src[0];
+ if (size-- > 0)
+ val |= convert(u64_t, src[1]) << 8;
+ if (size-- > 0)
+ val |= convert(u64_t, src[2]) << 16;
+ if (size-- > 0)
+ val |= convert(u64_t, src[3]) << 24;
+ if (size-- > 0)
+ val |= convert(u64_t, src[4]) << 32;
+ if (size-- > 0)
+ val |= convert(u64_t, src[5]) << 40;
+ if (size-- > 0)
+ val |= convert(u64_t, src[6]) << 48;
+ if (size-- > 0)
+ val |= convert(u64_t, src[7]) << 56;
+
+ return val;
+}
+
+static void swap_put64(mem_t *dst, u64_t val, cnum size)
+{
+ if (size > 0)
+ dst[0] = val;
+ if (size-- > 0)
+ dst[1] = val >> 8;
+ if (size-- > 0)
+ dst[2] = val >> 16;
+ if (size-- > 0)
+ dst[3] = val >> 24;
+ if (size-- > 0)
+ dst[4] = val >> 32;
+ if (size-- > 0)
+ dst[5] = val >> 40;
+ if (size-- > 0)
+ dst[6] = val >> 48;
+ if (size-- > 0)
+ dst[7] = val >> 56;
+}
+
+#endif
+
+#endif
+
+static void ffi_generic_swap_sbit_put(struct txr_ffi_type *tft, val n,
+ mem_t *dst, val self)
+{
+ u32_t tmp = swap_get32(dst, tft->size);
+ ffi_sbit_put(tft, n, coerce(mem_t *, &tmp), self);
+ swap_put32(dst, tmp, tft->size);
+}
+
+static val ffi_generic_swap_sbit_get(struct txr_ffi_type *tft,
+ mem_t *src, val self)
+{
+ u32_t tmp = swap_get32(src, tft->size);
+ return ffi_sbit_get(tft, coerce(mem_t *, &tmp), self);
+}
+
+static void ffi_generic_swap_ubit_put(struct txr_ffi_type *tft, val n,
+ mem_t *dst, val self)
+{
+ u32_t tmp = swap_get32(dst, tft->size);
+ ffi_ubit_put(tft, n, coerce(mem_t *, &tmp), self);
+ memcpy(dst, coerce(mem_t *, &tmp), tft->size);
+ swap_put32(dst, tmp, tft->size);
+}
+
+static val ffi_generic_swap_ubit_get(struct txr_ffi_type *tft,
+ mem_t *src, val self)
+{
+ u32_t tmp = swap_get32(src, tft->size);
+ return ffi_ubit_get(tft, coerce(mem_t *, &tmp), self);
+}
+
+#if HAVE_I64
+
+static void ffi_generic_swap_fat_sbit_put(struct txr_ffi_type *tft, val n,
+ mem_t *dst, val self)
+{
+ u64_t tmp = swap_get64(dst, tft->size);
+ ffi_fat_sbit_put(tft, n, coerce(mem_t *, &tmp), self);
+ swap_put64(dst, tmp, tft->size);
+}
+
+static val ffi_generic_swap_fat_sbit_get(struct txr_ffi_type *tft,
+ mem_t *src, val self)
+{
+ u64_t tmp = swap_get64(src, tft->size);
+ return ffi_fat_sbit_get(tft, coerce(mem_t *, &tmp), self);
+}
+
+static void ffi_generic_swap_fat_ubit_put(struct txr_ffi_type *tft, val n,
+ mem_t *dst, val self)
+{
+ u64_t tmp = swap_get64(dst, tft->size);
+ ffi_fat_ubit_put(tft, n, coerce(mem_t *, &tmp), self);
+ swap_put64(dst, tmp, tft->size);
+}
+
+static val ffi_generic_swap_fat_ubit_get(struct txr_ffi_type *tft,
+ mem_t *src, val self)
+{
+ u64_t tmp = swap_get64(src, tft->size);
+ return ffi_fat_ubit_get(tft, coerce(mem_t *, &tmp), self);
+}
+
+#endif
+
static void ffi_bool_put(struct txr_ffi_type *tft, val truth,
mem_t *dst, val self)
{
@@ -1410,22 +1879,29 @@ static val ffi_bool_get(struct txr_ffi_type *tft, mem_t *src, val self)
static void ffi_i8_rput(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
i8_t v = c_i8(n, self);
+ (void) tft;
*coerce(i8_t *, dst) = v;
}
static val ffi_i8_rget(struct txr_ffi_type *tft, mem_t *src, val self)
{
+ (void) tft;
+ (void) self;
return num_fast(*src);
}
static void ffi_u8_rput(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
u8_t v = c_u8(n, self);
+ (void) tft;
+ (void) self;
*coerce(u8_t *, dst) = v;
}
static val ffi_u8_rget(struct txr_ffi_type *tft, mem_t *src, val self)
{
+ (void) tft;
+ (void) self;
return num_fast(*coerce(u8_t *, src));
}
@@ -1433,24 +1909,32 @@ static val ffi_u8_rget(struct txr_ffi_type *tft, mem_t *src, val self)
static void ffi_i16_rput(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
i16_t v = c_i16(n, self);
+ (void) tft;
+ (void) self;
*coerce(ffi_arg *, dst) = v;
}
static val ffi_i16_rget(struct txr_ffi_type *tft, mem_t *src, val self)
{
i16_t n = *coerce(ffi_arg *, src);
+ (void) tft;
+ (void) self;
return num_fast(n);
}
static void ffi_u16_rput(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
u16_t v = c_u16(n, self);
+ (void) tft;
+ (void) self;
*coerce(ffi_arg *, dst) = v;
}
static val ffi_u16_rget(struct txr_ffi_type *tft, mem_t *src, val self)
{
u16_t n = *coerce(ffi_arg *, src);
+ (void) tft;
+ (void) self;
return num_fast(n);
}
#endif
@@ -1459,12 +1943,16 @@ static val ffi_u16_rget(struct txr_ffi_type *tft, mem_t *src, val self)
static void ffi_i32_rput(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
i32_t v = c_i32(n, self);
+ (void) tft;
+ (void) self;
*coerce(ffi_arg *, dst) = v;
}
static val ffi_i32_rget(struct txr_ffi_type *tft, mem_t *src, val self)
{
i32_t n = *coerce(ffi_arg *, src);
+ (void) tft;
+ (void) self;
return num(n);
}
#endif
@@ -1472,23 +1960,30 @@ static val ffi_i32_rget(struct txr_ffi_type *tft, mem_t *src, val self)
static void ffi_u32_rput(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
u32_t v = c_u32(n, self);
+ (void) tft;
+ (void) self;
*coerce(ffi_arg *, dst) = v;
}
static val ffi_u32_rget(struct txr_ffi_type *tft, mem_t *src, val self)
{
u32_t n = *coerce(ffi_arg *, src);
+ (void) tft;
+ (void) self;
return unum(n);
}
static void ffi_char_rput(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
char v = c_char(n, self);
+ (void) tft;
*coerce(ffi_arg *, dst) = v;
}
static val ffi_char_rget(struct txr_ffi_type *tft, mem_t *src, val self)
{
+ (void) tft;
+ (void) self;
return chr((char) *coerce(ffi_arg *, src));
}
@@ -1496,16 +1991,21 @@ static void ffi_uchar_rput(struct txr_ffi_type *tft, val n, mem_t *dst,
val self)
{
unsigned char v = c_uchar(n, self);
+ (void) tft;
*coerce(ffi_arg *, dst) = v;
}
static val ffi_uchar_rget(struct txr_ffi_type *tft, mem_t *src, val self)
{
+ (void) tft;
+ (void) self;
return num_fast((unsigned char) *coerce(ffi_arg *, src));
}
static val ffi_bchar_rget(struct txr_ffi_type *tft, mem_t *src, val self)
{
+ (void) tft;
+ (void) self;
return chr((unsigned char) *coerce(ffi_arg *, src));
}
@@ -1513,12 +2013,15 @@ static void ffi_short_rput(struct txr_ffi_type *tft, val n, mem_t *dst,
val self)
{
short v = c_short(n, self);
+ (void) tft;
*coerce(ffi_arg *, dst) = v;
}
static val ffi_short_rget(struct txr_ffi_type *tft, mem_t *src, val self)
{
short n = *coerce(ffi_arg *, src);
+ (void) tft;
+ (void) self;
return num_fast(n);
}
@@ -1526,60 +2029,76 @@ static void ffi_ushort_rput(struct txr_ffi_type *tft, val n, mem_t *dst,
val self)
{
unsigned short v = c_ushort(n, self);
+ (void) tft;
*coerce(ffi_arg *, dst) = v;
}
static val ffi_ushort_rget(struct txr_ffi_type *tft, mem_t *src, val self)
{
unsigned short n = *coerce(ffi_arg *, src);
+ (void) tft;
+ (void) self;
return num_fast(n);
}
static void ffi_int_rput(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
int v = c_int(n, self);
+ (void) tft;
*coerce(ffi_arg *, dst) = v;
}
static val ffi_int_rget(struct txr_ffi_type *tft, mem_t *src, val self)
{
int n = *coerce(ffi_arg *, src);
+ (void) tft;
+ (void) self;
return num(n);
}
static void ffi_uint_rput(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
unsigned v = c_uint(n, self);
+ (void) tft;
*coerce(ffi_arg *, dst) = v;
}
static val ffi_uint_rget(struct txr_ffi_type *tft, mem_t *src, val self)
{
unsigned n = *coerce(ffi_arg *, src);
+ (void) tft;
+ (void) self;
return unum(n);
}
static void ffi_long_rput(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
long v = c_long(n, self);
+ (void) tft;
+ (void) self;
*coerce(ffi_arg *, dst) = v;
}
static val ffi_long_rget(struct txr_ffi_type *tft, mem_t *src, val self)
{
long n = *coerce(ffi_arg *, src);
+ (void) tft;
+ (void) self;
return num(n);
}
static void ffi_ulong_rput(struct txr_ffi_type *tft, val n, mem_t *dst, val self)
{
unsigned long v = c_ulong(n, self);
+ (void) tft;
*coerce(ffi_arg *, dst) = v;
}
static val ffi_ulong_rget(struct txr_ffi_type *tft, mem_t *src, val self)
{
unsigned long n = *coerce(ffi_arg *, src);
+ (void) tft;
+ (void) self;
return unum(n);
}
@@ -1587,19 +2106,25 @@ static void ffi_wchar_rput(struct txr_ffi_type *tft, val ch, mem_t *dst,
val self)
{
wchar_t c = c_chr(ch);
+ (void) tft;
+ (void) self;
*coerce(ffi_arg *, dst) = c;
}
static val ffi_wchar_rget(struct txr_ffi_type *tft, mem_t *src, val self)
{
wchar_t c = *coerce(ffi_arg *, src);
+ (void) tft;
+ (void) self;
return chr(c);
}
+#if HAVE_I16
+
static void ffi_be_i16_rput(struct txr_ffi_type *tft, val n, mem_t *dst,
val self)
{
- memset(dst, 0, 6);
+ (void) tft;
ffi_be_i16_put(tft, n, dst + 6, self);
}
@@ -1620,6 +2145,10 @@ static val ffi_be_u16_rget(struct txr_ffi_type *tft, mem_t *src, val self)
return ffi_be_u16_get(tft, src + 6, self);
}
+#endif
+
+#if HAVE_I32
+
static void ffi_be_i32_rput(struct txr_ffi_type *tft, val n, mem_t *dst,
val self)
{
@@ -1644,6 +2173,10 @@ static val ffi_be_u32_rget(struct txr_ffi_type *tft, mem_t *src, val self)
return ffi_be_u32_get(tft, src + 4, self);
}
+#endif
+
+#if HAVE_I16
+
static void ffi_le_i16_rput(struct txr_ffi_type *tft, val n, mem_t *dst,
val self)
{
@@ -1668,6 +2201,10 @@ static val ffi_le_u16_rget(struct txr_ffi_type *tft, mem_t *src, val self)
return ffi_le_u16_get(tft, src + 6, self);
}
+#endif
+
+#if HAVE_I32
+
static void ffi_le_i32_rput(struct txr_ffi_type *tft, val n, mem_t *dst,
val self)
{
@@ -1692,6 +2229,8 @@ static val ffi_le_u32_rget(struct txr_ffi_type *tft, mem_t *src, val self)
return ffi_le_u32_get(tft, src + 4, self);
}
+#endif
+
static void ffi_bool_rput(struct txr_ffi_type *tft, val truth,
mem_t *dst, val self)
{
@@ -1709,19 +2248,47 @@ static val ffi_bool_rget(struct txr_ffi_type *tft, mem_t *src, val self)
#endif
-static void ffi_cptr_put(struct txr_ffi_type *tft, val n, mem_t *dst,
+static void ffi_cptr_put(struct txr_ffi_type *tft, val ptr, mem_t *dst,
val self)
{
- mem_t *p = cptr_handle(n, tft->tag, self);
+ mem_t *p = 0;
+
+ if (type(ptr) == CPTR)
+ p = cptr_handle(ptr, tft->tag, self);
+ else
+ p = carray_ptr(ptr, tft->eltype, self);
+
*coerce(mem_t **, dst) = p;
}
static val ffi_cptr_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
mem_t *p = *coerce(mem_t **, src);
+ (void) self;
return cptr_typed(p, tft->tag, 0);
}
+static val ffi_cptr_in(struct txr_ffi_type *tft, int copy, mem_t *src,
+ val ptr, val self)
+{
+ if (ptr) {
+ if (copy) {
+ mem_t *newp = *coerce(mem_t **, src);
+
+ if (type(ptr) == CPTR) {
+ mem_t **addr = cptr_addr_of(ptr, tft->tag, self);
+ *addr = newp;
+ } else {
+ carray_set_ptr(ptr, tft->eltype, newp, self);
+ }
+ }
+ } else {
+ ptr = ffi_cptr_get(tft, src, self);
+ }
+
+ return ptr;
+}
+
static mem_t *ffi_cptr_alloc(struct txr_ffi_type *tft, val ptr, val self)
{
return coerce(mem_t *, cptr_addr_of(ptr, tft->tag, self));
@@ -1731,6 +2298,8 @@ static val ffi_str_in(struct txr_ffi_type *tft, int copy,
mem_t *src, val obj, val self)
{
char **loc = coerce(char **, src);
+ (void) tft;
+ (void) self;
if (copy)
obj = if2(*loc, string_utf8(*loc));
free(*loc);
@@ -1741,10 +2310,12 @@ static val ffi_str_in(struct txr_ffi_type *tft, int copy,
static void ffi_str_put(struct txr_ffi_type *tft, val s, mem_t *dst,
val self)
{
+ (void) tft;
+ (void) self;
if (s == nil) {
*coerce(const char **, dst) = 0;
} else {
- const wchar_t *ws = c_str(s);
+ const wchar_t *ws = c_str(s, self);
char *u8s = utf8_dup_to(ws);
*coerce(const char **, dst) = u8s;
}
@@ -1753,6 +2324,8 @@ static void ffi_str_put(struct txr_ffi_type *tft, val s, mem_t *dst,
static val ffi_str_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
const char *p = *coerce(const char **, src);
+ (void) tft;
+ (void) self;
return p ? string_utf8(p) : nil;
}
@@ -1760,6 +2333,8 @@ static val ffi_str_d_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
char **loc = coerce(char **, src);
val ret = *loc ? string_utf8(*loc) : nil;
+ (void) tft;
+ (void) self;
free(*loc);
*loc = 0;
return ret;
@@ -1769,6 +2344,8 @@ static val ffi_wstr_in(struct txr_ffi_type *tft, int copy,
mem_t *src, val obj, val self)
{
wchar_t **loc = coerce(wchar_t **, src);
+ (void) tft;
+ (void) self;
if (copy)
obj = if2(*loc, string(*loc));
free(*loc);
@@ -1779,16 +2356,20 @@ static val ffi_wstr_in(struct txr_ffi_type *tft, int copy,
static val ffi_wstr_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
const wchar_t *p = *coerce(wchar_t **, src);
+ (void) tft;
+ (void) self;
return p ? string(p) : 0;
}
static void ffi_wstr_put(struct txr_ffi_type *tft, val s, mem_t *dst,
- val self)
+ val self)
{
+ (void) tft;
+ (void) self;
if (s == nil) {
*coerce(const wchar_t **, dst) = 0;
} else {
- const wchar_t *ws = c_str(s);
+ const wchar_t *ws = c_str(s, self);
*coerce(const wchar_t **, dst) = chk_strdup(ws);
}
}
@@ -1797,6 +2378,8 @@ static val ffi_wstr_d_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
wchar_t **loc = coerce(wchar_t **, src);
val ret = *loc ? string_own(*loc) : nil;
+ (void) tft;
+ (void) self;
*loc = 0;
return ret;
}
@@ -1805,6 +2388,8 @@ static val ffi_bstr_in(struct txr_ffi_type *tft, int copy,
mem_t *src, val obj, val self)
{
unsigned char **loc = coerce(unsigned char **, src);
+ (void) tft;
+ (void) self;
if (copy)
obj = if2(*loc, string_8bit(*loc));
free(*loc);
@@ -1815,10 +2400,12 @@ static val ffi_bstr_in(struct txr_ffi_type *tft, int copy,
static void ffi_bstr_put(struct txr_ffi_type *tft, val s, mem_t *dst,
val self)
{
+ (void) tft;
+ (void) self;
if (s == nil) {
*coerce(unsigned char **, dst) = 0;
} else {
- const wchar_t *ws = c_str(s);
+ const wchar_t *ws = c_str(s, self);
unsigned char *u8s = chk_strdup_8bit(ws);
*coerce(unsigned char **, dst) = u8s;
}
@@ -1827,6 +2414,8 @@ static void ffi_bstr_put(struct txr_ffi_type *tft, val s, mem_t *dst,
static val ffi_bstr_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
unsigned char *p = *coerce(unsigned char **, src);
+ (void) tft;
+ (void) self;
return p ? string_8bit(p) : nil;
}
@@ -1834,6 +2423,8 @@ static val ffi_bstr_d_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
unsigned char **loc = coerce(unsigned char **, src);
val ret = *loc ? string_8bit(*loc) : nil;
+ (void) tft;
+ (void) self;
free(*loc);
*loc = 0;
return ret;
@@ -1845,6 +2436,8 @@ static val ffi_buf_in(struct txr_ffi_type *tft, int copy, mem_t *src,
mem_t **loc = coerce(mem_t **, src);
mem_t *origptr = if3(obj, buf_get(obj, self), 0);
+ (void) tft;
+
if (copy && *loc != origptr)
obj = if2(*loc, make_duplicate_buf(length_buf(obj), *loc));
@@ -1854,6 +2447,8 @@ static val ffi_buf_in(struct txr_ffi_type *tft, int copy, mem_t *src,
static void ffi_buf_put(struct txr_ffi_type *tft, val buf, mem_t *dst,
val self)
{
+ (void) tft;
+
if (buf == nil) {
*coerce(const mem_t **, dst) = 0;
} else {
@@ -1865,6 +2460,7 @@ static void ffi_buf_put(struct txr_ffi_type *tft, val buf, mem_t *dst,
static val ffi_buf_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
mem_t *p = *coerce(mem_t **, src);
+ (void) self;
return p ? make_duplicate_buf(num(tft->nelem), p) : nil;
}
@@ -1873,6 +2469,8 @@ static val ffi_buf_d_in(struct txr_ffi_type *tft, int copy, mem_t *src,
{
mem_t **loc = coerce(mem_t **, src);
+ (void) self;
+
if (copy) {
obj = if2(*loc, make_borrowed_buf(num(tft->nelem), *loc));
*loc = 0;
@@ -1884,11 +2482,14 @@ static val ffi_buf_d_in(struct txr_ffi_type *tft, int copy, mem_t *src,
static void ffi_buf_d_put(struct txr_ffi_type *tft, val buf, mem_t *dst,
val self)
{
+ (void) tft;
+ (void) self;
+
if (buf == nil) {
*coerce(const mem_t **, dst) = 0;
} else {
mem_t *b = buf_get(buf, self);
- *coerce(const mem_t **, dst) = chk_copy_obj(b, c_num(length(buf)));
+ *coerce(const mem_t **, dst) = chk_copy_obj(b, c_num(length(buf), self));
}
}
@@ -1896,6 +2497,7 @@ static val ffi_buf_d_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
mem_t **loc = coerce(mem_t **, src);
val ret = *loc ? make_borrowed_buf(num(tft->nelem), *loc) : nil;
+ (void) self;
*loc = 0;
return ret;
}
@@ -1907,12 +2509,14 @@ static void ffi_closure_put(struct txr_ffi_type *tft, val ptr, mem_t *dst,
val type = typeof(ptr);
mem_t *p = 0;
+ (void) tft;
+
if (type == cptr_s) {
p = ptr->co.handle;
} else if (type == ffi_closure_s) {
struct txr_ffi_closure *tfcl = ffi_closure_struct(ptr);
p = tfcl->fptr;
- } else {
+ } else if (ptr != nil) {
uw_throwf(error_s, lit("~a: ~s cannot be used as function pointer"),
self, ptr, nao);
}
@@ -1927,6 +2531,7 @@ static val ffi_ptr_in_in(struct txr_ffi_type *tft, int copy, mem_t *src,
val tgttype = tft->eltype;
struct txr_ffi_type *tgtft = ffi_type_struct(tgttype);
mem_t **loc = coerce(mem_t **, src);
+ (void) copy;
if (!*loc)
return nil;
if (tgtft->in != 0 && tgtft->by_value_in)
@@ -1942,6 +2547,7 @@ static val ffi_ptr_in_d_in(struct txr_ffi_type *tft, int copy, mem_t *src,
val tgttype = tft->eltype;
struct txr_ffi_type *tgtft = ffi_type_struct(tgttype);
mem_t **loc = coerce(mem_t **, src);
+ (void) copy;
if (!*loc)
return nil;
if (tgtft->in != 0 && tgtft->by_value_in)
@@ -1954,6 +2560,7 @@ static void ffi_ptr_in_out(struct txr_ffi_type *tft, int copy, val s,
{
val tgttype = tft->eltype;
struct txr_ffi_type *tgtft = ffi_type_struct(tgttype);
+ (void) copy;
if (tgtft->out != 0) {
mem_t *buf = *coerce(mem_t **, dst);
tgtft->out(tgtft, 0, s, buf, self);
@@ -1966,6 +2573,7 @@ static val ffi_ptr_out_in(struct txr_ffi_type *tft, int copy, mem_t *src,
val tgttype = tft->eltype;
struct txr_ffi_type *tgtft = ffi_type_struct(tgttype);
mem_t **loc = coerce(mem_t **, src);
+ (void) copy;
if (!*loc)
return nil;
if (tgtft->in != 0)
@@ -1996,6 +2604,7 @@ static void ffi_ptr_out_out(struct txr_ffi_type *tft, int copy, val s,
val tgttype = tft->eltype;
struct txr_ffi_type *tgtft = ffi_type_struct(tgttype);
mem_t *buf = *coerce(mem_t **, dst);
+ (void) copy;
if (tgtft->out != 0)
tgtft->out(tgtft, 1, s, buf, self);
else
@@ -2038,6 +2647,9 @@ static void ffi_ptr_in_put(struct txr_ffi_type *tft, val s, mem_t *dst,
static void ffi_ptr_out_null_put(struct txr_ffi_type *tft, val s, mem_t *dst,
val self)
{
+ (void) tft;
+ (void) s;
+ (void) self;
*coerce(mem_t **, dst) = 0;
}
@@ -2047,6 +2659,7 @@ static val ffi_ptr_out_s_in(struct txr_ffi_type *tft, int copy,
val tgttype = tft->eltype;
struct txr_ffi_type *tgtft = ffi_type_struct(tgttype);
mem_t **loc = coerce(mem_t **, src);
+ (void) copy;
if (!*loc)
return nil;
if (tgtft->in != 0)
@@ -2056,29 +2669,47 @@ static val ffi_ptr_out_s_in(struct txr_ffi_type *tft, int copy,
return obj;
}
-static void ffi_ptr_in_release(struct txr_ffi_type *tft, val obj, mem_t *dst)
+static void ffi_ptr_in_release(struct txr_ffi_type *tft, val obj,
+ mem_t *dst, val self)
{
struct txr_ffi_type *tgtft = ffi_type_struct(tft->eltype);
mem_t **loc = coerce(mem_t **, dst);
if (tgtft->release != 0 && *loc != 0)
- tgtft->release(tgtft, obj, *loc);
+ tgtft->release(tgtft, obj, *loc, self);
free(*loc);
*loc = 0;
}
-static val ffi_flex_struct_in(struct txr_ffi_type *tft, val strct, val self)
+static val ffi_flex_array_len(struct smemb *lastm, val strct, val self)
{
- struct smemb *lastm = &tft->memb[tft->nelem - 1];
- val length_meth = get_special_slot(strct, length_m);
+ struct txr_ffi_type *lmtft = lastm->mtft;
+ (void) self;
- if (length_meth) {
- val len = funcall1(length_meth, strct);
- val memb = slot(strct, lastm->mname);
- if (vectorp(memb))
- return vec_set_length(memb, len);
- else
- return slotset(strct, lastm->mname, vector(len, nil));
+ if (lmtft->kind == FFI_KIND_ARRAY && !lmtft->null_term) {
+ val length_meth = get_special_slot(strct, length_m);
+
+ if (length_meth) {
+ val len = funcall1(length_meth, strct);
+
+ switch (lmtft->ch_conv) {
+ case conv_char:
+ case conv_zchar:
+ case conv_wchar:
+ case conv_bchar:
+ slotset(strct, lastm->mname, len);
+ break;
+ case conv_none:
+ {
+ val memb = slot(strct, lastm->mname);
+ if (memb)
+ return vec_set_length(memb, len);
+ else
+ return slotset(strct, lastm->mname, vector(len, nil));
+ }
+ break;
+ }
+ }
}
return slot(strct, lastm->mname);
@@ -2095,7 +2726,7 @@ static val ffi_struct_in(struct txr_ffi_type *tft, int copy, mem_t *src,
return strct;
if (strct == nil) {
- args_decl(args, 0);
+ args_decl_constsize(args, ARGS_ABS_MIN);
strct = make_struct(tft->lt, nil, args);
}
@@ -2105,7 +2736,7 @@ static val ffi_struct_in(struct txr_ffi_type *tft, int copy, mem_t *src,
ucnum offs = memb[i].offs;
if (slsym) {
if (flexp && copy && i == nmemb - 1)
- ffi_flex_struct_in(tft, strct, self);
+ ffi_flex_array_len(&memb[i], strct, self);
if (mtft->in != 0) {
val slval = slot(strct, slsym);
slotset(strct, slsym, mtft->in(mtft, copy, src + offs, slval, self));
@@ -2162,7 +2793,7 @@ static val ffi_struct_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
cnum i, nmemb = tft->nelem;
struct smemb *memb = tft->memb;
- args_decl(args, 0);
+ args_decl_constsize(args, ARGS_ABS_MIN);
val strct = make_struct(tft->lt, nil, args);
int flexp = tft->flexible;
@@ -2172,7 +2803,7 @@ static val ffi_struct_get(struct txr_ffi_type *tft, mem_t *src, val self)
ucnum offs = memb[i].offs;
if (slsym) {
if (flexp && i == nmemb - 1) {
- val slval = ffi_flex_struct_in(tft, strct, self);
+ val slval = ffi_flex_array_len(&memb[i], strct, self);
if (mtft->in != 0)
slotset(strct, slsym, mtft->in(mtft, 1, src + offs, slval, self));
} else {
@@ -2185,7 +2816,8 @@ static val ffi_struct_get(struct txr_ffi_type *tft, mem_t *src, val self)
return strct;
}
-static void ffi_struct_release(struct txr_ffi_type *tft, val strct, mem_t *dst)
+static void ffi_struct_release(struct txr_ffi_type *tft, val strct,
+ mem_t *dst, val self)
{
cnum i, nmemb = tft->nelem;
struct smemb *memb = tft->memb;
@@ -2200,7 +2832,7 @@ static void ffi_struct_release(struct txr_ffi_type *tft, val strct, mem_t *dst)
if (slsym) {
if (mtft->release != 0) {
val slval = slot(strct, slsym);
- mtft->release(mtft, slval, dst + offs);
+ mtft->release(mtft, slval, dst + offs, self);
}
}
}
@@ -2209,24 +2841,22 @@ static void ffi_struct_release(struct txr_ffi_type *tft, val strct, mem_t *dst)
static val ffi_char_array_get(struct txr_ffi_type *tft, mem_t *src,
cnum nelem)
{
- if (nelem == 0) {
+ const char *chptr = coerce(const char *, src);
+ if (tft->null_term) {
+ return string_utf8(chptr);
+ } else if (nelem == 0) {
return null_string;
} else {
- const char *chptr = coerce(const char *, src);
- if (tft->null_term) {
- return string_utf8(chptr);
- } else {
- wchar_t *wch = utf8_dup_from_buf(chptr, nelem);
- return string_own(wch);
- }
+ wchar_t *wch = utf8_dup_from_buf(chptr, nelem);
+ return string_own(wch);
}
}
static void ffi_char_array_put(struct txr_ffi_type *tft, val str, mem_t *dst,
- cnum nelem)
+ cnum nelem, val self)
{
int nt = tft->null_term;
- const wchar_t *wstr = c_str(str);
+ const wchar_t *wstr = c_str(str, self);
cnum needed = utf8_to_buf(0, wstr, nt);
if (needed <= nelem) {
@@ -2245,43 +2875,37 @@ static void ffi_char_array_put(struct txr_ffi_type *tft, val str, mem_t *dst,
static val ffi_zchar_array_get(struct txr_ffi_type *tft, mem_t *src,
cnum nelem)
{
- if (nelem == 0) {
+ const char *chptr = coerce(const char *, src);
+ if (tft->null_term) {
+ return string_utf8(chptr);
+ } else if (nelem == 0) {
return null_string;
+ } else if (memchr(chptr, 0, nelem)) {
+ return string_utf8(chptr);
} else {
- const char *chptr = coerce(const char *, src);
- if (tft->null_term) {
- return string_utf8(chptr);
- } else if (memchr(chptr, 0, nelem)) {
- return string_utf8(chptr);
- } else {
- wchar_t *wch = utf8_dup_from_buf(chptr, nelem);
- return string_own(wch);
- }
+ wchar_t *wch = utf8_dup_from_buf(chptr, nelem);
+ return string_own(wch);
}
}
-
static val ffi_wchar_array_get(struct txr_ffi_type *tft, mem_t *src,
- cnum nelem)
+ cnum nelem, val self)
{
- if (nelem == 0) {
+ const wchar_t *wchptr = coerce(const wchar_t *, src);
+ if (tft->null_term) {
+ return string(wchptr);
+ } else if (nelem == 0) {
return null_string;
} else {
- const wchar_t *wchptr = coerce(const wchar_t *, src);
-
- if (tft->null_term) {
- return string(wchptr);
- } else {
- val ustr = mkustring(num_fast(nelem));
- return init_str(ustr, wchptr);
- }
+ val ustr = mkustring(num_fast(nelem));
+ return init_str(ustr, wchptr, self);
}
}
static void ffi_wchar_array_put(struct txr_ffi_type *tft, val str, mem_t *dst,
- cnum nelem)
+ cnum nelem, val self)
{
- const wchar_t *wstr = c_str(str);
+ const wchar_t *wstr = c_str(str, self);
wcsncpy(coerce(wchar_t *, dst), wstr, nelem);
if (tft->null_term)
dst[nelem - 1] = 0;
@@ -2290,21 +2914,19 @@ static void ffi_wchar_array_put(struct txr_ffi_type *tft, val str, mem_t *dst,
static val ffi_bchar_array_get(struct txr_ffi_type *tft, mem_t *src,
cnum nelem)
{
- if (nelem == 0) {
+ const unsigned char *chptr = coerce(const unsigned char *, src);
+ if (tft->null_term)
+ return string_8bit(chptr);
+ else if (nelem == 0)
return null_string;
- } else {
- const unsigned char *chptr = coerce(const unsigned char *, src);
- if (tft->null_term)
- return string_8bit(chptr);
- else
- return string_8bit_size(chptr, nelem);
- }
+ else
+ return string_8bit_size(chptr, nelem);
}
static void ffi_bchar_array_put(struct txr_ffi_type *tft, val str, mem_t *dst,
cnum nelem, val self)
{
- const wchar_t *wstr = c_str(str);
+ const wchar_t *wstr = c_str(str, self);
cnum i;
for (i = 0; i < nelem && wstr[i]; i++) {
@@ -2370,7 +2992,7 @@ static val ffi_array_in(struct txr_ffi_type *tft, int copy, mem_t *src,
}
case conv_wchar:
{
- val str = ffi_wchar_array_get(tft, src, tft->nelem);
+ val str = ffi_wchar_array_get(tft, src, tft->nelem, self);
return if3(vec, replace(vec, str, zero, t), str);
}
case conv_bchar:
@@ -2412,7 +3034,7 @@ static void ffi_array_put_common(struct txr_ffi_type *tft, val vec, mem_t *dst,
case SEQ_VECLIKE:
{
val v = si.obj;
- cnum lim = min(nelem - nt, c_num(length(si.obj)));
+ cnum lim = min(nelem - nt, c_num(length(si.obj), self));
for (; i < lim; i++) {
val elval = ref(v, num_fast(i));
@@ -2437,10 +3059,10 @@ static void ffi_array_put(struct txr_ffi_type *tft, val vec, mem_t *dst,
switch (tft->ch_conv) {
case conv_char:
case conv_zchar:
- ffi_char_array_put(tft, vec, dst, tft->nelem);
+ ffi_char_array_put(tft, vec, dst, tft->nelem, self);
break;
case conv_wchar:
- ffi_wchar_array_put(tft, vec, dst, tft->nelem);
+ ffi_wchar_array_put(tft, vec, dst, tft->nelem, self);
break;
case conv_bchar:
ffi_bchar_array_put(tft, vec, dst, tft->nelem, self);
@@ -2487,10 +3109,10 @@ static void ffi_array_out(struct txr_ffi_type *tft, int copy, val vec,
switch (tft->ch_conv) {
case conv_char:
case conv_zchar:
- ffi_char_array_put(tft, vec, dst, tft->nelem);
+ ffi_char_array_put(tft, vec, dst, tft->nelem, self);
break;
case conv_wchar:
- ffi_wchar_array_put(tft, vec, dst, tft->nelem);
+ ffi_wchar_array_put(tft, vec, dst, tft->nelem, self);
break;
case conv_bchar:
ffi_bchar_array_put(tft, vec, dst, tft->nelem, self);
@@ -2515,7 +3137,7 @@ static val ffi_array_get_common(struct txr_ffi_type *tft, mem_t *src, val self,
case conv_zchar:
return ffi_zchar_array_get(tft, src, nelem);
case conv_wchar:
- return ffi_wchar_array_get(tft, src, nelem);
+ return ffi_wchar_array_get(tft, src, nelem, self);
case conv_bchar:
return ffi_bchar_array_get(tft, src, nelem);
case conv_none:
@@ -2547,7 +3169,7 @@ static val ffi_array_get(struct txr_ffi_type *tft, mem_t *src, val self)
}
static void ffi_array_release_common(struct txr_ffi_type *tft, val vec,
- mem_t *dst, cnum nelem)
+ mem_t *dst, cnum nelem, val self)
{
val eltype = tft->eltype;
ucnum offs = 0;
@@ -2565,15 +3187,16 @@ static void ffi_array_release_common(struct txr_ffi_type *tft, val vec,
for (i = 0; i < znelem; i++) {
if (etft->release != 0) {
val elval = ref(vec, num_fast(i));
- etft->release(etft, elval, dst + offs);
+ etft->release(etft, elval, dst + offs, self);
}
offs += elsize;
}
}
-static void ffi_array_release(struct txr_ffi_type *tft, val vec, mem_t *dst)
+static void ffi_array_release(struct txr_ffi_type *tft, val vec,
+ mem_t *dst, val self)
{
- ffi_array_release_common(tft, vec, dst, tft->nelem);
+ ffi_array_release_common(tft, vec, dst, tft->nelem, self);
}
static void ffi_varray_put(struct txr_ffi_type *tft, val vec, mem_t *dst,
@@ -2586,10 +3209,10 @@ static void ffi_varray_put(struct txr_ffi_type *tft, val vec, mem_t *dst,
switch (tft->ch_conv) {
case conv_char:
case conv_zchar:
- ffi_char_array_put(tft, vec, dst, nelem);
+ ffi_char_array_put(tft, vec, dst, nelem, self);
break;
case conv_wchar:
- ffi_wchar_array_put(tft, vec, dst, nelem);
+ ffi_wchar_array_put(tft, vec, dst, nelem, self);
break;
case conv_bchar:
ffi_bchar_array_put(tft, vec, dst, nelem, self);
@@ -2606,9 +3229,16 @@ static void ffi_varray_put(struct txr_ffi_type *tft, val vec, mem_t *dst,
static val ffi_varray_in(struct txr_ffi_type *tft, int copy, mem_t *src,
val vec, val self)
{
- if (copy && vec) {
+ if (copy) {
struct txr_ffi_type *etft = ffi_type_struct(tft->eltype);
- cnum nelem = ffi_varray_dynsize(tft, vec, self) / etft->size;
+ cnum nelem = 0;
+
+ if (vectorp(vec)) {
+ nelem = ffi_varray_dynsize(tft, vec, self) / etft->size;
+ } else if (numberp(vec)) {
+ nelem = c_num(vec, self);
+ vec = nil;
+ }
switch (tft->ch_conv) {
case conv_char:
@@ -2623,7 +3253,7 @@ static val ffi_varray_in(struct txr_ffi_type *tft, int copy, mem_t *src,
}
case conv_wchar:
{
- val str = ffi_wchar_array_get(tft, src, nelem);
+ val str = ffi_wchar_array_get(tft, src, nelem, self);
return if3(vec, replace(vec, str, zero, t), str);
}
case conv_bchar:
@@ -2651,7 +3281,7 @@ static val ffi_varray_null_term_in(struct txr_ffi_type *tft, int copy, mem_t *sr
struct txr_ffi_type *etft = ffi_type_struct(eltype);
cnum elsize = etft->size;
cnum offs, i;
- cnum nelem_orig = c_num(length(vec_in));
+ cnum nelem_orig = c_num(length(vec_in), self);
for (i = 0, offs = 0; ; i++) {
mem_t *el = src + offs, *p;
@@ -2689,9 +3319,9 @@ static val ffi_varray_null_term_get(struct txr_ffi_type *tft, mem_t *src,
val vec = vector(zero, nil);
struct txr_ffi_type *etft = ffi_type_struct(eltype);
cnum elsize = etft->size;
- cnum offs, i;
+ cnum offs = 0;
- for (i = 0, offs = 0; ; i++) {
+ for (;;) {
mem_t *el = src + offs, *p;
for (p = el; p < el + elsize; p++)
@@ -2712,18 +3342,35 @@ static val ffi_varray_null_term_get(struct txr_ffi_type *tft, mem_t *src,
}
}
-static void ffi_varray_release(struct txr_ffi_type *tft, val vec, mem_t *dst)
+static void ffi_varray_release(struct txr_ffi_type *tft, val vec,
+ mem_t *dst, val self)
{
- cnum nelem = c_num(length(vec)) + tft->null_term;
- ffi_array_release_common(tft, vec, dst, nelem);
+ cnum nelem = c_num(length(vec), self) + tft->null_term;
+ ffi_array_release_common(tft, vec, dst, nelem, self);
}
static val ffi_carray_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
mem_t *p = *coerce(mem_t **, src);
+ (void) self;
return make_carray(tft->eltype, p, -1, nil, 0);
}
+static val ffi_carray_in(struct txr_ffi_type *tft, int copy, mem_t *src,
+ val carray, val self)
+{
+ if (carray) {
+ if (copy) {
+ mem_t *p = *coerce(mem_t **, src);
+ carray_set_ptr(carray, tft->eltype, p, self);
+ }
+ } else {
+ carray = ffi_carray_get(tft, src, self);
+ }
+
+ return carray;
+}
+
static void ffi_carray_put(struct txr_ffi_type *tft, val carray, mem_t *dst,
val self)
{
@@ -2822,9 +3469,28 @@ static void ffi_union_put(struct txr_ffi_type *tft, val uni,
static val ffi_union_get(struct txr_ffi_type *tft, mem_t *src, val self)
{
+ (void) self;
return make_union_tft(src, tft);
}
+static val ffi_type_copy(val orig)
+{
+ struct txr_ffi_type *otft = ffi_type_struct(orig);
+ struct txr_ffi_type *ctft = otft->clone(otft);
+ val obj = cobj(coerce(mem_t *, ctft), orig->co.cls, orig->co.ops);
+ ctft->self = obj;
+ return obj;
+}
+
+static val ffi_type_copy_new_ops(val orig, struct cobj_ops *ops)
+{
+ struct txr_ffi_type *otft = ffi_type_struct(orig);
+ struct txr_ffi_type *ctft = otft->clone(otft);
+ val obj = cobj(coerce(mem_t *, ctft), orig->co.cls, ops);
+ ctft->self = obj;
+ return obj;
+}
+
static struct txr_ffi_type *ffi_simple_clone(struct txr_ffi_type *orig)
{
return coerce(struct txr_ffi_type *, chk_copy_obj(coerce(mem_t *, orig),
@@ -2845,7 +3511,7 @@ static val make_ffi_type_builtin(val syntax, val lisp_type, ffi_kind_t kind,
struct txr_ffi_type *tft = coerce(struct txr_ffi_type *,
chk_calloc(1, sizeof *tft));
- val obj = cobj(coerce(mem_t *, tft), ffi_type_s, &ffi_type_builtin_ops);
+ val obj = cobj(coerce(mem_t *, tft), ffi_type_cls, &ffi_type_builtin_ops);
tft->self = obj;
tft->kind = kind;
@@ -2863,11 +3529,34 @@ static val make_ffi_type_builtin(val syntax, val lisp_type, ffi_kind_t kind,
#if !HAVE_LITTLE_ENDIAN
tft->rput = (rput ? rput : put);
tft->rget = (rget ? rget : get);
+ tft->bigendian = 1;
+#else
+ (void) rput;
+ (void) rget;
#endif
return obj;
}
+static val make_ffi_type_endian(val syntax, val lisp_type, ffi_kind_t kind,
+ cnum size, cnum align, ffi_type *ft,
+ void (*put)(struct txr_ffi_type *,
+ val obj, mem_t *dst, val self),
+ val (*get)(struct txr_ffi_type *,
+ mem_t *src, val self),
+ void (*rput)(struct txr_ffi_type *,
+ val obj, mem_t *dst, val self),
+ val (*rget)(struct txr_ffi_type *,
+ mem_t *src, val self),
+ int bigendian)
+{
+ val type = make_ffi_type_builtin(syntax, lisp_type, kind, size, align, ft,
+ put, get, rput, rget);
+ struct txr_ffi_type *tft = ffi_type_struct(type);
+ tft->bigendian = bigendian;
+ return type;
+}
+
static val make_ffi_type_pointer(val syntax, val lisp_type,
void (*put)(struct txr_ffi_type *, val obj,
mem_t *dst, val self),
@@ -2878,7 +3567,7 @@ static val make_ffi_type_pointer(val syntax, val lisp_type,
void (*out)(struct txr_ffi_type *, int copy,
val obj, mem_t *dst, val self),
void (*release)(struct txr_ffi_type *,
- val obj, mem_t *dst),
+ val obj, mem_t *dst, val self),
val tgtype)
{
val self = lit("ffi-type-compile");
@@ -2891,7 +3580,7 @@ static val make_ffi_type_pointer(val syntax, val lisp_type,
struct txr_ffi_type *tft = coerce(struct txr_ffi_type *,
chk_calloc(1, sizeof *tft));
- val obj = cobj(coerce(mem_t *, tft), ffi_type_s, &ffi_type_ptr_ops);
+ val obj = cobj(coerce(mem_t *, tft), ffi_type_cls, &ffi_type_ptr_ops);
tft->self = obj;
tft->kind = FFI_KIND_PTR;
@@ -2914,7 +3603,7 @@ static val make_ffi_type_pointer(val syntax, val lisp_type,
tft->alloc = ffi_fixed_alloc;
tft->dynsize = ffi_fixed_dynsize;
tft->free = free;
- tft->by_value_in = 1;
+ tft->by_value_in = (in != 0);
return obj;
}
@@ -2925,13 +3614,7 @@ static struct txr_ffi_type *ffi_struct_clone(struct txr_ffi_type *orig)
cnum nmemb = orig->nelem;
struct txr_ffi_type *copy = ffi_simple_clone(orig);
size_t memb_size = sizeof *orig->memb * nmemb;
- ffi_type *ft = coerce(ffi_type *, chk_copy_obj(coerce(mem_t *, orig->ft),
- sizeof *orig->ft));
- copy->ft = ft;
-#if HAVE_LIBFFI
- ft->elements = copy->elements;
-#endif
copy->memb = coerce(struct smemb *, chk_copy_obj(coerce(mem_t *,
orig->memb),
memb_size));
@@ -2962,45 +3645,136 @@ static val ffi_memb_compile(val syntax, int last, int *pflexp, val self)
return comp_type;
}
+#if HAVE_LIBFFI
+
+static void ffi_struct_calcft(struct txr_ffi_type *tft)
+{
+ cnum nmemb = tft->nelem;
+ ffi_type *ft = coerce(ffi_type *, chk_calloc(1, sizeof *ft));
+ ffi_type **elem = coerce(ffi_type **, chk_calloc(nmemb + 1, sizeof *elem));
+ cnum i, e, po;
+
+ tft->ft = ft;
+ tft->elements = elem;
+
+ ft->type = FFI_TYPE_STRUCT;
+ ft->size = tft->size;
+ ft->alignment = tft->align;
+ ft->elements = tft->elements;
+
+ for (i = e = po = 0; i < nmemb; i++)
+ {
+ struct smemb *memb = &tft->memb[i];
+ struct txr_ffi_type *mtft = memb->mtft;
+
+ if (memb->offs != po) {
+ po = memb->offs;
+ if (mtft->calcft)
+ mtft->calcft(mtft);
+ elem[e++] = mtft->ft;
+ }
+ }
+}
+
+static void ffi_union_calcft(struct txr_ffi_type *tft)
+{
+ cnum nmemb = tft->nelem;
+ ffi_type *ft = coerce(ffi_type *, chk_calloc(1, sizeof *ft));
+ cnum i, e, po;
+ struct txr_ffi_type *most_aligned = 0;
+
+ for (i = e = po = 0; i < nmemb; i++)
+ {
+ struct smemb *memb = &tft->memb[i];
+ struct txr_ffi_type *mtft = memb->mtft;
+
+ if (most_aligned == 0 || mtft->align > most_aligned->align)
+ most_aligned = mtft;
+ }
+
+ {
+ ucnum units = tft->size / most_aligned->size, u;
+ ffi_type **elem = coerce(ffi_type **, chk_calloc(units + 1, sizeof *elem));
+ for (u = 0; u < units; u++)
+ elem[i] = most_aligned->ft;
+ tft->elements = elem;
+ }
+
+ tft->ft = ft;
+ ft->type = FFI_TYPE_STRUCT;
+ ft->size = tft->size;
+ ft->alignment = tft->align;
+ ft->elements = tft->elements;
+}
+
+static void ffi_array_calcft(struct txr_ffi_type *tft)
+{
+ cnum nmemb = tft->nelem;
+ ffi_type *ft = coerce(ffi_type *, chk_calloc(1, sizeof *ft));
+ ffi_type **elem = coerce(ffi_type **, chk_calloc(nmemb + 1, sizeof *elem));
+ struct txr_ffi_type *etft = ffi_type_struct(tft->eltype);
+ cnum i;
+
+ tft->ft = ft;
+ tft->elements = elem;
+
+ ft->type = FFI_TYPE_STRUCT;
+ ft->size = tft->size;
+ ft->alignment = tft->align;
+ ft->elements = tft->elements;
+
+ for (i = 0; i < nmemb; i++)
+ elem[i] = etft->ft;
+}
+
+#endif
+
static val make_ffi_type_struct(val syntax, val lisp_type,
val use_existing, val self)
{
+ val slot_exprs = cddr(syntax);
+ cnum nmemb = c_num(length(slot_exprs), self), i;
struct txr_ffi_type *tft = if3(use_existing,
ffi_type_struct(use_existing),
coerce(struct txr_ffi_type *,
chk_calloc(1, sizeof *tft)));
- ffi_type *ft = if3(use_existing,
- tft->ft,
- coerce(ffi_type *, chk_calloc(1, sizeof *ft)));
int flexp = 0;
- val slot_exprs = cddr(syntax);
- cnum nmemb = c_num(length(slot_exprs)), i;
struct smemb *memb = coerce(struct smemb *,
chk_calloc(nmemb, sizeof *memb));
val obj = if3(use_existing,
tft->self,
- cobj(coerce(mem_t *, tft), ffi_type_s, &ffi_type_struct_ops));
+ cobj(coerce(mem_t *, tft), ffi_type_cls, &ffi_type_struct_ops));
ucnum offs = 0;
- ucnum most_align = 0;
+ ucnum most_align = 1;
+ unsigned prev_bigendian = 0;
int need_out_handler = 0;
int bit_offs = 0;
const unsigned bits_int = 8 * sizeof(int);
+#if HAVE_I64
+ const unsigned bits_llint = 8 * sizeof(u64_t);
+#endif
if (use_existing) {
if (tft->nelem != 0) {
free(memb);
return make_ffi_type_struct(syntax, lisp_type, nil, self);
}
+#if HAVE_LIBFFI
+ free(tft->ft);
+ free(tft->elements);
+#endif
free(tft->memb);
memset(tft, 0, sizeof *tft);
}
tft->self = obj;
tft->kind = FFI_KIND_STRUCT;
- tft->ft = ft;
tft->syntax = syntax;
tft->lt = lisp_type;
tft->clone = ffi_struct_clone;
+#if HAVE_LIBFFI
+ tft->calcft = ffi_struct_calcft;
+#endif
tft->put = ffi_struct_put;
tft->get = ffi_struct_get;
#if !HAVE_LITTLE_ENDIAN
@@ -3012,7 +3786,6 @@ static val make_ffi_type_struct(val syntax, val lisp_type,
tft->alloc = ffi_fixed_alloc;
tft->dynsize = ffi_fixed_dynsize;
tft->free = free;
- tft->memb = memb;
tft->incomplete = 1;
@@ -3021,12 +3794,16 @@ static val make_ffi_type_struct(val syntax, val lisp_type,
sethash(ffi_struct_tag_hash, cadr(syntax), obj);
+ tft->memb = memb;
+
for (i = 0; i < nmemb; i++) {
val slot_syntax = pop(&slot_exprs);
val slot = car(slot_syntax);
val type = ffi_memb_compile(slot_syntax, i == nmemb - 1, &flexp, self);
struct txr_ffi_type *mtft = ffi_type_struct(type);
- cnum size = mtft->size;
+ ucnum size = mtft->size;
+ ucnum align = mtft->align;
+ ucnum almask = align - 1;
tft->nelem = i + 1;
@@ -3037,18 +3814,28 @@ static val make_ffi_type_struct(val syntax, val lisp_type,
setcheck(obj, slot);
setcheck(obj, type);
+ if (!mtft->bitfield || mtft->aligned || mtft->bigendian != prev_bigendian)
+ {
+ bug_unless (bit_offs < 8);
+ if (bit_offs)
+ offs++;
+ offs = (offs + almask) & ~almask;
+ bit_offs = 0;
+ }
+
if (mtft->bitfield) {
- ucnum size = mtft->size;
ucnum bits_type = 8 * size;
ucnum bits = mtft->nelem;
- ucnum offs_mask = size - 1;
- ucnum align_mask = ~offs_mask;
- ucnum unit_offs = offs & align_mask;
+ ucnum unit_offs = offs & ~almask;
ucnum bits_alloc = 8 * (offs - unit_offs) + bit_offs;
ucnum room = bits_type - bits_alloc;
+ bug_unless (bits_type >= bits_alloc);
+
if (bits == 0) {
- if (offs != unit_offs)
+ ucnum szmask = size - 1;
+ ucnum unit_offs = offs & ~szmask;
+ if (offs != unit_offs || bit_offs > 0)
offs = unit_offs + size;
bit_offs = 0;
nmemb--, i--;
@@ -3056,40 +3843,47 @@ static val make_ffi_type_struct(val syntax, val lisp_type,
}
if (bits > room) {
- offs = unit_offs + size;
+ offs = unit_offs + align;
bit_offs = bits_alloc = 0;
}
- if (bits_alloc == 0) {
- if (most_align < (ucnum) mtft->align)
- most_align = mtft->align;
- }
-
memb[i].offs = offs;
-#if HAVE_LITTLE_ENDIAN
- mtft->shift = bit_offs;
-#else
- mtft->shift = bits_int - bit_offs - bits;
+ if (!mtft->bigendian)
+ mtft->shift = bit_offs;
+#if HAVE_I64
+ else if (size > (sizeof (int)))
+ mtft->shift = bits_llint - bit_offs - bits;
#endif
- if (bits == bits_int)
- mtft->mask = UINT_MAX;
else
- mtft->mask = ((1U << bits) - 1) << mtft->shift;
+ mtft->shift = bits_int - bit_offs - bits;
+
+#if HAVE_I64
+ if (size > sizeof (int)) {
+ if (bits == bits_llint)
+ mtft->m.fmask = convert(u64_t, -1);
+ else
+ mtft->m.fmask = ((convert(u64_t, 1) << bits) - 1) << mtft->shift;
+ } else
+#endif
+ {
+ if (bits == bits_int)
+ mtft->m.mask = UINT_MAX;
+ else
+ mtft->m.mask = ((1U << bits) - 1) << mtft->shift;
+ }
+
bit_offs += bits;
offs += bit_offs / 8;
bit_offs %= 8;
- } else {
- ucnum align = mtft->align;
- ucnum almask = align - 1;
- if (bit_offs > 0) {
- bug_unless (bit_offs < 8);
- offs++;
- bit_offs = 0;
+ if (slot) {
+ if (align > most_align)
+ most_align = align;
+ if (convert(ucnum, mtft->oalign) > most_align)
+ most_align = mtft->oalign;
}
-
- offs = (offs + almask) & ~almask;
+ } else {
memb[i].offs = offs;
offs += size;
@@ -3097,6 +3891,8 @@ static val make_ffi_type_struct(val syntax, val lisp_type,
most_align = align;
}
+ prev_bigendian = mtft->bigendian;
+
need_out_handler = need_out_handler || mtft->out != 0;
if (mtft->by_value_in)
@@ -3124,13 +3920,6 @@ static val make_ffi_type_struct(val syntax, val lisp_type,
tft->align = most_align;
-#if HAVE_LIBFFI
- ft->type = FFI_TYPE_STRUCT;
- ft->size = tft->size;
- ft->alignment = tft->align;
- ft->elements = tft->elements;
-#endif
-
return obj;
}
@@ -3140,37 +3929,43 @@ static val make_ffi_type_union(val syntax, val use_existing, val self)
ffi_type_struct(use_existing),
coerce(struct txr_ffi_type *,
chk_calloc(1, sizeof *tft)));
- ffi_type *ft = if3(use_existing,
- tft->ft,
- coerce(ffi_type *, chk_calloc(1, sizeof *ft)));
int flexp = 0;
val slot_exprs = cddr(syntax);
- cnum nmemb = c_num(length(slot_exprs)), i;
+ cnum nmemb = c_num(length(slot_exprs), self), i;
struct smemb *memb = coerce(struct smemb *,
chk_calloc(nmemb, sizeof *memb));
val obj = if3(use_existing,
tft->self,
- cobj(coerce(mem_t *, tft), ffi_type_s, &ffi_type_struct_ops));
- ucnum most_align = 0;
+ cobj(coerce(mem_t *, tft), ffi_type_cls, &ffi_type_struct_ops));
+ ucnum most_align = 1;
ucnum biggest_size = 0;
const unsigned bits_int = 8 * sizeof(int);
+#if HAVE_I64
+ const unsigned bits_llint = 8 * sizeof(u64_t);
+#endif
if (use_existing) {
if (tft->nelem != 0) {
free(memb);
return make_ffi_type_union(syntax, nil, self);
}
+#if HAVE_LIBFFI
+ free(tft->ft);
+ free(tft->elements);
+#endif
free(tft->memb);
memset(tft, 0, sizeof *tft);
}
tft->self = obj;
tft->kind = FFI_KIND_UNION;
- tft->ft = ft;
tft->syntax = syntax;
tft->lt = union_s;
tft->nelem = nmemb;
tft->clone = ffi_struct_clone;
+#if HAVE_LIBFFI
+ tft->calcft = ffi_union_calcft;
+#endif
tft->put = ffi_union_put;
tft->get = ffi_union_get;
#if !HAVE_LITTLE_ENDIAN
@@ -3181,7 +3976,6 @@ static val make_ffi_type_union(val syntax, val use_existing, val self)
tft->alloc = ffi_fixed_alloc;
tft->dynsize = ffi_fixed_dynsize;
tft->free = free;
- tft->memb = memb;
tft->incomplete = 1;
@@ -3203,84 +3997,88 @@ static val make_ffi_type_union(val syntax, val use_existing, val self)
setcheck(obj, slot);
setcheck(obj, type);
- if (most_align < (ucnum) mtft->align)
- most_align = mtft->align;
-
- if (biggest_size < (ucnum) mtft->size)
- biggest_size = mtft->size;
-
if (mtft->bitfield) {
ucnum bits = mtft->nelem;
+ ucnum size = (bits + 7) / 8;
+ ucnum align = if3(slot, mtft->align, 1);
if (bits == 0) {
nmemb--, i--;
continue;
}
-#if HAVE_LITTLE_ENDIAN
- mtft->shift = 0;
-#else
- mtft->shift = bits_int - bits;
+ if (!mtft->bigendian)
+ mtft->shift = 0;
+#if HAVE_I64
+ else if (size > (sizeof (int)))
+ mtft->shift = bits_llint - bits;
#endif
- if (bits == bits_int)
- mtft->mask = UINT_MAX;
else
- mtft->mask = ((1U << bits) - 1) << mtft->shift;
+ mtft->shift = bits_int - bits;
+
+#if HAVE_I64
+ if (mtft->size > convert(int, sizeof (int))) {
+ if (bits == bits_llint)
+ mtft->m.fmask = convert(u64_t, -1);
+ else
+ mtft->m.fmask = ((convert(u64_t, 1) << bits) - 1) << mtft->shift;
+ } else
+#endif
+ {
+ if (bits == bits_int)
+ mtft->m.mask = UINT_MAX;
+ else
+ mtft->m.mask = ((1U << bits) - 1) << mtft->shift;
+ }
+
+ if (most_align < align)
+ most_align = align;
+ if (biggest_size < size)
+ biggest_size = size;
+ } else {
+ if (most_align < convert(ucnum, mtft->align))
+ most_align = mtft->align;
+ if (biggest_size < convert(ucnum, mtft->size))
+ biggest_size = mtft->size;
}
}
+ tft->memb = memb;
+
if (flexp)
uw_throwf(error_s,
lit("~a: unions cannot contain incomplete member"),
self, nao);
-
+ tft->incomplete = (nmemb == 0);
tft->nelem = i;
- tft->size = biggest_size;
+ tft->size = (biggest_size + most_align - 1) & ~(most_align - 1);
tft->align = most_align;
-#if HAVE_LIBFFI
- ft->type = FFI_TYPE_STRUCT;
- ft->size = tft->size;
- ft->alignment = tft->align;
- ft->elements = tft->elements;
-#endif
-
return obj;
}
-
-static struct txr_ffi_type *ffi_array_clone(struct txr_ffi_type *orig)
-{
- struct txr_ffi_type *copy = ffi_simple_clone(orig);
- ffi_type *ft = coerce(ffi_type *, chk_copy_obj(coerce(mem_t *, orig->ft),
- sizeof *orig->ft));
-
- copy->ft = ft;
-#if HAVE_LIBFFI
- ft->elements = copy->elements;
-#endif
- return copy;
-}
-
static val make_ffi_type_array(val syntax, val lisp_type,
val dim, val eltype, val self)
{
struct txr_ffi_type *tft = coerce(struct txr_ffi_type *,
chk_calloc(1, sizeof *tft));
- ffi_type *ft = coerce(ffi_type *, chk_calloc(1, sizeof *ft));
- cnum nelem = c_num(dim);
- val obj = cobj(coerce(mem_t *, tft), ffi_type_s, &ffi_type_struct_ops);
+ cnum nelem = c_num(dim, self);
+ val obj = cobj(coerce(mem_t *, tft), ffi_type_cls, &ffi_type_struct_ops);
struct txr_ffi_type *etft = ffi_type_struct(eltype);
+ (void) self;
+
tft->self = obj;
tft->kind = FFI_KIND_ARRAY;
- tft->ft = ft;
tft->syntax = syntax;
tft->lt = lisp_type;
tft->eltype = eltype;
- tft->clone = ffi_array_clone;
+ tft->clone = ffi_simple_clone;
+#if HAVE_LIBFFI
+ tft->calcft = ffi_array_calcft;
+#endif
tft->put = ffi_array_put;
tft->get = ffi_array_get;
#if !HAVE_LITTLE_ENDIAN
@@ -3299,13 +4097,6 @@ static val make_ffi_type_array(val syntax, val lisp_type,
tft->out = ffi_array_out;
tft->nelem = nelem;
-#if HAVE_LIBFFI
- ft->type = FFI_TYPE_STRUCT;
- ft->size = tft->size;
- ft->alignment = etft->align;
- ft->elements = tft->elements;
-#endif
-
return obj;
}
@@ -3318,66 +4109,55 @@ static val ffi_eval_expr(val expr, val menv, val env)
static val make_ffi_type_enum(val syntax, val enums,
val base_type, val self)
{
- struct txr_ffi_type *tft = coerce(struct txr_ffi_type *,
- chk_calloc(1, sizeof *tft));
+ val type_copy = ffi_type_copy_new_ops(base_type, &ffi_type_enum_ops);
+ struct txr_ffi_type *tft = ffi_type_struct(type_copy);
struct txr_ffi_type *btft = ffi_type_struct(base_type);
-
- val sym_num = make_hash(nil, nil, t);
- val num_sym = make_hash(nil, nil, nil);
- val obj = cobj(coerce(mem_t *, tft), ffi_type_s, &ffi_type_enum_ops);
- cnum lowest = INT_PTR_MAX;
- cnum highest = INT_PTR_MIN;
- cnum cur = -1;
- ucnum count = 0;
+ val sym_num = make_hash(hash_weak_none, t);
+ val num_sym = make_hash(hash_weak_none, nil);
+ val cur;
val iter;
val enum_env = make_env(nil, nil, nil);
val shadow_menv = make_env(nil, nil, nil);
- tft->self = obj;
+ if (btft->kind != FFI_KIND_INT && btft->kind != FFI_KIND_UINT)
+ uw_throwf(error_s, lit("~a: type ~s can't be basis for enum"),
+ self, btft->syntax, nao);
+
tft->kind = FFI_KIND_ENUM;
- tft->ft = btft->ft;
tft->syntax = syntax;
tft->lt = sym_s;
- tft->size = btft->size;
- tft->align = btft->align;
- tft->clone = btft->clone;
tft->put = ffi_enum_put;
tft->get = ffi_enum_get;
#if !HAVE_LITTLE_ENDIAN
tft->rput = ffi_enum_rput;
tft->rget = ffi_enum_rget;
#endif
- tft->alloc = btft->alloc;
- tft->free = btft->free;
tft->eltype = base_type;
tft->num_sym = num_sym;
tft->sym_num = sym_num;
- for (iter = enums; !endp(iter); iter = cdr(iter), count++) {
+ for (cur = negone, iter = enums; !endp(iter); iter = cdr(iter)) {
+ int_ptr_t conv_buf[2];
val en = car(iter);
- val nn;
+ val sym;
+
if (symbolp(en)) {
- val sym = en;
+ sym = en;
if (!bindable(sym))
uw_throwf(error_s, lit("~a: ~s member ~s isn't a bindable symbol"),
self, syntax, sym, nao);
- if (cur == INT_MAX)
- uw_throwf(error_s, lit("~a: ~s overflow at member ~s"),
- self, syntax, sym, nao);
+
if (gethash(num_sym, sym))
uw_throwf(error_s, lit("~a: ~s duplicate member ~s"),
self, syntax, sym, nao);
- sethash(num_sym, sym, nn = num(++cur));
- sethash(sym_num, nn, sym);
- env_vbind(enum_env, sym, nn);
- env_vbind(shadow_menv, sym, special_s);
- if (cur > highest)
- highest = cur;
+
+ cur = plus(cur, one);
} else {
val expr = cadr(en);
- val sym = car(en);
- val n;
+
+ sym = car(en);
+
if (!bindable(sym))
uw_throwf(error_s, lit("~a: ~s member ~s isn't a bindable symbol"),
self, syntax, sym, nao);
@@ -3385,39 +4165,37 @@ static val make_ffi_type_enum(val syntax, val enums,
uw_throwf(error_s, lit("~a: ~s duplicate member ~s"),
self, syntax, sym, nao);
- n = ffi_eval_expr(expr, shadow_menv, enum_env);
+ cur = ffi_eval_expr(expr, shadow_menv, enum_env);
- if (!integerp(n)) {
+ if (!integerp(cur)) {
uw_throwf(error_s, lit("~a: ~s member ~s value ~s not integer"),
- self, syntax, n, nao);
+ self, syntax, sym, cur, nao);
}
-
- cur = c_num(n);
- if (cur > INT_MAX)
- uw_throwf(error_s, lit("~a: ~s member ~s value ~s too large"),
- self, syntax, n, nao);
- sethash(num_sym, sym, nn = num(cur));
- sethash(sym_num, nn, sym);
- env_vbind(enum_env, sym, nn);
- env_vbind(shadow_menv, sym, special_s);
- if (cur < lowest)
- lowest = cur;
}
+
+ btft->put(btft, cur, coerce(mem_t *, conv_buf), self);
+
+ sethash(num_sym, sym, cur);
+ sethash(sym_num, cur, sym);
+ env_vbind(enum_env, sym, cur);
+ env_vbind(shadow_menv, sym, special_s);
}
- return obj;
+ return type_copy;
}
-static val ffi_type_copy(val orig)
+val ffi_type_lookup(val sym)
{
- struct txr_ffi_type *otft = ffi_type_struct(orig);
- struct txr_ffi_type *ctft = otft->clone(otft);
- return cobj(coerce(mem_t *, ctft), orig->co.cls, orig->co.ops);
+ return gethash(ffi_typedef_hash, sym);
}
-static val ffi_type_lookup(val sym)
+static val ffi_type_lookup_checked(val self, val sym)
{
- return gethash(ffi_typedef_hash, sym);
+ val type = gethash(ffi_typedef_hash, sym);
+ if (!type)
+ uw_throwf(error_s, lit("~a: unrecognized type specifier: ~s"),
+ self, sym, nao);
+ return type;
}
static val ffi_struct_init(val slot_init, val strct)
@@ -3432,6 +4210,44 @@ static val ffi_struct_init(val slot_init, val strct)
return nil;
}
+static val ffi_transform_pack(val syntax, val align)
+{
+ val args = syntax;
+ val op = pop(&args);
+
+ if (op == struct_s || op == union_s)
+ {
+ val name = pop(&args);
+ val iter;
+ list_collect_decl (packed, ptail);
+
+ for (iter = args; iter; iter = cdr(iter)) {
+ val slot_spec = car(iter);
+ val slot = car(slot_spec);
+ val type = cadr(slot_spec);
+ val init = caddr(slot_spec);
+ val packed_type = list(pack_s, align, type, nao);
+
+ ptail = list_collect(ptail, if3(init,
+ list(slot, packed_type, init, nao),
+ list(slot, packed_type, nao)));
+ }
+
+ return if3(packed, cons(op, cons(name, packed)), syntax);
+ } else if (op == align_s) {
+ if (length(syntax) == two) {
+ val type = car(args);
+ return list(align_s, list(pack_s, align, type, nao), nao);
+ } else if (length(syntax) == three) {
+ val align = car(args);
+ val type = cadr(args);
+ return list(align_s, align, list(pack_s, align, type, nao), nao);
+ }
+ }
+
+ return syntax;
+}
+
val ffi_type_compile(val syntax)
{
val self = lit("ffi-type-compile");
@@ -3497,15 +4313,10 @@ val ffi_type_compile(val syntax)
if (length(syntax) == two) {
val eltype_syntax = cadr(syntax);
val eltype = ffi_type_compile(eltype_syntax);
- val type = make_ffi_type_pointer(syntax, vec_s,
- ffi_varray_put, ffi_void_get,
- ffi_varray_in, 0, ffi_varray_release,
- eltype);
+ val type = make_ffi_type_array(syntax, vec_s, zero, eltype, self);
struct txr_ffi_type *tft = ffi_type_struct(type);
struct txr_ffi_type *etft = ffi_type_struct(eltype);
- tft->kind = FFI_KIND_ARRAY;
-
if (etft->incomplete || etft->bitfield)
uw_throwf(error_s,
lit("~a: ~a ~s cannot be array element"),
@@ -3513,6 +4324,13 @@ val ffi_type_compile(val syntax)
if3(etft->bitfield,
lit("bitfield"), lit("incomplete type")),
eltype_syntax, nao);
+
+ tft->put = ffi_varray_put;
+ tft->get = ffi_void_get;
+ tft->in = ffi_varray_in;
+ tft->out = 0;
+ tft->release = ffi_varray_release;
+
if (sym == zarray_s) {
tft->null_term = 1;
tft->get = ffi_varray_null_term_get;
@@ -3626,7 +4444,7 @@ val ffi_type_compile(val syntax)
} else if (sym == buf_s || sym == buf_d_s) {
val size = ffi_eval_expr(cadr(syntax), nil, nil);
val xsyntax = list(sym, size, nao);
- cnum nelem = c_num(size);
+ cnum nelem = c_num(size, self);
val type = make_ffi_type_builtin(xsyntax, buf_s, FFI_KIND_PTR,
sizeof (mem_t *),
alignof (mem_t *),
@@ -3661,25 +4479,33 @@ val ffi_type_compile(val syntax)
&ffi_type_pointer,
ffi_cptr_put, ffi_cptr_get, 0, 0);
struct txr_ffi_type *tft = ffi_type_struct(type);
+ tft->in = ffi_cptr_in;
tft->alloc = ffi_cptr_alloc;
tft->free = ffi_noop_free;
tft->tag = tag;
+ tft->eltype = gethash(ffi_typedef_hash, tag);
if (cddr(syntax))
goto excess;
return type;
} else if (sym == carray_s) {
- val eltype = ffi_type_compile(cadr(syntax));
- if (cddr(syntax))
+ if (cddr(syntax)) {
goto excess;
- return make_ffi_type_pointer(syntax, carray_s,
- ffi_carray_put, ffi_carray_get,
- 0, 0, 0, eltype);
+ } else {
+ val eltype = ffi_type_compile(cadr(syntax));
+ val type = make_ffi_type_pointer(syntax, carray_s,
+ ffi_carray_put, ffi_carray_get,
+ 0, 0, 0, eltype);
+ struct txr_ffi_type *tft = ffi_type_struct(type);
+ tft->in = ffi_carray_in;
+ return type;
+ }
} else if (sym == sbit_s || sym == ubit_s) {
val nbits = ffi_eval_expr(cadr(syntax), nil, nil);
- cnum nb = c_num(nbits);
+ cnum nb = c_num(nbits, self);
val xsyntax = list(sym, nbits, nao);
val type = make_ffi_type_builtin(xsyntax, integer_s,
- FFI_KIND_NUM,
+ if3(sym == sbit_s,
+ FFI_KIND_INT, FFI_KIND_UINT),
sizeof (int), alignof (int),
&ffi_type_void,
if3(sym == sbit_s,
@@ -3692,50 +4518,102 @@ val ffi_type_compile(val syntax)
if (cddr(syntax))
goto excess;
if (nb < 0 || nb > bits_int)
- uw_throwf(error_s, lit("~a: invalid bitfield size ~s; "
+ uw_throwf(error_s, lit("~a: invalid bitfield size ~s in ~s: "
"must be 0 to ~s"),
- self, nbits, num_fast(bits_int), nao);
- tft->nelem = c_num(nbits);
+ self, nbits, syntax, num_fast(bits_int), nao);
+ tft->nelem = c_num(nbits, self);
tft->bitfield = 1;
+ if (nb == bits_int)
+ tft->m.mask = UINT_MAX;
+ else
+ tft->m.mask = ((1U << nb) - 1);
return type;
} else if (sym == bit_s && !consp(cddr(syntax))) {
goto toofew;
} else if (sym == bit_s) {
val nbits = ffi_eval_expr(cadr(syntax), nil, nil);
- cnum nb = c_num(nbits);
+ cnum nb = c_num(nbits, self);
val type_syntax = caddr(syntax);
val xsyntax = list(sym, nbits, type_syntax, nao);
val type = ffi_type_compile(type_syntax);
struct txr_ffi_type *tft = ffi_type_struct(type);
- const cnum max_bits = 8 * tft->size;
+ const int bits_int = 8 * sizeof(int);
+#if HAVE_I64
+ const int bits_llint = 8 * sizeof(u64_t);
+ const int bits_lim = min(8 * tft->size, bits_llint);
+#else
+ const int bits_lim = min(8 * tft->size, bits_int);
+#endif
val type_copy = ffi_type_copy(type);
struct txr_ffi_type *tft_cp = ffi_type_struct(type_copy);
- val syn = tft->syntax;
int unsgnd = 0;
if (cdddr(syntax))
goto excess;
- if (syn == uint8_s || syn == uint16_s || syn == uint32_s ||
- syn == uchar_s || syn == ushort_s || syn == uint_s)
- {
+ if (tft_cp->kind == FFI_KIND_UINT)
unsgnd = 1;
- } else if (syn != int8_s && syn != int16_s && syn != int32_s &&
- syn != char_s && syn != short_s && syn != int_s)
- {
+ else if (tft_cp->kind != FFI_KIND_INT)
uw_throwf(error_s, lit("~a: ~s not supported as bitfield type"),
self, type, nao);
- }
- if (nb < 0 || nb > max_bits)
- uw_throwf(error_s, lit("~a: invalid bitfield size ~s; "
+ if (nb < 0 || nb > bits_lim)
+ uw_throwf(error_s, lit("~a: bitfield size ~s in ~s: "
"must be 0 to ~s"),
- self, nbits, num_fast(max_bits), nao);
+ self, nbits, syntax, num_fast(bits_lim), nao);
+
tft_cp->syntax = xsyntax;
tft_cp->nelem = nb;
- tft_cp->put = if3(unsgnd, ffi_generic_ubit_put, ffi_generic_sbit_put);
- tft_cp->get = if3(unsgnd, ffi_generic_ubit_get, ffi_generic_sbit_get);
+ if ((!tft_cp->bigendian && HAVE_LITTLE_ENDIAN) ||
+ (tft_cp->bigendian && !HAVE_LITTLE_ENDIAN))
+ {
+#if HAVE_I64
+ if (tft->size > convert(int, sizeof (int))) {
+ tft_cp->put = if3(unsgnd,
+ ffi_generic_fat_ubit_put,
+ ffi_generic_fat_sbit_put);
+ tft_cp->get = if3(unsgnd,
+ ffi_generic_fat_ubit_get,
+ ffi_generic_fat_sbit_get);
+ } else
+#endif
+ {
+ tft_cp->put = if3(unsgnd, ffi_generic_ubit_put, ffi_generic_sbit_put);
+ tft_cp->get = if3(unsgnd, ffi_generic_ubit_get, ffi_generic_sbit_get);
+ }
+ } else {
+#if HAVE_I64
+ if (tft->size > convert(int, sizeof (int))) {
+ tft_cp->put = if3(unsgnd,
+ ffi_generic_swap_fat_ubit_put,
+ ffi_generic_swap_fat_sbit_put);
+ tft_cp->get = if3(unsgnd,
+ ffi_generic_swap_fat_ubit_get,
+ ffi_generic_swap_fat_sbit_get);
+ } else
+#endif
+ {
+ tft_cp->put = if3(unsgnd,
+ ffi_generic_swap_ubit_put,
+ ffi_generic_swap_sbit_put);
+ tft_cp->get = if3(unsgnd,
+ ffi_generic_swap_ubit_get,
+ ffi_generic_swap_sbit_get);
+ }
+ }
tft_cp->bitfield = 1;
+ /* mask needed at type compilation time by (enumed (bit ...)) */
+#if HAVE_I64
+ if (nb == bits_llint)
+ tft_cp->m.fmask = convert(u64_t, -1);
+ else if (nb > bits_int)
+ tft_cp->m.fmask = ((convert(u64_t, 1) << nb) - 1);
+ else
+#endif
+ if (nb == bits_int)
+ tft_cp->m.mask = UINT_MAX;
+ else
+ tft_cp->m.mask = ((1U << nb) - 1);
return type_copy;
} else if (sym == enum_s) {
val name = cadr(syntax);
@@ -3759,26 +4637,42 @@ val ffi_type_compile(val syntax)
lit("~a: enum name ~s must be bindable symbol or nil"),
self, name, nao);
return make_ffi_type_enum(xsyntax, enums, base_type, self);
- } else if (sym == align_s && !consp(cddr(syntax))) {
- goto toofew;
- } else if (sym == align_s) {
- val align = ffi_eval_expr(cadr(syntax), nil, nil);
- ucnum al = c_num(align);
+ } else if (sym == align_s || sym == pack_s) {
+ int twoarg = !consp(cddr(syntax));
+ val align = if3(twoarg,
+ if3(sym == pack_s, one, num_fast(16)),
+ ffi_eval_expr(cadr(syntax), nil, nil));
+ cnum al = c_num(align, self);
if (cdddr(syntax))
goto excess;
if (al <= 0) {
uw_throwf(error_s, lit("~a: alignment must be positive"),
self, nao);
- } else if (al != 0 && (al & (al - 1)) != 0) {
+ } else if ((al & (al - 1)) != 0) {
uw_throwf(error_s, lit("~a: alignment must be a power of two"),
self, nao);
} else {
- val alsyntax = caddr(syntax);
- val altype = ffi_type_compile(alsyntax);
- val altype_copy = ffi_type_copy(altype);
- struct txr_ffi_type *atft = ffi_type_struct(altype_copy);
- atft->align = al;
- return altype_copy;
+ val alsyntax = if3(twoarg, cadr(syntax), caddr(syntax));
+ val xalsyntax = if3(sym == pack_s && consp(alsyntax),
+ ffi_transform_pack(alsyntax, align),
+ alsyntax);
+ val altype = ffi_type_compile(xalsyntax);
+ if (xalsyntax != alsyntax) {
+ return altype;
+ } else {
+ val altype_copy = ffi_type_copy(altype);
+ struct txr_ffi_type *atft = ffi_type_struct(altype_copy);
+ cnum oalign = atft->align;
+ if (al > atft->align || sym == pack_s || atft->bitfield ||
+ (opt_compat && opt_compat <= 275))
+ atft->align = al;
+ if (al != 1 || sym != pack_s) {
+ if (!atft->oalign)
+ atft->oalign = oalign;
+ atft->aligned = 1;
+ }
+ return altype_copy;
+ }
}
} else if (sym == bool_s) {
val type_syntax = cadr(syntax);
@@ -3872,7 +4766,8 @@ val ffi_type_operator_p(val sym)
sym == ptr_out_s_s || sym == buf_s || sym == buf_d_s ||
sym == cptr_s || sym == carray_s || sym == sbit_s ||
sym == ubit_s || sym == bit_s || sym == enum_s ||
- sym == enumed_s || sym == align_s || sym == bool_s);
+ sym == enumed_s || sym == align_s || sym == pack_s ||
+ sym == bool_s);
}
val ffi_type_p(val sym)
@@ -3890,14 +4785,14 @@ static void ffi_init_types(void)
#if HAVE_I8
ffi_typedef(uint8_s, make_ffi_type_builtin(uint8_s, integer_s,
- FFI_KIND_NUM,
+ FFI_KIND_UINT,
sizeof (i8_t), alignof (i8_t),
&ffi_type_uint8,
ffi_u8_put, ffi_u8_get,
ifbe(ffi_u8_rput),
ifbe(ffi_u8_rget)));
ffi_typedef(int8_s, make_ffi_type_builtin(int8_s, integer_s,
- FFI_KIND_NUM,
+ FFI_KIND_INT,
sizeof (i8_t), alignof (i8_t),
&ffi_type_sint8,
ffi_i8_put, ffi_i8_get,
@@ -3906,14 +4801,14 @@ static void ffi_init_types(void)
#endif
#if HAVE_I16
ffi_typedef(uint16_s, make_ffi_type_builtin(uint16_s, integer_s,
- FFI_KIND_NUM,
+ FFI_KIND_UINT,
sizeof (i16_t), alignof (i16_t),
&ffi_type_uint16,
ffi_u16_put, ffi_u16_get,
ifbe(ffi_u16_rput),
ifbe(ffi_u16_rget)));
ffi_typedef(int16_s, make_ffi_type_builtin(int16_s, integer_s,
- FFI_KIND_NUM,
+ FFI_KIND_INT,
sizeof (i16_t), alignof (i16_t),
&ffi_type_sint16,
ffi_i16_put, ffi_i16_get,
@@ -3922,14 +4817,14 @@ static void ffi_init_types(void)
#endif
#if HAVE_I32
ffi_typedef(uint32_s, make_ffi_type_builtin(uint32_s, integer_s,
- FFI_KIND_NUM,
+ FFI_KIND_UINT,
sizeof (i32_t), alignof (i32_t),
&ffi_type_uint32,
ffi_u32_put, ffi_u32_get,
ifbe(ffi_u32_rput),
ifbe(ffi_u32_rget)));
ffi_typedef(int32_s, make_ffi_type_builtin(int32_s, integer_s,
- FFI_KIND_NUM,
+ FFI_KIND_INT,
sizeof (i32_t), alignof (i32_t),
&ffi_type_sint32,
ffi_i32_put, ffi_i32_get,
@@ -3938,46 +4833,49 @@ static void ffi_init_types(void)
#endif
#if HAVE_I64
ffi_typedef(uint64_s, make_ffi_type_builtin(uint64_s, integer_s,
- FFI_KIND_NUM,
+ FFI_KIND_UINT,
sizeof (i64_t), alignof (i64_t),
&ffi_type_uint64,
ffi_u64_put, ffi_u64_get, 0, 0));
ffi_typedef(int64_s, make_ffi_type_builtin(int64_s, integer_s,
- FFI_KIND_NUM,
+ FFI_KIND_INT,
sizeof (i64_t), alignof (i64_t),
&ffi_type_sint64,
ffi_i64_put, ffi_i64_get, 0, 0));
#endif
ffi_typedef(uchar_s, make_ffi_type_builtin(uchar_s, integer_s,
- FFI_KIND_NUM,
+ FFI_KIND_UINT,
1, 1,
&ffi_type_uchar,
ffi_uchar_put, ffi_uchar_get,
ifbe(ffi_uchar_rput),
ifbe(ffi_uchar_rget)));
ffi_typedef(char_s, make_ffi_type_builtin(char_s, integer_s,
- FFI_KIND_NUM,
+ if3(CHAR_MAX == UCHAR_MAX,
+ FFI_KIND_UINT, FFI_KIND_INT),
1, 1,
ffi_char, ffi_char_put,
ffi_char_get,
ifbe(ffi_char_rput),
ifbe(ffi_char_rget)));
ffi_typedef(zchar_s, make_ffi_type_builtin(zchar_s, integer_s,
- FFI_KIND_NUM,
+ if3(CHAR_MAX == UCHAR_MAX,
+ FFI_KIND_UINT, FFI_KIND_INT),
1, 1,
ffi_char, ffi_char_put,
ffi_char_get,
ifbe(ffi_char_rput),
ifbe(ffi_char_rget)));
ffi_typedef(bchar_s, make_ffi_type_builtin(bchar_s, char_s,
- FFI_KIND_NUM,
+ FFI_KIND_UINT,
1, 1,
&ffi_type_uchar,
ffi_uchar_put, ffi_bchar_get,
ifbe(ffi_uchar_rput),
ifbe(ffi_bchar_rget)));
ffi_typedef(wchar_s, make_ffi_type_builtin(wchar_s, char_s,
- FFI_KIND_NUM,
+ if3(convert(wchar_t, -1) < 0,
+ FFI_KIND_INT, FFI_KIND_UINT),
sizeof (wchar_t),
alignof (wchar_t),
&ffi_type_wchar,
@@ -3985,55 +4883,55 @@ static void ffi_init_types(void)
ifbe(ffi_wchar_rput),
ifbe(ffi_wchar_rget)));
ffi_typedef(ushort_s, make_ffi_type_builtin(ushort_s, integer_s,
- FFI_KIND_NUM,
+ FFI_KIND_UINT,
sizeof (short), alignof (short),
&ffi_type_ushort,
ffi_ushort_put, ffi_ushort_get,
ifbe(ffi_ushort_rput),
ifbe(ffi_ushort_rget)));
ffi_typedef(short_s, make_ffi_type_builtin(short_s, integer_s,
- FFI_KIND_NUM,
+ FFI_KIND_INT,
sizeof (short), alignof (short),
&ffi_type_sshort,
ffi_short_put, ffi_short_get,
ifbe(ffi_short_rput),
ifbe(ffi_short_rget)));
ffi_typedef(int_s, make_ffi_type_builtin(int_s, integer_s,
- FFI_KIND_NUM,
+ FFI_KIND_INT,
sizeof (int), alignof (int),
&ffi_type_sint,
ffi_int_put, ffi_int_get,
ifbe(ffi_int_rput),
ifbe(ffi_int_rget)));
ffi_typedef(uint_s, make_ffi_type_builtin(uint_s, integer_s,
- FFI_KIND_NUM,
+ FFI_KIND_UINT,
sizeof (int), alignof (int),
&ffi_type_uint,
ffi_uint_put, ffi_uint_get,
ifbe(ffi_uint_rput),
ifbe(ffi_uint_rget)));
ffi_typedef(ulong_s, make_ffi_type_builtin(ulong_s, integer_s,
- FFI_KIND_NUM,
+ FFI_KIND_UINT,
sizeof (long), alignof (long),
&ffi_type_ulong,
ffi_ulong_put, ffi_ulong_get,
ifbe(ffi_ulong_rput),
ifbe(ffi_ulong_rget)));
ffi_typedef(long_s, make_ffi_type_builtin(long_s, integer_s,
- FFI_KIND_NUM,
+ FFI_KIND_INT,
sizeof (long), alignof (long),
&ffi_type_slong,
ffi_long_put, ffi_long_get,
ifbe(ffi_long_rput),
ifbe(ffi_long_rget)));
ffi_typedef(float_s, make_ffi_type_builtin(float_s, float_s,
- FFI_KIND_NUM,
+ FFI_KIND_FLO,
sizeof (float), alignof (float),
&ffi_type_float,
ffi_float_put, ffi_float_get,
0, 0));
ffi_typedef(double_s, make_ffi_type_builtin(double_s, float_s,
- FFI_KIND_NUM,
+ FFI_KIND_FLO,
sizeof (double),
alignof (double),
&ffi_type_double,
@@ -4046,140 +4944,177 @@ static void ffi_init_types(void)
&ffi_type_pointer,
ffi_val_put, ffi_val_get,
0, 0));
- ffi_typedef(be_uint16_s, make_ffi_type_builtin(be_uint16_s, integer_s,
- FFI_KIND_NUM,
- sizeof (u16_t),
- alignof (u16_t),
- &ffi_type_uint16,
- ffi_be_u16_put,
- ffi_be_u16_get,
- ifbe(ffi_be_u16_rput),
- ifbe(ffi_be_u16_rget)));
- ffi_typedef(be_int16_s, make_ffi_type_builtin(be_int16_s, integer_s,
- FFI_KIND_NUM,
- sizeof (i16_t),
- alignof (i16_t),
- &ffi_type_sint16,
- ffi_be_i16_put,
- ffi_be_i16_get,
- ifbe(ffi_be_i16_rput),
- ifbe(ffi_be_i16_rget)));
- ffi_typedef(be_uint32_s, make_ffi_type_builtin(be_uint32_s, integer_s,
- FFI_KIND_NUM,
- sizeof (u32_t),
- alignof (u32_t),
- &ffi_type_uint32,
- ffi_be_u32_put,
- ffi_be_u32_get,
- ifbe(ffi_be_u32_rput),
- ifbe(ffi_be_u32_rget)));
- ffi_typedef(be_int32_s, make_ffi_type_builtin(be_int32_s, integer_s,
- FFI_KIND_NUM,
- sizeof (i32_t),
- alignof (i32_t),
- &ffi_type_sint32,
- ffi_be_i32_put,
- ffi_be_i32_get,
- ifbe(ffi_be_i32_rput),
- ifbe(ffi_be_i32_rget)));
- ffi_typedef(be_uint64_s, make_ffi_type_builtin(be_uint64_s, integer_s,
- FFI_KIND_NUM,
- sizeof (u64_t),
- alignof (u64_t),
- &ffi_type_uint64,
- ffi_be_u64_put,
- ffi_be_u64_get, 0, 0));
- ffi_typedef(be_int64_s, make_ffi_type_builtin(be_int64_s, integer_s,
- FFI_KIND_NUM,
- sizeof (i64_t),
- alignof (i64_t),
- &ffi_type_sint64,
- ffi_be_i64_put,
- ffi_be_i64_get, 0, 0));
- ffi_typedef(be_float_s, make_ffi_type_builtin(be_float_s, integer_s,
- FFI_KIND_NUM,
- sizeof (float),
- alignof (float),
- &ffi_type_float,
- ffi_be_float_put,
- ffi_be_float_get, 0, 0));
- ffi_typedef(be_double_s, make_ffi_type_builtin(be_double_s, integer_s,
- FFI_KIND_NUM,
- sizeof (double),
- alignof (double),
- &ffi_type_double,
- ffi_be_double_put,
- ffi_be_double_get, 0, 0));
- ffi_typedef(le_uint16_s, make_ffi_type_builtin(le_uint16_s, integer_s,
- FFI_KIND_NUM,
- sizeof (u16_t),
- alignof (u16_t),
- &ffi_type_uint16,
- ffi_le_u16_put,
- ffi_le_u16_get,
- ifbe(ffi_le_u16_rput),
- ifbe(ffi_le_u16_rget)));
- ffi_typedef(le_int16_s, make_ffi_type_builtin(le_int16_s, integer_s,
- FFI_KIND_NUM,
- sizeof (i16_t),
- alignof (i16_t),
- &ffi_type_sint16,
- ffi_le_i16_put,
- ffi_le_i16_get,
- ifbe(ffi_le_i16_rput),
- ifbe(ffi_le_i16_rget)));
- ffi_typedef(le_uint32_s, make_ffi_type_builtin(le_uint32_s, integer_s,
- FFI_KIND_NUM,
- sizeof (u32_t),
- alignof (u32_t),
- &ffi_type_uint32,
- ffi_le_u32_put,
- ffi_le_u32_get,
- ifbe(ffi_le_u32_rput),
- ifbe(ffi_le_u32_rget)));
- ffi_typedef(le_int32_s, make_ffi_type_builtin(le_int32_s, integer_s,
- FFI_KIND_NUM,
- sizeof (i32_t),
- alignof (i32_t),
- &ffi_type_sint32,
- ffi_le_i32_put,
- ffi_le_i32_get,
- ifbe(ffi_le_i32_rput),
- ifbe(ffi_le_i32_rget)));
- ffi_typedef(le_uint64_s, make_ffi_type_builtin(le_uint64_s, integer_s,
- FFI_KIND_NUM,
- sizeof (u64_t),
- alignof (u64_t),
- &ffi_type_uint64,
- ffi_le_u64_put,
- ffi_le_u64_get, 0, 0));
- ffi_typedef(le_int64_s, make_ffi_type_builtin(le_int64_s, integer_s,
- FFI_KIND_NUM,
- sizeof (i64_t),
- alignof (i64_t),
- &ffi_type_sint64,
- ffi_le_i64_put,
- ffi_le_i64_get, 0, 0));
- ffi_typedef(le_float_s, make_ffi_type_builtin(le_float_s, integer_s,
- FFI_KIND_NUM,
- sizeof (float),
- alignof (float),
- &ffi_type_float,
- ffi_le_float_put,
- ffi_le_float_get, 0, 0));
- ffi_typedef(le_double_s, make_ffi_type_builtin(le_double_s, integer_s,
- FFI_KIND_NUM,
- sizeof (double),
- alignof (double),
- &ffi_type_double,
- ffi_le_double_put,
- ffi_le_double_get, 0, 0));
+
+#if HAVE_I16
+ ffi_typedef(be_uint16_s, make_ffi_type_endian(be_uint16_s, integer_s,
+ FFI_KIND_UINT,
+ sizeof (u16_t),
+ alignof (u16_t),
+ &ffi_type_uint16,
+ ffi_be_u16_put,
+ ffi_be_u16_get,
+ ifbe(ffi_be_u16_rput),
+ ifbe(ffi_be_u16_rget),
+ 1));
+ ffi_typedef(be_int16_s, make_ffi_type_endian(be_int16_s, integer_s,
+ FFI_KIND_INT,
+ sizeof (i16_t),
+ alignof (i16_t),
+ &ffi_type_sint16,
+ ffi_be_i16_put,
+ ffi_be_i16_get,
+ ifbe(ffi_be_i16_rput),
+ ifbe(ffi_be_i16_rget),
+ 1));
+#endif
+
+#if HAVE_I32
+ ffi_typedef(be_uint32_s, make_ffi_type_endian(be_uint32_s, integer_s,
+ FFI_KIND_UINT,
+ sizeof (u32_t),
+ alignof (u32_t),
+ &ffi_type_uint32,
+ ffi_be_u32_put,
+ ffi_be_u32_get,
+ ifbe(ffi_be_u32_rput),
+ ifbe(ffi_be_u32_rget),
+ 1));
+ ffi_typedef(be_int32_s, make_ffi_type_endian(be_int32_s, integer_s,
+ FFI_KIND_INT,
+ sizeof (i32_t),
+ alignof (i32_t),
+ &ffi_type_sint32,
+ ffi_be_i32_put,
+ ffi_be_i32_get,
+ ifbe(ffi_be_i32_rput),
+ ifbe(ffi_be_i32_rget),
+ 1));
+#endif
+
+#if HAVE_I64
+ ffi_typedef(be_uint64_s, make_ffi_type_endian(be_uint64_s, integer_s,
+ FFI_KIND_UINT,
+ sizeof (u64_t),
+ alignof (u64_t),
+ &ffi_type_uint64,
+ ffi_be_u64_put,
+ ffi_be_u64_get,
+ 0, 0, 1));
+ ffi_typedef(be_int64_s, make_ffi_type_endian(be_int64_s, integer_s,
+ FFI_KIND_INT,
+ sizeof (i64_t),
+ alignof (i64_t),
+ &ffi_type_sint64,
+ ffi_be_i64_put,
+ ffi_be_i64_get,
+ 0, 0, 1));
+#endif
+
+ ffi_typedef(be_float_s, make_ffi_type_endian(be_float_s, float_s,
+ FFI_KIND_FLO,
+ sizeof (float),
+ alignof (float),
+ &ffi_type_float,
+ ffi_be_float_put,
+ ffi_be_float_get,
+ 0, 0, 1));
+ ffi_typedef(be_double_s, make_ffi_type_endian(be_double_s, float_s,
+ FFI_KIND_FLO,
+ sizeof (double),
+ alignof (double),
+ &ffi_type_double,
+ ffi_be_double_put,
+ ffi_be_double_get,
+ 0, 0, 1));
+
+#if HAVE_I16
+ ffi_typedef(le_uint16_s, make_ffi_type_endian(le_uint16_s, integer_s,
+ FFI_KIND_UINT,
+ sizeof (u16_t),
+ alignof (u16_t),
+ &ffi_type_uint16,
+ ffi_le_u16_put,
+ ffi_le_u16_get,
+ ifbe(ffi_le_u16_rput),
+ ifbe(ffi_le_u16_rget),
+ 0));
+ ffi_typedef(le_int16_s, make_ffi_type_endian(le_int16_s, integer_s,
+ FFI_KIND_INT,
+ sizeof (i16_t),
+ alignof (i16_t),
+ &ffi_type_sint16,
+ ffi_le_i16_put,
+ ffi_le_i16_get,
+ ifbe(ffi_le_i16_rput),
+ ifbe(ffi_le_i16_rget),
+ 0));
+#endif
+
+#if HAVE_I32
+ ffi_typedef(le_uint32_s, make_ffi_type_endian(le_uint32_s, integer_s,
+ FFI_KIND_UINT,
+ sizeof (u32_t),
+ alignof (u32_t),
+ &ffi_type_uint32,
+ ffi_le_u32_put,
+ ffi_le_u32_get,
+ ifbe(ffi_le_u32_rput),
+ ifbe(ffi_le_u32_rget),
+ 0));
+ ffi_typedef(le_int32_s, make_ffi_type_endian(le_int32_s, integer_s,
+ FFI_KIND_INT,
+ sizeof (i32_t),
+ alignof (i32_t),
+ &ffi_type_sint32,
+ ffi_le_i32_put,
+ ffi_le_i32_get,
+ ifbe(ffi_le_i32_rput),
+ ifbe(ffi_le_i32_rget),
+ 0));
+#endif
+
+#if HAVE_I64
+ ffi_typedef(le_uint64_s, make_ffi_type_endian(le_uint64_s, integer_s,
+ FFI_KIND_UINT,
+ sizeof (u64_t),
+ alignof (u64_t),
+ &ffi_type_uint64,
+ ffi_le_u64_put,
+ ffi_le_u64_get,
+ 0, 0, 0));
+ ffi_typedef(le_int64_s, make_ffi_type_endian(le_int64_s, integer_s,
+ FFI_KIND_INT,
+ sizeof (i64_t),
+ alignof (i64_t),
+ &ffi_type_sint64,
+ ffi_le_i64_put,
+ ffi_le_i64_get,
+ 0, 0, 0));
+#endif
+
+ ffi_typedef(le_float_s, make_ffi_type_endian(le_float_s, float_s,
+ FFI_KIND_FLO,
+ sizeof (float),
+ alignof (float),
+ &ffi_type_float,
+ ffi_le_float_put,
+ ffi_le_float_get,
+ 0, 0, 0));
+ ffi_typedef(le_double_s, make_ffi_type_endian(le_double_s, float_s,
+ FFI_KIND_FLO,
+ sizeof (double),
+ alignof (double),
+ &ffi_type_double,
+ ffi_le_double_put,
+ ffi_le_double_get,
+ 0, 0, 0));
{
val type = make_ffi_type_builtin(cptr_s, cptr_s, FFI_KIND_PTR,
sizeof (mem_t *), alignof (mem_t *),
&ffi_type_pointer,
ffi_cptr_put, ffi_cptr_get, 0, 0);
struct txr_ffi_type *tft = ffi_type_struct(type);
+ tft->in = ffi_cptr_in;
tft->alloc = ffi_cptr_alloc;
tft->free = ffi_noop_free;
tft->tag = nil;
@@ -4210,10 +5145,6 @@ static void ffi_init_types(void)
ffi_typedef(bstr_s, type);
}
- ffi_typedef(str_d_s, make_ffi_type_builtin(str_d_s, str_s, FFI_KIND_PTR,
- sizeof (mem_t *), alignof (mem_t *),
- &ffi_type_pointer,
- ffi_str_put, ffi_str_d_get, 0, 0));
{
val type = ffi_typedef(wstr_s, make_ffi_type_builtin(wstr_s, str_s,
FFI_KIND_PTR,
@@ -4229,6 +5160,12 @@ static void ffi_init_types(void)
ffi_typedef(wstr_s, type);
}
+ ffi_typedef(str_d_s, make_ffi_type_builtin(str_d_s, str_s, FFI_KIND_PTR,
+ sizeof (mem_t *),
+ alignof (mem_t *),
+ &ffi_type_pointer,
+ ffi_str_put, ffi_str_d_get, 0, 0));
+
ffi_typedef(wstr_d_s, make_ffi_type_builtin(wstr_d_s, str_s, FFI_KIND_PTR,
sizeof (mem_t *),
alignof (mem_t *),
@@ -4242,6 +5179,26 @@ static void ffi_init_types(void)
ffi_bstr_put, ffi_bstr_d_get,
0, 0));
+ ffi_typedef(str_s_s, make_ffi_type_builtin(str_s_s, str_s, FFI_KIND_PTR,
+ sizeof (mem_t *),
+ alignof (mem_t *),
+ &ffi_type_pointer,
+ ffi_ptr_out_null_put, ffi_str_get,
+ 0, 0));
+
+ ffi_typedef(wstr_s_s, make_ffi_type_builtin(wstr_s_s, str_s, FFI_KIND_PTR,
+ sizeof (mem_t *),
+ alignof (mem_t *),
+ &ffi_type_pointer,
+ ffi_ptr_out_null_put, ffi_wstr_get,
+ 0, 0));
+
+ ffi_typedef(bstr_s_s, make_ffi_type_builtin(bstr_s_s, str_s, FFI_KIND_PTR,
+ sizeof (mem_t *),
+ alignof (mem_t *),
+ &ffi_type_pointer,
+ ffi_ptr_out_null_put, ffi_bstr_get,
+ 0, 0));
{
val iter;
@@ -4281,10 +5238,15 @@ static void ffi_init_types(void)
ffi_typedef(bool_s, ffi_type_compile(cons(bool_s, cons(uchar_s, nil))));
}
-static void ffi_init_extra_types(void)
+static val type_by_size[2][16];
+
+val ffi_type_by_size(int unsig, size_t size)
{
- val type_by_size[2][18] = { { 0 }, { 0 } };
+ return type_by_size[unsig][size];
+}
+static void ffi_init_extra_types(void)
+{
#if HAVE_I64
type_by_size[0][sizeof (i64_t)] = ffi_type_lookup(int64_s);
type_by_size[1][sizeof (i64_t)] = ffi_type_lookup(uint64_s);
@@ -4330,6 +5292,23 @@ static void ffi_init_extra_types(void)
ffi_typedef(intern(lit("wint-t"), user_package),
type_by_size[convert(wint_t, -1) > 0][sizeof (wint_t)]);
+#if HAVE_INTMAX_T || HAVE_LONGLONG_T
+ {
+#if HAVE_INTMAX_T
+ typedef intmax_t imax_t;
+#elif HAVE_LONGLONG_T
+ typedef longlong_t imax_t;
+#endif
+
+ if (sizeof(imax_t) <= 8) {
+ ffi_typedef(intern(lit("intmax-t"), user_package),
+ type_by_size[0][sizeof (imax_t)]);
+ ffi_typedef(intern(lit("uintmax-t"), user_package),
+ type_by_size[1][sizeof (imax_t)]);
+ }
+ }
+#endif
+
#if HAVE_SYS_TYPES_H
ffi_typedef(intern(lit("blkcnt-t"), user_package),
type_by_size[convert(blkcnt_t, -1) > 0][sizeof (blkcnt_t)]);
@@ -4370,10 +5349,13 @@ static void ffi_init_extra_types(void)
ffi_typedef(intern(lit("uid-t"), user_package),
type_by_size[convert(uid_t, -1) > 0][sizeof (uid_t)]);
#endif
+
+#if HAVE_LONGLONG_T
ffi_typedef(intern(lit("longlong"), user_package),
- type_by_size[0][sizeof (long long)]);
+ type_by_size[0][sizeof (longlong_t)]);
ffi_typedef(intern(lit("ulonglong"), user_package),
- type_by_size[1][sizeof (long long)]);
+ type_by_size[1][sizeof (longlong_t)]);
+#endif
}
#if HAVE_LIBFFI
@@ -4385,6 +5367,7 @@ struct txr_ffi_call_desc {
cnum nfixed, ntotal;
val argtypes;
val rettype;
+ val name;
};
static struct txr_ffi_call_desc *ffi_call_desc(val obj)
@@ -4395,7 +5378,7 @@ static struct txr_ffi_call_desc *ffi_call_desc(val obj)
static struct txr_ffi_call_desc *ffi_call_desc_checked(val self, val obj)
{
return coerce(struct txr_ffi_call_desc *, cobj_handle(self, obj,
- ffi_call_desc_s));
+ ffi_call_desc_cls));
}
static void ffi_call_desc_print_op(val obj, val out,
@@ -4403,8 +5386,9 @@ static void ffi_call_desc_print_op(val obj, val out,
{
struct txr_ffi_call_desc *tfcd = ffi_call_desc(obj);
put_string(lit("#<"), out);
- obj_print_impl(obj->co.cls, out, pretty, ctx);
- format(out, lit(" ~s ~!~s>"), tfcd->rettype, tfcd->argtypes, nao);
+ obj_print_impl(obj->co.cls->cls_sym, out, pretty, ctx);
+ format(out, lit(" ~s ~s ~!~s>"), tfcd->name, tfcd->rettype,
+ tfcd->argtypes, nao);
}
static void ffi_call_desc_destroy_op(val obj)
@@ -4420,6 +5404,7 @@ static void ffi_call_desc_mark_op(val obj)
struct txr_ffi_call_desc *tfcd = ffi_call_desc(obj);
gc_mark(tfcd->argtypes);
gc_mark(tfcd->rettype);
+ gc_mark(tfcd->name);
}
static struct cobj_ops ffi_call_desc_ops =
@@ -4429,23 +5414,26 @@ static struct cobj_ops ffi_call_desc_ops =
ffi_call_desc_mark_op,
cobj_eq_hash_op);
-val ffi_make_call_desc(val ntotal, val nfixed, val rettype, val argtypes)
+val ffi_make_call_desc(val ntotal, val nfixed, val rettype, val argtypes,
+ val name_in)
{
- val self = lit("ffi-make-call-desc");
- cnum nf = c_num(default_arg(nfixed, zero));
- cnum nt = c_num(ntotal), i;
+ val name = default_null_arg(name_in);
+ val self = if3(name, name, lit("ffi-make-call-desc"));
+ cnum nt = c_num(ntotal, self), i;
+ cnum nf = c_num(default_arg(nfixed, ntotal), self);
struct txr_ffi_call_desc *tfcd = coerce(struct txr_ffi_call_desc *,
chk_calloc(1, sizeof *tfcd));
ffi_type **args = coerce(ffi_type **, chk_xalloc(nt, sizeof *args, self));
- val obj = cobj(coerce(mem_t *, tfcd), ffi_call_desc_s, &ffi_call_desc_ops);
+ val obj = cobj(coerce(mem_t *, tfcd), ffi_call_desc_cls, &ffi_call_desc_ops);
ffi_status ffis = FFI_OK;
- tfcd->variadic = (nfixed != nil);
+ tfcd->variadic = (nt != nf);
tfcd->nfixed = nf;
tfcd->ntotal = nt;
tfcd->argtypes = argtypes;
tfcd->rettype = rettype;
tfcd->args = args;
+ tfcd->name = name;
for (i = 0; i < nt; i++) {
val type = pop(&argtypes);
@@ -4456,6 +5444,10 @@ val ffi_make_call_desc(val ntotal, val nfixed, val rettype, val argtypes)
if (tft->bitfield)
uw_throwf(error_s, lit("~a: can't pass bitfield as argument"),
self, nao);
+ if (tft->calcft != 0) {
+ tft->calcft(tft);
+ tft->calcft = 0;
+ }
args[i] = tft->ft;
}
@@ -4483,10 +5475,11 @@ val ffi_make_call_desc(val ntotal, val nfixed, val rettype, val argtypes)
return obj;
}
-val ffi_call_wrap(val fptr, val ffi_call_desc, struct args *args)
+val ffi_call_wrap(val fptr, val ffi_call_desc, varg args)
{
- val self = lit("ffi-call");
- struct txr_ffi_call_desc *tfcd = ffi_call_desc_checked(self, ffi_call_desc);
+ val real_self = lit("ffi-call");
+ struct txr_ffi_call_desc *tfcd = ffi_call_desc_checked(real_self, ffi_call_desc);
+ val self = if3(tfcd->name, tfcd->name, real_self);
mem_t *fp = cptr_get(fptr);
cnum n = tfcd->ntotal;
void **values = convert(void **, alloca(sizeof *values * tfcd->ntotal));
@@ -4534,7 +5527,7 @@ val ffi_call_wrap(val fptr, val ffi_call_desc, struct args *args)
for (i = 0; i < nreached; i++) {
struct txr_ffi_type *mtft = type[i];
if (mtft->release != 0)
- mtft->release(mtft, args->arg[i], convert(mem_t *, values[i]));
+ mtft->release(mtft, args->arg[i], convert(mem_t *, values[i]), self);
}
}
}
@@ -4546,7 +5539,7 @@ val ffi_call_wrap(val fptr, val ffi_call_desc, struct args *args)
ret = ifbe2(rtft->rget, rtft->get)(rtft, convert(mem_t *, rc), self);
if (in_pass_needed) {
- for (i = 0; i < n; i++) {
+ for (i = n - 1; i >= 0; i--) {
struct txr_ffi_type *mtft = type[i];
if (mtft->by_value_in)
mtft->in(mtft, 0, convert(mem_t *, values[i]), args->arg[i], self);
@@ -4565,22 +5558,25 @@ val ffi_call_wrap(val fptr, val ffi_call_desc, struct args *args)
static void ffi_closure_dispatch(ffi_cif *cif, void *cret,
void *cargs[], void *clo)
{
- val self = lit("ffi-closure-dispatch");
val closure = coerce(val, clo);
struct txr_ffi_closure *tfcl = ffi_closure_struct(closure);
cnum i, nargs = tfcl->nparam;
struct txr_ffi_call_desc *tfcd = tfcl->tfcd;
+ val self = if3(tfcd->name, tfcd->name, lit("ffi-closure-dispatch"));
val types = tfcd->argtypes;
val rtype = tfcd->rettype;
struct txr_ffi_type *rtft = ffi_type_struct(rtype);
val retval = nil;
int out_pass_needed = 0;
+ val *type = convert(val *, alloca(nargs * sizeof *type));
args_decl(args, nargs);
args_decl(args_cp, nargs);
+
+ (void) cif;
+
for (i = 0; i < nargs; i++) {
- val type = pop(&types);
- struct txr_ffi_type *mtft = ffi_type_struct(type);
+ struct txr_ffi_type *mtft = ffi_type_struct((type[i] = pop(&types)));
val arg = mtft->get(mtft, convert(mem_t *, cargs[i]), self);
args_add(args, arg);
if (mtft->out != 0)
@@ -4592,10 +5588,9 @@ static void ffi_closure_dispatch(ffi_cif *cif, void *cret,
retval = generic_funcall(tfcl->fun, args);
if (out_pass_needed) {
- for (types = tfcd->argtypes, i = 0; i < nargs; i++) {
- val type = pop(&types);
+ for (types = tfcd->argtypes, i = nargs - 1; i >= 0; i--) {
val arg = args_at(args_cp, i);
- struct txr_ffi_type *mtft = ffi_type_struct(type);
+ struct txr_ffi_type *mtft = ffi_type_struct(type[i]);
if (mtft->out != 0)
mtft->out(mtft, 0, arg, convert(mem_t *, cargs[i]), self);
}
@@ -4607,11 +5602,11 @@ static void ffi_closure_dispatch(ffi_cif *cif, void *cret,
static void ffi_closure_dispatch_safe(ffi_cif *cif, void *cret,
void *cargs[], void *clo)
{
- val self = lit("ffi-closure-dispatch-safe");
val closure = coerce(val, clo);
struct txr_ffi_closure *tfcl = ffi_closure_struct(closure);
cnum i, nargs = tfcl->nparam;
struct txr_ffi_call_desc *tfcd = tfcl->tfcd;
+ val self = if3(tfcd->name, tfcd->name, lit("ffi-closure-dispatch-safe"));
val types = tfcd->argtypes;
val rtype = tfcd->rettype;
struct txr_ffi_type *rtft = ffi_type_struct(rtype);
@@ -4620,6 +5615,8 @@ static void ffi_closure_dispatch_safe(ffi_cif *cif, void *cret,
size_t rsize = pad_retval(rtft->size);
uw_frame_t cont_guard;
+ (void) cif;
+
if (rtft->release != 0)
memset(cret, 0, rsize);
@@ -4632,10 +5629,10 @@ static void ffi_closure_dispatch_safe(ffi_cif *cif, void *cret,
{
args_decl(args, nargs);
args_decl(args_cp, nargs);
+ val *type = convert(val *, alloca(nargs * sizeof *type));
for (i = 0; i < nargs; i++) {
- val type = pop(&types);
- struct txr_ffi_type *mtft = ffi_type_struct(type);
+ struct txr_ffi_type *mtft = ffi_type_struct((type[i] = pop(&types)));
val arg = mtft->get(mtft, convert(mem_t *, cargs[i]), self);
args_add(args, arg);
if (mtft->out != 0)
@@ -4647,10 +5644,9 @@ static void ffi_closure_dispatch_safe(ffi_cif *cif, void *cret,
retval = generic_funcall(tfcl->fun, args);
if (out_pass_needed) {
- for (types = tfcd->argtypes, i = 0; i < nargs; i++) {
- val type = pop(&types);
+ for (types = tfcd->argtypes, i = nargs - 1; i >= 0; i--) {
val arg = args_at(args_cp, i);
- struct txr_ffi_type *mtft = ffi_type_struct(type);
+ struct txr_ffi_type *mtft = ffi_type_struct(type[i]);
if (mtft->out != 0)
mtft->out(mtft, 0, arg, convert(mem_t *, cargs[i]), self);
}
@@ -4663,7 +5659,7 @@ static void ffi_closure_dispatch_safe(ffi_cif *cif, void *cret,
s_exit_point = uw_curr_exit_point;
if (s_exit_point) {
if (rtft->release != 0 && retval != nao)
- rtft->release(rtft, retval, convert(mem_t *, cret));
+ rtft->release(rtft, retval, convert(mem_t *, cret), self);
if (!tfcl->abort_retval)
memset(cret, 0, rsize);
else
@@ -4681,11 +5677,12 @@ static void ffi_closure_dispatch_safe(ffi_cif *cif, void *cret,
val ffi_make_closure(val fun, val call_desc, val safe_p_in, val abort_ret_in)
{
- val self = lit("ffi-make-closure");
+ val real_self = lit("ffi-make-closure");
struct txr_ffi_closure *tfcl = coerce(struct txr_ffi_closure *,
chk_calloc(1, sizeof *tfcl));
- struct txr_ffi_call_desc *tfcd = ffi_call_desc_checked(self, call_desc);
- val obj = cobj(coerce(mem_t *, tfcl), ffi_closure_s, &ffi_closure_ops);
+ struct txr_ffi_call_desc *tfcd = ffi_call_desc_checked(real_self, call_desc);
+ val self = if3(tfcd->name, tfcd->name, real_self);
+ val obj = cobj(coerce(mem_t *, tfcl), ffi_closure_cls, &ffi_closure_ops);
val safe_p = default_arg_strict(safe_p_in, t);
ffi_status ffis = FFI_OK;
@@ -4766,7 +5763,7 @@ val ffi_offsetof(val type, val memb)
struct smemb *pmemb = tft->memb + i;
if (pmemb->mname == memb) {
- if (pmemb->mtft->mask != 0)
+ if (pmemb->mtft->bitfield)
uw_throwf(error_s, lit("~a: ~s is a bitfield in ~s"), self,
memb, type, nao);
return num(tft->memb[i].offs);
@@ -4818,8 +5815,8 @@ val ffi_put_into(val dstbuf, val obj, val type, val offset_in)
struct txr_ffi_type *tft = ffi_type_struct_checked(self, type);
mem_t *dst = buf_get(dstbuf, self);
val offset = default_arg(offset_in, zero);
- cnum offsn = c_num(offset);
- cnum room = c_num(minus(length_buf(dstbuf), offset));
+ cnum offsn = c_num(offset, self);
+ cnum room = c_num(minus(length_buf(dstbuf), offset), self);
cnum size = tft->dynsize(tft, obj, self);
if (offsn < 0)
uw_throwf(error_s, lit("~a: negative offset ~s specified"),
@@ -4847,8 +5844,8 @@ val ffi_in(val srcbuf, val obj, val type, val copy_p, val offset_in)
struct txr_ffi_type *tft = ffi_type_struct_checked(self, type);
mem_t *src = buf_get(srcbuf, self);
val offset = default_arg(offset_in, zero);
- cnum offsn = c_num(offset);
- cnum room = c_num(minus(length_buf(srcbuf), offset));
+ cnum offsn = c_num(offset, self);
+ cnum room = c_num(minus(length_buf(srcbuf), offset), self);
cnum size = tft->dynsize(tft, obj, self);
if (offsn < 0)
uw_throwf(error_s, lit("~a: negative offset ~s specified"),
@@ -4869,8 +5866,8 @@ val ffi_get(val srcbuf, val type, val offset_in)
struct txr_ffi_type *tft = ffi_type_struct_checked(self, type);
mem_t *src = buf_get(srcbuf, self);
val offset = default_arg(offset_in, zero);
- cnum offsn = c_num(offset);
- cnum room = c_num(minus(length_buf(srcbuf), offset));
+ cnum offsn = c_num(offset, self);
+ cnum room = c_num(minus(length_buf(srcbuf), offset), self);
if (offsn < 0)
uw_throwf(error_s, lit("~a: negative offset ~s specified"),
self, offset, nao);
@@ -4886,8 +5883,8 @@ val ffi_out(val dstbuf, val obj, val type, val copy_p, val offset_in)
struct txr_ffi_type *tft = ffi_type_struct_checked(self, type);
mem_t *dst = buf_get(dstbuf, self);
val offset = default_arg(offset_in, zero);
- cnum offsn = c_num(offset);
- cnum room = c_num(minus(length_buf(dstbuf), offset));
+ cnum offsn = c_num(offset, self);
+ cnum room = c_num(minus(length_buf(dstbuf), offset), self);
cnum size = tft->dynsize(tft, obj, self);
if (offsn < 0)
uw_throwf(error_s, lit("~a: negative offset ~s specified"),
@@ -4909,7 +5906,10 @@ struct carray {
cnum nelem;
val ref;
cnum offs;
- val artype;
+ val artype[2];
+#if HAVE_MMAP
+ size_t mm_len;
+#endif
};
static struct carray *carray_struct(val carray)
@@ -4919,14 +5919,14 @@ static struct carray *carray_struct(val carray)
static struct carray *carray_struct_checked(val self, val carray)
{
- return coerce(struct carray*, cobj_handle(self, carray, carray_s));
+ return coerce(struct carray*, cobj_handle(self, carray, carray_cls));
}
static void carray_print_op(val obj, val out, val pretty, struct strm_ctx *ctx)
{
struct carray *scry = carray_struct(obj);
put_string(lit("#<"), out);
- obj_print_impl(obj->co.cls, out, pretty, ctx);
+ obj_print_impl(obj->co.cls->cls_sym, out, pretty, ctx);
format(out, lit(" ~a"), if3(scry->nelem < 0,
lit("unknown-len"), num(scry->nelem)), nao);
format(out, lit(" ~s>"), scry->eltype, nao);
@@ -4937,7 +5937,8 @@ static void carray_mark_op(val obj)
struct carray *scry = carray_struct(obj);
gc_mark(scry->eltype);
gc_mark(scry->ref);
- gc_mark(scry->artype);
+ gc_mark(scry->artype[0]);
+ gc_mark(scry->artype[1]);
}
static void carray_destroy_op(val obj)
@@ -4972,24 +5973,27 @@ val make_carray(val type, mem_t *data, cnum nelem, val ref, cnum offs)
scry->data = data;
scry->nelem = nelem;
scry->ref = nil;
- scry->artype = nil;
- obj = cobj(coerce(mem_t *, scry), carray_s, &carray_borrowed_ops);
+ scry->artype[0] = scry->artype[1] = nil;
+ obj = cobj(coerce(mem_t *, scry), carray_cls, &carray_borrowed_ops);
scry->eltype = type;
scry->ref = ref;
scry->offs = offs;
+#if HAVE_MMAP
+ scry->mm_len = 0;
+#endif
return obj;
}
val carrayp(val obj)
{
- return cobjclassp(obj, carray_s);
+ return cobjclassp(obj, carray_cls);
}
val carray_set_length(val carray, val nelem)
{
val self = lit("carray-set-length");
struct carray *scry = carray_struct_checked(self, carray);
- cnum nel = c_num(nelem);
+ cnum nel = c_num(nelem, self);
if (carray->co.ops == &carray_owned_ops)
uw_throwf(error_s,
@@ -5002,6 +6006,7 @@ val carray_set_length(val carray, val nelem)
carray, nao);
scry->nelem = nel;
+ scry->artype[0] = scry->artype[1] = nil;
return nil;
}
@@ -5013,17 +6018,17 @@ val carray_dup(val carray)
if (carray->co.ops == &carray_owned_ops) {
return nil;
} else if (scry->nelem < 0) {
- uw_throwf(error_s, lit("~a: size of ~s array unknown"), self, carray, nao);
+ uw_throwf(error_s, lit("~a: size of ~s carray unknown"), self, carray, nao);
} else if (scry->data == 0) {
- uw_throwf(error_s, lit("~a: ~s: array data pointer is null"),
+ uw_throwf(error_s, lit("~a: ~s: carray data pointer is null"),
self, carray, nao);
} else {
cnum elsize = scry->eltft->size;
- cnum size = (ucnum) scry->nelem * (ucnum) elsize;
+ cnum size = convert(ucnum, scry->nelem) * convert(ucnum, elsize);
mem_t *dup = chk_copy_obj(scry->data, scry->nelem * scry->eltft->size);
if (size < 0 || (elsize > 0 && size / elsize != scry->nelem))
- uw_throwf(error_s, lit("~a: array size overflow"), self, nao);
+ uw_throwf(error_s, lit("~a: carray size overflow"), self, nao);
carray->co.ops = &carray_owned_ops;
scry->data = dup;
@@ -5078,9 +6083,12 @@ val copy_carray(val carray)
{
val self = lit("copy-carray");
struct carray *scry = carray_struct_checked(self, carray);
- val copy = make_carray(scry->eltype, scry->data, scry->nelem, nil, 0);
- carray_dup(copy);
- return copy;
+ if (scry->nelem >= 0) {
+ val copy = make_carray(scry->eltype, scry->data, scry->nelem, nil, 0);
+ carray_dup(copy);
+ return copy;
+ }
+ uw_throwf(error_s, lit("~a: size of ~s carray unknown"), self, carray, nao);
}
mem_t *carray_ptr(val carray, val type, val self)
@@ -5092,11 +6100,32 @@ mem_t *carray_ptr(val carray, val type, val self)
return scry->data;
}
+void carray_set_ptr(val carray, val type, mem_t *ptr, val self)
+{
+ struct carray *scry = carray_struct_checked(self, carray);
+ if (scry->eltype != type)
+ uw_throwf(error_s, lit("~a: ~s is not of element type ~!~s"),
+ self, carray, type, nao);
+ if (carray->co.ops == &carray_borrowed_ops) {
+ /* nothing to do */
+ } else if (carray->co.ops == &carray_owned_ops) {
+ free(scry->data);
+ scry->nelem = 0;
+ carray->co.ops = &carray_borrowed_ops;
+ } else {
+ uw_throwf(error_s, lit("~a: cannot change address of mmapped ~!~s"),
+ self, carray, type, nao);
+ }
+
+ scry->data = ptr;
+}
+
val carray_vec(val vec, val type, val null_term_p)
{
+ val self = lit("carray-vec");
val len = length(vec);
val nt_p = default_null_arg(null_term_p);
- cnum i, l = c_num(if3(nt_p, succ(len), len));
+ cnum i, l = c_num(if3(nt_p, succ(len), len), self);
val carray = carray_blank(len, type);
for (i = 0; i < l; i++) {
@@ -5110,12 +6139,13 @@ val carray_vec(val vec, val type, val null_term_p)
val carray_list(val list, val type, val null_term_p)
{
+ val self = lit("carray-vec");
val nt_p = default_null_arg(null_term_p);
val len = if3(nt_p, succ(length(list)), length(list));
val carray = carray_blank(len, type);
cnum i;
- (void) c_num(len);
+ (void) c_num(len, self);
for (i = 0; !endp(list); list = cdr(list), i++) {
val el = car(list);
@@ -5128,11 +6158,11 @@ val carray_list(val list, val type, val null_term_p)
val carray_blank(val nelem, val type)
{
val self = lit("carray-blank");
- cnum nel = c_num(nelem);
+ cnum nel = c_num(nelem, self);
struct txr_ffi_type *tft = ffi_type_struct_checked(self, type);
if (nel < 0) {
- uw_throwf(error_s, lit("~a: negative array size"), self, nao);
+ uw_throwf(error_s, lit("~a: negative carray size"), self, nao);
} else {
mem_t *data = chk_calloc(nel, tft->size);
val carray = make_carray(type, data, nel, nil, 0);
@@ -5156,8 +6186,8 @@ val carray_buf(val buf, val type, val offs_in)
val self = lit("carray-buf");
mem_t *data = buf_get(buf, self);
val offs = default_arg_strict(offs_in, zero);
- cnum offsn = c_num(offs);
- cnum blen = c_num(minus(length_buf(buf), offs));
+ cnum offsn = c_num(offs, self);
+ cnum blen = c_num(minus(length_buf(buf), offs), self);
struct txr_ffi_type *tft = ffi_type_struct_checked(self, type);
cnum nelem = if3(tft->size, blen / tft->size, 0);
if (offsn < 0)
@@ -5178,7 +6208,7 @@ val carray_buf_sync(val carray)
struct carray *scry = carray_struct_checked(self, carray);
val buf = scry->ref;
mem_t *data = buf_get(buf, self);
- cnum blen = c_num(minus(length_buf(buf), num(scry->offs)));
+ cnum blen = c_num(minus(length_buf(buf), num(scry->offs)), self);
struct txr_ffi_type *tft = ffi_type_struct(scry->eltype);
if (blen < 0)
uw_throwf(error_s,
@@ -5194,19 +6224,30 @@ val buf_carray(val carray)
val self = lit("buf-carray");
struct carray *scry = carray_struct_checked(self, carray);
struct txr_ffi_type *etft = scry->eltft;
- cnum bytes = scry->nelem * etft->size;
- return make_duplicate_buf(num(bytes), scry->data);
+ if (scry->nelem >= 0) {
+ cnum bytes = scry->nelem * etft->size;
+ return make_duplicate_buf(num(bytes), scry->data);
+ }
+ uw_throwf(error_s, lit("~a: size of ~s carray unknown"), self, carray, nao);
}
val carray_cptr(val cptr, val type, val len)
{
val self = lit("carray-cptr");
mem_t *data = cptr_get(cptr);
- cnum nelem = c_num(default_arg(len, negone));
+ cnum nelem = c_num(default_arg(len, negone), self);
(void) ffi_type_struct_checked(self, type);
return make_carray(type, data, nelem, nil, 0);
}
+val cptr_carray(val carray, val type_sym_in)
+{
+ val self = lit("cptr-carray");
+ struct carray *scry = carray_struct_checked(self, carray);
+ val type_sym = default_null_arg(type_sym_in);
+ return cptr_typed(scry->data, type_sym, 0);
+}
+
val vec_carray(val carray, val null_term_p)
{
val self = lit("vec-carray");
@@ -5259,9 +6300,9 @@ val carray_ref(val carray, val idx)
{
val self = lit("carray-ref");
struct carray *scry = carray_struct_checked(self, carray);
- cnum ix = c_num(idx);
+ cnum ix = c_num(idx, self);
- if (ix < 0)
+ if (ix < 0 && scry->nelem >= 0)
ix += scry->nelem;
if (ix < 0 || (scry->nelem >= 0 && ix >= scry->nelem)) {
@@ -5270,7 +6311,7 @@ val carray_ref(val carray, val idx)
} else {
struct txr_ffi_type *eltft = scry->eltft;
if (scry->data == 0)
- uw_throwf(error_s, lit("~a: ~s: array was freed"),
+ uw_throwf(error_s, lit("~a: ~s: carray storage was freed"),
self, carray, nao);
return eltft->get(eltft, scry->data + eltft->size * ix, self);
}
@@ -5280,9 +6321,9 @@ val carray_refset(val carray, val idx, val newval)
{
val self = lit("carray-refset");
struct carray *scry = carray_struct_checked(self, carray);
- cnum ix = c_num(idx);
+ cnum ix = c_num(idx, self);
- if (ix < 0)
+ if (ix < 0 && scry->nelem >= 0)
ix += scry->nelem;
if (ix < 0 || (scry->nelem >= 0 && ix >= scry->nelem)) {
@@ -5291,7 +6332,7 @@ val carray_refset(val carray, val idx, val newval)
} else {
struct txr_ffi_type *eltft = scry->eltft;
if (scry->data == 0)
- uw_throwf(error_s, lit("~a: ~s: array was freed"),
+ uw_throwf(error_s, lit("~a: ~s: carray storage was freed"),
self, carray, nao);
eltft->put(eltft, newval, scry->data + eltft->size * ix, self);
return newval;
@@ -5307,19 +6348,29 @@ val carray_sub(val carray, val from, val to)
if (null_or_missing_p(from))
from = zero;
+ else if (from == t)
+ from = len;
+ else if (minusp(from)) {
+ if (ln < 0)
+ goto nolen;
+ from = plus(from, len);
+ if (to == zero)
+ to = len;
+ }
- if (null_or_missing_p(to))
+ if (null_or_missing_p(to) || to == t) {
+ if (ln < 0)
+ goto nolen;
to = len;
-
- if (minusp(to))
+ } else if (minusp(to)) {
+ if (ln < 0)
+ goto nolen;
to = plus(to, len);
-
- if (minusp(from))
- from = plus(from, len);
+ }
{
- cnum fn = c_num(from);
- cnum tn = c_num(to);
+ cnum fn = c_num(from, self);
+ cnum tn = c_num(to, self);
cnum elsize = scry->eltft->size;
if (fn < 0)
@@ -5339,6 +6390,8 @@ val carray_sub(val carray, val from, val to)
return make_carray(scry->eltype, scry->data + fn * elsize, tn - fn, carray, 0);
}
+nolen:
+ uw_throwf(error_s, lit("~a: operation requires size of ~s to be known"), self, carray, nao);
}
val carray_replace(val carray, val values, val from, val to)
@@ -5350,6 +6403,8 @@ val carray_replace(val carray, val values, val from, val to)
if (null_or_missing_p(from)) {
from = zero;
+ } else if (from == t) {
+ from = len;
} else if (!integerp(from)) {
seq_iter_t wh_iter, item_iter;
val wh, item;
@@ -5362,6 +6417,8 @@ val carray_replace(val carray, val values, val from, val to)
self, nao);
while (seq_get(&wh_iter, &wh) && seq_get(&item_iter, &item)) {
+ if (ln < 0)
+ goto nolen;
if (ge(wh, len))
break;
carray_refset(carray, wh, item);
@@ -5369,22 +6426,31 @@ val carray_replace(val carray, val values, val from, val to)
return carray;
} else if (minusp(from)) {
+ if (ln < 0)
+ goto nolen;
from = plus(from, len);
+ if (to == zero)
+ to = len;
}
- if (null_or_missing_p(to))
+ if (null_or_missing_p(to) || to == t) {
+ if (ln < 0)
+ goto nolen;
to = len;
- else if (minusp(to))
+ } else if (minusp(to)) {
+ if (ln < 0)
+ goto nolen;
to = plus(to, len);
+ }
{
val vlen = length(values);
- cnum fn = c_num(from);
- cnum tn = c_num(to);
+ cnum fn = c_num(from, self);
+ cnum tn = c_num(to, self);
struct txr_ffi_type *eltft = scry->eltft;
cnum elsize = eltft->size;
- cnum size = (ucnum) ln * (ucnum) elsize;
- cnum vn = c_num(vlen);
+ cnum size = convert(ucnum, ln) * convert(ucnum, elsize);
+ cnum vn = c_num(vlen, self);
cnum sn;
mem_t *ptr;
seq_iter_t item_iter;
@@ -5411,7 +6477,7 @@ val carray_replace(val carray, val values, val from, val to)
sn = ln;
if (size < 0 || (ln != 0 && size / elsize != ln) || (sn < fn))
- uw_throwf(error_s, lit("~a: array size overflow"), self, nao);
+ uw_throwf(error_s, lit("~a: carray size overflow"), self, nao);
ptr = scry->data + fn * elsize;
@@ -5427,37 +6493,45 @@ val carray_replace(val carray, val values, val from, val to)
} else if (newrange < oldrange) {
cnum delta = oldrange - newrange;
memmove(ptr + newrange, ptr + oldrange, tail);
- memset(ptr + whole - delta, 0, delta);
+ memset(scry->data + whole - delta, 0, delta);
}
}
- for (; fn < vn; fn++, ptr += elsize) {
+ for (; fn < sn; fn++, ptr += elsize) {
val item = seq_geti(&item_iter);
eltft->put(eltft, item, ptr, self);
}
return carray;
}
+nolen:
+ uw_throwf(error_s, lit("~a: operation requires size of ~s to be known"), self, carray, nao);
}
-static void carray_ensure_artype(val carray, struct carray *scry, val self)
+static void carray_ensure_artype(val carray, struct carray *scry, int null_term, val self)
{
- if (!scry->artype) {
+ if (!scry->artype[null_term]) {
val dim = num(scry->nelem);
- val syntax = list(carray_s, dim, scry->eltft->syntax, nao);
+ val syntax = if3(scry->nelem < 0,
+ list(carray_s, scry->eltft->syntax, nao),
+ list(carray_s, dim, scry->eltft->syntax, nao));
struct txr_ffi_type *etft = scry->eltft;
- set(mkloc(scry->artype, carray), make_ffi_type_array(syntax, vec_s,
- dim, scry->eltype,
- self));
+ set(mkloc(scry->artype[null_term], carray),
+ make_ffi_type_array(syntax, vec_s,
+ dim, scry->eltype,
+ self));
{
- struct txr_ffi_type *atft = ffi_type_struct(scry->artype);
+ struct txr_ffi_type *atft = ffi_type_struct(scry->artype[null_term]);
+
if (etft->syntax == char_s)
atft->ch_conv = conv_char;
else if (etft->syntax == wchar_s)
atft->ch_conv = conv_wchar;
else if (etft->syntax == bchar_s)
atft->ch_conv = conv_bchar;
+
+ atft->null_term = null_term;
}
}
}
@@ -5466,11 +6540,10 @@ static val carray_get_common(val carray, val self, unsigned null_term)
{
struct carray *scry = carray_struct_checked(self, carray);
- carray_ensure_artype(carray, scry, self);
+ carray_ensure_artype(carray, scry, null_term, self);
{
- struct txr_ffi_type *atft = ffi_type_struct(scry->artype);
- atft->null_term = null_term;
+ struct txr_ffi_type *atft = ffi_type_struct(scry->artype[null_term]);
return atft->get(atft, scry->data, self);
}
}
@@ -5479,11 +6552,10 @@ static void carray_put_common(val carray, val seq, val self, unsigned null_term)
{
struct carray *scry = carray_struct_checked(self, carray);
- carray_ensure_artype(carray, scry, self);
+ carray_ensure_artype(carray, scry, null_term, self);
{
- struct txr_ffi_type *atft = ffi_type_struct(scry->artype);
- atft->null_term = null_term;
+ struct txr_ffi_type *atft = ffi_type_struct(scry->artype[null_term]);
return atft->put(atft, seq, scry->data, self);
}
}
@@ -5514,34 +6586,50 @@ val carray_putz(val carray, val seq)
return carray;
}
-val carray_pun(val carray, val type)
+val carray_pun(val carray, val type, val offset_in, val lim_in)
{
val self = lit("carray-pun");
struct carray *scry = carray_struct_checked(self, carray);
struct txr_ffi_type *tft = ffi_type_struct_checked(self, type);
- cnum len = scry->nelem;
- cnum elsize = scry->eltft->size;
- cnum size = (ucnum) len * (ucnum) elsize;
+ ucnum len = scry->nelem;
+ ucnum elsize = scry->eltft->size;
+ ucnum size = len * elsize;
+ ucnum off = if3(missingp(offset_in), 0, c_unum(offset_in, self));
+ ucnum lim = if3(missingp(lim_in), size - off, c_unum(lim_in, self));
carray_elem_check(tft, self);
if (len != 0 && size / elsize != len)
- uw_throwf(error_s, lit("~a: array size overflow"), self, nao);
+ uw_throwf(error_s, lit("~a: carray size overflow"), self, nao);
+
+ if (off > size)
+ uw_throwf(error_s, lit("~a: ~s: offset ~a is out of bounds"),
+ self, carray, unum(off), nao);
+
+ if (off + lim < off)
+ uw_throwf(error_s, lit("~a: ~s: limit ~a from offset ~a wraps around"),
+ self, carray, unum(lim), unum(off), nao);
+
+ if (off + lim > size)
+ uw_throwf(error_s, lit("~a: ~s: limit ~a from offset ~a extends out of bounds"),
+ self, carray, unum(lim), unum(off), nao);
- return make_carray(type, scry->data, size / tft->size, carray, 0);
+ return make_carray(type, scry->data + off, lim / tft->size, carray, 0);
}
val carray_uint(val num, val eltype_in)
{
val self = lit("carray-uint");
val eltype = default_arg(eltype_in, ffi_type_compile(uchar_s));
- struct txr_ffi_type *tft = ffi_type_struct(eltype);
+ struct txr_ffi_type *tft = ffi_type_struct_checked(self, eltype);
carray_elem_check(tft, self);
switch (type(num)) {
- case NUM: case CHR:
- num = bignum(c_num(num));
+ case CHR:
+ return carray_uint(num_fast(c_ch(num)), eltype);
+ case NUM:
+ num = bignum(c_num(num, self));
/* fallthrough */
case BGNUM:
if (minusp(num))
@@ -5570,13 +6658,15 @@ val carray_int(val num, val eltype_in)
{
val self = lit("carray-int");
val eltype = default_arg(eltype_in, ffi_type_compile(uchar_s));
- struct txr_ffi_type *tft = ffi_type_struct(eltype);
+ struct txr_ffi_type *tft = ffi_type_struct_checked(self, eltype);
carray_elem_check(tft, self);
switch (type(num)) {
- case NUM: case CHR:
- num = bignum(c_num(num));
+ case CHR:
+ return carray_int(num_fast(c_ch(num)), eltype);
+ case NUM:
+ num = bignum(c_num(num, self));
/* fallthrough */
case BGNUM:
{
@@ -5585,10 +6675,10 @@ val carray_int(val num, val eltype_in)
val bytes = ash(plus(bits, num_fast(7)), num_fast(-3));
val bitsround = ash(bytes, num_fast(3));
val un = logtrunc(num, bitsround);
- val ube = if3(bignump(un), un, bignum(c_num(un)));
+ val ube = if3(bignump(un), un, bignum(c_num(un, self)));
mp_int *m = mp(ube);
ucnum size = mp_unsigned_bin_size(m);
- ucnum nelem = (c_unum(bytes) + tft->size - 1) / tft->size;
+ ucnum nelem = (c_unum(bytes, self) + tft->size - 1) / tft->size;
mem_t *data = chk_xalloc(nelem, tft->size, self);
ucnum delta = nelem * tft->size - size;
val ca = make_carray(eltype, data, nelem, nil, 0);
@@ -5609,7 +6699,7 @@ val uint_carray(val carray)
val self = lit("uint-carray");
struct carray *scry = carray_struct_checked(self, carray);
struct txr_ffi_type *etft = scry->eltft;
- ucnum size = (ucnum) etft->size * (ucnum) scry->nelem;
+ ucnum size = convert(ucnum, etft->size) * convert(ucnum, scry->nelem);
val ubn = make_bignum();
mp_err mpe = mp_read_unsigned_bin(mp(ubn), scry->data, size);
if (mpe != MP_OKAY)
@@ -5622,7 +6712,7 @@ val int_carray(val carray)
val self = lit("int-carray");
struct carray *scry = carray_struct_checked(self, carray);
struct txr_ffi_type *etft = scry->eltft;
- ucnum size = (ucnum) etft->size * (ucnum) scry->nelem;
+ ucnum size = convert(ucnum, etft->size) * convert(ucnum, scry->nelem);
ucnum bits = size * 8;
val ubn = make_bignum();
mp_err mpe = mp_read_unsigned_bin(mp(ubn), scry->data, size);
@@ -5636,7 +6726,7 @@ val put_carray(val carray, val offs, val stream)
val self = lit("put-carray");
struct carray *scry = carray_struct_checked(self, carray);
struct txr_ffi_type *etft = scry->eltft;
- ucnum size = (ucnum) etft->size * (ucnum) scry->nelem;
+ ucnum size = convert(ucnum, etft->size) * convert(ucnum, scry->nelem);
val buf = make_borrowed_buf(unum(size), scry->data);
val pos = default_arg(offs, zero);
val ret = put_buf(buf, pos, stream);
@@ -5649,7 +6739,7 @@ val fill_carray(val carray, val offs, val stream)
val self = lit("fill-carray");
struct carray *scry = carray_struct_checked(self, carray);
struct txr_ffi_type *etft = scry->eltft;
- ucnum size = (ucnum) etft->size * (ucnum) scry->nelem;
+ ucnum size = convert(ucnum, etft->size) * convert(ucnum, scry->nelem);
val buf = make_borrowed_buf(unum(size), scry->data);
val pos = default_arg(offs, zero);
val ret = fill_buf(buf, pos, stream);
@@ -5657,6 +6747,316 @@ val fill_carray(val carray, val offs, val stream)
return ret;
}
+#if HAVE_MMAP
+
+#ifndef MAP_GROWSDOWN
+#define MAP_GROWSDOWN 0
+#endif
+#ifndef MAP_LOCKED
+#define MAP_LOCKED 0
+#endif
+#ifndef MAP_NORESERVE
+#define MAP_NORESERVE 0
+#endif
+#ifndef MAP_POPULATE
+#define MAP_POPULATE 0
+#endif
+#ifndef MAP_NONBLOCK
+#define MAP_NONBLOCK 0
+#endif
+#ifndef MAP_STACK
+#define MAP_STACK 0
+#endif
+#ifndef MAP_HUGETLB
+#define MAP_HUGETLB 0
+#endif
+#ifndef MAP_SHARED
+#define MAP_SHARED 0
+#endif
+#ifndef MAP_PRIVATE
+#define MAP_PRIVATE 0
+#endif
+#ifndef MAP_FIXED
+#define MAP_FIXED 0
+#endif
+#if !defined MAP_ANON && defined MAP_ANONYMOUS
+#define MAP_ANON MAP_ANONYMOUS
+#elif !defined MAP_ANON
+#define MAP_ANON 0
+#endif
+#ifndef MAP_HUGE_SHIFT
+#define MAP_HUGE_SHIFT 0
+#endif
+#ifndef MAP_HUGE_MASK
+#define MAP_HUGE_MASK 0
+#endif
+
+#ifndef PROT_READ
+#define PROT_READ 0
+#endif
+#ifndef PROT_WRITE
+#define PROT_WRITE 0
+#endif
+#ifndef PROT_EXEC
+#define PROT_EXEC 0
+#endif
+#ifndef PROT_NONE
+#define PROT_NONE 0
+#endif
+#ifndef PROT_GROWSDOWN
+#define PROT_GROWSDOWN 0
+#endif
+#ifndef PROT_GROWSUP
+#define PROT_GROWSUP 0
+#endif
+
+#ifndef MADV_NORMAL
+#define MADV_NORMAL 0
+#endif
+#ifndef MADV_RANDOM
+#define MADV_RANDOM 0
+#endif
+#ifndef MADV_SEQUENTIAL
+#define MADV_SEQUENTIAL 0
+#endif
+#ifndef MADV_WILLNEED
+#define MADV_WILLNEED 0
+#endif
+#ifndef MADV_DONTNEED
+#define MADV_DONTNEED 0
+#endif
+#ifndef MADV_FREE
+#define MADV_FREE 0
+#endif
+#ifndef MADV_REMOVE
+#define MADV_REMOVE 0
+#endif
+#ifndef MADV_DONTFORK
+#define MADV_DONTFORK 0
+#endif
+#ifndef MADV_DOFORK
+#define MADV_DOFORK 0
+#endif
+#ifndef MADV_MERGEABLE
+#define MADV_MERGEABLE 0
+#endif
+#ifndef MADV_UNMERGEABLE
+#define MADV_UNMERGEABLE 0
+#endif
+#ifndef MADV_HUGEPAGE
+#define MADV_HUGEPAGE 0
+#endif
+#ifndef MADV_NOHUGEPAGE
+#define MADV_NOHUGEPAGE 0
+#endif
+#ifndef MADV_DONTDUMP
+#define MADV_DONTDUMP 0
+#endif
+#ifndef MADV_DODUMP
+#define MADV_DODUMP 0
+#endif
+#ifndef MADV_WIPEONFORK
+#define MADV_WIPEONFORK 0
+#endif
+#ifndef MADV_KEEPONFORK
+#define MADV_KEEPONFORK 0
+#endif
+#ifndef MADV_HWPOISON
+#define MADV_HWPOISON 0
+#endif
+
+#ifndef MS_ASYNC
+#define MS_ASYNC 0
+#endif
+#ifndef MS_SYNC
+#define MS_SYNC 0
+#endif
+#ifndef MS_INVALIDATE
+#define MS_INVALIDATE 0
+#endif
+
+static void carray_munmap_op(val obj)
+{
+ struct carray *scry = carray_struct(obj);
+ munmap(scry->data, scry->mm_len);
+ scry->data = 0;
+ free(scry);
+}
+
+static struct cobj_ops carray_mmap_ops =
+ cobj_ops_init(eq,
+ carray_print_op,
+ carray_munmap_op,
+ carray_mark_op,
+ cobj_eq_hash_op);
+
+val mmap_wrap(val type, val len, val prot, val flags,
+ val source_opt, val offset_opt, val addr_opt)
+{
+ val self = lit("mmap");
+ val source = default_null_arg(source_opt);
+ val offset = default_arg_strict(offset_opt, zero);
+ val addr = default_null_arg(addr_opt);
+ void *ad_req = if3(addr, coerce(void *, c_unum(addr, self)), 0);
+ mem_t *ad_out;
+ int fd = -1;
+ ucnum ln = c_unum(len, self);
+ struct txr_ffi_type *tft = ffi_type_struct_checked(self, type);
+ cnum nelem = if3(tft->size, ln / tft->size, 0);
+ int pro = c_int(prot, self);
+ int flg = c_int(flags, self);
+
+ if (!tft->size)
+ uw_throwf(error_s, lit("~a: zero-sized element type ~s specified"),
+ self, type, nao);
+
+ if (streamp(source)) {
+ val fileno = stream_fd(source);
+ if (!fileno)
+ uw_throwf(type_error_s, lit("~a: stream ~s has no file descriptor"),
+ self, source, nao);
+ fd = c_int(fileno, self);
+ } else if (integerp(source)) {
+ fd = c_int(source, self);
+ } else if (stringp(source)) {
+ val mode = if3(pro & PROT_WRITE, lit("r+"), lit("r"));
+ val stream = open_file(source, mode);
+ val map = nil;
+ uw_simple_catch_begin;
+ map = mmap_wrap(type, len, prot, flags, stream, offset_opt, addr_opt);
+ uw_unwind {
+ close_stream(stream, nil);
+ }
+ uw_catch_end;
+ return map;
+ } else if (source) {
+ uw_throwf(type_error_s, lit("~a: unsupported map source object ~s"),
+ self, source, nao);
+ }
+
+ ad_out = coerce(mem_t *,
+ mmap(ad_req, ln, pro, flg, fd, c_u64(offset, self)));
+
+ if (ad_out == MAP_FAILED) {
+ int eno = errno;
+ uw_ethrowf(system_error_s, lit("~a: mmap failed: ~d/~s"),
+ self, num(eno), errno_to_str(eno), nao);
+ } else {
+ val ca = make_carray(type, ad_out, nelem, nil, 0);
+ struct carray *scry = carray_struct(ca);
+ scry->mm_len = ln;
+ ca->co.ops = &carray_mmap_ops;
+ return ca;
+ }
+}
+
+val munmap_wrap(val carray)
+{
+ val self = lit("munmap");
+ struct carray *scry = carray_struct_checked(self, carray);
+
+ if (carray->co.ops != &carray_mmap_ops)
+ uw_throwf(type_error_s, lit("~a: ~s isn't a mmapped carray"),
+ self, carray, nao);
+ if (scry->data != 0) {
+ munmap(scry->data, scry->mm_len);
+ scry->data = 0;
+ return t;
+ }
+
+ return nil;
+}
+
+static val mmap_op(val carray, val offset_in, val size_in,
+ val arg, int (*op_fn)(void *, size_t, int),
+ val self)
+{
+ struct carray *scry = carray_struct_checked(self, carray);
+ size_t off = 0, sz;
+
+ if (carray->co.ops != &carray_mmap_ops)
+ uw_throwf(type_error_s, lit("~a: ~s isn't a mmapped carray"),
+ self, carray, nao);
+
+ if (missingp(offset_in) && missingp(size_in)) {
+ sz = scry->mm_len;
+ } else if (missingp(offset_in)) {
+ sz = c_unum(size_in, self);
+ } else if (missingp(size_in)) {
+ off = c_unum(offset_in, self);
+ sz = scry->mm_len - off;
+ } else {
+ off = c_unum(offset_in, self);
+ sz = c_unum(size_in, self);
+ }
+
+ if (off > scry->mm_len)
+ uw_throwf(error_s, lit("~a: ~s: offset ~s lies beyond ~s byte mapping"),
+ self, carray, unum(off), unum(scry->mm_len), nao);
+
+ if (off + sz < off)
+ uw_throwf(error_s,
+ lit("~a: ~s: size ~s from offset ~s wraps around"),
+ self, carray, unum(sz), unum(off), nao);
+
+ if (off + sz > scry->mm_len)
+ uw_throwf(error_s,
+ lit("~a: ~s: size ~s from offset ~s extends beyond ~s byte mapping"),
+ self, carray, unum(sz), unum(off), unum(scry->mm_len), nao);
+
+ if (op_fn(scry->data + off, sz, c_int(arg, self)) < 0) {
+ int eno = errno;
+ uw_ethrowf(system_error_s, lit("~a: ~s: ~a failed: ~d/~s"),
+ self, carray, self, num(eno), errno_to_str(eno), nao);
+ }
+
+ return t;
+}
+
+val mprotect_wrap(val carray, val prot, val offset, val size)
+{
+ return mmap_op(carray, offset, size, prot, mprotect, lit("mprotect"));
+}
+
+val madvise_wrap(val carray, val advice, val offset, val size)
+{
+ return mmap_op(carray, offset, size, advice, madvise, lit("madvise"));
+}
+
+val msync_wrap(val carray, val flags, val offset, val size)
+{
+ return mmap_op(carray, offset, size, flags, msync, lit("msync"));
+}
+
+#endif
+
+static val cptr_getobj(val cptr, val type_in)
+{
+ val self = lit("cptr-get");
+ mem_t *data = cptr_get(cptr);
+ val type = default_arg(type_in, ffi_type_lookup_checked(self, cptr->cp.cls));
+ struct txr_ffi_type *tft = ffi_type_struct_checked(self, type);
+ if (data != 0)
+ return tft->get(tft, data, self);
+ uw_throwf(type_error_s, lit("~a: ~s is a null pointer"), self, cptr, nao);
+}
+
+static val cptr_out(val cptr, val obj, val type_in)
+{
+ val self = lit("cptr-out");
+ mem_t *data = cptr_get(cptr);
+ val type = default_arg(type_in, ffi_type_lookup_checked(self, cptr->cp.cls));
+ struct txr_ffi_type *tft = ffi_type_struct_checked(self, type);
+ if (data != 0) {
+ if (tft->out != 0)
+ tft->out(tft, 0, obj, data, self);
+ else
+ tft->put(tft, obj, data, self);
+ return obj;
+ }
+ uw_throwf(type_error_s, lit("~a: ~s is a null pointer"), self, cptr, nao);
+}
+
struct uni {
struct txr_ffi_type *tft;
mem_t *data;
@@ -5669,7 +7069,7 @@ static struct uni *uni_struct(val obj)
static struct uni *uni_struct_checked(val self, val obj)
{
- return coerce(struct uni *, cobj_handle(self, obj, union_s));
+ return coerce(struct uni *, cobj_handle(self, obj, union_cls));
}
static void union_destroy_op(val obj)
@@ -5696,7 +7096,7 @@ static struct cobj_ops union_ops =
static val make_union_common(mem_t *data, struct txr_ffi_type *tft)
{
struct uni *us = coerce(struct uni *, chk_calloc(1, sizeof *us));
- val obj = cobj(coerce(mem_t *, us), union_s, &union_ops);
+ val obj = cobj(coerce(mem_t *, us), union_cls, &union_ops);
us->tft = tft;
us->data = data;
return obj;
@@ -5790,12 +7190,12 @@ val union_out(val uni, val memb, val memb_obj)
return memb_obj;
}
-val make_zstruct(val type, struct args *args)
+val make_zstruct(val type, varg args)
{
val self = lit("make-zstruct");
struct txr_ffi_type *tft = ffi_type_struct_checked(self, type);
val pairs = args_get_list(args);
- args_decl(ms_args, 0);
+ args_decl_constsize(ms_args, ARGS_ABS_MIN);
val strct = make_struct(tft->lt, nil, ms_args);
mem_t *zbuf;
char *inited = coerce(char *, zalloca(tft->nelem));
@@ -5918,13 +7318,45 @@ static val dyn_size(val type, val obj)
return num(tft->dynsize(tft, obj, self));
}
+static val mk_jmp_buf(void)
+{
+ val uchar_type = gethash(ffi_typedef_hash, uchar_s);
+ return carray_blank(num_fast(sizeof (jmp_buf)), uchar_type);
+}
+
+static val rt_setjmp(val jmp, val try_fun, val longjmp_fun)
+{
+ val self = lit("setjmp");
+ val uchar_type = gethash(ffi_typedef_hash, uchar_s);
+ mem_t *ptr = carray_ptr(jmp, uchar_type, self);
+ jmp_buf *jbptr = coerce(jmp_buf *, ptr);
+ int res = 0;
+ uw_snapshot_t uws = uw_snapshot();
+
+ if ((res = setjmp(*jbptr)) == 0) {
+ return funcall(try_fun);
+ } else {
+ uw_restore(&uws);
+ return funcall1(longjmp_fun, num(res));
+ }
+}
+
+static val longjmp_wrap(val jmp, val ret)
+{
+ val self = lit("longjmp");
+ val uchar_type = gethash(ffi_typedef_hash, uchar_s);
+ mem_t *ptr = carray_ptr(jmp, uchar_type, self);
+ jmp_buf *jbptr = coerce(jmp_buf *, ptr);
+ int ri = c_int(ret, self);
+ longjmp(*jbptr, ri);
+}
+
void ffi_init(void)
{
prot1(&ffi_typedef_hash);
prot1(&ffi_struct_tag_hash);
uint8_s = intern(lit("uint8"), user_package);
int8_s = intern(lit("int8"), user_package);
- int8_s = intern(lit("int8"), user_package);
uint16_s = intern(lit("uint16"), user_package);
int16_s = intern(lit("int16"), user_package);
uint32_s = intern(lit("uint32"), user_package);
@@ -5966,10 +7398,13 @@ void ffi_init(void)
carray_s = intern(lit("carray"), user_package);
union_s = intern(lit("union"), user_package);
str_d_s = intern(lit("str-d"), user_package);
+ str_s_s = intern(lit("str-s"), user_package);
wstr_s = intern(lit("wstr"), user_package);
wstr_d_s = intern(lit("wstr-d"), user_package);
+ wstr_s_s = intern(lit("wstr-s"), user_package);
bstr_s = intern(lit("bstr"), user_package);
bstr_d_s = intern(lit("bstr-d"), user_package);
+ bstr_s_s = intern(lit("bstr-s"), user_package);
buf_d_s = intern(lit("buf-d"), user_package);
ptr_in_s = intern(lit("ptr-in"), user_package);
ptr_out_s = intern(lit("ptr-out"), user_package);
@@ -5985,15 +7420,22 @@ void ffi_init(void)
enumed_s = intern(lit("enumed"), user_package);
elemtype_s = intern(lit("elemtype"), user_package);
align_s = intern(lit("align"), user_package);
+ pack_s = intern(lit("pack"), user_package);
bool_s = intern(lit("bool"), user_package);
+ jmp_buf_s = intern(lit("jmp-buf"), user_package);
ffi_type_s = intern(lit("ffi-type"), user_package);
ffi_call_desc_s = intern(lit("ffi-call-desc"), user_package);
ffi_closure_s = intern(lit("ffi-closure"), user_package);
+ ffi_type_cls = cobj_register(ffi_type_s);
+ ffi_call_desc_cls = cobj_register(ffi_call_desc_s);
+ ffi_closure_cls = cobj_register(ffi_closure_s);
+ carray_cls = cobj_register(carray_s);
+ union_cls = cobj_register(union_s);
reg_fun(intern(lit("ffi-type-compile"), user_package), func_n1(ffi_type_compile));
reg_fun(intern(lit("ffi-type-operator-p"), user_package), func_n1(ffi_type_operator_p));
reg_fun(intern(lit("ffi-type-p"), user_package), func_n1(ffi_type_p));
#if HAVE_LIBFFI
- reg_fun(intern(lit("ffi-make-call-desc"), user_package), func_n4(ffi_make_call_desc));
+ reg_fun(intern(lit("ffi-make-call-desc"), user_package), func_n5o(ffi_make_call_desc, 4));
reg_fun(intern(lit("ffi-call"), user_package), func_n2v(ffi_call_wrap));
reg_fun(intern(lit("ffi-make-closure"), user_package), func_n4o(ffi_make_closure, 2));
#endif
@@ -6024,6 +7466,7 @@ void ffi_init(void)
reg_fun(intern(lit("carray-buf-sync"), user_package), func_n1(carray_buf_sync));
reg_fun(intern(lit("buf-carray"), user_package), func_n1(buf_carray));
reg_fun(intern(lit("carray-cptr"), user_package), func_n3o(carray_cptr, 2));
+ reg_fun(intern(lit("cptr-carray"), user_package), func_n2o(cptr_carray, 1));
reg_fun(intern(lit("vec-carray"), user_package), func_n2o(vec_carray, 1));
reg_fun(intern(lit("list-carray"), user_package), func_n2o(list_carray, 1));
reg_fun(intern(lit("carray-ref"), user_package), func_n2(carray_ref));
@@ -6034,7 +7477,7 @@ void ffi_init(void)
reg_fun(intern(lit("carray-getz"), user_package), func_n1(carray_getz));
reg_fun(intern(lit("carray-put"), user_package), func_n2(carray_put));
reg_fun(intern(lit("carray-putz"), user_package), func_n2(carray_putz));
- reg_fun(intern(lit("carray-pun"), user_package), func_n2(carray_pun));
+ reg_fun(intern(lit("carray-pun"), user_package), func_n4o(carray_pun, 2));
{
val ca_uint = func_n2o(carray_uint, 1);
val ca_int = func_n2o(carray_int, 1);
@@ -6045,16 +7488,59 @@ void ffi_init(void)
reg_fun(intern(lit("carray-int"), user_package), ca_int);
reg_fun(intern(lit("uint-carray"), user_package), uint_ca);
reg_fun(intern(lit("int-carray"), user_package), int_ca);
-
- if (opt_compat && opt_compat <= 227) {
- reg_fun(intern(lit("carray-unum"), user_package), ca_uint);
- reg_fun(intern(lit("carray-num"), user_package), ca_int);
- reg_fun(intern(lit("unum-carray"), user_package), uint_ca);
- reg_fun(intern(lit("num-carray"), user_package), int_ca);
- }
}
reg_fun(intern(lit("put-carray"), user_package), func_n3o(put_carray, 1));
reg_fun(intern(lit("fill-carray"), user_package), func_n3o(fill_carray, 1));
+ reg_fun(intern(lit("cptr-get"), user_package), func_n2o(cptr_getobj, 1));
+ reg_fun(intern(lit("cptr-out"), user_package), func_n3o(cptr_out, 2));
+#if HAVE_MMAP
+ reg_fun(intern(lit("mmap"), user_package), func_n7o(mmap_wrap, 4));
+ reg_fun(intern(lit("munmap"), user_package), func_n1(munmap_wrap));
+ reg_fun(intern(lit("mprotect"), user_package), func_n4o(mprotect_wrap, 2));
+ reg_fun(intern(lit("madvise"), user_package), func_n4o(madvise_wrap, 2));
+ reg_fun(intern(lit("msync"), user_package), func_n4o(msync_wrap, 2));
+ reg_varl(intern(lit("map-growsdown"), user_package), num_fast(MAP_GROWSDOWN));
+ reg_varl(intern(lit("map-locked"), user_package), num_fast(MAP_LOCKED));
+ reg_varl(intern(lit("map-noreserve"), user_package), num_fast(MAP_NORESERVE));
+ reg_varl(intern(lit("map-populate"), user_package), num_fast(MAP_POPULATE));
+ reg_varl(intern(lit("map-nonblock"), user_package), num_fast(MAP_NONBLOCK));
+ reg_varl(intern(lit("map-stack"), user_package), num_fast(MAP_STACK));
+ reg_varl(intern(lit("map-hugetlb"), user_package), num_fast(MAP_HUGETLB));
+ reg_varl(intern(lit("map-shared"), user_package), num_fast(MAP_SHARED));
+ reg_varl(intern(lit("map-private"), user_package), num_fast(MAP_PRIVATE));
+ reg_varl(intern(lit("map-fixed"), user_package), num_fast(MAP_FIXED));
+ reg_varl(intern(lit("map-anon"), user_package), num_fast(MAP_ANON));
+ reg_varl(intern(lit("map-huge-shift"), user_package), num_fast(MAP_HUGE_SHIFT));
+ reg_varl(intern(lit("map-huge-mask"), user_package), num_fast(MAP_HUGE_MASK));
+ reg_varl(intern(lit("prot-read"), user_package), num_fast(PROT_READ));
+ reg_varl(intern(lit("prot-write"), user_package), num_fast(PROT_WRITE));
+ reg_varl(intern(lit("prot-exec"), user_package), num_fast(PROT_EXEC));
+ reg_varl(intern(lit("prot-none"), user_package), num_fast(PROT_NONE));
+ reg_varl(intern(lit("prot-growsdown"), user_package), num_fast(PROT_GROWSDOWN));
+ reg_varl(intern(lit("prot-growsup"), user_package), num_fast(PROT_GROWSUP));
+ reg_varl(intern(lit("madv-normal"), user_package), num_fast(MADV_NORMAL));
+ reg_varl(intern(lit("madv-random"), user_package), num_fast(MADV_RANDOM));
+ reg_varl(intern(lit("madv-sequential"), user_package), num_fast(MADV_SEQUENTIAL));
+ reg_varl(intern(lit("madv-willneed"), user_package), num_fast(MADV_WILLNEED));
+ reg_varl(intern(lit("madv-dontneed"), user_package), num_fast(MADV_DONTNEED));
+ reg_varl(intern(lit("madv-free"), user_package), num_fast(MADV_FREE));
+ reg_varl(intern(lit("madv-remove"), user_package), num_fast(MADV_REMOVE));
+ reg_varl(intern(lit("madv-dontfork"), user_package), num_fast(MADV_DONTFORK));
+ reg_varl(intern(lit("madv-dofork"), user_package), num_fast(MADV_DOFORK));
+ reg_varl(intern(lit("madv-mergeable"), user_package), num_fast(MADV_MERGEABLE));
+ reg_varl(intern(lit("madv-unmergeable"), user_package), num_fast(MADV_UNMERGEABLE));
+ reg_varl(intern(lit("madv-hugepage"), user_package), num_fast(MADV_HUGEPAGE));
+ reg_varl(intern(lit("madv-nohugepage"), user_package), num_fast(MADV_NOHUGEPAGE));
+ reg_varl(intern(lit("madv-dontdump"), user_package), num_fast(MADV_DONTDUMP));
+ reg_varl(intern(lit("madv-dodump"), user_package), num_fast(MADV_DODUMP));
+ reg_varl(intern(lit("madv-wipeonfork"), user_package), num_fast(MADV_WIPEONFORK));
+ reg_varl(intern(lit("madv-keeponfork"), user_package), num_fast(MADV_KEEPONFORK));
+ reg_varl(intern(lit("madv-hwpoison"), user_package), num_fast(MADV_HWPOISON));
+ reg_varl(intern(lit("ms-async"), user_package), num_fast(MS_ASYNC));
+ reg_varl(intern(lit("ms-sync"), user_package), num_fast(MS_SYNC));
+ reg_varl(intern(lit("ms-invalidate"), user_package), num_fast(MS_INVALIDATE));
+ reg_varl(intern(lit("page-size"), user_package), num_fast(sysconf(_SC_PAGESIZE)));
+#endif
reg_fun(intern(lit("make-union"), user_package), func_n3o(make_union, 1));
reg_fun(intern(lit("union-members"), user_package), func_n1(union_members));
reg_fun(intern(lit("union-get"), user_package), func_n2(union_get));
@@ -6067,8 +7553,26 @@ void ffi_init(void)
reg_fun(intern(lit("get-obj"), user_package), func_n2o(get_obj, 1));
reg_fun(intern(lit("fill-obj"), user_package), func_n3o(fill_obj, 2));
reg_fun(intern(lit("dyn-size"), system_package), func_n2(dyn_size));
- ffi_typedef_hash = make_hash(nil, nil, nil);
- ffi_struct_tag_hash = make_hash(nil, nil, nil);
+ reg_fun(jmp_buf_s, func_n0(mk_jmp_buf));
+ reg_fun(intern(lit("rt-setjmp"), system_package), func_n3(rt_setjmp));
+ reg_fun(intern(lit("longjmp"), user_package), func_n2(longjmp_wrap));
+ ffi_typedef_hash = make_hash(hash_weak_none, nil);
+ ffi_struct_tag_hash = make_hash(hash_weak_none, nil);
ffi_init_types();
ffi_init_extra_types();
}
+
+void ffi_compat_fixup(int compat_ver)
+{
+ if (compat_ver <= 227) {
+ val ca_uint = func_n2o(carray_uint, 1);
+ val ca_int = func_n2o(carray_int, 1);
+ val uint_ca = func_n1(uint_carray);
+ val int_ca = func_n1(int_carray);
+
+ reg_fun(intern(lit("carray-unum"), user_package), ca_uint);
+ reg_fun(intern(lit("carray-num"), user_package), ca_int);
+ reg_fun(intern(lit("unum-carray"), user_package), uint_ca);
+ reg_fun(intern(lit("num-carray"), user_package), int_ca);
+ }
+}
diff --git a/ffi.h b/ffi.h
index c16de4a6..1b863359 100644
--- a/ffi.h
+++ b/ffi.h
@@ -1,4 +1,4 @@
-/* Copyright 2017-2020
+/* Copyright 2017-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,25 +6,28 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
+struct txr_ffi_type;
+
extern val uint8_s, int8_s;
extern val uint16_s, int16_s;
extern val uint32_s, int32_s;
@@ -69,12 +72,23 @@ extern val align_s;
extern val bool_s;
+extern val jmp_buf_s;
+
extern val ffi_type_s, ffi_call_desc_s, ffi_closure_s;
+extern struct cobj_class *carray_cls;
+
+struct txr_ffi_type *ffi_type_struct_checked(val self, val typeobj);
+cnum ffi_type_size(struct txr_ffi_type *);
+void ffi_type_put(struct txr_ffi_type *, val obj, mem_t *dst, val self);
+val ffi_type_get(struct txr_ffi_type *, mem_t *src, val self);
+
val ffi_type_compile(val syntax);
+val ffi_type_lookup(val sym);
val ffi_type_operator_p(val sym);
val ffi_type_p(val sym);
-val ffi_make_call_desc(val ntotal, val nfixed, val rettype, val argtypes);
+val ffi_make_call_desc(val ntotal, val nfixed, val rettype, val argtypes,
+ val name);
val ffi_make_closure(val fun, val call_desc, val safe_p_in, val abort_ret_in);
mem_t *ffi_closure_get_fptr(val self, val closure);
val ffi_call_wrap(val fptr, val ffi_call_desc, struct args *args);
@@ -100,6 +114,7 @@ val carray_type(val carray);
val length_carray(val carray);
val copy_carray(val carray);
mem_t *carray_ptr(val carray, val type, val self);
+void carray_set_ptr(val carray, val type, mem_t *ptr, val self);
val carray_vec(val vec, val type, val null_term_p);
val carray_list(val list, val type, val null_term_p);
val carray_blank(val nelem, val type);
@@ -107,6 +122,7 @@ val carray_buf(val buf, val type, val offs);
val carray_buf_sync(val carray);
val buf_carray(val carray);
val carray_cptr(val cptr, val type, val len);
+val cptr_carray(val carray, val type_sym_in);
val vec_carray(val carray, val null_term_p);
val list_carray(val carray, val null_term_p);
val carray_ref(val carray, val idx);
@@ -118,13 +134,21 @@ val carray_get(val carray);
val carray_getz(val carray);
val carray_put(val array, val seq);
val carray_putz(val array, val seq);
-val carray_pun(val carray, val type);
+val carray_pun(val carray, val type, val offset_in, val lim_in);
val carray_uint(val num, val type);
val carray_int(val num, val type);
val uint_carray(val carray);
val int_carray(val carray);
val put_carray(val carray, val offs, val stream);
val fill_carray(val carray, val offs, val stream);
+#if HAVE_MMAP
+val mmap_wrap(val type, val len, val prot, val flags,
+ val source_opt, val offset_opt, val addr_opt);
+val munmap_wrap(val carray);
+val mprotect_wrap(val carray, val prot, val offset, val size);
+val madvise_wrap(val carray, val advice, val offset, val size);
+val msync_wrap(val carray, val flags, val offset, val size);
+#endif
mem_t *union_get_ptr(val self, val uni);
val make_union(val type, val init, val memb);
val union_members(val uni);
@@ -137,4 +161,6 @@ val zero_fill(val type, val obj);
val put_obj(val obj, val type, val stream);
val get_obj(val type, val stream);
val fill_obj(val obj, val type, val stream);
+val ffi_type_by_size(int unsig, size_t size);
void ffi_init(void);
+void ffi_compat_fixup(int compat_ver);
diff --git a/filter.c b/filter.c
index 37e7bb8b..36b7a915 100644
--- a/filter.c
+++ b/filter.c
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <string.h>
@@ -52,7 +53,7 @@ val tonumber_k, toint_k, tofloat_k, hextoint_k;
static val make_trie(void)
{
- return make_hash(nil, nil, nil);
+ return make_hash(hash_weak_none, nil);
}
static val trie_add(val trie, val key, val value)
@@ -64,7 +65,7 @@ static val trie_add(val trie, val key, val value)
val newnode_p;
loc place = gethash_l(lit("trie-add"), node, ch, mkcloc(newnode_p));
if (newnode_p)
- set(place, make_hash(nil, nil, nil));
+ set(place, make_hash(hash_weak_none, nil));
node = deref(place);
}
@@ -121,7 +122,7 @@ static val regex_from_trie(val trie)
{
switch (type(trie)) {
case NIL:
- return nil;
+ return t;
case CONS:
{
val a = car(trie);
@@ -135,7 +136,7 @@ static val regex_from_trie(val trie)
return list(compound_s, a, rx, nao);
}
case COBJ:
- if (d->co.cls == hash_s)
+ if (d->co.cls == hash_cls)
return list(compound_s, a, regex_from_trie(d), nao);
/* fallthrough */
default:
@@ -143,24 +144,31 @@ static val regex_from_trie(val trie)
}
}
case COBJ:
- if (trie->co.cls == hash_s) {
+ if (trie->co.cls == hash_cls) {
if (zerop(hash_count(trie))) {
- return nil;
+ return tnil(!get_hash_userdata(trie));
} else {
- list_collect_decl (out, ptail);
+ val out = nil;
val cell;
struct hash_iter hi;
us_hash_iter_init(&hi, trie);
while ((cell = hash_iter_next(&hi)) != nil) {
- val rx = regex_from_trie(us_cdr(cell));
- ptail = list_collect(ptail,
- if3(consp(rx) && car(rx) == compound_s,
- cons(compound_s, cons(us_car(cell), cdr(rx))),
- list(compound_s, us_car(cell), rx, nao)));
+ val a = us_car(cell);
+ val d = us_cdr(cell);
+ val rx = if2(consp(d) || hashp(d), regex_from_trie(d));
+ val ry = if3(consp(rx) && car(rx) == compound_s,
+ cons(compound_s, cons(a, cdr(rx))),
+ if3(rx, list(compound_s, a, rx, nao), a));
+ if (out)
+ out = list(or_s, ry, out, nao);
+ else
+ out = ry;
}
- return cons(or_s, out);
+ if (get_hash_userdata(trie))
+ out = list(or_s, nil, out, nao);
+ return out;
}
}
/* fallthrough */
@@ -284,12 +292,10 @@ static val trie_filter_string(val filter, val str)
}
if (match) {
- if (!stringp(subst) && chrp(subst))
- subst = tostringp(subst);
- string_extend(out, subst);
+ string_extend(out, subst, nil);
i = plus(match, one);
} else {
- string_extend(out, chr_str(str, i));
+ string_extend(out, chr_str(str, i), nil);
i = plus(i, one);
}
}
@@ -299,6 +305,8 @@ static val trie_filter_string(val filter, val str)
val filter_string_tree(val filter, val obj)
{
+ val self = lit("filter-string-tree");
+
switch (type(obj)) {
case NIL:
return nil;
@@ -314,8 +322,8 @@ val filter_string_tree(val filter, val obj)
return trie_filter_string(filter, obj);
else if (type == fun_s)
return funcall1(filter, obj);
- return obj;
- uw_throwf(error_s, lit("invalid filter ~a"), filter, nao);
+ uw_throwf(type_error_s, lit("~a: ~s isn't a filter"),
+ self, filter, nao);
}
}
}
@@ -676,12 +684,13 @@ static int is_url_reserved(int ch)
val url_encode(val str, val space_plus)
{
+ val self = lit("url-encode");
val in_byte = make_string_byte_input_stream(str);
val out = make_string_output_stream();
val ch;
while ((ch = get_byte(in_byte)) != nil) {
- int c = c_num(ch);
+ int c = c_num(ch, self);
if (space_plus && c == ' ')
put_char(chr('+'), out);
@@ -696,6 +705,7 @@ val url_encode(val str, val space_plus)
val url_decode(val str, val space_plus)
{
+ val self = lit("url-encode");
val in = make_string_input_stream(str);
val out = make_string_output_stream();
@@ -707,7 +717,7 @@ val url_decode(val str, val space_plus)
val ch3 = get_char(in);
if (ch2 && ch3 && chr_isxdigit(ch2) && chr_isxdigit(ch3)) {
- int byte = digit_value(c_num(ch2)) << 4 | digit_value(c_num(ch3));
+ int byte = digit_value(c_num(ch2, self)) << 4 | digit_value(c_num(ch3, self));
put_byte(num_fast(byte), out);
} else {
put_char(ch, out);
@@ -744,12 +754,13 @@ INLINE void col_check(cnum *pcol, cnum wcol, val out)
static val base64_stream_enc_impl(val out, val in, val nbytes, val wrap_cols,
const char *b64)
{
+ val self = lit("base64-stream-enc");
int ulim = nilp(default_null_arg(nbytes));
cnum col = 0;
- cnum nb = if3(ulim, 0, c_num(nbytes));
+ cnum nb = if3(ulim, 0, c_num(nbytes, self));
cnum count = 0;
val ret = zero;
- cnum wcol = c_num(default_arg(wrap_cols, zero));
+ cnum wcol = c_num(default_arg(wrap_cols, zero), self);
for (; ulim || nb > 0; ulim ? --nb : 0) {
val bv0 = get_byte(in);
@@ -757,9 +768,9 @@ static val base64_stream_enc_impl(val out, val in, val nbytes, val wrap_cols,
val bv2 = if2(bv1 && (ulim || --nb > 0), get_byte(in));
if (bv2) {
- cnum b0 = c_num(bv0);
- cnum b1 = c_num(bv1);
- cnum b2 = c_num(bv2);
+ cnum b0 = c_num(bv0, self);
+ cnum b1 = c_num(bv1, self);
+ cnum b2 = c_num(bv2, self);
cnum word = (b0 << 16) | (b1 << 8) | b2;
put_char(chr(b64[(word >> 18) ]), out); col_check(&col, wcol, out);
put_char(chr(b64[(word >> 12) & 0x3F]), out); col_check(&col, wcol, out);
@@ -767,8 +778,8 @@ static val base64_stream_enc_impl(val out, val in, val nbytes, val wrap_cols,
put_char(chr(b64[(word ) & 0x3F]), out); col_check(&col, wcol, out);
count += 3;
} else if (bv1) {
- cnum b0 = c_num(bv0);
- cnum b1 = c_num(bv1);
+ cnum b0 = c_num(bv0, self);
+ cnum b1 = c_num(bv1, self);
cnum word = (b0 << 16) | (b1 << 8);
put_char(chr(b64[(word >> 18) ]), out); col_check(&col, wcol, out);
put_char(chr(b64[(word >> 12) & 0x3F]), out); col_check(&col, wcol, out);
@@ -777,7 +788,7 @@ static val base64_stream_enc_impl(val out, val in, val nbytes, val wrap_cols,
count += 2;
break;
} else if (bv0) {
- cnum b0 = c_num(bv0);
+ cnum b0 = c_num(bv0, self);
cnum word = (b0 << 16);
put_char(chr(b64[(word >> 18) ]), out); col_check(&col, wcol, out);
put_char(chr(b64[(word >> 12) & 0x3F]), out); col_check(&col, wcol, out);
@@ -1024,7 +1035,7 @@ static val html_decode(val str)
void filter_init(void)
{
- val fh = make_hash(nil, nil, nil);
+ val fh = make_hash(hash_weak_none, nil);
filters_s = intern(lit("*filters*"), user_package);
filter_k = intern(lit("filter"), keyword_package);
diff --git a/filter.h b/filter.h
index d4b37ea2..6ef5c129 100644
--- a/filter.h
+++ b/filter.h
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#define filters (deref(lookup_var_l(nil, filters_s)))
diff --git a/ftw.c b/ftw.c
index 537e6d4f..712ccc71 100644
--- a/ftw.c
+++ b/ftw.c
@@ -1,4 +1,4 @@
-/* Copyright 2016-2020
+/* Copyright 2016-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,26 +6,26 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
-#include <stdarg.h>
#include <wchar.h>
#include <signal.h>
#include <stdlib.h>
@@ -43,6 +43,7 @@
#include "signal.h"
#include "unwind.h"
#include "sysif.h"
+#include "txr.h"
#include "ftw.h"
#define max(a, b) ((a) > (b) ? (a) : (b))
@@ -53,6 +54,7 @@ static uw_frame_t *s_exit_point;
static int ftw_callback(const char *c_path, const struct stat *c_sb,
int c_type, struct FTW *fb)
{
+ val self = lit("ftw");
int c_result = 1;
uw_frame_t cont_guard;
@@ -65,15 +67,15 @@ static int ftw_callback(const char *c_path, const struct stat *c_sb,
{
val path = string_utf8(c_path);
val type = num(c_type);
- val sb = stat_to_struct(*c_sb, path);
+ val sb = stat_to_struct(*c_sb, path, nil);
val level = num(fb->level);
val base = num(fb->base);
val result;
- args_decl(args, max(ARGS_MIN, 5));
+ args_decl_constsize(args, max(ARGS_MIN, 5));
args_add5(args, path, type, sb, level, base);
result = generic_funcall(s_callback, args);
- c_result = if3(integerp(result), c_num(result), 0);
+ c_result = if3(integerp(result), c_num(result, self), 0);
}
uw_unwind {
@@ -90,9 +92,12 @@ static int ftw_callback(const char *c_path, const struct stat *c_sb,
val ftw_wrap(val dirpath, val fn, val flags_in, val nopenfd_in)
{
+ val self = lit("ftw");
+
if (s_callback) {
- uw_throwf(error_s, lit("ftw: cannot be re-entered from "
- "ftw callback"), nao);
+ uw_throwf(error_s,
+ lit("~a: cannot be re-entered from ~a callback"),
+ self, self, nao);
} else if (dirpath == nil) {
return t;
} else if (consp(dirpath)) {
@@ -106,9 +111,10 @@ val ftw_wrap(val dirpath, val fn, val flags_in, val nopenfd_in)
}
return ret;
} else {
- int nopenfd = c_num(default_arg(nopenfd_in, num_fast(20)));
- int flags = c_num(default_arg(flags_in, zero));
- char *dirpath_u8 = utf8_dup_to(c_str(dirpath));
+ int nopenfd = c_num(default_arg(nopenfd_in, num_fast(20)), self);
+ val flags_dfl = if3(opt_compat && opt_compat <= 283, zero, num(FTW_PHYS));
+ int flags = c_num(default_arg(flags_in, flags_dfl), self);
+ char *dirpath_u8 = utf8_dup_to(c_str(dirpath, self));
int res = (s_callback = fn,
nftw(dirpath_u8, ftw_callback, nopenfd, flags));
s_callback = nil;
@@ -126,8 +132,8 @@ val ftw_wrap(val dirpath, val fn, val flags_in, val nopenfd_in)
case -1:
{
int eno = errno;
- uw_throwf(errno_to_file_error(eno), lit("ftw ~a: ~d/~s"),
- dirpath, num(eno), string_utf8(strerror(eno)), nao);
+ uw_ethrowf(errno_to_file_error(eno), lit("~a ~a: ~d/~s"),
+ self, dirpath, num(eno), errno_to_str(eno), nao);
}
default:
return num(res);
@@ -140,9 +146,7 @@ void ftw_init(void)
prot1(&s_callback);
/* ftw flags */
-#ifdef FTW_PHYS
reg_varl(intern(lit("ftw-phys"), user_package), num_fast(FTW_PHYS));
-#endif
#ifdef FTW_MOUNT
reg_varl(intern(lit("ftw-mount"), user_package), num_fast(FTW_MOUNT));
#endif
diff --git a/ftw.h b/ftw.h
index 164bab92..98a609b3 100644
--- a/ftw.h
+++ b/ftw.h
@@ -1,4 +1,4 @@
-/* Copyright 2016-2020
+/* Copyright 2016-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
val ftw_wrap(val dirpath, val fn, val nopenfd, val flags);
diff --git a/gc.c b/gc.c
index a945f7fd..bf5482f7 100644
--- a/gc.c
+++ b/gc.c
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,28 +6,30 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stdio.h>
#include <stdlib.h>
#include <stdarg.h>
+#include <stddef.h>
#include <assert.h>
#include <wchar.h>
#include <signal.h>
@@ -36,10 +38,12 @@
#if HAVE_VALGRIND
#include <valgrind/memcheck.h>
#endif
+#if HAVE_RLIMIT
+#include <sys/resource.h>
+#endif
#include "lib.h"
#include "stream.h"
#include "hash.h"
-#include "txr.h"
#include "eval.h"
#include "gc.h"
#include "signal.h"
@@ -55,6 +59,7 @@
#define FULL_GC_INTERVAL 20
#define FRESHOBJ_VEC_SIZE (2 * HEAP_SIZE)
#define DFL_MALLOC_DELTA_THRESH (16L * 1024 * 1024)
+#define DFL_STACK_LIMIT (128 * 1024L)
#else
#define HEAP_SIZE 16384
#define CHECKOBJ_VEC_SIZE (2 * HEAP_SIZE)
@@ -62,8 +67,11 @@
#define FULL_GC_INTERVAL 40
#define FRESHOBJ_VEC_SIZE (8 * HEAP_SIZE)
#define DFL_MALLOC_DELTA_THRESH (64L * 1024 * 1024)
+#define DFL_STACK_LIMIT (16384 * 1024L)
#endif
+#define MIN_STACK_LIMIT 32768
+
#if HAVE_MEMALIGN || HAVE_POSIX_MEMALIGN
#define OBJ_ALIGN (sizeof (obj_t))
#else
@@ -73,6 +81,9 @@
typedef struct heap {
obj_t block[HEAP_SIZE];
struct heap *next;
+#if CONFIG_NAN_BOXING_STRIP_TAG
+ ucnum tag;
+#endif
} heap_t;
typedef struct mach_context {
@@ -85,7 +96,9 @@ int opt_gc_debug;
#if HAVE_VALGRIND
int opt_vg_debug;
#endif
-static val *gc_stack_bottom;
+
+val *gc_stack_bottom;
+val *gc_stack_limit;
static val *prot_stack[PROT_STACK_SIZE];
static val **prot_stack_limit = prot_stack + PROT_STACK_SIZE;
@@ -123,6 +136,14 @@ int full_gc;
val break_obj;
#endif
+struct prot_array {
+ cnum size;
+ val self;
+ val arr[FLEX_ARRAY];
+};
+
+struct cobj_class *prot_array_cls;
+
val prot1(val *loc)
{
assert (gc_prot_top < prot_stack_limit);
@@ -147,9 +168,18 @@ void protect(val *first, ...)
static void more(void)
{
+#if CONFIG_NAN_BOXING_STRIP_TAG
+ ucnum tagged_ptr = coerce(cnum, chk_malloc_gc_more(sizeof (heap_t)));
+ heap_t *heap = coerce(heap_t *, tagged_ptr & ~TAG_BIGMASK);
+#else
heap_t *heap = coerce(heap_t *, chk_malloc_gc_more(sizeof *heap));
+#endif
obj_t *block = heap->block, *end = heap->block + HEAP_SIZE;
+#if CONFIG_NAN_BOXING_STRIP_TAG
+ heap->tag = tagged_ptr >> TAG_BIGSHIFT;
+#endif
+
if (free_list == 0)
free_tail = &heap->block[0].t.next;
@@ -221,6 +251,7 @@ val make_obj(void)
#endif
#if CONFIG_GEN_GC
ret->t.gen = 0;
+ ret->t.fincount = 0;
if (!full_gc)
freshobj[freshobj_idx++] = ret;
#endif
@@ -259,6 +290,17 @@ val make_obj(void)
abort();
}
+val copy_obj(val orig)
+{
+ val copy = make_obj();
+ *copy = *orig;
+#if CONFIG_GEN_GC
+ copy->t.fincount = 0;
+ copy->t.gen = 0;
+#endif
+ return copy;
+}
+
static void finalize(val obj)
{
switch (convert(type_t, obj->t.type)) {
@@ -316,6 +358,7 @@ static void finalize(val obj)
void cobj_destroy_stub_op(val obj)
{
+ (void) obj;
}
void cobj_destroy_free_op(val obj)
@@ -325,6 +368,7 @@ void cobj_destroy_free_op(val obj)
static void mark_obj(val obj)
{
+ val self = lit("gc");
type_t t;
tail_call:
@@ -374,8 +418,7 @@ tail_call:
mark_obj(obj->c.car);
mark_obj_tail(obj->c.cdr);
case STR:
- mark_obj(obj->st.len);
- mark_obj_tail(obj->st.alloc);
+ mark_obj_tail(obj->st.len);
case SYM:
mark_obj(obj->s.name);
mark_obj_tail(obj->s.package);
@@ -397,7 +440,7 @@ tail_call:
{
val alloc_size = obj->v.vec[vec_alloc];
val len = obj->v.vec[vec_length];
- cnum i, fp = c_num(len);
+ cnum i, fp = c_num(len, self);
mark_obj(alloc_size);
mark_obj(len);
@@ -416,9 +459,11 @@ tail_call:
mark_obj(obj->ls.props->term);
mark_obj_tail(obj->ls.list);
case COBJ:
+ obj->co.ops->mark(obj);
+ return;
case CPTR:
obj->co.ops->mark(obj);
- mark_obj_tail(obj->co.cls);
+ mark_obj_tail(obj->cp.cls);
case ENV:
mark_obj(obj->e.vbindings);
mark_obj(obj->e.fbindings);
@@ -435,7 +480,7 @@ tail_call:
mark_obj_tail(obj->tn.key);
case DARG:
{
- struct args *args = obj->a.args;
+ varg args = obj->a.args;
cnum i, n = args->fill;
val *arg = args->arg;
@@ -452,8 +497,46 @@ tail_call:
assert (0 && "corrupt type field");
}
+static void mark_obj_norec(val obj)
+{
+ type_t t;
+
+ if (!is_ptr(obj))
+ return;
+
+ t = obj->t.type;
+
+ if ((t & REACHABLE) != 0)
+ return;
+
+#if CONFIG_GEN_GC
+ if (!full_gc && obj->t.gen > 0)
+ return;
+#endif
+
+ if ((t & FREE) != 0)
+ abort();
+
+#if CONFIG_GEN_GC
+ if (obj->t.gen == -1)
+ obj->t.gen = 0; /* Will be promoted to generation 1 by sweep_one */
+#endif
+
+ obj->t.type = convert(type_t, t | REACHABLE);
+
+#if CONFIG_EXTRA_DEBUGGING
+ if (obj == break_obj) {
+#if HAVE_VALGRIND
+ VALGRIND_PRINTF_BACKTRACE("object %p marked\n", convert(void *, obj));
+#endif
+ breakpt();
+ }
+#endif
+}
+
void cobj_mark_op(val obj)
{
+ (void) obj;
}
static int in_heap(val ptr)
@@ -490,11 +573,12 @@ static void mark_obj_maybe(val maybe_obj)
VALGRIND_MAKE_MEM_DEFINED(&maybe_obj, sizeof maybe_obj);
#endif
if (in_heap(maybe_obj)) {
+ type_t t;
#if HAVE_VALGRIND
if (opt_vg_debug)
VALGRIND_MAKE_MEM_DEFINED(maybe_obj, SIZEOF_PTR);
#endif
- type_t t = maybe_obj->t.type;
+ t = maybe_obj->t.type;
if ((t & FREE) == 0) {
mark_obj(maybe_obj);
} else {
@@ -518,7 +602,7 @@ static void mark_mem_region(val *low, val *high)
mark_obj_maybe(*low);
}
-static void mark(val *gc_stack_top)
+NOINLINE static void mark(val *gc_stack_top)
{
val **rootloc;
@@ -624,7 +708,7 @@ static int sweep_one(obj_t *block)
return 1;
}
-static int_ptr_t sweep(void)
+NOINLINE static int_ptr_t sweep(void)
{
int_ptr_t free_count = 0;
heap_t **pph;
@@ -692,7 +776,12 @@ static int_ptr_t sweep(void)
}
}
*pph = heap->next;
+#if CONFIG_NAN_BOXING_STRIP_TAG
+ free(coerce(heap_t *, coerce(ucnum, heap) | (heap->tag << TAG_BIGSHIFT)));
+#else
free(heap);
+#endif
+
#if HAVE_VALGRIND
if (vg_dbg) {
val iter, next;
@@ -730,7 +819,7 @@ static int is_reachable(val obj)
return (t & REACHABLE) != 0;
}
-static void prepare_finals(void)
+NOINLINE static void prepare_finals(void)
{
struct fin_reg *f;
@@ -742,9 +831,6 @@ static void prepare_finals(void)
for (f = final_list; f; f = f->next) {
if (!f->reachable) {
-#if CONFIG_GEN_GC
- f->obj->t.gen = 0;
-#endif
mark_obj(f->obj);
}
mark_obj(f->fun);
@@ -754,47 +840,53 @@ static void prepare_finals(void)
static val call_finalizers_impl(val ctx,
int (*should_call)(struct fin_reg *, val))
{
- struct fin_reg *f, **tail;
- struct fin_reg *found = 0, **ftail = &found;
val ret = nil;
- if (!final_list)
- return ret;
+ for (;;) {
+ struct fin_reg *f, **tail;
+ struct fin_reg *found = 0, **ftail = &found;
- for (f = final_list, tail = &final_list; f; ) {
- struct fin_reg *next = f->next;
+ for (f = final_list, tail = &final_list; f; ) {
+ struct fin_reg *next = f->next;
- if (should_call(f, ctx)) {
- *ftail = f;
- ftail = &f->next;
- f->next = 0;
- } else {
- *tail = f;
- tail = &f->next;
+ if (should_call(f, ctx)) {
+ *ftail = f;
+ ftail = &f->next;
+ } else {
+ *tail = f;
+ tail = &f->next;
+ }
+
+ f = next;
}
- f = next;
- }
+ *ftail = 0;
+ *tail = 0;
+ final_tail = tail;
- *tail = 0;
- final_tail = tail;
+ if (!found)
+ break;
- while (found) {
- struct fin_reg *next = found->next;
- val obj = found->obj;
- funcall1(found->fun, obj);
+ do {
+ struct fin_reg *next = found->next;
+ val obj = found->obj;
+ funcall1(found->fun, obj);
#if CONFIG_GEN_GC
- /* Note: here an object may be added to freshobj more than once, since
- * multiple finalizers can be registered.
- */
- if (freshobj_idx < FRESHOBJ_VEC_SIZE && obj->t.gen == 0)
- freshobj[freshobj_idx++] = obj;
- else
- full_gc = 1;
+ if (--obj->t.fincount == 0 && inprogress &&
+ !full_gc && !found->reachable)
+ {
+ if (freshobj_idx < FRESHOBJ_VEC_SIZE) {
+ obj->t.gen = 0;
+ freshobj[freshobj_idx++] = obj;
+ } else {
+ full_gc = 1;
+ }
+ }
#endif
- free(found);
- found = next;
- ret = t;
+ free(found);
+ found = next;
+ ret = t;
+ } while (found);
}
return ret;
@@ -806,7 +898,7 @@ static int is_unreachable_final(struct fin_reg *f, val ctx)
return !f->reachable;
}
-static void call_finals(void)
+NOINLINE static void call_finals(void)
{
(void) call_finalizers_impl(nil, is_unreachable_final);
}
@@ -882,6 +974,21 @@ int gc_inprogress(void)
void gc_init(val *stack_bottom)
{
gc_stack_bottom = stack_bottom;
+ gc_stack_limit = gc_stack_bottom - DFL_STACK_LIMIT / sizeof (val);
+#if HAVE_RLIMIT
+ {
+ struct rlimit rl;
+ if (getrlimit(RLIMIT_STACK, &rl) == 0) {
+ rlim_t lim = rl.rlim_cur;
+ if (lim != RLIM_INFINITY) {
+ ptrdiff_t delta = (lim >= MIN_STACK_LIMIT
+ ? (lim - lim / 16)
+ : MIN_STACK_LIMIT) / sizeof (val);
+ gc_stack_limit = gc_stack_bottom - delta;
+ }
+ }
+ }
+#endif
}
void gc_mark(val obj)
@@ -889,6 +996,11 @@ void gc_mark(val obj)
mark_obj(obj);
}
+void gc_mark_norec(val obj)
+{
+ mark_obj_norec(obj);
+}
+
void gc_conservative_mark(val maybe_obj)
{
mark_obj_maybe(maybe_obj);
@@ -959,13 +1071,41 @@ val gc_push(val obj, loc plist)
static val gc_set_delta(val delta)
{
- opt_gc_delta = c_num(delta);
+ val self = lit("gc");
+ opt_gc_delta = c_num(delta, self);
return nil;
}
-static val gc_wrap(void)
+static val set_stack_limit(val limit)
+{
+ val self = lit("set-stack-limit");
+ val *gsl = gc_stack_limit;
+
+ if (limit == nil || limit == zero) {
+ gc_stack_limit = 0;
+ } else {
+ ucnum lim = c_unum(limit, self);
+ gc_stack_limit = gc_stack_bottom - lim / sizeof (val);
+ }
+
+ return if2(gsl, num((gc_stack_bottom - gsl) * sizeof (val)));
+}
+
+static val get_stack_limit(void)
+{
+ val *gsl = gc_stack_limit;
+ return if2(gsl, num((gc_stack_bottom - gsl) * sizeof (val)));
+}
+
+static val gc_wrap(val full)
{
if (gc_enabled) {
+#if CONFIG_GEN_GC
+ if (!null_or_missing_p(full))
+ full_gc = 1;
+#else
+ (void) full;
+#endif
gc();
return t;
}
@@ -974,7 +1114,8 @@ static val gc_wrap(void)
val gc_finalize(val obj, val fun, val rev_order_p)
{
- type_check(lit("gc-finalize"), fun, FUN);
+ val self = lit("gc-finalize");
+ type_check(self, fun, FUN);
rev_order_p = default_null_arg(rev_order_p);
@@ -982,7 +1123,17 @@ val gc_finalize(val obj, val fun, val rev_order_p)
struct fin_reg *f = coerce(struct fin_reg *, chk_malloc(sizeof *f));
f->obj = obj;
f->fun = fun;
- f->reachable = 0;
+ f->reachable = 1;
+
+#if CONFIG_GEN_GC
+ if (++obj->t.fincount == 0) {
+ obj->t.fincount--;
+ free(f);
+ uw_throwf(error_s,
+ lit("~a: too many finalizations registered against object ~s"),
+ self, obj, nao);
+ }
+#endif
if (rev_order_p) {
if (!final_list)
@@ -1024,11 +1175,15 @@ val valid_object_p(val obj)
void gc_late_init(void)
{
- reg_fun(intern(lit("gc"), system_package), func_n0(gc_wrap));
+ reg_fun(intern(lit("gc"), system_package), func_n1o(gc_wrap, 0));
reg_fun(intern(lit("gc-set-delta"), system_package), func_n1(gc_set_delta));
reg_fun(intern(lit("finalize"), user_package), func_n3o(gc_finalize, 2));
reg_fun(intern(lit("call-finalizers"), user_package),
func_n1(gc_call_finalizers));
+ reg_fun(intern(lit("set-stack-limit"), user_package), func_n1(set_stack_limit));
+ reg_fun(intern(lit("get-stack-limit"), user_package), func_n0(get_stack_limit));
+
+ prot_array_cls = cobj_register(intern(lit("gc-prot-array"), system_package));
}
/*
@@ -1124,7 +1279,11 @@ void gc_free_all(void)
finalize(block);
}
+#if CONFIG_NAN_BOXING_STRIP_TAG
+ free(coerce(heap_t *, coerce(ucnum, iter) | (iter->tag << TAG_BIGSHIFT)));
+#else
free(iter);
+#endif
iter = next;
}
}
@@ -1139,3 +1298,46 @@ void gc_free_all(void)
}
}
}
+
+void gc_stack_overflow(void)
+{
+ uw_throwf(stack_overflow_s, lit("computation exceeded stack limit"), nao);
+}
+
+static void prot_array_mark(val obj)
+{
+ struct prot_array *pa = coerce(struct prot_array *, obj->co.handle);
+
+ if (pa) {
+ cnum i;
+ for (i = 0; i < pa->size; i++)
+ gc_mark(pa->arr[i]);
+ }
+}
+
+static struct cobj_ops prot_array_ops = cobj_ops_init(eq,
+ cobj_print_op,
+ cobj_destroy_free_op,
+ prot_array_mark,
+ cobj_eq_hash_op);
+
+val *gc_prot_array_alloc(cnum size, val *obj)
+{
+ struct prot_array *pa = coerce(struct prot_array *,
+ chk_calloc(offsetof(struct prot_array, arr) +
+ size * sizeof(val), 1));
+ pa->size = size;
+ *obj = pa->self = cobj(coerce(mem_t *, pa), prot_array_cls, &prot_array_ops);
+
+ return pa->arr;
+}
+
+void gc_prot_array_free(val *arr)
+{
+ if (arr) {
+ struct prot_array *pa = container(arr, struct prot_array, arr);
+ val obj = pa->self;
+ obj->co.handle = 0;
+ free(pa);
+ }
+}
diff --git a/gc.h b/gc.h
index 0c026cbf..f980573e 100644
--- a/gc.h
+++ b/gc.h
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
void gc_init(val *stack_bottom);
@@ -30,10 +31,12 @@ void gc_late_init(void);
val prot1(val *loc);
void protect(val *, ...);
val make_obj(void);
+val copy_obj(val);
void gc(void);
int gc_state(int);
int gc_inprogress(void);
void gc_mark(val);
+void gc_mark_norec(val obj);
void gc_conservative_mark(val);
void gc_mark_mem(val *low, val *high);
int gc_is_reachable(val);
@@ -64,8 +67,26 @@ extern val break_obj;
#endif
#define gc_hint(var) gc_hint_func(&var)
-#define REACHABLE 0x100
-#define FREE 0x200
+#define REACHABLE 0x100U
+#define FREE 0x200U
INLINE val zap(volatile val *loc) { val ret = *loc; *loc = nil; return ret; }
+
+#if CONFIG_ZAP_DEAD_LOCATIONS
#define z(lvalue) zap(&lvalue)
+#else
+#define z(lvalue) (lvalue)
+#endif
+
+extern val *gc_stack_bottom;
+extern val *gc_stack_limit;
+void gc_stack_overflow(void);
+INLINE void gc_stack_check(void)
+{
+ val v;
+ if (&v < gc_stack_limit)
+ gc_stack_overflow();
+}
+
+val *gc_prot_array_alloc(cnum size, val *obj);
+void gc_prot_array_free(val *);
diff --git a/gencadr.txr b/gencadr.txr
index 650a0100..6ed9ae5e 100644
--- a/gencadr.txr
+++ b/gencadr.txr
@@ -10,7 +10,7 @@
@(until)
@(end)
-@(next "share/txr/stdlib/place.tl")
+@(next "stdlib/place.tl")
@(collect)
@{tl-copyright}
@(until)
@@ -25,12 +25,11 @@
#include <stdarg.h>
#include <stdlib.h>
#include <limits.h>
-#include <signal.h>
#include "config.h"
#include "lib.h"
#include "eval.h"
#include "stream.h"
-#include "lisplib.h"
+#include "autoload.h"
#include "txr.h"
#include "cadr.h"
@ (repeat)
@@ -41,17 +40,16 @@ val c@{ad}r(val cons)
}
@ (end)
-static val cadr_register(val set_fun)
+static val cadr_register(void)
{
- funcall1(set_fun, nil);
@ (repeat)
reg_fun(intern(lit("c@{ad}r"), user_package), func_n1(c@{ad}r));
@ (end)
- load(format(nil, lit("~acadr"), stdlib_path, nao));
+ load(scat2(stdlib_path, lit("cadr")));
return nil;
}
-static val cadr_set_entries(val dlt, val fun)
+static val cadr_set_entries(val fun)
{
val name[] = {
@ (repeat)
@@ -60,13 +58,13 @@ static val cadr_set_entries(val dlt, val fun)
nil
};
- set_dlt_entries(dlt, name, fun);
+ autoload_set(al_fun, name, fun);
return nil;
}
void cadr_init(void)
{
- dlt_register(dl_table, cadr_register, cadr_set_entries);
+ autoload_reg(cadr_register, cadr_set_entries);
}
@(end)
@(output "cadr.h")
@@ -80,7 +78,7 @@ val c@{ad}r(val);
void cadr_init(void);
@(end)
-@(output "share/txr/stdlib/cadr.tl")
+@(output "stdlib/cadr.tl")
;; This file is generated by gencadr.txr
@{tl-copyright "\n"}
diff --git a/genchksum.txr b/genchksum.txr
new file mode 100644
index 00000000..b86108fb
--- /dev/null
+++ b/genchksum.txr
@@ -0,0 +1,266 @@
+@(do
+ (defstruct (chksum cname type strname hashlen init update final) ()
+ cname
+ type
+ strname
+ hashlen
+ init
+ update
+ final))
+@(output :into sums-txt)
+sha1 SHA1_t "SHA-1" SHA1_DIGEST_LENGTH
+SHA1_init SHA1_update SHA1_final
+
+sha256 SHA256_t "SHA-256" SHA256_DIGEST_LENGTH
+SHA256_init SHA256_update SHA256_final
+
+md5 MD5_t "MD5" MD5_DIGEST_LENGTH
+MD5_init MD5_update MD5_final
+@(end)
+@(next :list sums-txt)
+@(collect :vars (s))
+@ cname @type @strname @hashlen
+@init @update @final
+@ (bind s @(new (chksum cname type strname hashlen init update final)))
+@(end)
+@(next "chksum.c")
+/* This file is partially generated by genchksum.txr; see comment below. */
+
+@(collect)
+@ prolog
+@(until)
+
+static val @{nil}_ctx_s, @nil
+@(end)
+@(skip)
+@(data crc32-start)
+val crc32_stream(val stream, val nbytes, val init)
+@(skip)
+@(data chksum-init-start)
+void chksum_init(void)
+{
+@(skip)
+@(data epilog)
+ reg_fun(intern(lit("crc32-stream"), user_package), func_n3o(crc32_stream, 1));
+ reg_fun(intern(lit("crc32"), user_package), func_n2o(crc32, 1));
+}
+@(bind crc32 @(ldiff crc32-start chksum-init-start))
+@(output "chksum.c")
+/* This file is partially generated by genchksum.txr; see comment below. */
+
+@(repeat)
+@ prolog
+@(end)
+
+static val @(rep)@{s.cname}_ctx_s, @(last)@{s.cname}_ctx_s;@(end)
+static struct cobj_class @(rep)*@{s.cname}_ctx_cls, @(last)*@{s.cname}_ctx_cls;@(end)
+
+@(repeat)
+static void @{s.cname}_stream_impl(val stream, val nbytes,
+ unsigned char *hash, val self)
+{
+ @{s.type} ctx;
+ val buf = iobuf_get();
+ val bfsz = length_buf(buf);
+ @{s.init}(&ctx);
+
+ if (null_or_missing_p(nbytes)) {
+ for (;;) {
+ val read = fill_buf(buf, zero, stream);
+ cnum rd = c_num(read, self);
+
+ if (!rd)
+ break;
+
+ @{s.update}(&ctx, buf->b.data, rd);
+ }
+ } else {
+ while (ge(nbytes, bfsz)) {
+ val read = fill_buf(buf, zero, stream);
+ cnum rd = c_num(read, self);
+
+ if (zerop(read))
+ break;
+
+ @{s.update}(&ctx, buf->b.data, rd);
+ nbytes = minus(nbytes, read);
+ }
+
+ buf_set_length(buf, nbytes, nil);
+
+ {
+ val read = fill_buf(buf, zero, stream);
+ cnum rd = c_num(read, self);
+ if (rd)
+ @{s.update}(&ctx, buf->b.data, rd);
+ }
+ }
+
+ @{s.final}(&ctx, hash);
+ iobuf_put(buf);
+}
+
+val @{s.cname}_stream(val stream, val nbytes, val buf_in)
+{
+ val self = lit("@{s.cname}-stream");
+ unsigned char *hash;
+ val buf = chksum_ensure_buf(self, buf_in,
+ num_fast(@{s.hashlen}),
+ &hash, lit(@{s.strname}));
+ @{s.cname}_stream_impl(stream, nbytes, hash, self);
+ return buf;
+}
+
+static void @{s.cname}_szmax_upd(@{s.type} *pctx, mem_t *data, ucnum len)
+{
+ const size_t szmax = convert(size_t, -1) / 4 + 1;
+ while (len >= szmax) {
+ @{s.update}(pctx, data, szmax);
+ data += szmax;
+ len -= szmax;
+ }
+ if (len > 0)
+ @{s.update}(pctx, data, len);
+}
+
+static void @{s.cname}_buf(val buf, unsigned char *hash, val self)
+{
+ @{s.type} ctx;
+ @{s.init}(&ctx);
+ @{s.cname}_szmax_upd(&ctx, buf->b.data, c_unum(buf->b.len, self));
+ @{s.final}(&ctx, hash);
+}
+
+static void @{s.cname}_str(val str, unsigned char *hash, val self)
+{
+ char *s = utf8_dup_to(c_str(str, self));
+ @{s.type} ctx;
+ @{s.init}(&ctx);
+ @{s.update}(&ctx, coerce(const unsigned char *, s), strlen(s));
+ free(s);
+ @{s.final}(&ctx, hash);
+}
+
+val @{s.cname}(val obj, val buf_in)
+{
+ val self = lit("@{s.cname}");
+ unsigned char *hash;
+ val buf = chksum_ensure_buf(self, buf_in,
+ num_fast(@{s.hashlen}),
+ &hash, lit(@{s.strname}));
+ switch (type(obj)) {
+ case STR:
+ case LSTR:
+ case LIT:
+ @{s.cname}_str(obj, hash, self);
+ return buf;
+ case BUF:
+ @{s.cname}_buf(obj, hash, self);
+ return buf;
+ default:
+ uw_throwf(error_s,
+ lit("~a: cannot hash ~s, "
+ "only buffer and strings"),
+ self, obj, nao);
+ }
+}
+
+static struct cobj_ops @{s.cname}_ops = cobj_ops_init(cobj_equal_handle_op,
+ cobj_print_op,
+ cobj_destroy_free_op,
+ cobj_mark_op,
+ cobj_handle_hash_op);
+
+val @{s.cname}_begin(void)
+{
+ @{s.type} *pctx = coerce(@{s.type} *, chk_malloc(sizeof *pctx));
+ @{s.init}(pctx);
+ return cobj(coerce(mem_t *, pctx), @{s.cname}_ctx_cls, &@{s.cname}_ops);
+}
+
+static int @{s.cname}_utf8_byte_callback(int b, mem_t *ctx)
+{
+ @{s.type} *pctx = coerce(@{s.type} *, ctx);
+ unsigned char uc = b;
+ @{s.update}(pctx, &uc, 1);
+ return 1;
+}
+
+val @{s.cname}_hash(val ctx, val obj)
+{
+ val self = lit("@{s.cname}-hash");
+ @{s.type} *pctx = coerce(@{s.type} *,
+ cobj_handle(self, ctx, @{s.cname}_ctx_cls));
+ switch (type(obj)) {
+ case STR:
+ case LSTR:
+ case LIT:
+ {
+ char *str = utf8_dup_to(c_str(obj, self));
+ @{s.update}(pctx, coerce(const unsigned char *, str), strlen(str));
+ free(str);
+ }
+ break;
+ case BUF:
+ @{s.cname}_szmax_upd(pctx, obj->b.data, c_unum(obj->b.len, self));
+ break;
+ case CHR:
+ utf8_encode(c_ch(obj), @{s.cname}_utf8_byte_callback,
+ coerce(mem_t *, pctx));
+ break;
+ case NUM:
+ {
+ cnum n = c_num(obj, self);
+ unsigned char uc = n;
+ if (n < 0 || n > 255)
+ uw_throwf(error_s,
+ lit("~a: byte value ~s out of range"),
+ self, obj, nao);
+ @{s.update}(pctx, &uc, 1);
+ }
+ break;
+ default:
+ uw_throwf(error_s, lit("~a: cannot hash ~s, "
+ "only buffer and strings"),
+ self, obj, nao);
+ }
+
+ return obj;
+}
+
+val @{s.cname}_end(val ctx, val buf_in)
+{
+ val self = lit("@{s.cname}-end");
+ unsigned char *hash;
+ @{s.type} *pctx = coerce(@{s.type} *,
+ cobj_handle(self, ctx, @{s.cname}_ctx_cls));
+ val buf = chksum_ensure_buf(self, buf_in, num_fast(@{s.hashlen}),
+ &hash, lit(@{s.strname}));
+ @{s.final}(pctx, hash);
+ @{s.init}(pctx);
+ return buf;
+}
+
+@(end)
+@(repeat)
+@ crc32
+@(end)
+void chksum_init(void)
+{
+@(repeat)
+ @{s.cname}_ctx_s = intern(lit("@{s.cname}-ctx"), user_package);
+@(end)
+@(repeat)
+ @{s.cname}_ctx_cls = cobj_register(@{s.cname}_ctx_s);
+@(end)
+@(repeat)
+ reg_fun(intern(lit("@{s.cname}-stream"), user_package), func_n3o(@{s.cname}_stream, 1));
+ reg_fun(intern(lit("@{s.cname}"), user_package), func_n2o(@{s.cname}, 1));
+ reg_fun(intern(lit("@{s.cname}-begin"), user_package), func_n0(@{s.cname}_begin));
+ reg_fun(intern(lit("@{s.cname}-hash"), user_package), func_n2(@{s.cname}_hash));
+ reg_fun(intern(lit("@{s.cname}-end"), user_package), func_n2o(@{s.cname}_end, 1));
+@(end)
+@(repeat)
+@ epilog
+@(end)
+@(end)
diff --git a/genman.txr b/genman.txr
index a99996b6..6ef0404b 100644
--- a/genman.txr
+++ b/genman.txr
@@ -1,50 +1,57 @@
@# This requires a hacked version of man2html
@# See here: http://www.kylheku.com/cgit/man
-@(bind symhash @(hash :equal-based))
-@(bind tagmap @(hash :equal-based))
-@(bind tochash @(hash :equal-based))
@(bind closedtxt " <TT>[+]</TT>")
@(bind opentxt " <TT>[-]</TT>")
@(bind xpnall "[expand all]")
@(bind clpsall "[collapse all]")
@(bind closed t)
@(do
- (defvar dupes (hash))
- (defvar tagnum (hash :equal-based))
- (defvarl disamb (hash :equal-based))
+ (defvarl symhash (hash))
+ (defvarl tagmap (hash))
+ (defvarl tochash (hash))
+ (defvarl dupe-hashes (hash))
+ (defvarl dupe-titles (hash))
+ (defvarl direct (hash))
+ (defvarl disamb (hash))
(defvarl dist-counter 0)
-
- (defun hash-str (str)
- (for ((lim (len str)) (i 0) (h 0) g) ((< i lim) h) ((inc i))
- (set h (+ (ash h 4) (int-chr [str i])))
- (set g (logand h #x7c000000))
- (set h (logtrunc (logxor h (logxor (ash g -26) g)) 32))))
+ (defvarl colli (hash-props))
(defun hash-title (title)
- (let* ((h (logtrunc (hash-str title) 32))
- (existing [dupes h]))
- (when existing
- (unless (equal title existing)
- (error "~a ~a hash collision!" existing title)))
- (set [dupes h] title)
- (format nil "N-~,08X" h)))
+ (let* ((ti title)
+ (cntr 0)
+ (defs (build (while-match `@nil<tt>@ttitem</tt>@rest` ti
+ (add ttitem)
+ (set ti rest)))))
+ (set title (if defs
+ (car defs)
+ (downcase-str title))
+ ti title)
+ (while* [dupe-titles title]
+ (set title `T-@(inc cntr)-@ti`))
+ (set [dupe-titles title] t)
+ (let* ((h (crc32 title))
+ (h (+ h (or [colli title] 0)))
+ (existing [dupe-hashes h]))
+ (when existing
+ (unless (equal title existing)
+ (error "~a ~a hash collision!" existing title)))
+ (set [dupe-hashes h] title)
+ (format nil "N-~,08X" h))))
(defun toc-tag (sec)
`TOC-@sec`)
- (set [tagmap "lbAB"] (hash-title "NAME"))
-
- (defun enumerate (title)
- (let ((num (inc [tagnum title 0])))
- `@title@(if (> num 1) `-@num` "")`))
-
(defun process-ambiguities (hash)
- (hash-update hash (do if (eql (length @1) 1)
- (first @1)
- (let ((new-tag (format nil "D-~,04X"
- (inc dist-counter))))
- (set [disamb new-tag] (reverse @1))
- new-tag)))))
+ (let ((rhash (hash)))
+ (dohash (sym tags hash)
+ (let ((shash (fmt "S-~,08X" (crc32 sym))))
+ (if [rhash shash]
+ (error "~a ~a hash collision" sym [rhash shash])
+ (set [rhash shash] sym))
+ (set [hash sym] shash)
+ (if (null (cdr tags))
+ (push shash [direct (car tags)])
+ (set [disamb shash] (reverse tags))))))))
Content-type: text/html
@(skip 15)
<h1>TXR</h1>
@@ -62,7 +69,7 @@ Content-type: text/html
<h@level>@sec @title
</h@level>
@ (end)
-@ (bind newtag @(hash-title (enumerate title)))
+@ (bind newtag @(hash-title title))
@ (do (set [tagmap tag] newtag))
@ (output :into BODY)
<a name="@newtag">&nbsp;</a>
@@ -108,7 +115,7 @@ Content-type: text/html
@ (and)
<dt><a href="#@tag">@(coll :vars (sym))<tt>@sym</tt>@(end)
@ (do (let ((n-tag [tagmap tag]))
- (mapdo (do pushnew n-tag [symhash @1]) sym)
+ (mapdo (do pushnew n-tag [symhash (html-decode @1)]) sym)
(set [tochash n-tag] rest)))
@ (and)
<dt><a href="#@tag">@num @nil
@@ -146,10 +153,17 @@ This document was created by
(pop @1)))
(tok [@1 1..:])
(bkt [@1 0])
- (tag [symhash tok]))
+ (tag [symhash (html-decode tok)]))
(if tag
`@at@bkt<a href="#@tag">@tok</a>`
`@at@1`)) @1))
+ ((starts-with "<a name=" @1)
+ (match @(with `<a name="@tag">@rest`
+ shash [direct tag])
+ @1
+ (join (collect-each ((sh shash))
+ `<a name="@sh">&nbsp;</a>\n`)
+ @1)))
((search-regex @1 #/<h[1-9]>/) @1)
(t (regsub #/<tt>.%<\/tt>/
(do let* ((tok [@1 4 -5])
@@ -160,8 +174,8 @@ This document was created by
(set pfx "@("
sym [tok 2 tend]
sfx [tok tend .. :]
- tag [symhash sym]))
- (t (set tag [symhash tok]
+ tag [symhash (html-decode sym)]))
+ (t (set tag [symhash (html-decode tok)]
sym tok)))
(if tag
`<tt>@pfx<a href="#@tag">@sym</a>@sfx</tt>`
@@ -175,7 +189,37 @@ This document was created by
<head><title>Manpage for TXR @VERSION</title>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
<style>
-.disambiguations dl { margin-bottom: 2048px; }
+.disambiguations dl {
+ margin-bottom: 2048px;
+}
+dl.items dd:-moz-only-whitespace::after {
+ content: "\00A0";
+}
+dl.items dd:empty:after {
+ content: "\00A0";
+}
+dl.items dd {
+ overflow: auto;
+ min-width: calc(100% - 3em);
+ margin-left: 3em;
+ margin-bottom: 1ex;
+}
+dl.items dt {
+ float: left;
+ padding-right: 1ex;
+}
+kbd {
+ background-color: #eee;
+ border-radius: 3px;
+ border: 1px solid #b4b4b4;
+ box-shadow: 0 1px 1px rgba(0, 0, 0, .2), 0 2px 0 0 rgba(255, 255, 255, .7) inset;
+ color: #333;
+ display: inline-block;
+ font-weight: 700;
+ line-height: 1;
+ padding: 2px 4px;
+ white-space: nowrap;
+}
</style>
<script type="text/javascript">
var xpanded = false;
@@ -265,3 +309,26 @@ function tocjump(hash) {
</body>
</html>
@(end)
+@(do (let ((ignames '("*-1" "*-2" "*-20"
+ "*0" "*1" "*2" "*99"
+ "*n" "*r" "*v"
+ "--args" "--eargs" "-C"
+ ".."
+ "TXR_COMPAT"
+ "buf-get-" "buf-put-"))
+ (imgsyms (hash-list (append-each* ((entry [remove-if (op equal "pub")
+ (package-alist)
+ car])
+ (pkg-name [mapcar car entry])
+ (pkg [mapcar cdr entry]))
+ (let ((fn (casequal pkg-name
+ (("usr" "keyword")
+ (fun tostringp))
+ (t (opip tostringp
+ (join-with ":" pkg-name))))))
+ (mapcar fn (package-symbols pkg)))))))
+ (each ((sym ignames))
+ (del [symhash sym]))
+ (let ((missing (hash-diff symhash imgsyms)))
+ (dohash (sym val missing)
+ (format *stderr* "~a: missing from image\n" sym)))))
diff --git a/genvim.txr b/genvim.txr
index e831e85e..201d0beb 100644
--- a/genvim.txr
+++ b/genvim.txr
@@ -9,7 +9,6 @@ static void dir_tables_init(void)
@(end)
@(bind tl-orig-sym
@(append-each* ((entry (package-alist))
- (pkg-name [mapcar car entry])
(pkg [mapcar cdr entry]))
(append-each ((sym (package-symbols pkg)))
(when (or (boundp sym) (fboundp sym)
@@ -25,7 +24,9 @@ static void dir_tables_init(void)
("keyword" ":")
("usr" "")
(t `@{pkg-name}:`))))
- (list `@qualif@(symbol-name sym)`))))
+ (if (eq sym 'contains)
+ '("contain[s]") ;; Vim doesn't like the word "contains"
+ (list `@qualif@(symbol-name sym)`)))))
@(do (set [txr-sym 0..0] '("end" "and" "or"
"catch" "finally"
"until" "last"
@@ -36,13 +37,20 @@ static void dir_tables_init(void)
@(set (tl-sym tl-orig-sym) @(multi-sort (list tl-sym tl-orig-sym)
[list less]))
@(bind bs "\\\\")
+@(bind ws "[\\t\\n ]")
@(bind hex "0-9A-Fa-f")
@(bind at "\\(@[ \\t]*\\)")
@(bind alpha "A-Za-z_")
+@(bind alpha-noe "A-DF-Za-dfz_")
@(bind alnum "A-Za-z_0-9")
@(bind dig "0-9")
+@(bind dig19 "1-9")
@(bind oct "0-7")
-@(bind chesc `abtnvfre@bs \\n`)
+@(bind digsep `\\([@dig][,@dig]*[@dig]\\|[@dig]\\)`)
+@(bind hexsep `\\([@hex][,@hex]*[@hex]\\|[@hex]\\)`)
+@(bind octsep `\\([@oct][,@oct]*[@oct]\\|[@oct]\\)`)
+@(bind binsep `\\([01][,01]*[01]\\|[01]\\)`)
+@(bind chesc `abtnvfre@bs `)
@(bind glyph `!$%&*+\\-<=>?@{bs}_~`)
@(bind lispwords @(append-each ((sym tl-orig-sym)
(text tl-sym))
@@ -58,8 +66,39 @@ static void dir_tables_init(void)
meth umeth usl))
(list text)))))
@(bind comments #"\\;\\;\\; \\;\\; \\;")
+@(bind txr-elem "txr_error,txr_atat,txr_comment,txr_contin,\
+ txr_char,txr_error,txr_char,txr_regdir,txr_variable,\
+ txr_splicevar,txr_metanum,txr_directive,txr_bracevar,\
+ txr_bracket")
+@(bind txr-qelem "txr_splicevar,txr_metanum,txr_qbracevar,txr_list,\
+ txr_bracket,txr_escat,txr_stresc,txr_numesc,txr_badesc")
+@(bind bvar "txr_num,txr_pnum,tl_ident,tl_splice,tl_metanum,\
+ txr_metaat,txr_circ,txr_braced_ident,txr_dot,\
+ txr_dotdot,txr_string,txr_list,txr_bracket,\
+ txr_regex,tl_regex,txr_quasilit,\
+ txr_chr,txr_nested_error")
+@(bind dir "txr_keyword,txr_string,txr_list,txr_bracket,\
+ txr_quasilit,txr_num,txr_pnum,\
+ txr_badnum,tl_ident,tl_regex,txr_string,txr_chr,\
+ txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,\
+ txr_metaat,txr_circ,txr_ncomment,txr_nested_error")
+@(bind list "tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,\
+ txr_badnum,tl_ident,txr_metanum,\
+ txr_ign,txr_ign_json,txr_list,txr_bracket,\
+ txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,\
+ txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_jhash,\
+ txr_jarray,txr_jatom,txr_ncomment,tl_error,txr_nested_error")
+@(bind jlist "txr_jarray_in,txr_jhash_in,txr_jkeyword,txr_jstring,\
+ txr_jnum,txr_jpunc,txr_junqlist,txr_junqbkt,txr_junqtok,\
+ txr_circ,txr_jerr")
+@(bind jsonkw #"true false null")
+@(bind jerr ".")
+@(bind jpunc "[,: \\t\\n]")
+@(bind jesc "\\\\[bfnrt\"\\\\/]")
+@(bind juesc `\\\\u[@hex][@hex][@hex][@hex]`)
+@(bind jnum `-\\?\\(0\\|[@dig19][@dig]*\\)\\([.][@dig]\\+\\)\\?\\([Ee][+-]\\?[@dig]\\+\\)\\?`)
@(define generate (txr-p))
-@ (output @(if txr-p "txr.vim" "tl.vim") :named out)
+@ (output @(if txr-p "txr.vim" "tl.vim"))
" VIM Syntax file for txr
" Kaz Kylheku <kaz@@kylheku.com>
@@ -82,26 +121,23 @@ syn spell toplevel
setlocal iskeyword=a-z,A-Z,48-57,!,$,%,&,*,+,-,<,=,>,?,\\,_,~,/,^
@ (rep) @{tl-sym}@(mod 0 4)@\nsyn keyword tl_keyword contained @{tl-sym}@(end)
-@ (end)
@ (if txr-p)
-@ (output :continue out)
-@ (rep) @{txr-sym}@(mod 0 4)@\nsyn keyword txr_keyword contained @{txr-sym}@(end)
-syn match txr_error "@at[*]\?[\t ]*."
-syn match txr_atat "@at@@"
-syn match txr_comment "@at[#;].*"
-syn match txr_contin "@at\\$"
-syn match txr_char "@at\\."
-syn match txr_error "@at\\[xo]"
-syn match txr_char "@at\\x[@hex]\+;\?"
-syn match txr_char "@at\\[@oct]\+;\?"
-syn match txr_regdir "@at/\(\\/\|[^/]\|\\\n\)*/"
-@ (end)
+@ (rep) @{txr-sym}@(mod 0 4)@\nsyn keyword txr_keyword contained @{txr-sym}@(end)
+syn match txr_at "@at" nextgroup=@{txr-elem}
+syn match txr_error "[*]\?[\t ]*." contained
+syn match txr_atat "@@" contained
+syn match txr_comment "[#;].*" contained
+syn match txr_contin "\\$" contained
+syn match txr_char "\\." contained
+syn match txr_error "\\[xo]" contained
+syn match txr_char "\\x[@hex]\+;\?" contained
+syn match txr_char "\\[@oct]\+;\?" contained
+syn match txr_regdir "/\(\\/\|[^/]\|\\\n\)*/" contained
@ (end)
-@ (output :continue out)
syn match txr_nested_error "[^\t ]\+" contained
-syn match txr_variable "@at[*]\?[ \t]*[@alpha][@alnum]*"
-syn match txr_splicevar "@@[ \t,*@@]*[@alpha][@alnum]*" contained
-syn match txr_metanum "@@\+[0-9]\+"@(if txr-p " contained")
+syn match txr_variable "[*]\?[ \t]*[@alpha][@alnum]*" contained
+syn match txr_splicevar "[ \t,*@@]*[@alpha][@alnum]*" contained
+syn match txr_metanum "@at\+[0-9]\+"@(if txr-p " contained")
syn match txr_badesc "\\." contained
syn match txr_escat "\\@@" contained
syn match txr_stresc "\\[@chesc"`']" contained
@@ -109,7 +145,7 @@ syn match txr_numesc "\\x[@hex]\+;\?" contained
syn match txr_numesc "\\[@oct]\+;\?" contained
syn match txr_regesc "\\[@chesc/sSdDwW()\|.*?+~&%\[\]\-]" contained
-syn match txr_error "#[^HSR]"@(if txr-p " contained")
+syn match tl_error "#[^HSRTN]"@(if txr-p " contained")
syn match txr_chr "#\\x[@hex]\+"@(if txr-p " contained")
syn match txr_chr "#\\o[@oct]\+"@(if txr-p " contained")
@@ -119,64 +155,86 @@ syn match txr_ncomment ";.*"@(if txr-p " contained")
syn match txr_hashbang "\%^#!.*"
+syn match txr_qat "@at" nextgroup=@{txr-qelem} contained
syn match txr_dot "\." contained
syn match txr_ident "[@alnum@glyph]*[@alpha@glyph^][@alnum@glyph^]*" contained
-syn match tl_ident "[:@@][@alnum@glyph^/]\+"@(if txr-p " contained")
-syn match txr_braced_ident "[:][@alnum@glyph^/]\+" contained
-syn match tl_ident "[@alnum@glyph/]\+[@alnum@glyph^/#]*"@(if txr-p " contained")
-syn match txr_pnum "#[xob][+\-]\?[@alnum]\+" contains=txr_xnum,txr_bnum,txr_onum@(if txr-p " contained")
-syn match txr_xnum "#x[+\-]\?[@hex]\+" containedin=txr_pnum contained
-syn match txr_onum "#o[+\-]\?[@oct]\+" containedin=txr_pnum contained
-syn match txr_bnum "#b[+\-]\?[01]\+" containedin=txr_pnum contained
-syn match txr_num "[+\-]\?[@dig]\+\([^@alnum@glyph^/#]\|\n\)"me=e-1@(if txr-p " contained")
-syn match txr_badnum "[+\-]\?[@dig]*[.][@dig]\+\([eE][+\-]\?[@dig]\+\)\?[@alpha@glyph^/#]\+"@(if txr-p " contained")
-syn match txr_num "[+\-]\?[@dig]*[.][@dig]\+\([eE][+\-]\?[@dig]\+\)\?\([^@alnum@glyph^/#]\|\n\)"me=e-1@(if txr-p " contained")
-syn match txr_num "[+\-]\?[@dig]\+\([eE][+\-]\?[@dig]\+\)\([^@alnum@glyph^/#]\|\n\)"me=e-1@(if txr-p " contained")
-syn match tl_ident ":"@(if txr-p " contained")
+syn match txr_braced_ident "\(#\?:\)\?[[@alnum@glyph^/]\+" contained
+syn match tl_ident "\(#\?:\)\?[@alnum@glyph/]\+[@alnum@glyph^/#]*"@(if txr-p " contained")
+syn match txr_pnum "#[xob][+\-]\?[@alnum,]\+" contains=txr_xnum,txr_bnum,txr_onum@(if txr-p " contained")
+syn match txr_xnum "#x[+\-]\?@hexsep" containedin=txr_pnum contained
+syn match txr_onum "#o[+\-]\?@octsep" containedin=txr_pnum contained
+syn match txr_bnum "#b[+\-]\?@binsep" containedin=txr_pnum contained
+syn match txr_num "[+\-]\?@digsep"@(if txr-p " contained")
+syn match txr_num "[+\-]\?@digsep\?[.]@digsep\([eE][+\-]\?[@dig]\+\)\?"@(if txr-p " contained")
+syn match txr_num "[+\-]\?@digsep[.]\?\([eE][+\-]\?[@dig]\+\)"@(if txr-p " contained")
+syn match txr_badnum "[+\-]\?@digsep\?[.]@digsep\([@{alpha-noe}@glyph^/#]\|[eE][^+\-@dig]\|[eE][+/-]\?$\|[eE][+\-][^0-9]\)"@(if txr-p " contained")
+syn match txr_badnum "[+\-]\?@digsep[.]\?\([@{alpha-noe}@glyph^/#]\|[eE][^+\-@dig]\|[eE][+/-]\?$\|[eE][+\-][^0-9]\)"@(if txr-p " contained")
+syn match tl_ident "#\?:"@(if txr-p " contained")
syn match tl_splice "[ \t,]\|,[*]"@(if txr-p " contained")
syn match txr_unquote "," contained
syn match txr_splice ",\*" contained
-syn match txr_quote "'" contained
-syn match txr_quote "\^" contained
+syn match txr_quote "'"@(if txr-p " contained")
+syn match txr_quote "\^"@(if txr-p " contained")
syn match txr_dotdot "\.\." contained
-syn match txr_metaat "@@" contained
-syn match txr_circ "#[0-9]\+[#=]"
+syn match txr_metaat "@@"@(if txr-p " contained")
syn match txr_buf_error "[^']" contained
syn match txr_buf_interior "\([@hex][\n\t ]*[@hex]\|[\n\t ]\+\)" contained
-syn region txr_bracevar matchgroup=Delimiter start="@@[ \t]*[*]\?{" matchgroup=Delimiter end="}" contains=txr_num,txr_pnum,tl_ident,tl_splice,tl_metanum,txr_metaat,txr_circ,txr_braced_ident,txr_dot,txr_dotdot,txr_string,txr_list,txr_bracket,txr_mlist,txr_mbracket,txr_regex,txr_quasilit,txr_chr,txr_nested_error
-@ (end)
+syn region txr_bracevar contained matchgroup=Delimiter start="[*]\?{" matchgroup=Delimiter end="}" contains=@bvar
+syn region txr_qbracevar contained matchgroup=Delimiter start="[*]\?{" matchgroup=Delimiter end="}" contains=@bvar
@ (if txr-p)
-@ (output :continue out)
-syn region txr_directive matchgroup=Delimiter start="@@[ \t]*(" matchgroup=Delimiter end=")" contains=txr_keyword,txr_string,txr_list,txr_bracket,txr_mlist,txr_mbracket,txr_quasilit,txr_num,txr_pnum,txr_badnum,tl_ident,tl_regex,txr_string,txr_chr,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_ncomment,txr_nested_error
-@ (end)
+syn region txr_directive contained matchgroup=Delimiter start="(" matchgroup=Delimiter end=")" contains=@dir
@ (end)
-@ (output :continue out)
-syn region txr_list @(if txr-p "contained ")matchgroup=Delimiter start="\(#[HSR]\?\)\?(" matchgroup=Delimiter end=")" contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign_par,txr_ign_bkt,txr_list,txr_bracket,txr_mlist,txr_mbracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_ncomment,txr_nested_error
-syn region txr_bracket @(if txr-p "contained ")matchgroup=Delimiter start="\[" matchgroup=Delimiter end="\]" contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign_par,txr_ign_bkt,txr_list,txr_bracket,txr_mlist,txr_mbracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_ncomment,txr_nested_error
-syn region txr_mlist @(if txr-p "contained ")matchgroup=Delimiter start="@@[ \t^',]*(" matchgroup=Delimiter end=")" contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign_par,txr_ign_bkt,txr_list,txr_bracket,txr_mlist,txr_mbracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_ncomment,txr_nested_error
-syn region txr_mbracket matchgroup=Delimiter start="@@[ \t^',]*\[" matchgroup=Delimiter end="\]" contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign_par,txr_ign_bkt,txr_list,txr_bracket,txr_mlist,txr_mbracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_ncomment,txr_nested_error
-syn region txr_string @(if txr-p "contained ")start=+#\?\*\?"+ end=+["\n]+ contains=txr_stresc,txr_numesc,txr_badesc
-syn region txr_quasilit @(if txr-p "contained ")start=+#\?\*\?`+ end=+[`\n]+ contains=txr_splicevar,txr_metanum,txr_bracevar,txr_mlist,txr_mbracket,txr_escat,txr_stresc,txr_numesc,txr_badesc
-syn region txr_regex @(if txr-p "contained ")start="/" end="[/\n]" contains=txr_regesc,txr_numesc,txr_badesc
-syn region tl_regex @(if txr-p "contained ")start="#/" end="[/\n]" contains=txr_regesc,txr_numesc,txr_badesc
+syn region txr_list @(if txr-p "contained ")matchgroup=Delimiter start="\(#[HSRTN]\?\)\?(" matchgroup=Delimiter end=")" contains=@list
+syn region txr_bracket @(if txr-p "contained ")matchgroup=Delimiter start="\[" matchgroup=Delimiter end="\]" contains=@list
+syn region txr_string @(if txr-p "contained ")start=+#\?\*\?"+ skip=+\\\n+ end=+["\n]+ contains=txr_stresc,txr_numesc,txr_badesc
+syn region txr_quasilit @(if txr-p "contained ")start=+#\?\*\?`+ skip=+\\\n+ end=+[`\n]+ contains=txr_qat,txr_stresc,txr_numesc,txr_badesc
+syn region txr_regex @(if txr-p "contained ")start="/" skip=+\\\n+ end="[/\n]" contains=txr_regesc,txr_numesc,txr_badesc
+syn region tl_regex @(if txr-p "contained ")start="#/" skip=+\\\n+ end="[/\n]" contains=txr_regesc,txr_numesc,txr_badesc
syn region txr_buf @(if txr-p "contained ")matchgroup=txr_buf start="#b'" end="'" contains=txr_buf_interior,txr_buf_error
-syn region txr_ign_par @(if txr-p "contained ")matchgroup=Comment start="#;[ \t',]*\(#[HSR]\?\)\?(" matchgroup=Comment end=")" contains=txr_ign_par_interior,txr_ign_bkt_interior
-syn region txr_ign_bkt @(if txr-p "contained ")matchgroup=Comment start="#;[ \t',]*\(#[HSR]\?\)\?\[" matchgroup=Comment end="\]" contains=txr_ign_par_interior,txr_ign_bkt_interior
-syn region txr_ign_par_interior contained matchgroup=Comment start="(" matchgroup=Comment end=")" contains=txr_ign_par_interior,txr_ign_bkt_interior
-syn region txr_ign_bkt_interior contained matchgroup=Comment start="\[" matchgroup=Comment end="\]" contains=txr_ign_par_interior,txr_ign_bkt_interior
+syn region txr_ign @(if txr-p "contained ")matchgroup=Comment start="#;" end="[ \(\)\[\]]"me=e contains=@list
+syn region txr_ign @(if txr-p "contained ")matchgroup=Comment start="#;[ \t',^@@]*\(#[HSRTN]\?\)\?(" matchgroup=Comment end=")" contains=txr_ign_interior
+syn region txr_ign @(if txr-p "contained ")matchgroup=Comment start="#;[ \t',^@@]*\(#[HSRTNJ]\?\)\?\[" matchgroup=Comment end="\]" contains=txr_ign_interior
+syn region txr_ign_json @(if txr-p "contained ")matchgroup=Comment start="#;[ \t',^@@]*#J[~^]*{" matchgroup=Comment end="}" contains=txr_ign_interior
+syn region txr_ign_json @(if txr-p "contained ")matchgroup=Comment start="#;[ \t',^@@]*#J[~^]*\[" matchgroup=Comment end="\]" contains=txr_ign_interior
+syn region txr_ign_json @(if txr-p "contained ")matchgroup=Comment start="#;[ \t',^@@]*#J[~^]*(" matchgroup=Comment end=")" contains=txr_ign_interior
+syn region txr_ign_interior contained matchgroup=Comment start="(" matchgroup=Comment end=")" contains=txr_ign_interior
+syn region txr_ign_interior contained matchgroup=Comment start="\[" matchgroup=Comment end="\]" contains=txr_ign_interior
+syn region txr_ign_interior contained matchgroup=Comment start="{" matchgroup=Comment end="}" contains=txr_ign_interior
+
+syn match txr_jerr "@jerr" contained
+syn match txr_jpunc "@jpunc" contained
+syn match txr_jesc "@jesc" contained
+syn match txr_juesc "@juesc" contained
+syn match txr_jnum "@jnum" contained
+syn match txr_jkeyword "@(join-with "\\|" . jsonkw)" contained
+
+syn region txr_jatom @(if txr-p "contained ")matchgroup=Delimiter start="#J\^\?@ws*"rs=e end="@ws\|[\])}]"re=e-1 contains=@jlist
+syn region txr_junqtok contained matchgroup=Delimiter start="\~" end="[ \(\)\[\]{}]"re=s contains=@list
+syn region txr_junqlist contained matchgroup=Delimiter start="\~\*\?#\?(" end=")" contains=@list
+syn region txr_junqbkt contained matchgroup=Delimiter start="\~\*\?\[" end="\]" contains=@list
+syn region txr_jstring contained matchgroup=Delimiter start=+"+ end=+["\n]+ contains=txr_jesc,txr_juesc,txr_badesc
+syn region txr_jarray @(if txr-p "contained ")matchgroup=Delimiter start="#J\^\?@ws*\[" matchgroup=Delimiter end="\]" contains=@jlist
+syn region txr_jhash @(if txr-p "contained ")matchgroup=Delimiter start="#J\^\?@ws*{" matchgroup=Delimiter end="}" contains=@jlist
+syn region txr_jarray_in contained matchgroup=Delimiter start="\[" end="\]" contains=@jlist
+syn region txr_jhash_in contained matchgroup=Delimiter start="{" end="}" contains=@jlist
+
+syn match txr_circ "#[0-9]\+[#=]" contained
hi def link txr_at Special
hi def link txr_atstar Special
hi def link txr_atat Special
+hi def link txr_qat Special
hi def link txr_comment Comment
hi def link txr_ncomment Comment
hi def link txr_hashbang Preproc
hi def link txr_contin Preproc
hi def link txr_char String
+@ (if txr-p)
hi def link txr_keyword Keyword
+@ (end)
hi def link tl_keyword Type
hi def link txr_string String
hi def link txr_chr String
@@ -210,14 +268,22 @@ hi def link txr_circ Special
hi def link txr_munqspl Special
hi def link tl_splice Special
hi def link txr_error Error
+hi def link tl_error Error
hi def link txr_nested_error Error
hi def link txr_buf String
hi def link txr_buf_interior String
hi def link txr_buf_error Error
-hi def link txr_ign_par Comment
-hi def link txr_ign_bkt_interior Comment
-hi def link txr_ign_par_interior Comment
-hi def link txr_ign_bkt Comment
+hi def link txr_ign_interior Comment
+hi def link txr_ign Comment
+hi def link txr_ign_json Comment
+
+hi def link txr_jkeyword Type
+hi def link txr_jnum Number
+hi def link txr_jstring String
+hi def link txr_jesc Special
+hi def link txr_juesc Special
+hi def link txr_jpunc Special
+hi def link txr_jerr Error
let b:current_syntax = "lisp"
diff --git a/genvmop.txr b/genvmop.txr
index fa1af41c..7cc097e6 100644
--- a/genvmop.txr
+++ b/genvmop.txr
@@ -11,8 +11,17 @@
@{copyright "\n"}
typedef enum vm_op {
-@ (repeat :vars (oc))
- @{oc.symbol :filter :upcase} = @{oc.code},
+@ (repeat)
+ @{oc.symbol :filter :upcase} = @{oc.code},@(if oc.deprecated
+ " /* deprecated */")
@ (end)
} vm_op_t;
+
+#define VM_LEV_BITS @{sys:%lev-bits%}
+#define VM_LEV_MASK @(fmt "0x~X" (pred (ash 1 sys:%lev-bits%)))
+#define VM_SM_LEV_BITS @{sys:%sm-lev-bits%}
+#define VM_SM_LEV_MASK @(fmt "0x~X" (pred (ash 1 sys:%sm-lev-bits%)))
+#define VM_MAX_LEV @{sys:%max-lev%}
+#define VM_MAX_V_LEV @{sys:%max-v-lev%}
+#define VM_LEV_SIZE @{sys:%lev-size%}
@(end)
diff --git a/glob.c b/glob.c
index 0584f9bf..2bba8f6c 100644
--- a/glob.c
+++ b/glob.c
@@ -1,4 +1,4 @@
-/* Copyright 2015-2020
+/* Copyright 2015-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,29 +6,30 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
-#include <stdarg.h>
#include <wchar.h>
#include <signal.h>
#include <stdlib.h>
+#include <string.h>
#include <glob.h>
#include "config.h"
#include "lib.h"
@@ -38,10 +39,18 @@
#include "signal.h"
#include "unwind.h"
#include "glob.h"
+#include "txr.h"
+
+#define GLOB_XNOBRACE (1 << 30)
+#define GLOB_XSTAR (1 << 29)
static val s_errfunc;
static uw_frame_t *s_exit_point;
+static int super_glob(const char *pattern, int flags,
+ int (*errfunc) (const char *epath, int eerrno),
+ glob_t *pglob);
+
static int errfunc_thunk(const char *errpath, int errcode)
{
val result = t;
@@ -67,22 +76,65 @@ static int errfunc_thunk(const char *errpath, int errcode)
val glob_wrap(val pattern, val flags, val errfun)
{
- cnum c_flags = c_num(default_arg(flags, zero));
- char *pat_u8 = utf8_dup_to(c_str(pattern));
+ val self = lit("glob");
+ cnum c_flags = c_num(default_arg(flags, zero), self);
glob_t gl;
+ int (*globfn)(const char *, int,
+ int (*) (const char *, int),
+ glob_t *) = if3((c_flags & GLOB_XSTAR) != 0, super_glob, glob);
+ size_t i = 0;
+ list_collect_decl (out, ptail);
- if (s_errfunc) {
- free(pat_u8);
- uw_throwf(error_s, lit("glob: glob cannot be re-entered from "
- "its error callback function"), nao);
- }
+ if (s_errfunc)
+ uw_throwf(error_s, lit("~a: glob cannot be re-entered from "
+ "its error callback function"), self, nao);
s_errfunc = default_null_arg(errfun);
- (void) glob(pat_u8, c_flags, s_errfunc ? errfunc_thunk : 0, &gl);
+ c_flags &= ~(GLOB_APPEND | GLOB_XSTAR | GLOB_XNOBRACE);
+
+#ifdef GLOB_BRACE
+ if (globfn == super_glob)
+ c_flags &= ~GLOB_BRACE;
+#endif
+
+ if (stringp(pattern)) {
+ char *pat_u8 = utf8_dup_to(c_str(pattern, self));
+ const char *prev = "";
+ (void) globfn(pat_u8, c_flags, s_errfunc ? errfunc_thunk : 0, &gl);
+ free(pat_u8);
+ for (; i < gl.gl_pathc; i++) {
+ const char *path = gl.gl_pathv[i];
+ if (prev == path || strcmp(prev, path) == 0)
+ continue;
+ ptail = list_collect (ptail, string_utf8(path));
+ prev = path;
+ }
+ } else {
+ seq_iter_t iter;
+ val elem;
+ seq_iter_init(self, &iter, pattern);
+
+ while (seq_get(&iter, &elem)) {
+ char *pat_u8 = utf8_dup_to(c_str(elem, self));
+ const char *prev = "";
+ (void) globfn(pat_u8, c_flags, s_errfunc ? errfunc_thunk : 0, &gl);
+ free(pat_u8);
+ if (s_exit_point)
+ break;
+ c_flags |= GLOB_APPEND;
+
+ for (; i < gl.gl_pathc; i++) {
+ const char *path = gl.gl_pathv[i];
+ if (prev == path || strcmp(prev, path) == 0)
+ continue;
+ ptail = list_collect (ptail, string_utf8(path));
+ prev = path;
+ }
+ }
+ }
s_errfunc = nil;
- free(pat_u8);
if (s_exit_point) {
uw_frame_t *ep = s_exit_point;
@@ -91,16 +143,152 @@ val glob_wrap(val pattern, val flags, val errfun)
uw_continue(ep);
}
+ globfree(&gl);
+ return out;
+}
+
+static const char *super_glob_find_inner(const char *pattern)
+{
+ enum state { init, bsl, cls } st = init, pst = init;
+ int ch;
+
+ for (; (ch = *pattern) != 0; pattern++) {
+ switch (st) {
+ case init:
+ if (strncmp(pattern, "/**/", 4) == 0)
+ return pattern + 1;
+ switch (ch) {
+ case '\\':
+ pst = init;
+ st = bsl;
+ break;
+ case '[':
+ st = cls;
+ break;
+ }
+ break;
+ case bsl:
+ st = pst;
+ break;
+ case cls:
+ switch (ch) {
+ case '\\':
+ pst = cls;
+ st = bsl;
+ break;
+ case ']':
+ st = init;
+ break;
+ }
+ }
+ }
+
+ return 0;
+}
+
+static int super_glob_rec(const char *pattern, int flags,
+ int (*errfunc) (const char *epath, int eerrno),
+ glob_t *pglob, size_t star_limit)
+{
+ const char *dblstar = 0;
+
+ if (strncmp(pattern, "**/", 3) == 0 || strcmp(pattern, "**") == 0) {
+ dblstar = pattern;
+ } else if ((dblstar = super_glob_find_inner(pattern)) != 0) {
+ /* nothing */
+ } else if (strlen(pattern) >= 3) {
+ const char *end = pattern + strlen(pattern);
+ if (strcmp(end - 3, "/**") == 0)
+ {
+ const char *maybe_sl_dblstar = end - 3;
+
+ if (maybe_sl_dblstar == pattern || maybe_sl_dblstar[-1] != '\\')
+ dblstar = maybe_sl_dblstar + 1;
+ }
+ }
+
+ if (dblstar == 0) {
+ return glob(pattern, flags, errfunc, pglob);
+ } else {
+ size_t i, base_len = strlen(pattern);
+ size_t ds_off = dblstar - pattern;
+ size_t tail_off = ds_off + 2;
+ size_t limit = star_limit > 10 ? 10 : star_limit;
+
+ for (i = 0; i < limit; i++) {
+ size_t space = base_len - 3 + i * 2;
+ char *pat_copy = coerce(char *, chk_malloc(space + 2));
+ size_t j;
+ char *out = pat_copy + ds_off;
+ int res;
+
+ strncpy(pat_copy, pattern, ds_off);
+
+ for (j = 0; j < i; j++) {
+ if (j > 0)
+ *out++ = '/';
+ *out++ = '*';
+ }
+
+ if (i == 0 && pattern[tail_off] == '/')
+ strcpy(out, pattern + tail_off + 1);
+ else
+ strcpy(out, pattern + tail_off);
+
+ if (i > 0)
+ flags |= GLOB_APPEND;
+
+ res = super_glob_rec(pat_copy, flags, errfunc, pglob, star_limit - i);
+
+ free(pat_copy);
+
+ if (res && res != GLOB_NOMATCH)
+ return res;
+ }
+
+ return 0;
+ }
+}
+
+static int glob_path_cmp(const void *ls, const void *rs)
+{
+ const unsigned char *lstr = *convert(const unsigned char * const *, ls);
+ const unsigned char *rstr = *convert(const unsigned char * const *, rs);
+
+ for (; *lstr && *rstr; lstr++, rstr++)
{
- size_t i;
- list_collect_decl (out, ptail);
+ if (*lstr == *rstr)
+ continue;
+ if (*lstr == '/')
+ return -1;
+ if (*rstr == '/')
+ return 1;
+ if (*lstr < *rstr)
+ return -1;
+ if (*lstr > *rstr)
+ return 1;
+ }
- for (i = 0; i < gl.gl_pathc; i++)
- ptail = list_collect (ptail, string_utf8(gl.gl_pathv[i]));
+ if (!*lstr)
+ return -1;
+ if (!*rstr)
+ return 1;
- globfree(&gl);
- return out;
+ return 0;
+}
+
+static int super_glob(const char *pattern, int flags,
+ int (*errfunc) (const char *epath, int eerrno),
+ glob_t *pglob)
+{
+ int res = super_glob_rec(pattern, flags | GLOB_NOSORT, errfunc, pglob, 48);
+
+ if (res == 0 && (flags & GLOB_NOSORT) == 0) {
+ qsort(pglob->gl_pathv, pglob->gl_pathc,
+ sizeof pglob->gl_pathv[0], glob_path_cmp);
}
+
+ return 0;
}
void glob_init(void)
@@ -133,4 +321,6 @@ void glob_init(void)
#ifdef GLOB_ONLYDIR
reg_varl(intern(lit("glob-onlydir"), user_package), num_fast(GLOB_ONLYDIR));
#endif
+ reg_varl(intern(lit("glob-xstar"), system_package), num(GLOB_XSTAR));
+ reg_varl(intern(lit("glob-xnobrace"), user_package), num(GLOB_XNOBRACE));
}
diff --git a/glob.h b/glob.h
index 259901dc..7c038f96 100644
--- a/glob.h
+++ b/glob.h
@@ -1,4 +1,4 @@
-/* Copyright 2015-2020
+/* Copyright 2015-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
val glob_wrap(val pattern, val flags, val errfun);
diff --git a/gzio.c b/gzio.c
new file mode 100644
index 00000000..4f7430b1
--- /dev/null
+++ b/gzio.c
@@ -0,0 +1,597 @@
+/* Copyright 2022-2024
+ * Kaz Kylheku <kaz@kylheku.com>
+ * Vancouver, Canada
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ */
+
+#include <stddef.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdarg.h>
+#include <wchar.h>
+#include <signal.h>
+#include <errno.h>
+#include <zlib.h>
+#include "config.h"
+#if HAVE_SYS_WAIT
+#include <sys/wait.h>
+#endif
+#include "alloca.h"
+#include "lib.h"
+#include "stream.h"
+#include "gc.h"
+#include "args.h"
+#include "utf8.h"
+#include "eval.h"
+#include "signal.h"
+#include "unwind.h"
+#include "sysif.h"
+#include "itypes.h"
+#include "gzio.h"
+
+struct gzio_handle {
+ struct strm_base a;
+ gzFile f;
+ val descr;
+ val unget_c;
+ utf8_decoder_t ud;
+ val err, errstr;
+ char *buf;
+ int fd;
+#if HAVE_FORK_STUFF
+ pid_t pid;
+#endif
+ unsigned is_byte_oriented : 8;
+ unsigned is_output : 8;
+};
+
+val gzio_stream_s;
+
+struct cobj_class *gzio_stream_cls;
+
+static void gzio_stream_print(val stream, val out, val pretty,
+ struct strm_ctx *ctx)
+{
+ struct strm_ops *ops = coerce(struct strm_ops *, stream->co.ops);
+ val name = static_str(ops->name);
+ val descr = ops->get_prop(stream, name_k);
+
+ (void) pretty;
+ (void) ctx;
+
+ format(out, lit("#<~a ~a ~p>"), name, descr, stream, nao);
+}
+
+static void gzio_stream_destroy(val stream)
+{
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+ close_stream(stream, nil);
+ strm_base_cleanup(&h->a);
+ free(h->buf);
+ free(h);
+}
+
+static void gzio_stream_mark(val stream)
+{
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+ strm_base_mark(&h->a);
+ gc_mark(h->descr);
+ gc_mark(h->err);
+ gc_mark(h->errstr);
+}
+
+static val gzio_maybe_read_error(val stream)
+{
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+ const char *gztxt;
+ int gzerr;
+
+ if (h->f == 0) {
+ uw_throwf(file_error_s, lit("error reading ~s: file closed"), stream, nao);
+ } else if (gzeof(h->f)) {
+ h->err = t;
+ h->errstr = lit("eof");
+ } else if ((gztxt = gzerror(h->f, &gzerr)) != 0 && gzerr != Z_OK) {
+ if (gzerr == Z_ERRNO) {
+ int eno = errno;
+ h->err = num(eno);
+ h->errstr = nil;
+#ifdef EAGAIN
+ if (errno == EAGAIN)
+ uw_ethrowf(timeout_error_s, lit("timed out reading ~s"), stream, nao);
+#endif
+ uw_ethrowf(file_error_s, lit("error reading ~s: ~d/~s"),
+ stream, h->err, errno_to_string(h->err), nao);
+ } else {
+ h->err = negone;
+ h->errstr = string_utf8(gztxt);
+ }
+ } else {
+ h->err = nil;
+ h->errstr = lit("no error");
+ }
+
+ return nil;
+}
+
+static val gzio_maybe_error(val stream, val action)
+{
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+ val err = num(errno);
+ if (h->f == 0)
+ uw_ethrowf(file_error_s, lit("error ~a ~s: file closed"), action, stream, nao);
+ h->err = err;
+#ifdef EAGAIN
+ if (errno == EAGAIN)
+ uw_ethrowf(timeout_error_s, lit("timed out on ~s"), stream, nao);
+#endif
+ uw_ethrowf(file_error_s, lit("error ~a ~s: ~d/~s"),
+ action, stream, err, errno_to_string(err), nao);
+}
+
+static val gzio_get_error(val stream)
+{
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+ if (h->f != 0 && gzeof(h->f))
+ return t;
+ return h->err;
+}
+
+static val gzio_get_error_str(val stream)
+{
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+
+ if (h->f != 0 && gzeof(h->f))
+ return lit("eof");
+ return h->errstr;
+}
+
+static val gzio_clear_error(val stream)
+{
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+ val ret = h->err;
+ if (h->f != 0)
+ gzclearerr(h->f);
+ h->err = h->errstr = lit("no error");
+ return ret;
+}
+
+static val gzio_get_fd(val stream)
+{
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+ return (h->f && h->fd != -1) ? num(h->fd) : nil;
+}
+
+static int se_gzputc(int ch, gzFile f)
+{
+ int ret;
+ sig_save_enable;
+ ret = gzputc(f, ch);
+ sig_restore_enable;
+ return ret;
+}
+
+static int se_gzgetc(gzFile f)
+{
+ int ret;
+ sig_save_enable;
+ ret = gzgetc(f);
+ sig_restore_enable;
+ return ret;
+}
+
+static int gzio_get_char_callback(mem_t *f)
+{
+ return se_gzgetc(coerce(gzFile, f));
+}
+
+static val gzio_get_char(val stream)
+{
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+
+ if (h->unget_c)
+ return rcyc_pop(&h->unget_c);
+
+ if (h->f) {
+ wint_t ch;
+
+ if (h->is_byte_oriented) {
+ ch = se_gzgetc(h->f);
+ if (ch == 0)
+ ch = 0xDC00;
+ } else {
+ ch = utf8_decode(&h->ud, gzio_get_char_callback,
+ coerce(mem_t *, h->f));
+ }
+
+ return (ch != WEOF) ? chr(ch) : gzio_maybe_read_error(stream);
+ }
+ return gzio_maybe_read_error(stream);
+}
+
+static val gzio_get_byte(val stream)
+{
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+
+ if (h->f) {
+ int ch = se_gzgetc(h->f);
+ return (ch != EOF) ? num(ch) : gzio_maybe_read_error(stream);
+ }
+ return gzio_maybe_read_error(stream);
+}
+
+static val gzio_unget_char(val stream, val ch)
+{
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+ mpush(ch, mkloc(h->unget_c, stream));
+ return ch;
+}
+
+static val gzio_unget_byte(val stream, int byte)
+{
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+
+ errno = 0;
+ return h->f != 0 && gzungetc(byte, coerce(gzFile, h->f)) != EOF
+ ? num_fast(byte)
+ : gzio_maybe_error(stream, lit("writing"));
+}
+
+static ucnum gzio_fill_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
+{
+ val self = lit("fill-buf");
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+ if (convert(size_t, len) != len || len > INT_PTR_MAX)
+ uw_throwf(error_s, lit("~a: buffer too large"), self, nao);
+ if (pos >= len)
+ return len;
+ errno = 0;
+ if (h->f != 0) {
+ cnum nread = gzread(h->f, ptr + pos, len - pos);
+ if (nread > 0)
+ return pos + nread;
+ }
+ gzio_maybe_read_error(stream);
+ return pos;
+}
+
+static val gzio_close(val stream, val throw_on_error)
+{
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+
+ if (h->f != 0) {
+ int result = gzclose(h->f);
+ h->f = 0;
+ if (result != Z_OK) {
+ if (default_null_arg(throw_on_error))
+ gzio_maybe_error(stream, lit("closing"));
+ return nil;
+ }
+#if HAVE_FORK_STUFF
+ if (h->pid != 0)
+ {
+ int status = 0;
+ val self = lit("close-stream");
+ sig_save_enable;
+ while (waitpid(h->pid, &status, 0) == -1 && errno == EINTR)
+ ;
+ sig_restore_enable;
+ return pipe_close_status_helper(stream, throw_on_error, status, self);
+ }
+#endif
+ }
+ return nil;
+}
+
+static val num_z_off_t(z_off_t off)
+{
+ if (sizeof (off) <= sizeof (cnum)) {
+ return num(off);
+ } else if (NUM_MIN <= off && off <= NUM_MAX) {
+ return num(off);
+ } else if (sizeof (off) <= sizeof (i64_t)) {
+ return num_64(off);
+ } else {
+ internal_error("portme: unsupported z_off_t size");
+ }
+}
+static z_off_t z_off_t_num(val num, val self)
+{
+ switch (CHAR_BIT * sizeof(z_off_t)) {
+ case 32:
+ return c_i32(num, self);
+ case 64:
+ return c_i64(num, self);
+ default:
+ internal_error("portme: unsupported z_off_t size");
+ }
+}
+static val gzio_seek(val stream, val offset, enum strm_whence whence)
+{
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+ val self = lit("seek-stream");
+
+ errno = 0;
+
+ if (h->f != 0) {
+ if (offset == zero && whence == strm_cur) {
+ return num_z_off_t(gztell(h->f));
+ } else {
+ if (gzseek(h->f, z_off_t_num(offset, self), whence) >= 0) {
+ if (!h->is_output)
+ utf8_decoder_init(&h->ud);
+ h->unget_c = nil;
+ return t;
+ }
+ }
+ }
+
+ return gzio_maybe_error(stream, lit("seeking"));
+}
+
+static int gzio_put_char_callback(int ch, mem_t *f)
+{
+ int ret = se_gzputc(ch, coerce(gzFile, f)) != EOF;
+ return ret;
+}
+
+static val gzio_put_string(val stream, val str)
+{
+ val self = lit("put-string");
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+
+ errno = 0;
+
+ if (h->f != 0) {
+ const wchar_t *s = c_str(str, self);
+
+ while (*s) {
+ if (!utf8_encode(*s++, gzio_put_char_callback, coerce(mem_t *, h->f)))
+ return gzio_maybe_error(stream, lit("writing"));
+ }
+ return t;
+ }
+ return gzio_maybe_error(stream, lit("writing"));
+}
+
+static val gzio_put_char(val stream, val ch)
+{
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+ errno = 0;
+ return h->f != 0 && utf8_encode(c_chr(ch), gzio_put_char_callback,
+ coerce(mem_t *, h->f))
+ ? t : gzio_maybe_error(stream, lit("writing"));
+}
+
+static val gzio_put_byte(val stream, int b)
+{
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+ errno = 0;
+ return h->f != 0 && se_gzputc(b, coerce(gzFile, h->f)) != EOF
+ ? t : gzio_maybe_error(stream, lit("writing"));
+}
+
+static ucnum gzio_put_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
+{
+ val self = lit("put-buf");
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+ if (convert(size_t, len) != len || len > INT_PTR_MAX)
+ uw_throwf(error_s, lit("~a: buffer too large"), self, nao);
+ if (pos >= len)
+ return len;
+ errno = 0;
+ if (h->f != 0) {
+ cnum nwrit = gzwrite(h->f, ptr + pos, len - pos);
+ if (nwrit > 0)
+ return pos + nwrit;
+ }
+ gzio_maybe_error(stream, lit("writing"));
+ return 0;
+}
+
+static val gzio_get_prop(val stream, val ind)
+{
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+
+ if (ind == name_k) {
+ return h->descr;
+ } else if (ind == byte_oriented_k) {
+ return h->is_byte_oriented ? t : nil;
+ }
+ return nil;
+}
+
+static val gzio_set_prop(val stream, val ind, val prop)
+{
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+
+ if (ind == name_k) {
+ h->descr = prop;
+ return t;
+ } else if (ind == byte_oriented_k) {
+ h->is_byte_oriented = prop ? 1 : 0;
+ return t;
+ }
+
+ return nil;
+}
+
+static struct strm_ops gzio_ops_rd =
+ strm_ops_init(cobj_ops_init(eq,
+ gzio_stream_print,
+ gzio_stream_destroy,
+ gzio_stream_mark,
+ cobj_eq_hash_op),
+ wli("gzip-input-stream"),
+ 0,
+ 0,
+ 0,
+ generic_get_line,
+ gzio_get_char,
+ gzio_get_byte,
+ gzio_unget_char,
+ gzio_unget_byte,
+ 0,
+ gzio_fill_buf,
+ gzio_close,
+ 0,
+ gzio_seek,
+ 0,
+ gzio_get_prop,
+ gzio_set_prop,
+ gzio_get_error,
+ gzio_get_error_str,
+ gzio_clear_error,
+ gzio_get_fd);
+
+static struct strm_ops gzio_ops_wr =
+ strm_ops_init(cobj_ops_init(eq,
+ gzio_stream_print,
+ gzio_stream_destroy,
+ gzio_stream_mark,
+ cobj_eq_hash_op),
+ wli("gzip-output-stream"),
+ gzio_put_string,
+ gzio_put_char,
+ gzio_put_byte,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ gzio_put_buf,
+ 0,
+ gzio_close,
+ 0,
+ gzio_seek,
+ 0,
+ gzio_get_prop,
+ gzio_set_prop,
+ gzio_get_error,
+ gzio_get_error_str,
+ gzio_clear_error,
+ gzio_get_fd);
+
+void gzio_init(void)
+{
+ fill_stream_ops(&gzio_ops_rd);
+ fill_stream_ops(&gzio_ops_wr);
+ gzio_stream_s = intern(lit("gzip-stream"), user_package);
+ gzio_stream_cls = cobj_register_super(gzio_stream_s, stream_cls);
+}
+
+gzFile w_gzopen_mode(const wchar_t *wname, const wchar_t *wmode,
+ const struct stdio_mode m, val self)
+{
+ if (m.buforder >= 0 || m.nonblock || m.notrunc || m.unbuf ||
+ m.linebuf || m.interactive)
+ {
+ uw_throwf(file_error_s,
+ lit("~a: invalid modes for gzip stream"), self, nao);
+ }
+
+ if (m.read && m.write) {
+ uw_throwf(file_error_s,
+ lit("~a: gzip stream cannot both read and write"), self, nao);
+ }
+
+#if HAVE_FCNTL
+ {
+ int fd = w_open_mode(wname, m);
+ return (fd < 0) ? NULL : w_gzdopen_mode(fd, wmode, m, self);
+ }
+#else
+ {
+ char *name = utf8_dup_to(wname);
+ char *mode = utf8_dup_to(wmode);
+ gzFile f = gzopen(name, mode);
+ free(name);
+ free(mode);
+ return f;
+ }
+#endif
+}
+
+gzFile w_gzdopen_mode(int fd, const wchar_t *wmode,
+ const struct stdio_mode m, val self)
+{
+ if (m.buforder >= 0 || m.nonblock || m.notrunc || m.unbuf ||
+ m.linebuf || m.interactive)
+ {
+ goto badmode;
+ }
+
+ if (m.read && m.write) {
+ uw_throwf(file_error_s,
+ lit("~a: gzip stream cannot both read and write"), self, nao);
+ }
+
+ {
+ char *mode = utf8_dup_to(wmode);
+ gzFile f = gzdopen(fd, mode);
+ free(mode);
+ if (f)
+ return f;
+ }
+
+badmode:
+ uw_throwf(file_error_s,
+ lit("~a: invalid modes for gzip stream"), self, nao);
+}
+
+val make_gzio_stream(gzFile f, int fd, val descr, int is_output)
+{
+ struct gzio_handle *h = coerce(struct gzio_handle *, chk_malloc(sizeof *h));
+ val stream = cobj(coerce(mem_t *, h), gzio_stream_cls,
+ if3(is_output,
+ &gzio_ops_wr.cobj_ops, &gzio_ops_rd.cobj_ops));
+ strm_base_init(&h->a);
+ h->f = f;
+ h->fd = fd;
+ h->descr = descr;
+ h->unget_c = nil;
+ utf8_decoder_init(&h->ud);
+ h->err = nil;
+ h->errstr = lit("no error");
+ h->buf = 0;
+ h->is_byte_oriented = 0;
+ h->is_output = is_output;
+#if HAVE_FORK_STUFF
+ h->pid = 0;
+#endif
+ return stream;
+}
+
+#if HAVE_FORK_STUFF
+
+val make_gzio_pipe_stream(gzFile f, int fd, val descr, int is_output, pid_t pid)
+{
+ val stream = make_gzio_stream(f, fd, descr, is_output);
+ struct gzio_handle *h = coerce(struct gzio_handle *, stream->co.handle);
+ h->pid = pid;
+ return stream;
+}
+
+#endif
diff --git a/gzio.h b/gzio.h
new file mode 100644
index 00000000..c714e01c
--- /dev/null
+++ b/gzio.h
@@ -0,0 +1,38 @@
+/* Copyright 2022-2024
+ * Kaz Kylheku <kaz@kylheku.com>
+ * Vancouver, Canada
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ */
+
+extern val gzio_stream_s;
+void gzio_init(void);
+gzFile w_gzopen_mode(const wchar_t *wname, const wchar_t *wmode,
+ const struct stdio_mode m, val self);
+gzFile w_gzdopen_mode(int fd, const wchar_t *wmode,
+ const struct stdio_mode m, val self);
+val make_gzio_stream(gzFile f, int fd, val descr, int is_output);
+#if HAVE_FORK_STUFF
+val make_gzio_pipe_stream(gzFile f, int fd, val descr, int is_output, pid_t pid);
+#endif
diff --git a/hash.c b/hash.c
index 9f4df00b..7ebe95a7 100644
--- a/hash.c
+++ b/hash.c
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stddef.h>
@@ -46,17 +47,10 @@
#include "stream.h"
#include "eval.h"
#include "itypes.h"
-#include "arith.h"
#include "sysif.h"
+#include "time.h"
#include "hash.h"
-typedef enum hash_flags {
- hash_weak_none = 0,
- hash_weak_keys = 1,
- hash_weak_vals = 2,
- hash_weak_both = 3
-} hash_flags_t;
-
typedef enum hash_type {
hash_type_eq,
hash_type_eql,
@@ -67,21 +61,21 @@ struct hash_ops {
ucnum (*hash_fun)(val, int *, ucnum);
val (*equal_fun)(val, val);
val (*assoc_fun)(val key, ucnum hash, val list);
- val (*acons_new_c_fun)(val key, ucnum hash, loc new_p, loc list);
};
-#define hash_ops_init(hash, equal, assoc, acons) \
- { hash, equal, assoc, acons }
+#define hash_ops_init(hash, equal, assoc) \
+ { hash, equal, assoc }
struct hash {
ucnum seed;
- hash_flags_t flags;
+ hash_weak_opt_t wkopt;
struct hash *next;
val table;
- cnum modulus;
- cnum count;
+ ucnum mask;
+ ucnum count;
val userdata;
int usecount;
+ val tblstack;
struct hash_ops *hops;
};
@@ -91,10 +85,11 @@ static_forward(struct hash_ops hash_eq_ops);
static_forward(struct hash_ops hash_eql_ops);
static_forward(struct hash_ops hash_equal_ops);
-val weak_keys_k, weak_vals_k, userdata_k;
+val weak_keys_k, weak_vals_k, weak_and_k, weak_or_k, userdata_k;
val equal_based_k, eql_based_k, eq_based_k;
val hash_seed_s;
+struct cobj_class *hash_cls, *hash_iter_cls;
/*
* Dynamic lists built up during gc.
*/
@@ -103,6 +98,107 @@ static struct hash_iter *reachable_iters;
static int hash_traversal_limit = 32;
+#if SIZEOF_PTR == 8
+
+static u64_t randbox[] = {
+ 0x41f00c9949848f1bU, 0x16f1d887e6255dbaU,
+ 0x6921f21236da5bdcU, 0x1878975147bf94e9U,
+ 0x97b6024b8cbcce22U, 0x9a803523559fc06aU,
+ 0x45d41914d268f536U, 0x40b0bc43e10af79aU,
+ 0x90e011a9c1af4d69U, 0x6ac090fe1d2917b5U,
+ 0x142a6ebeec4c304dU, 0x08fb26fc9ee5016cU,
+ 0x3f04e1d969232f74U, 0x6177e1befead7bb3U,
+ 0x778108b4e9089ab6U, 0x6a6e2ab4f012f6aeU
+};
+
+static u64_t hash_c_str(const wchar_t *str, u64_t seed, int *pcount)
+{
+ int count = *pcount << 2;
+ u64_t acc = seed;
+ u64_t ch;
+
+ while (count-- && (ch = *str++) != 0) {
+ acc ^= ch;
+ acc ^= randbox[acc & 0xf];
+ acc = acc >> 1 | acc << (64 - 1);
+ }
+
+ acc ^= randbox[acc & 0xf];
+ acc = acc >> 1 | acc << (64 - 1);
+ acc ^= randbox[acc & 0xf];
+ acc = acc >> 1 | acc << (64 - 1);
+ acc ^= randbox[acc & 0xf];
+ acc = acc >> 1 | acc << (64 - 1);
+ acc ^= randbox[acc & 0xf];
+
+ *pcount = count >> 2;
+
+ return acc;
+}
+
+static u64_t hash_buf(const mem_t *ptr, ucnum size, u64_t seed, int *pcount)
+{
+ const u64_t *buf = coerce(const u64_t *, ptr);
+ int count = *pcount << 2;
+ u64_t acc = seed;
+
+ for (; size >= sizeof *buf && count--; size -= sizeof *buf, buf++) {
+ u64_t in = *buf;
+ acc ^= in;
+ acc ^= randbox[acc & 0xf];
+ acc = acc >> 1 | acc << (64 - 1);
+ }
+
+ if (size != 0) {
+ const mem_t *tail = coerce(const mem_t *, ptr);
+ u64_t in = 0;
+
+ switch (size) {
+ case 7:
+ in |= convert(u64_t, tail[6]) << 48;
+ break;
+ /* fallthrough */
+ case 6:
+ in |= convert(u64_t, tail[5]) << 40;
+ break;
+ /* fallthrough */
+ case 5:
+ in |= convert(u64_t, tail[4]) << 32;
+ break;
+ case 4:
+ in |= convert(u64_t, tail[3]) << 24;
+ break;
+ case 3:
+ in |= convert(u64_t, tail[2]) << 16;
+ /* fallthrough */
+ case 2:
+ in |= convert(u64_t, tail[1]) << 8;
+ /* fallthrough */
+ case 1:
+ in |= convert(u64_t, tail[0]);
+ break;
+ }
+
+ acc ^= in;
+ acc ^= randbox[acc & 0xf];
+ acc = acc >> 1 | acc << (64 - 1);
+ }
+
+ acc ^= randbox[acc & 0xf];
+ acc = acc >> 1 | acc << (64 - 1);
+ acc ^= randbox[acc & 0xf];
+ acc = acc >> 1 | acc << (64 - 1);
+ acc ^= randbox[acc & 0xf];
+ acc = acc >> 1 | acc << (64 - 1);
+ acc ^= randbox[acc & 0xf];
+
+ *pcount = count >> 2;
+
+ return acc;
+}
+
+#elif SIZEOF_PTR == 4
+
static u32_t randbox[] = {
0x49848f1bU, 0xe6255dbaU, 0x36da5bdcU, 0x47bf94e9U,
0x8cbcce22U, 0x559fc06aU, 0xd268f536U, 0xe10af79aU,
@@ -155,10 +251,13 @@ static u32_t hash_buf(const mem_t *ptr, ucnum size, u32_t seed, int *pcount)
switch (size) {
case 3:
in |= convert(u32_t, tail[2]) << 16;
+ /* fallthrough */
case 2:
in |= convert(u32_t, tail[1]) << 8;
+ /* fallthrough */
case 1:
in |= convert(u32_t, tail[0]);
+ break;
}
acc ^= in;
@@ -179,6 +278,10 @@ static u32_t hash_buf(const mem_t *ptr, ucnum size, u32_t seed, int *pcount)
return acc;
}
+#else
+#error portme
+#endif
+
static ucnum hash_double(double n)
{
union hack {
@@ -188,22 +291,26 @@ static ucnum hash_double(double n)
ucnum h = 0;
unsigned i;
- u.d = n;
+ if (n != 0.0) {
+ u.d = n;
- for (i = 0; i < sizeof u.a / sizeof u.a[0]; i++)
- h += u.a[i];
+ for (i = 0; i < sizeof u.a / sizeof u.a[0]; i++)
+ h += u.a[i];
+ }
return h;
}
ucnum equal_hash(val obj, int *count, ucnum seed)
{
+ val self = lit("hash-equal");
+
if ((*count)-- <= 0)
return 0;
switch (type(obj)) {
case NIL:
- return convert(ucnum, -1);
+ return UINT_PTR_MAX;
case LIT:
return hash_c_str(litptr(obj), seed, count);
case CONS:
@@ -212,9 +319,9 @@ ucnum equal_hash(val obj, int *count, ucnum seed)
case STR:
return hash_c_str(obj->st.str, seed, count);
case CHR:
- return c_chr(obj);
+ return c_ch(obj);
case NUM:
- return c_num(obj);
+ return c_u(obj);
case SYM:
case PKG:
case ENV:
@@ -233,7 +340,7 @@ ucnum equal_hash(val obj, int *count, ucnum seed)
{
val length = obj->v.vec[vec_length];
ucnum h = equal_hash(obj->v.vec[vec_length], count, seed);
- cnum i, len = c_num(length);
+ cnum i, len = c_num(length, self);
ucnum lseed;
for (i = 0, lseed = seed; i < len; i++, lseed += seed) {
@@ -252,9 +359,9 @@ ucnum equal_hash(val obj, int *count, ucnum seed)
lazy_str_force_upto(obj, num(*count - 1));
return equal_hash(obj->ls.prefix, count, seed);
case BGNUM:
- return mp_hash(mp(obj)) * seed;
+ return mp_hash(mp(obj)) * if3(seed, seed, 1);
case FLNUM:
- return hash_double(obj->fl.n) * seed;
+ return hash_double(c_f(obj)) * if3(seed, seed, 1);
case COBJ:
case CPTR:
if (obj->co.ops->equalsub) {
@@ -267,7 +374,7 @@ ucnum equal_hash(val obj, int *count, ucnum seed)
return equal_hash(obj->rn.from, count, seed)
+ equal_hash(obj->rn.to, count, seed + (RNG << 8));
case BUF:
- return hash_buf(obj->b.data, c_unum(obj->b.len), seed, count);
+ return hash_buf(obj->b.data, c_unum(obj->b.len, self), seed, count);
case TNOD:
return equal_hash(obj->tn.left, count, (seed + TNOD))
+ equal_hash(obj->tn.right, count, seed + (TNOD << 8))
@@ -286,11 +393,11 @@ static ucnum eql_hash(val obj, int *count)
case TAG_PTR:
switch (type(obj)) {
case NIL:
- return convert(ucnum, -1);
+ return UINT_PTR_MAX;
case BGNUM:
return mp_hash(mp(obj));
case FLNUM:
- return hash_double(obj->fl.n);
+ return hash_double(c_f(obj));
case RNG:
return eql_hash(obj->rn.from, count) + 2 * eql_hash(obj->rn.to, count);
default:
@@ -302,9 +409,9 @@ static ucnum eql_hash(val obj, int *count)
}
}
case TAG_CHR:
- return c_chr(obj);
+ return c_ch(obj);
case TAG_NUM:
- return c_num(obj);
+ return c_u(obj);
case TAG_LIT:
switch (CHAR_BIT * sizeof (mem_t *)) {
case 32:
@@ -319,7 +426,7 @@ static ucnum eql_hash(val obj, int *count)
static ucnum eq_hash(val obj)
{
- switch (tag(obj)) {
+ switch (tag_ex(obj)) {
case TAG_PTR:
switch (CHAR_BIT * sizeof (mem_t *)) {
case 32:
@@ -328,9 +435,9 @@ static ucnum eq_hash(val obj)
return coerce(ucnum, obj) >> 5;
}
case TAG_CHR:
- return c_chr(obj);
+ return c_ch(obj);
case TAG_NUM:
- return c_num(obj);
+ return c_u(obj);
case TAG_LIT:
switch (CHAR_BIT * sizeof (mem_t *)) {
case 32:
@@ -338,11 +445,200 @@ static ucnum eq_hash(val obj)
case 64: default:
return coerce(ucnum, obj) >> 3;
}
+#if CONFIG_NAN_BOXING
+ case TAG_FLNUM:
+ return coerce(ucnum, obj);
+#endif
}
/* notreached */
abort();
}
+static ucnum hash_find_slot(struct hash *h, val key, ucnum hcode)
+{
+ val table = h->table;
+ val *vec = table->v.vec;
+ val (*equal_fun)(val, val) = h->hops->equal_fun;
+ ucnum mask = h->mask, start = hcode & mask, i = start;
+
+ do {
+ val cell = vec[i];
+
+ if (cell == nil)
+ break;
+
+ if (cell->ch.hash == hcode && equal_fun(us_car(cell), key))
+ return i;
+
+ i = (i + 1) & h->mask;
+ } while (i != start);
+
+ return UINT_PTR_MAX;
+}
+
+static val hash_lookup(struct hash *h, val key, ucnum hcode)
+{
+ val table = h->table;
+ val *vec = table->v.vec;
+
+ val (*equal_fun)(val, val) = h->hops->equal_fun;
+ ucnum mask = h->mask, start = hcode & mask, i = start;
+
+ do {
+ val cell = vec[i];
+
+ if (cell == nil)
+ break;
+
+ if (cell->ch.hash == hcode && equal_fun(us_car(cell), key))
+ return cell;
+
+ i = (i + 1) & h->mask;
+ } while (i != start);
+
+ return nil;
+}
+
+static void hash_grow(val hash, struct hash *h, ucnum mask)
+{
+ ucnum j, nmask = (mask << 1) | 1;
+ val ntable;
+ val table = h->table;
+ val *vec = h->table->v.vec;
+ val *nvec;
+
+ if (nmask > NUM_MAX - 1)
+ uw_throwf(error_s, lit("hash table overflow"), nao);
+
+ if (h->usecount > 0) {
+ push(table, &h->tblstack);
+ setcheck(hash, h->tblstack);
+ } else {
+ h->tblstack = nil;
+ }
+
+ ntable = vector(num_fast(nmask + 1), nil);
+ nvec = ntable->v.vec;
+
+ h->table = ntable;
+ h->mask = nmask;
+
+ setcheck(hash, ntable);
+
+ for (j = 0; j <= mask; j++) {
+ val cell = vec[j];
+
+ if (cell) {
+ ucnum hcode = cell->ch.hash;
+ ucnum start = hcode & nmask, i = start;
+
+ for (;; i = (i + 1) & nmask) {
+ if (nvec[i] == nil) {
+ nvec[i] = cell;
+ break;
+ }
+ }
+ }
+ }
+}
+
+static val hash_insert(val hash, struct hash *h, val key, ucnum hcode, loc new_p)
+{
+ val table = h->table;
+ val *vec = table->v.vec;
+ val (*equal_fun)(val, val) = h->hops->equal_fun;
+ ucnum mask = h->mask, start = hcode & mask, i = start;
+
+ do {
+ val cell = vec[i];
+
+ if (cell == nil) {
+ val ncell = cons(key, nil);
+ ncell->ch.hash = hcode;
+ vec[i] = ncell;
+ setcheck(table, ncell);
+ if (!nullocp(new_p))
+ deref(new_p) = t;
+ if (++h->count > h->mask >> 1)
+ hash_grow(hash, h, mask);
+ return ncell;
+ }
+
+ if (cell->ch.hash == hcode && equal_fun(us_car(cell), key)) {
+ if (!nullocp(new_p))
+ deref(new_p) = nil;
+ return cell;
+ }
+
+ i = (i + 1) & h->mask;
+ } while (i != start);
+
+ hash_grow(hash, h, mask);
+
+ return hash_insert(hash, h, key, hcode, new_p);
+}
+
+static val hash_remove(struct hash *h, ucnum victim)
+{
+ val table = h->table;
+ val *vec = table->v.vec;
+ ucnum wipe = victim, i = wipe, mask = h->mask;
+ val cell = vec[i];
+ val ret = nil;
+ val vicentry = vec[victim];
+
+ if (cell == nil)
+ return ret;
+
+ ret = us_cdr(cell);
+
+ i = (i + 1) & mask;
+
+ while (i != wipe) {
+ cell = vec[i];
+
+ if (cell == nil) {
+ break;
+ } else {
+ ucnum hcode = cell->ch.hash;
+ ucnum iprobe = hcode & mask;
+
+ if ((i < wipe) ^ (iprobe <= wipe) ^ (iprobe > i)) {
+ vec[wipe] = vec[i];
+ wipe = i;
+ }
+ i = (i + 1) & h->mask;
+ }
+ }
+
+ vec[wipe] = nil;
+ bug_unless (h->count > 0);
+ h->count--;
+
+ if (h->usecount) {
+ val tblit;
+
+ for (tblit = h->tblstack; tblit; tblit = us_cdr(tblit)) {
+ val stbl = us_car(tblit);
+ val *svec = stbl->v.vec;
+ ucnum smask = c_unum(svec[vec_length], nil) - 1;
+ ucnum start = victim & smask;
+ ucnum end = (victim + smask) & smask;
+
+ for (i = start; i != end; i = (i + 1) & smask) {
+ if (svec[i] == vicentry) {
+ svec[i] = nil;
+ break;
+ }
+ }
+ }
+ } else if (h->tblstack) {
+ h->tblstack = nil;
+ }
+
+ return ret;
+}
+
static ucnum eql_hash_op(val obj, int *count, ucnum seed)
{
(void) seed;
@@ -472,8 +768,10 @@ static ucnum hash_hash_op(val obj, int *count, ucnum seed)
switch (CHAR_BIT * sizeof (mem_t *)) {
case 32:
out += coerce(ucnum, h->hops) >> 4;
+ break;
case 64: default:
out += coerce(ucnum, h->hops) >> 5;
+ break;
}
out += equal_hash(h->userdata, count, seed);
@@ -504,25 +802,29 @@ static void hash_print_op(val hash, val out, val pretty, struct strm_ctx *ctx)
put_char(chr('('), out);
if (opt_compat && opt_compat <= 188) {
- if (h->hops == &hash_eq_ops)
+ if (h->hops == &hash_eq_ops) {
obj_print_impl(eq_based_k, out, pretty, ctx);
- else if (h->hops == &hash_equal_ops)
+ need_space = 1;
+ } else if (h->hops == &hash_equal_ops) {
obj_print_impl(equal_based_k, out, pretty, ctx);
- need_space = 1;
+ need_space = 1;
+ }
} else {
- if (h->hops == &hash_eql_ops)
+ if (h->hops == &hash_eql_ops) {
obj_print_impl(eql_based_k, out, pretty, ctx);
- else if (h->hops == &hash_eq_ops)
+ need_space = 1;
+ } else if (h->hops == &hash_eq_ops) {
obj_print_impl(eq_based_k, out, pretty, ctx);
- need_space = 1;
+ need_space = 1;
+ }
}
- if (h->flags != hash_weak_none) {
+ if (h->wkopt != hash_weak_none) {
if (need_space)
put_char(chr(' '), out);
need_space = 1;
- switch (h->flags) {
- case hash_weak_both:
+ switch (h->wkopt) {
+ case hash_weak_or:
obj_print_impl(weak_keys_k, out, pretty, ctx);
put_char(chr(' '), out);
/* fallthrough */
@@ -532,6 +834,9 @@ static void hash_print_op(val hash, val out, val pretty, struct strm_ctx *ctx)
case hash_weak_keys:
obj_print_impl(weak_keys_k, out, pretty, ctx);
break;
+ case hash_weak_and:
+ obj_print_impl(weak_and_k, out, pretty, ctx);
+ break;
default:
break;
}
@@ -586,55 +891,64 @@ static void hash_print_op(val hash, val out, val pretty, struct strm_ctx *ctx)
static void hash_mark(val hash)
{
struct hash *h = coerce(struct hash *, hash->co.handle);
- cnum i;
+ val table = h->table;
+ val *vec = table->v.vec;
+ ucnum mask = h->mask;
gc_mark(h->userdata);
+ if (h->count == 0 || h->tblstack) {
+ gc_mark(table);
+ gc_mark(h->tblstack);
+ return;
+ }
+
/* Use counts will be re-calculated by a scan of the
hash iterators which are still reachable. */
h->usecount = 0;
- switch (h->flags) {
+ switch (h->wkopt) {
+ ucnum i;
case hash_weak_none:
- /* If the hash is not weak, we can simply mark the table
- vector and we are done. */
- gc_mark(h->table);
- break;
+ gc_mark(table);
+ return;
case hash_weak_keys:
- /* Keys are weak: mark the values only. */
- for (i = 0; i < h->modulus; i++) {
- val chain = h->table->v.vec[i];
- val iter;
-
- for (iter = chain; iter != nil; iter = us_cdr(iter)) {
- val entry = us_car(iter);
- gc_mark(us_cdr(entry));
- }
+ /* Mark values only. Don't mark the table. */
+ for (i = 0; i <= mask; i++) {
+ val entry = vec[i];
+ if (!entry)
+ continue;
+ gc_mark(us_cdr(entry));
}
- h->next = reachable_weak_hashes;
- reachable_weak_hashes = h;
break;
case hash_weak_vals:
- /* Values are weak: mark the keys only. */
-
- for (i = 0; i < h->modulus; i++) {
- val chain = h->table->v.vec[i];
- val iter;
-
- for (iter = chain; iter != nil; iter = us_cdr(iter)) {
- val entry = us_car(iter);
- gc_mark(us_car(entry));
- }
+ /* Mark keys only. Don't mark the table. */
+ for (i = 0; i <= mask; i++) {
+ val entry = vec[i];
+ if (!entry)
+ continue;
+ gc_mark(us_car(entry));
}
- h->next = reachable_weak_hashes;
- reachable_weak_hashes = h;
break;
- case hash_weak_both:
- /* Values and keys are weak: don't mark anything. */
- h->next = reachable_weak_hashes;
- reachable_weak_hashes = h;
+ case hash_weak_or:
+ /* mark nothing */
+ break;
+ case hash_weak_and:
+ /* Mark key if value is reachable and vice versa. */
+ for (i = 0; i <= mask; i++) {
+ val entry = vec[i];
+ if (!entry)
+ continue;
+ if (gc_is_reachable(us_car(entry)))
+ gc_mark(us_cdr(entry));
+ else if (gc_is_reachable(us_cdr(entry)))
+ gc_mark(us_car(entry));
+ }
break;
}
+
+ h->next = reachable_weak_hashes;
+ reachable_weak_hashes = h;
}
static struct cobj_ops hash_ops = cobj_ops_init(hash_equal_op,
@@ -643,36 +957,6 @@ static struct cobj_ops hash_ops = cobj_ops_init(hash_equal_op,
hash_mark,
hash_hash_op);
-static void hash_grow(struct hash *h, val hash)
-{
- cnum i;
- cnum new_modulus = 2 * h->modulus;
- val new_table;
-
- if (new_modulus > NUM_MAX)
- return;
-
- new_table = vector(num_fast(new_modulus), nil);
-
- for (i = 0; i < h->modulus; i++) {
- val conses = h->table->v.vec[i];
-
- while (conses) {
- val entry = us_car(conses);
- val next = us_cdr(conses);
- loc pchain = mkloc(new_table->v.vec[entry->ch.hash % new_modulus],
- new_table);
- us_rplacd(conses, deref(pchain));
- set(pchain, conses);
- conses = next;
- }
- }
-
- h->modulus = new_modulus;
- h->table = new_table;
- setcheck(hash, new_table);
-}
-
static val hash_assoc(val key, ucnum hash, val list)
{
while (list) {
@@ -710,96 +994,41 @@ static val hash_assq(val key, ucnum hash, val list)
}
-static val hash_acons_new_c(val key, ucnum hash, loc new_p, loc list)
-{
- val existing = hash_assoc(key, hash, deref(list));
-
- if (existing) {
- if (!nullocp(new_p))
- deref(new_p) = nil;
- return existing;
- } else {
- val nc = cons(key, nil);
- nc->ch.hash = hash;
- set(list, cons(nc, deref(list)));
- if (!nullocp(new_p))
- deref(new_p) = t;
- return nc;
- }
-}
-
-static val hash_aconsql_new_c(val key, ucnum hash, loc new_p, loc list)
-{
- val existing = hash_assql(key, hash, deref(list));
-
- if (existing) {
- if (!nullocp(new_p))
- deref(new_p) = nil;
- return existing;
- } else {
- val nc = cons(key, nil);
- nc->ch.hash = hash;
- set(list, cons(nc, deref(list)));
- if (!nullocp(new_p))
- deref(new_p) = t;
- return nc;
- }
-}
-
-static val hash_aconsq_new_c(val key, ucnum hash, loc new_p, loc list)
-{
- val existing = hash_assq(key, hash, deref(list));
-
- if (existing) {
- if (!nullocp(new_p))
- deref(new_p) = nil;
- return existing;
- } else {
- val nc = cons(key, nil);
- nc->ch.hash = hash;
- set(list, cons(nc, deref(list)));
- if (!nullocp(new_p))
- deref(new_p) = t;
- return nc;
- }
-}
-
static_def(struct hash_ops hash_eq_ops = hash_ops_init(eq_hash_op, eql,
- hash_assq,
- hash_aconsq_new_c));
+ hash_assq));
static_def(struct hash_ops hash_eql_ops = hash_ops_init(eql_hash_op, eql,
- hash_assql,
- hash_aconsql_new_c));
+ hash_assql));
static_def(struct hash_ops hash_equal_ops = hash_ops_init(equal_hash, equal,
- hash_assoc,
- hash_acons_new_c));
+ hash_assoc));
-static val do_make_hash(val weak_keys, val weak_vals,
- hash_type_t type, val seed)
+static val do_make_hash(hash_weak_opt_t wkopt, hash_type_t type, val seed)
{
- if (weak_keys && type == hash_type_equal) {
+ val self = lit("make-hash");
+
+ if (type == hash_type_equal &&
+ wkopt != hash_weak_none && wkopt != hash_weak_vals)
+ {
uw_throwf(error_s,
lit("make-hash: bad combination :weak-keys with :equal-based"),
nao);
} else {
- int flags = ((weak_vals != nil) << 1) | (weak_keys != nil);
struct hash *h = coerce(struct hash *, chk_malloc(sizeof *h));
val mod = num_fast(256);
val table = vector(mod, nil);
- val hash = cobj(coerce(mem_t *, h), hash_s, &hash_ops);
+ val hash = cobj(coerce(mem_t *, h), hash_cls, &hash_ops);
- h->seed = convert(u32_t, c_unum(default_arg(seed,
- if3(hash_seed_s,
- hash_seed, zero))));
- h->flags = convert(hash_flags_t, flags);
- h->modulus = c_num(mod);
+ h->seed = c_unum(default_arg(seed, if3(hash_seed_s, hash_seed, zero)),
+ self);
+ h->wkopt = wkopt;
+ h->mask = c_unum(mod, self) - 1;
h->count = 0;
h->table = table;
h->userdata = nil;
h->usecount = 0;
+ h->tblstack = nil;
switch (type) {
case hash_type_eq:
@@ -818,106 +1047,123 @@ static val do_make_hash(val weak_keys, val weak_vals,
}
}
+static hash_weak_opt_t weak_opt_from_flags(val weak_keys, val weak_vals)
+{
+ if (weak_keys) {
+ if (weak_keys == weak_and_k)
+ return hash_weak_and;
+ if (weak_keys == weak_or_k)
+ return hash_weak_or;
+ }
+
+ switch (!!weak_vals << 1 | !!weak_keys) {
+ case 0: return hash_weak_none;
+ case 1: return hash_weak_keys;
+ case 2: return hash_weak_vals;
+ case 3: return hash_weak_or;
+ default:
+ /* notreached */
+ abort();
+ }
+}
+
val make_seeded_hash(val weak_keys, val weak_vals, val equal_based, val seed)
{
- return do_make_hash(weak_keys, weak_vals,
+ return do_make_hash(weak_opt_from_flags(weak_keys, weak_vals),
if3(equal_based, hash_type_equal, hash_type_eql),
seed);
}
-val make_hash(val weak_keys, val weak_vals, val equal_based)
+val make_hash(hash_weak_opt_t wkopt, val equal_based)
{
- return make_seeded_hash(weak_keys, weak_vals, equal_based, nil);
+ return do_make_hash(wkopt,
+ if3(equal_based, hash_type_equal, hash_type_eql),
+ nil);
}
-val make_eq_hash(val weak_keys, val weak_vals)
+val make_eq_hash(hash_weak_opt_t wkopt)
{
- return do_make_hash(weak_keys, weak_vals, hash_type_eq, nil);
+ return do_make_hash(wkopt, hash_type_eq, nil);
}
val make_similar_hash(val existing)
{
val self = lit("make-similar-hash");
- struct hash *ex = coerce(struct hash *, cobj_handle(self, existing, hash_s));
+ struct hash *ex = coerce(struct hash *, cobj_handle(self, existing, hash_cls));
struct hash *h = coerce(struct hash *, chk_malloc(sizeof *h));
val mod = num_fast(256);
val table = vector(mod, nil);
- val hash = cobj(coerce(mem_t *, h), hash_s, &hash_ops);
+ val hash = cobj(coerce(mem_t *, h), hash_cls, &hash_ops);
- h->modulus = c_num(mod);
+ h->mask = c_unum(mod, self) - 1;
h->count = 0;
h->table = table;
h->userdata = ex->userdata;
h->seed = ex->seed;
- h->flags = ex->flags;
+ h->wkopt = ex->wkopt;
h->usecount = 0;
+ h->tblstack = 0;
h->hops = ex->hops;
return hash;
}
-static val copy_hash_chain(val chain)
-{
- list_collect_decl(out, ptail);
-
- for (; chain; chain = us_cdr(chain)) {
- val entry = us_car(chain);
- val nentry = cons(us_car(entry), us_cdr(entry));
- nentry->ch.hash = entry->ch.hash;
- ptail = list_collect(ptail, nentry);
- }
-
- return out;
-}
-
val copy_hash(val existing)
{
val self = lit("copy-hash");
- struct hash *ex = coerce(struct hash *, cobj_handle(self, existing, hash_s));
+ struct hash *ex = coerce(struct hash *, cobj_handle(self, existing, hash_cls));
struct hash *h = coerce(struct hash *, chk_malloc(sizeof *h));
- val mod = num_fast(ex->modulus);
- val hash = cobj(coerce(mem_t *, h), hash_s, &hash_ops);
+ val mod = num_fast(ex->mask + 1);
val table = vector(mod, nil);
- cnum i;
+ val hash = cobj(coerce(mem_t *, h), hash_cls, &hash_ops);
+ val *exvec = ex->table->v.vec;
+ val *vec = table->v.vec;
+ ucnum i;
- h->modulus = ex->modulus;
+ h->mask = ex->mask;
h->count = ex->count;
h->table = table;
h->userdata = ex->userdata;
h->seed = ex->seed;
- h->flags = ex->flags;
+ h->wkopt = ex->wkopt;
h->usecount = 0;
+ h->tblstack = 0;
h->hops = ex->hops;
- for (i = 0; i < h->modulus; i++)
- set(mkloc(h->table->v.vec[i], h->table),
- copy_hash_chain(ex->table->v.vec[i]));
+ for (i = 0; i <= h->mask; i++) {
+ val cell = exvec[i];
+ if (cell) {
+ val ncell = cons(us_car(cell), us_cdr(cell));
+ ncell->ch.hash = cell->ch.hash;
+ vec[i] = ncell;
+ setcheck(table, ncell);
+ }
+ }
return hash;
}
val gethash_c(val self, val hash, val key, loc new_p)
{
- struct hash *h = coerce(struct hash *, cobj_handle(self, hash, hash_s));
+ struct hash *h = coerce(struct hash *, cobj_handle(self, hash, hash_cls));
int lim = hash_traversal_limit;
ucnum hv = h->hops->hash_fun(key, &lim, h->seed);
- loc pchain = mkloc(h->table->v.vec[hv % h->modulus], h->table);
- val old = deref(pchain);
- val cell = h->hops->acons_new_c_fun(key, hv, new_p, pchain);
- if (old != deref(pchain) && ++h->count > 2 * h->modulus && h->usecount == 0)
- hash_grow(h, hash);
- return cell;
+ return hash_insert(hash, h, key, hv, new_p);
}
val gethash_e(val self, val hash, val key)
{
- struct hash *h = coerce(struct hash *, cobj_handle(self, hash, hash_s));
+ struct hash *h = coerce(struct hash *, cobj_handle(self, hash, hash_cls));
int lim = hash_traversal_limit;
ucnum hv = h->hops->hash_fun(key, &lim, h->seed);
- val chain = h->table->v.vec[hv % h->modulus];
- return h->hops->assoc_fun(key, hv, chain);
+ return hash_lookup(h, key, hv);
+}
+
+val gethash_d(val hash, val key)
+{
+ return gethash_e(lit("gethash-d"), hash, key);
}
val gethash(val hash, val key)
@@ -967,35 +1213,21 @@ val pushhash(val hash, val key, val value)
val remhash(val hash, val key)
{
val self = lit("remhash");
- struct hash *h = coerce(struct hash *, cobj_handle(self, hash, hash_s));
+ struct hash *h = coerce(struct hash *, cobj_handle(self, hash, hash_cls));
int lim = hash_traversal_limit;
ucnum hv = h->hops->hash_fun(key, &lim, h->seed);
- val *pchain = &h->table->v.vec[hv % h->modulus];
- val existing = h->hops->assoc_fun(key, hv, *pchain);
-
- if (existing) {
- for (; *pchain; pchain = us_cdr_p(*pchain)) {
- if (us_car(*pchain) == existing) {
- *pchain = us_cdr(*pchain);
- break;
- }
- }
- h->count--;
- bug_unless (h->count >= 0);
- return us_cdr(existing);
- }
-
- return nil;
+ ucnum victim = hash_find_slot(h, key, hv);
+ return (victim != UINT_PTR_MAX) ? hash_remove(h, victim) : nil;
}
val clearhash(val hash)
{
val self = lit("clearhash");
- struct hash *h = coerce(struct hash *, cobj_handle(self, hash, hash_s));
+ struct hash *h = coerce(struct hash *, cobj_handle(self, hash, hash_cls));
val mod = num_fast(256);
val table = vector(mod, nil);
- cnum oldcount = h->count;
- h->modulus = c_num(mod);
+ ucnum oldcount = h->count;
+ h->mask = c_unum(mod, self) - 1;
h->count = 0;
h->table = table;
setcheck(hash, table);
@@ -1005,7 +1237,7 @@ val clearhash(val hash)
val hash_count(val hash)
{
val self = lit("hash-count");
- struct hash *h = coerce(struct hash *, cobj_handle(self, hash, hash_s));
+ struct hash *h = coerce(struct hash *, cobj_handle(self, hash, hash_cls));
return num_fast(h->count);
}
@@ -1018,14 +1250,14 @@ val us_hash_count(val hash)
val get_hash_userdata(val hash)
{
val self = lit("get-hash-userdata");
- struct hash *h = coerce(struct hash *, cobj_handle(self, hash, hash_s));
+ struct hash *h = coerce(struct hash *, cobj_handle(self, hash, hash_cls));
return h->userdata;
}
val set_hash_userdata(val hash, val data)
{
val self = lit("set-hash-userdata");
- struct hash *h = coerce(struct hash *, cobj_handle(self, hash, hash_s));
+ struct hash *h = coerce(struct hash *, cobj_handle(self, hash, hash_cls));
val olddata = h->userdata;
set(mkloc(h->userdata, hash), data);
return olddata;
@@ -1033,15 +1265,14 @@ val set_hash_userdata(val hash, val data)
val hashp(val obj)
{
- return cobjclassp(obj, hash_s);
+ return cobjclassp(obj, hash_cls);
}
static void hash_iter_mark(val hash_iter)
{
struct hash_iter *hi = coerce(struct hash_iter *, hash_iter->co.handle);
- if (hi->hash)
- gc_mark(hi->hash);
- gc_mark(hi->cons);
+ gc_mark(hi->hash);
+ gc_mark(hi->table);
hi->next = reachable_iters;
reachable_iters = hi;
}
@@ -1054,11 +1285,12 @@ static struct cobj_ops hash_iter_ops = cobj_ops_init(eq,
void hash_iter_init(struct hash_iter *hi, val hash, val self)
{
- struct hash *h = coerce(struct hash *, cobj_handle(self, hash, hash_s));
+ struct hash *h = coerce(struct hash *, cobj_handle(self, hash, hash_cls));
hi->next = 0;
- hi->chain = -1;
- hi->cons = nil;
hi->hash = hash;
+ hi->table = h->table;
+ hi->mask = h->mask;
+ hi->index = 0;
h->usecount++;
}
@@ -1066,57 +1298,56 @@ void us_hash_iter_init(struct hash_iter *hi, val hash)
{
struct hash *h = coerce(struct hash *, hash->co.handle);
hi->next = 0;
- hi->chain = -1;
- hi->cons = nil;
hi->hash = hash;
+ hi->table = h->table;
+ hi->mask = h->mask;
+ hi->index = 0;
h->usecount++;
}
-static val hash_iter_next_impl(struct hash_iter *hi, val iter)
+static val hash_iter_next_impl(struct hash_iter *hi)
{
val hash = hi->hash;
struct hash *h = hash ? coerce(struct hash *, hash->co.handle) : 0;
+ ucnum mask = hi->mask;
if (!h)
return nil;
- if (hi->cons)
- hi->cons = us_cdr(hi->cons);
- while (nilp(hi->cons)) {
- if (++hi->chain >= h->modulus) {
- hi->hash = nil;
- h->usecount--;
- return nil;
- }
- set(mkloc(hi->cons, iter), h->table->v.vec[hi->chain]);
+
+ while (hi->index <= mask) {
+ val cell = hi->table->v.vec[hi->index++];
+ if (cell)
+ return cell;
}
- return us_car(hi->cons);
+
+ hi->hash = nil;
+ if (--h->usecount <= 0)
+ h->tblstack = nil;
+
+ return nil;
}
val hash_iter_next(struct hash_iter *hi)
{
- return hash_iter_next_impl(hi, 0);
+ return hash_iter_next_impl(hi);
}
val hash_iter_peek(struct hash_iter *hi)
{
val hash = hi->hash;
struct hash *h = hash ? coerce(struct hash *, hash->co.handle) : 0;
- cnum chain = hi->chain;
- val cell = hi->cons;
+ ucnum mask = hi->mask, index = hi->index;
if (!h)
return nil;
- if (cell) {
- val peek = us_cdr(cell);
- if (peek)
- return us_car(peek);
+
+ while (index <= mask) {
+ val cell = hi->table->v.vec[index++];
+ if (cell)
+ return cell;
}
- do {
- if (++chain >= h->modulus)
- return nil;
- cell = h->table->v.vec[chain];
- } while (!cell);
- return us_car(cell);
+
+ return nil;
}
val hash_begin(val hash)
@@ -1125,7 +1356,7 @@ val hash_begin(val hash)
val hi_obj;
struct hash_iter *hi = coerce(struct hash_iter *, chk_malloc(sizeof *hi));
hash_iter_init(hi, hash, self);
- hi_obj = cobj(coerce(mem_t *, hi), hash_iter_s, &hash_iter_ops);
+ hi_obj = cobj(coerce(mem_t *, hi), hash_iter_cls, &hash_iter_ops);
gc_hint(hash);
return hi_obj;
}
@@ -1134,8 +1365,8 @@ val hash_next(val iter)
{
val self = lit("hash-next");
struct hash_iter *hi = coerce(struct hash_iter *,
- cobj_handle(self, iter, hash_iter_s));
- return hash_iter_next_impl(hi, iter);
+ cobj_handle(self, iter, hash_iter_cls));
+ return hash_iter_next_impl(hi);
}
@@ -1143,7 +1374,7 @@ val hash_peek(val iter)
{
val self = lit("hash-peek");
struct hash_iter *hi = coerce(struct hash_iter *,
- cobj_handle(self, iter, hash_iter_s));
+ cobj_handle(self, iter, hash_iter_cls));
return hash_iter_peek(hi);
}
@@ -1151,17 +1382,21 @@ val hash_reset(val iter, val hash)
{
val self = lit("hash-reset");
struct hash_iter *hi = coerce(struct hash_iter *,
- cobj_handle(self, iter, hash_iter_s));
+ cobj_handle(self, iter, hash_iter_cls));
if (hi->hash) {
struct hash *h = coerce(struct hash *, hash->co.handle);
- h->usecount--;
+ if (--h->usecount <= 0)
+ h->tblstack = nil;
}
- if (hash)
+ if (hash) {
hash_iter_init(hi, hash, self);
- else
+ if (hi->table)
+ setcheck(iter, hash);
+ } else {
memset(hi, 0, sizeof *hi);
+ }
return iter;
}
@@ -1183,14 +1418,16 @@ val maphash(val fun, val hash)
val hash_eql(val obj)
{
- int lim = 0;
+ int lim = hash_traversal_limit;
return num_fast(eql_hash(obj, &lim));
}
val hash_equal(val obj, val seed)
{
+ val self = lit("hash-equal");
int lim = hash_traversal_limit;
- return num_fast(equal_hash(obj, &lim, if3(missingp(seed), 0, c_unum(seed))));
+ return num_fast(equal_hash(obj, &lim,
+ if3(missingp(seed), 0, c_unum(seed, self))));
}
/*
@@ -1200,84 +1437,100 @@ val hash_equal(val obj, val seed)
*/
static void do_weak_tables(void)
{
- struct hash *h;
+ struct hash *h = reachable_weak_hashes;
+
+ reachable_weak_hashes = 0;
+
+ for (; h != 0; h = h->next) {
+ ucnum i, c = 0;
+ val table = h->table;
+ val *vec = table->v.vec;
+ ucnum mask = h->mask;
- for (h = reachable_weak_hashes; h != 0; h = h->next) {
- cnum i, c;
/* The table of a weak hash was spuriously reached by conservative GC;
it's a waste of time doing weak processing, since all keys and
values have been transitively marked as reachable; and so we
won't find anything to remove. */
- if (gc_is_reachable(h->table))
+ if (gc_is_reachable(table))
continue;
- switch (h->flags) {
+ h->count = UINT_PTR_MAX;
+
+ switch (h->wkopt) {
case hash_weak_none:
/* what is this doing here */
break;
case hash_weak_keys:
/* Sweep through all entries. Delete any which have keys
that are garbage. */
- for (c = 0, i = 0; i < h->modulus; i++) {
- val *pchain = &h->table->v.vec[i];
- val *iter;
-
- for (iter = pchain; !gc_is_reachable(*iter); ) {
- val entry = us_car(*iter);
- if (!gc_is_reachable(entry) && !gc_is_reachable(us_car(entry))) {
- *iter = us_cdr(*iter);
+ for (i = 0; i <= mask; i++) {
+ val entry = vec[i];
+
+ if (entry) {
+ if (!gc_is_reachable(us_car(entry))) {
+ hash_remove(h, i--);
#if CONFIG_EXTRA_DEBUGGING
if (us_car(entry) == break_obj)
breakpt();
#endif
} else {
- iter = us_cdr_p(*iter);
+ gc_mark(entry);
c++;
}
}
}
- /* Garbage is gone now. Seal things by marking the vector. */
- gc_mark(h->table);
- h->count = c;
break;
case hash_weak_vals:
/* Sweep through all entries. Delete any which have values
that are garbage. */
- for (i = 0, c = 0; i < h->modulus; i++) {
- val *pchain = &h->table->v.vec[i];
- val *iter;
-
- for (iter = pchain; !gc_is_reachable(*iter); ) {
- val entry = us_car(*iter);
- if (!gc_is_reachable(entry) && !gc_is_reachable(us_cdr(entry))) {
- *iter = us_cdr(*iter);
+ for (i = 0; i <= mask; i++) {
+ val entry = vec[i];
+
+ if (entry) {
+ if (!gc_is_reachable(us_cdr(entry))) {
+ hash_remove(h, i--);
#if CONFIG_EXTRA_DEBUGGING
if (us_cdr(entry) == break_obj)
breakpt();
#endif
} else {
- iter = us_cdr_p(*iter);
+ gc_mark(entry);
+ c++;
+ }
+ }
+ }
+ break;
+ case hash_weak_and:
+ /* Sweep through all entries. Delete any which have keys
+ and values that are garbage. */
+ for (i = 0; i <= mask; i++) {
+ val entry = vec[i];
+
+ if (entry) {
+ if (!gc_is_reachable(us_car(entry)) && !gc_is_reachable(us_cdr(entry))) {
+ hash_remove(h, i--);
+#if CONFIG_EXTRA_DEBUGGING
+ if (!gc_is_reachable(us_car(entry)) && us_car(entry) == break_obj)
+ breakpt();
+ if (!gc_is_reachable(us_cdr(entry)) && us_cdr(entry) == break_obj)
+ breakpt();
+#endif
+ } else {
+ gc_mark(entry);
c++;
}
}
}
- /* Garbage is gone now. Seal things by marking the vector. */
- gc_mark(h->table);
- h->count = c;
break;
- case hash_weak_both:
+ case hash_weak_or:
/* Sweep through all entries. Delete any which have keys
or values that are garbage. */
- for (i = 0, c = 0; i < h->modulus; i++) {
- val *pchain = &h->table->v.vec[i];
- val *iter;
-
- for (iter = pchain; !gc_is_reachable(*iter); ) {
- val entry = us_car(*iter);
- if (!gc_is_reachable(entry) &&
- (!gc_is_reachable(us_car(entry)) || !gc_is_reachable(us_cdr(entry))))
- {
- *iter = us_cdr(*iter);
+ for (i = 0; i <= mask; i++) {
+ val entry = vec[i];
+
+ if (entry) {
+ if (!gc_is_reachable(us_car(entry)) || !gc_is_reachable(us_cdr(entry))) {
+ hash_remove(h, i--);
#if CONFIG_EXTRA_DEBUGGING
if (!gc_is_reachable(us_car(entry)) && us_car(entry) == break_obj)
breakpt();
@@ -1285,21 +1538,25 @@ static void do_weak_tables(void)
breakpt();
#endif
} else {
- iter = us_cdr_p(*iter);
+ gc_mark(entry);
c++;
}
}
}
- /* Garbage is gone now. Seal things by marking the vector. */
- gc_mark(h->table);
- h->count = c;
break;
}
+
+ /* Garbage is gone now. Seal things by marking the vector. */
+ gc_mark_norec(table);
+ gc_mark(vec[vec_alloc]);
+ gc_mark(vec[vec_length]);
+ h->count = c;
}
- /* Done with weak processing; clear out the list in preparation for
- the next gc round. */
- reachable_weak_hashes = 0;
+ /* More weak hashes were discovered during weak processing.
+ Do another round. */
+ if (reachable_weak_hashes)
+ do_weak_tables();
}
static void do_iters(void)
@@ -1362,9 +1619,10 @@ static val equal_based_p(val equal, val eql, val eq, val wkeys)
return null(eql);
}
-val hashv(struct args *args)
+val hashv(varg args)
{
- val wkeys = nil, wvals = nil, equal = nil, eql = nil;
+ val self = lit("hash");
+ val wkeys = nil, wvals = nil, equal = nil, eql = nil, wand = nil, wor = nil;
val eq = nil, userdata = nil;
struct args_bool_key akv[] = {
{ weak_keys_k, nil, &wkeys },
@@ -1372,14 +1630,34 @@ val hashv(struct args *args)
{ equal_based_k, nil, &equal },
{ eql_based_k, nil, &eql },
{ eq_based_k, nil, &eq },
+ { weak_and_k, nil, &wand },
+ { weak_or_k, nil, &wor },
{ userdata_k, t, &userdata }
};
- val ebp = (args_keys_extract(args, akv, sizeof akv / sizeof akv[0]),
- equal_based_p(equal, eql, eq, wkeys));
- val hash = if3(eq, make_eq_hash(wkeys, wvals), make_hash(wkeys, wvals, ebp));
- if (userdata)
- set_hash_userdata(hash, userdata);
- return hash;
+ hash_weak_opt_t wkopt = hash_weak_none;
+
+ args_keys_extract(args, akv, sizeof akv / sizeof akv[0]);
+
+ if (wand && wor)
+ uw_throwf(error_s, lit("~a: both ~s and ~s specified"),
+ self, weak_and_k, weak_or_k, nao);
+
+ if (wand)
+ wkopt = hash_weak_and;
+ else if (wor)
+ wkopt = hash_weak_or;
+ else
+ wkopt = weak_opt_from_flags(wkeys, wvals);
+
+ {
+ val ebp = equal_based_p(equal, eql, eq, wkeys);
+ val hash = if3(eq,
+ make_eq_hash(wkopt),
+ make_hash(wkopt, ebp));
+ if (userdata)
+ set_hash_userdata(hash, userdata);
+ return hash;
+ }
}
val hashl(val arglist)
@@ -1402,12 +1680,12 @@ val hash_construct(val hashl_args, val pairs)
return hash;
}
-val hash_from_pairs_v(val pairs, struct args *hashv_args)
+val hash_from_pairs_v(val pairs, varg hashv_args)
{
return hash_construct(args_get_list(hashv_args), pairs);
}
-val hash_from_alist_v(val alist, struct args *hashv_args)
+val hash_from_alist_v(val alist, varg hashv_args)
{
val hash = hashv(hashv_args);
@@ -1421,7 +1699,40 @@ val hash_from_alist_v(val alist, struct args *hashv_args)
return hash;
}
-val hash_list(val keys, struct args *hashv_args)
+val hash_map(val fun, val seq, varg hashv_args)
+{
+ val self = lit("hash-map");
+ seq_iter_t iter;
+ val hash = hashv(hashv_args), elem;
+ seq_iter_init(self, &iter, seq);
+
+ while (seq_get(&iter, &elem))
+ sethash(hash, elem, funcall1(fun, elem));
+
+ return hash;
+}
+
+val hash_props(varg plist)
+{
+ val self = lit("hash-props");
+ args_decl_constsize(args, ARGS_MIN);
+ val hash = hashv(args);
+ cnum index = 0;
+
+ while (args_two_more(plist, index)) {
+ val key = args_get(plist, &index);
+ val value = args_get(plist, &index);
+ sethash(hash, key, value);
+ }
+
+ if (args_more(plist, index))
+ uw_throwf(error_s, lit("~a: unpaired ~s argument"),
+ self, args_get(plist, &index), nao);
+
+ return hash;
+}
+
+val hash_list(val keys, varg hashv_args)
{
val hash = hashv(hashv_args);
@@ -1435,7 +1746,7 @@ val hash_list(val keys, struct args *hashv_args)
return hash;
}
-val hash_zip(val keys, val vals, struct args *hashv_args)
+val hash_zip(val keys, val vals, varg hashv_args)
{
val self = lit("hash-zip");
seq_iter_t key_iter, val_iter;
@@ -1451,24 +1762,17 @@ val hash_zip(val keys, val vals, struct args *hashv_args)
return hash;
}
-val group_by(val func, val seq, struct args *hashv_args)
+val group_by(val func, val seq, varg hashv_args)
{
val self = lit("group-by");
val hash = hashv(hashv_args);
+ seq_iter_t iter;
+ val elem;
- if (vectorp(seq)) {
- cnum i, len;
+ seq_iter_init(self, &iter, seq);
- for (i = 0, len = c_fixnum(length(seq), self); i < len; i++) {
- val v = vecref(seq, num_fast(i));
- pushhash(hash, funcall1(func, v), v);
- }
- } else {
- for (; seq; seq = cdr(seq)) {
- val v = car(seq);
- pushhash(hash, funcall1(func, v), v);
- }
- }
+ while (seq_get(&iter, &elem))
+ pushhash(hash, funcall1(func, elem), elem);
{
struct hash_iter hi;
@@ -1483,48 +1787,37 @@ val group_by(val func, val seq, struct args *hashv_args)
}
}
+val group_map(val by_fun, val filter_fun, val seq, varg hashv_args)
+{
+ val hash = group_by(by_fun, seq, hashv_args);
+ return hash_update(hash, filter_fun);
+}
+
val group_reduce(val hash, val by_fun, val reduce_fun, val seq,
val initval, val filter_fun)
{
val self = lit("group-reduce");
- initval = default_null_arg(initval);
+ seq_iter_t iter;
+ val elem;
- if (vectorp(seq)) {
- cnum i, len;
+ initval = default_null_arg(initval);
- for (i = 0, len = c_fixnum(length(seq), self); i < len; i++) {
- val v = vecref(seq, num_fast(i));
- val key = funcall1(by_fun, v);
- val new_p;
- loc pcdr = gethash_l(self, hash, key, mkcloc(new_p));
+ seq_iter_init(self, &iter, seq);
- if (new_p)
- set(pcdr, funcall2(reduce_fun, initval, v));
- else
- set(pcdr, funcall2(reduce_fun, deref(pcdr), v));
- }
- } else {
- for (; seq; seq = cdr(seq)) {
- val v = car(seq);
- val key = funcall1(by_fun, v);
- val new_p;
- loc pcdr = gethash_l(self, hash, key, mkcloc(new_p));
+ while (seq_get(&iter, &elem))
+ {
+ val key = funcall1(by_fun, elem);
+ val new_p;
+ loc pcdr = gethash_l(self, hash, key, mkcloc(new_p));
- if (new_p)
- set(pcdr, funcall2(reduce_fun, initval, v));
- else
- set(pcdr, funcall2(reduce_fun, deref(pcdr), v));
- }
+ if (new_p)
+ set(pcdr, funcall2(reduce_fun, initval, elem));
+ else
+ set(pcdr, funcall2(reduce_fun, deref(pcdr), elem));
}
- if (!null_or_missing_p(filter_fun)) {
- struct hash_iter hi;
- val cell;
- hash_iter_init(&hi, hash, self);
-
- while ((cell = hash_iter_next(&hi)) != nil)
- us_rplacd(cell, funcall1(filter_fun, us_cdr(cell)));
- }
+ if (!null_or_missing_p(filter_fun))
+ hash_update(hash, filter_fun);
return hash;
}
@@ -1601,8 +1894,8 @@ val hash_alist(val hash)
val hash_uni(val hash1, val hash2, val joinfun, val map1fun, val map2fun)
{
val self = lit("hash-uni");
- struct hash *h1 = coerce(struct hash *, cobj_handle(self, hash1, hash_s));
- struct hash *h2 = coerce(struct hash *, cobj_handle(self, hash2, hash_s));
+ struct hash *h1 = coerce(struct hash *, cobj_handle(self, hash1, hash_cls));
+ struct hash *h2 = coerce(struct hash *, cobj_handle(self, hash2, hash_cls));
if (h1->hops != h2->hops)
uw_throwf(error_s, lit("~a: ~s and ~s are incompatible hashes"),
@@ -1646,11 +1939,52 @@ val hash_uni(val hash1, val hash2, val joinfun, val map1fun, val map2fun)
}
}
+val hash_join(val hash1, val hash2, val joinfun, val h1dfl, val h2dfl)
+{
+ val self = lit("hash-join");
+ struct hash *h1 = coerce(struct hash *, cobj_handle(self, hash1, hash_cls));
+ struct hash *h2 = coerce(struct hash *, cobj_handle(self, hash2, hash_cls));
+
+ if (h1->hops != h2->hops)
+ uw_throwf(error_s, lit("~a: ~s and ~s are incompatible hashes"),
+ self, hash1, hash2, nao);
+
+ {
+ val hout = make_similar_hash(hash1);
+ val h1ent, h2ent;
+ struct hash_iter hi;
+
+ hash_iter_init(&hi, hash1, self);
+
+ for (h1ent = hash_iter_next(&hi); h1ent; h1ent = hash_iter_next(&hi)) {
+ val h1val = us_cdr(h1ent);
+ val key = us_car(h1ent);
+ val h2ent = gethash_e(self, hash2, key);
+ val h2val = if3(h2ent, us_cdr(h2ent), h2dfl);
+
+ sethash(hout, key, funcall2(joinfun, h1val, h2val));
+ }
+
+ hash_iter_init(&hi, hash2, self);
+
+ for (h2ent = hash_iter_next(&hi); h2ent; h2ent = hash_iter_next(&hi)) {
+ val h2val = us_cdr(h2ent);
+ val key = us_car(h2ent);
+ val h1ent = gethash_e(self, hash1, us_car(h2ent));
+ val h1val = if3(h1ent, us_cdr(h1ent), h1dfl);
+
+ sethash(hout, key, funcall2(joinfun, h1val, h2val));
+ }
+
+ return hout;
+ }
+}
+
val hash_diff(val hash1, val hash2)
{
val self = lit("hash-diff");
- struct hash *h1 = coerce(struct hash *, cobj_handle(self, hash1, hash_s));
- struct hash *h2 = coerce(struct hash *, cobj_handle(self, hash2, hash_s));
+ struct hash *h1 = coerce(struct hash *, cobj_handle(self, hash1, hash_cls));
+ struct hash *h2 = coerce(struct hash *, cobj_handle(self, hash2, hash_cls));
if (h1->hops != h2->hops)
uw_throwf(error_s, lit("~a: ~s and ~a are incompatible hashes"),
@@ -1674,8 +2008,8 @@ val hash_diff(val hash1, val hash2)
val hash_symdiff(val hash1, val hash2)
{
val self = lit("hash-symdiff");
- struct hash *h1 = coerce(struct hash *, cobj_handle(self, hash1, hash_s));
- struct hash *h2 = coerce(struct hash *, cobj_handle(self, hash2, hash_s));
+ struct hash *h1 = coerce(struct hash *, cobj_handle(self, hash1, hash_cls));
+ struct hash *h2 = coerce(struct hash *, cobj_handle(self, hash2, hash_cls));
if (h1->hops != h2->hops)
uw_throwf(error_s, lit("~a: ~s and ~a are incompatible hashes"),
@@ -1707,8 +2041,8 @@ val hash_symdiff(val hash1, val hash2)
val hash_isec(val hash1, val hash2, val joinfun)
{
val self = lit("hash-isec");
- struct hash *h1 = coerce(struct hash *, cobj_handle(self, hash1, hash_s));
- struct hash *h2 = coerce(struct hash *, cobj_handle(self, hash2, hash_s));
+ struct hash *h1 = coerce(struct hash *, cobj_handle(self, hash1, hash_cls));
+ struct hash *h2 = coerce(struct hash *, cobj_handle(self, hash2, hash_cls));
if (h1->hops != h2->hops)
uw_throwf(error_s, lit("~a: ~s and ~s are incompatible hashes"),
@@ -1759,7 +2093,7 @@ val hash_proper_subset(val hash1, val hash2)
val hash_update(val hash, val fun)
{
- val self = lit("hash-subset");
+ val self = lit("hash-update");
val cell;
struct hash_iter hi;
@@ -1804,7 +2138,11 @@ val hash_revget(val hash, val value, val test, val keyfun)
hash_iter_init(&hi, hash, self);
- test = default_arg(test, eql_f);
+ if (opt_compat && opt_compat <= 248)
+ test = default_arg(test, eql_f);
+ else
+ test = default_arg(test, equal_f);
+
keyfun = default_arg(keyfun, identity_f);
while ((cell = hash_iter_next(&hi)) != nil) {
@@ -1815,7 +2153,27 @@ val hash_revget(val hash, val value, val test, val keyfun)
return nil;
}
-val hash_invert(val hash, val joinfun, val unitfun, struct args *hashv_args)
+val hash_keys_of(val hash, val value, val test, val keyfun)
+{
+ val self = lit("hash-keys-of");
+ val cell;
+ struct hash_iter hi;
+ list_collect_decl(out, ptail);
+
+ hash_iter_init(&hi, hash, self);
+
+ test = default_arg(test, equal_f);
+ keyfun = default_arg(keyfun, identity_f);
+
+ while ((cell = hash_iter_next(&hi)) != nil) {
+ if (funcall2(test, value, funcall1(keyfun, us_cdr(cell))))
+ ptail = list_collect(ptail, us_car(cell));
+ }
+
+ return out;
+}
+
+val hash_invert(val hash, val joinfun, val unitfun, varg hashv_args)
{
val self = lit("hash-invert");
val hout = hashv(hashv_args);
@@ -1849,34 +2207,52 @@ val hash_invert(val hash, val joinfun, val unitfun, struct args *hashv_args)
static val set_hash_traversal_limit(val lim)
{
+ val self = lit("set-hash-traversal-limit");
val old = num(hash_traversal_limit);
- hash_traversal_limit = c_num(lim);
+ hash_traversal_limit = c_num(lim, self);
return old;
}
static val gen_hash_seed(void)
{
- val time = time_sec_usec();
- ucnum sec = convert(ucnum, c_time(car(time)));
- ucnum usec = c_unum(cdr(time));
+ val self = lit("gen-hash-seed");
+ val time = time_sec_nsec();
+ ucnum sec = convert(ucnum, c_time(car(time), self));
+ ucnum nsec = c_unum(cdr(time), self);
#if HAVE_UNISTD_H
- ucnum pid = convert(ucnum, getpid());
+ ucnum pid = convert(ucnum, getpid());
+#else
+ ucnum pid = 0;
+#endif
+#if SIZEOF_PTR == 8
+ return unum((sec << 32) ^ (pid << 16) ^ nsec);
#else
- ucnum pid = 0;
+ return unum(sec ^ (nsec << 12) ^ pid);
#endif
- return unum(sec ^ (usec << 12) ^ pid);
+}
+
+void hash_early_init(void)
+{
+ hash_cls = cobj_register(nil);
+ hash_iter_cls = cobj_register(nil);
}
void hash_init(void)
{
+ val ghu = func_n1(get_hash_userdata);
+
weak_keys_k = intern(lit("weak-keys"), keyword_package);
weak_vals_k = intern(lit("weak-vals"), keyword_package);
+ weak_and_k = intern(lit("weak-and"), keyword_package);
+ weak_or_k = intern(lit("weak-or"), keyword_package);
equal_based_k = intern(lit("equal-based"), keyword_package);
eql_based_k = intern(lit("eql-based"), keyword_package);
eq_based_k = intern(lit("eq-based"), keyword_package);
userdata_k = intern(lit("userdata"), keyword_package);
hash_seed_s = intern(lit("*hash-seed*"), user_package);
- val ghu = func_n1(get_hash_userdata);
+
+ hash_cls->cls_sym = hash_s;
+ hash_iter_cls->cls_sym = hash_iter_s;
reg_var(hash_seed_s, zero);
@@ -1887,6 +2263,8 @@ void hash_init(void)
reg_fun(hash_construct_s, func_n2(hash_construct));
reg_fun(intern(lit("hash-from-pairs"), user_package), func_n1v(hash_from_pairs_v));
reg_fun(intern(lit("hash-from-alist"), user_package), func_n1v(hash_from_alist_v));
+ reg_fun(intern(lit("hash-map"), user_package), func_n2v(hash_map));
+ reg_fun(intern(lit("hash-props"), user_package), func_n0v(hash_props));
reg_fun(intern(lit("hash-list"), user_package), func_n1v(hash_list));
reg_fun(intern(lit("hash-zip"), user_package), func_n2v(hash_zip));
reg_fun(intern(lit("gethash"), user_package), func_n3o(gethash_n, 2));
@@ -1909,18 +2287,21 @@ void hash_init(void)
reg_fun(intern(lit("hash-pairs"), user_package), func_n1(hash_pairs));
reg_fun(intern(lit("hash-alist"), user_package), func_n1(hash_alist));
reg_fun(intern(lit("hash-uni"), user_package), func_n5o(hash_uni, 2));
+ reg_fun(intern(lit("hash-join"), user_package), func_n5o(hash_join, 3));
reg_fun(intern(lit("hash-diff"), user_package), func_n2(hash_diff));
reg_fun(intern(lit("hash-symdiff"), user_package), func_n2(hash_symdiff));
reg_fun(intern(lit("hash-isec"), user_package), func_n3o(hash_isec, 2));
reg_fun(intern(lit("hash-subset"), user_package), func_n2(hash_subset));
reg_fun(intern(lit("hash-proper-subset"), user_package), func_n2(hash_proper_subset));
reg_fun(intern(lit("group-by"), user_package), func_n2v(group_by));
+ reg_fun(intern(lit("group-map"), user_package), func_n3v(group_map));
reg_fun(intern(lit("group-reduce"), user_package),
func_n6o(group_reduce, 4));
reg_fun(intern(lit("hash-update"), user_package), func_n2(hash_update));
reg_fun(intern(lit("hash-update-1"), user_package),
func_n4o(hash_update_1, 3));
reg_fun(intern(lit("hash-revget"), user_package), func_n4o(hash_revget, 2));
+ reg_fun(intern(lit("hash-keys-of"), user_package), func_n4o(hash_keys_of, 2));
reg_fun(intern(lit("hash-invert"), user_package), func_n3ov(hash_invert, 1));
reg_fun(intern(lit("hash-begin"), user_package), func_n1(hash_begin));
reg_fun(intern(lit("hash-next"), user_package), func_n1(hash_next));
diff --git a/hash.h b/hash.h
index e272ce45..36efde14 100644
--- a/hash.h
+++ b/hash.h
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,43 +6,56 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
+typedef enum hash_weak_opt {
+ hash_weak_none = 0,
+ hash_weak_keys = 1,
+ hash_weak_vals = 2,
+ hash_weak_or = 3,
+ hash_weak_and = 4,
+} hash_weak_opt_t;
+
struct hash_iter {
struct hash_iter *next;
val hash;
- cnum chain;
- val cons;
+ val table;
+ ucnum mask;
+ ucnum index;
};
-extern val weak_keys_k, weak_vals_k, userdata_k;
+extern val weak_keys_k, weak_vals_k, weak_and_k, weak_or_k, userdata_k;
extern val equal_based_k, eql_based_k, eq_based_k;
+extern struct cobj_class *hash_cls;
+
ucnum equal_hash(val obj, int *count, ucnum);
val make_seeded_hash(val weak_keys, val weak_vals, val equal_based, val seed);
-val make_hash(val weak_keys, val weak_vals, val equal_based);
-val make_eq_hash(val weak_keys, val weak_vals);
+val make_hash(hash_weak_opt_t, val equal_based);
+val make_eq_hash(hash_weak_opt_t);
val make_similar_hash(val existing);
val copy_hash(val existing);
val gethash_c(val self, val hash, val key, loc new_p);
val gethash_e(val self, val hash, val key);
+val gethash_d(val hash, val key);
val gethash(val hash, val key);
val inhash(val hash, val key, val init);
val gethash_n(val hash, val key, val notfound_val);
@@ -71,16 +84,20 @@ val hashl(val args);
val hash_construct(val hashl_args, val pairs);
val hash_from_pairs_v(val pairs, struct args *hashv_args);
val hash_from_alist_v(val alist, struct args *hashv_args);
+val hash_map(val fun, val seq, struct args *hashv_args);
+val hash_props(struct args *plist);
val hash_list(val keys, struct args *hashv_args);
val hash_zip(val keys, val vals, struct args *hashv_args);
val group_by(val func, val seq, struct args *hashv_args);
+val group_map(val by_fun, val filter_fun, val seq, struct args *hashv_args);
val group_reduce(val hash, val by_fun, val reduce_fun, val seq,
val initval, val filter_fun);
val hash_keys(val hash);
val hash_values(val hash);
val hash_pairs(val hash);
val hash_alist(val hash);
-val hash_uni(val hash1, val hash2, val joinfun, val lunitfun, val runitfun);
+val hash_uni(val hash1, val hash2, val joinfun, val map1fun, val map2fun);
+val hash_join(val hash1, val hash2, val joinfun, val h1dfl, val h2dfl);
val hash_diff(val hash1, val hash2);
val hash_symdiff(val hash1, val hash2);
val hash_isec(val hash1, val hash2, val joinfun);
@@ -89,6 +106,7 @@ val hash_proper_subset(val hash1, val hash2);
val hash_update(val hash, val fun);
val hash_update_1(val hash, val key, val fun, val init);
val hash_revget(val hash, val value, val test, val keyfun);
+val hash_keys_of(val hash, val value, val test, val keyfun);
val hash_invert(val hash, val joinfun, val unitfun, struct args *hashv_args);
void hash_process_weak(void);
@@ -98,4 +116,5 @@ INLINE loc gethash_l(val self, val hash, val key, loc new_p)
return cdr_l(gethash_c(self, hash, key, new_p));
}
+void hash_early_init(void);
void hash_init(void);
diff --git a/inst.nsi b/inst.nsi
index 7bc2e7d3..262f2eb8 100644
--- a/inst.nsi
+++ b/inst.nsi
@@ -10,11 +10,18 @@ UninstallIcon "win\txr.ico"
SetCompressor lzma
CRCCheck on
-RequestExecutionLevel admin
+
+RequestExecutionLevel highest
+
+var AccountType
Function .onInit
- # default installation dir
- StrCpy $INSTDIR "C:\Program Files"
+ StrCpy $INSTDIR "$LOCALAPPDATA"
+ UserInfo::GetAccountType
+ Pop $AccountType
+ ${If} $AccountType == "Admin"
+ StrCpy $INSTDIR "$PROGRAMFILES32"
+ ${EndIf}
FunctionEnd
Function .onInstSuccess
@@ -49,6 +56,7 @@ section "TXR"
File txr.exe
File txr-win.exe
File win\cygwin1.dll
+ File c:\cygwin\bin\cygz.dll
File c:\cygwin\bin\cyggcc_s-1.dll
File c:\cygwin\bin\cygffi-6.dll
SetOutPath $INSTDIR\txr\doc
@@ -58,9 +66,9 @@ section "TXR"
File LICENSE
File METALICENSE
SetOutPath $INSTDIR\txr\share\txr\stdlib
- File share\txr\stdlib\*.txr
- File share\txr\stdlib\*.tl
- File share\txr\stdlib\*.tlo
+ File stdlib\*.txr
+ File stdlib\*.tl
+ File stdlib\*.tlo
Delete /REBOOTOK $INSTDIR\txr\bin\sh.exe
RmDir /r /REBOOTOK $INSTDIR\txr\share\man
WriteUninstaller $INSTDIR\txr\uninstall.exe
@@ -70,7 +78,11 @@ section "TXR"
CreateShortCut "$SMPROGRAMS\txr\uninstall.lnk" "$INSTDIR\txr\uninstall.exe"
CreateShortCut "$SMPROGRAMS\txr\install-root.lnk" "$INSTDIR\txr"
CreateShortCut "$STARTMENU\txr.lnk" "$INSTDIR\txr\bin\txr.exe"
- ${EnvVarUpdate} $0 "PATH" "A" "HKLM" "$INSTDIR\txr\bin"
+ ${If} $AccountType == "Admin"
+ ${EnvVarUpdate} $0 "PATH" "A" "HKLM" "$INSTDIR\txr\bin"
+ ${Else}
+ ${EnvVarUpdate} $0 "PATH" "A" "HKCU" "$INSTDIR\txr\bin"
+ ${Endif}
${RegisterExtension} "$INSTDIR\txr\bin\txr-win.exe" ".txr" "TXR Pattern Language"
${RegisterExtension} "$INSTDIR\txr\bin\txr-win.exe" ".tl" "TXR Lisp"
${RegisterExtension} "$INSTDIR\txr\bin\txr-win.exe" ".tlo" "Compiled TXR Lisp"
@@ -81,7 +93,11 @@ section "Uninstall"
# $INSTDIR is now where the uninstaller is installed,
# not the $INSTDIR that was used during installation!
- ${un.EnvVarUpdate} $0 "PATH" "R" "HKLM" "$INSTDIR\bin"
+ ${If} $AccountType == "Admin"
+ ${un.EnvVarUpdate} $0 "PATH" "R" "HKLM" "$INSTDIR\bin"
+ ${Else}
+ ${un.EnvVarUpdate} $0 "PATH" "R" "HKCU" "$INSTDIR\bin"
+ ${Endif}
${UnregisterExtension} ".txr" "TXR Pattern Language"
${UnregisterExtension} ".tl" "TXR Lisp"
${UnregisterExtension} ".tlo" "Compiled TXR Lisp"
diff --git a/itypes.c b/itypes.c
index d5821638..11a69d1c 100644
--- a/itypes.c
+++ b/itypes.c
@@ -1,4 +1,4 @@
-/* Copyright 2017-2020
+/* Copyright 2017-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,28 +6,30 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stddef.h>
#include <wchar.h>
#include <signal.h>
+#include <stdlib.h>
#include "config.h"
#include "lib.h"
#include "signal.h"
@@ -35,12 +37,10 @@
#include "arith.h"
#include "itypes.h"
-int itypes_little_endian;
-
#if HAVE_I8
i8_t c_i8(val n, val self)
{
- cnum v = c_num(n);
+ cnum v = c_num(n, self);
if (v < -128 || v > 127)
uw_throwf(error_s, lit("~a: value ~s out of signed 8 bit range"),
self, n, nao);
@@ -49,7 +49,7 @@ i8_t c_i8(val n, val self)
u8_t c_u8(val n, val self)
{
- cnum v = c_num(n);
+ cnum v = c_num(n, self);
if (v < 0 || v > 255)
uw_throwf(error_s, lit("~a: value ~s out of unsigned 8 bit range"),
self, n, nao);
@@ -60,7 +60,7 @@ u8_t c_u8(val n, val self)
#if HAVE_I16
i16_t c_i16(val n, val self)
{
- cnum v = c_num(n);
+ cnum v = c_num(n, self);
if (v < -0x8000 || v > 0x7FFF)
uw_throwf(error_s, lit("~a: value ~s is out of signed 16 bit range"),
self, n, nao);
@@ -69,7 +69,7 @@ i16_t c_i16(val n, val self)
u16_t c_u16(val n, val self)
{
- cnum v = c_num(n);
+ cnum v = c_num(n, self);
if (v < 0 || v > 0xFFFF)
uw_throwf(error_s, lit("~a: value ~s is out of unsigned 16 bit range"),
self, n, nao);
@@ -80,7 +80,7 @@ u16_t c_u16(val n, val self)
#if HAVE_I32
i32_t c_i32(val n, val self)
{
- cnum v = c_num(n);
+ cnum v = c_num(n, self);
if (v < (-convert(cnum, 0x7FFFFFFF) - 1) || v > 0x7FFFFFFF)
uw_throwf(error_s, lit("~a: value ~s is out of signed 32 bit range"),
self, n, nao);
@@ -89,8 +89,8 @@ i32_t c_i32(val n, val self)
u32_t c_u32(val n, val self)
{
- uint_ptr_t v = c_unum(n);
- if (v < 0 || v > 0xFFFFFFFF)
+ uint_ptr_t v = c_unum(n, self);
+ if (v > 0xFFFFFFFF)
uw_throwf(error_s, lit("~a: value ~s is out of unsigned 32 bit range"),
self, n, nao);
return v;
@@ -102,7 +102,7 @@ u32_t c_u32(val n, val self)
#if CHAR_BIT * SIZEOF_PTR >= 64
i64_t c_i64(val n, val self)
{
- cnum v = c_num(n);
+ cnum v = c_num(n, self);
if (v < (- (cnum) 0x7FFFFFFFFFFFFFFF - 1) || v > (cnum) 0x7FFFFFFFFFFFFFFF)
uw_throwf(error_s, lit("~a: value ~s is out of signed 64 bit range"),
self, n, nao);
@@ -111,7 +111,7 @@ i64_t c_i64(val n, val self)
u64_t c_u64(val n, val self)
{
- ucnum v = c_unum(n);
+ ucnum v = c_unum(n, self);
if (v > (ucnum) 0xFFFFFFFFFFFFFFFF)
uw_throwf(error_s, lit("~a: value ~s is out of unsigned 64 bit range"),
self, n, nao);
@@ -121,18 +121,23 @@ u64_t c_u64(val n, val self)
i64_t c_i64(val n, val self)
{
dbl_cnum v = c_dbl_num(n);
- if (v < (- (dbl_cnum) 0x7FFFFFFFFFFFFFFF - 1) || v > (dbl_cnum) 0x7FFFFFFFFFFFFFFF)
+ if (v < (- convert(dbl_cnum, 0x7FFFFFFFFFFFFFFF) - 1) ||
+ v > convert(dbl_cnum, 0x7FFFFFFFFFFFFFFF))
+ {
uw_throwf(error_s, lit("~a: value ~s is out of signed 64 bit range"),
self, n, nao);
+ }
return v;
}
u64_t c_u64(val n, val self)
{
dbl_ucnum v = c_dbl_unum(n);
- if (v > (dbl_ucnum) 0xFFFFFFFFFFFFFFFF)
+ if (v > convert(dbl_ucnum, 0xFFFFFFFFFFFFFFFF))
+ {
uw_throwf(error_s, lit("~a: value ~s is out of unsigned 64 bit range"),
self, n, nao);
+ }
return v;
}
#else
@@ -188,11 +193,6 @@ char c_char(val n, val self)
#endif
}
-signed char c_schar(val n, val self)
-{
- return c_i8(n, self);
-}
-
unsigned char c_uchar(val n, val self)
{
return c_u8(n, self);
@@ -200,7 +200,7 @@ unsigned char c_uchar(val n, val self)
short c_short(val n, val self)
{
- cnum v = c_num(n);
+ cnum v = c_num(n, self);
if (v < SHRT_MIN || v > SHRT_MAX)
uw_throwf(error_s, lit("~a: value ~s is out of short int range"),
self, n, nao);
@@ -209,7 +209,7 @@ short c_short(val n, val self)
unsigned short c_ushort(val n, val self)
{
- cnum v = c_num(n);
+ cnum v = c_num(n, self);
if (v < 0 || v > USHRT_MAX)
uw_throwf(error_s, lit("~a: value ~s is out of unsigned short range"),
self, n, nao);
@@ -218,7 +218,7 @@ unsigned short c_ushort(val n, val self)
int c_int(val n, val self)
{
- cnum v = c_num(n);
+ cnum v = c_num(n, self);
if (v < INT_MIN || v > INT_MAX)
uw_throwf(error_s, lit("~a: value ~s is out of int range"),
self, n, nao);
@@ -227,8 +227,8 @@ int c_int(val n, val self)
unsigned int c_uint(val n, val self)
{
- uint_ptr_t v = c_unum(n);
- if (v < 0 || v > UINT_MAX)
+ uint_ptr_t v = c_unum(n, self);
+ if (v > UINT_MAX)
uw_throwf(error_s, lit("~a: value ~s is out of unsigned int range"),
self, n, nao);
return v;
@@ -237,7 +237,7 @@ unsigned int c_uint(val n, val self)
long c_long(val n, val self)
{
#if SIZEOF_LONG <= SIZEOF_PTR
- cnum v = c_num(n);
+ cnum v = c_num(n, self);
if (v < LONG_MIN || v > LONG_MAX)
uw_throwf(error_s, lit("~a: value ~s is out of long int range"),
self, n, nao);
@@ -252,8 +252,8 @@ long c_long(val n, val self)
unsigned long c_ulong(val n, val self)
{
#if SIZEOF_LONG <= SIZEOF_PTR
- uint_ptr_t v = c_unum(n);
- if (v < 0 || v > ULONG_MAX)
+ uint_ptr_t v = c_unum(n, self);
+ if (v > ULONG_MAX)
uw_throwf(error_s, lit("~a: value ~s is out of unsigned long range"),
self, n, nao);
return v;
@@ -264,15 +264,16 @@ unsigned long c_ulong(val n, val self)
#endif
}
-extern int itypes_little_endian;
-void itypes_init(void);
-
-void itypes_init()
+size_t c_size(val n, val self)
{
- union u {
- volatile unsigned ui;
- volatile unsigned char uc[sizeof (unsigned)];
- } u = { 0xff };
-
- itypes_little_endian = (u.uc[0] == 0xff);
+ switch (sizeof (size_t)) {
+ case sizeof (unsigned):
+ return c_uint(n, self);
+#if SIZEOF_LONG != SIZEOF_INT
+ case sizeof (unsigned long):
+ return c_ulong(n, self);
+#endif
+ default:
+ abort();
+ }
}
diff --git a/itypes.h b/itypes.h
index 0991b1cd..ebaabfd5 100644
--- a/itypes.h
+++ b/itypes.h
@@ -1,4 +1,4 @@
-/* Copyright 2017-2020
+/* Copyright 2017-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#if CHAR_BIT == 8
@@ -75,7 +76,7 @@ typedef long i64_t;
#define HAVE_I64 1
typedef ulonglong_t u64_t;
typedef longlong_t i64_t;
-#elif HAVE_DBL_INTPTR_T && (SIZEOF_DOUBLE_INTPTR * CHAR_BIT) == 64
+#elif HAVE_DOUBLE_INTPTR_T && (SIZEOF_DOUBLE_INTPTR * CHAR_BIT) == 64
#define HAVE_I64 1
typedef double_uintptr_t u64_t;
typedef double_intptr_t i64_t;
@@ -105,7 +106,6 @@ val unum_64(u64_t n);
#endif
char c_char(val, val self);
-signed char c_schar(val, val self);
unsigned char c_uchar(val, val self);
short c_short(val, val self);
@@ -117,5 +117,4 @@ unsigned int c_uint(val, val self);
long c_long(val, val self);
unsigned long c_ulong(val, val self);
-extern int itypes_little_endian;
-void itypes_init(void);
+size_t c_size(val, val self);
diff --git a/jmp.S b/jmp.S
index 994b09bd..55754697 100644
--- a/jmp.S
+++ b/jmp.S
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,29 +6,35 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#if __MINGW32__ || (__CYGWIN__ && __i386__)
#define DEFUN(NAME) \
.global _ ## NAME ; \
_ ## NAME: ;
+#elif __APPLE__ && __arm64__
+#define DEFUN(NAME) \
+.globl _ ## NAME %% \
+.p2align 2 %% \
+_ ## NAME: ;
#elif __APPLE__
#define DEFUN(NAME) \
.globl _ ## NAME ; \
@@ -54,6 +60,11 @@ NAME: ;
.globl NAME ; \
.def NAME; .scl 2; .type 32; .endef; \
NAME: ;
+#elif __riscv
+#define DEFUN(NAME) \
+.global NAME ; \
+.type NAME, %function ; \
+NAME: ;
#else
#define DEFUN(NAME) \
.global NAME ; \
@@ -237,9 +248,14 @@ DEFUN(jmp_restore)
#elif __PPC64__
+
DEFUN(jmp_save)
mflr %r11
mfcr %r12
+#if __ALTIVEC__
+ stvx %v31, 0, %r3
+ addi %r3, %r3, 32
+#endif
std %r1, 0(%r3)
std %r2, 8(%r3)
std %r11, 16(%r3)
@@ -263,10 +279,17 @@ DEFUN(jmp_save)
std %r29, 160(%r3)
std %r30, 168(%r3)
std %r31, 176(%r3)
+#if __ALTIVEC__
+ std %r11, 184(%r3) /* clobber padding */
+#endif
li %r3, 0
blr
DEFUN(jmp_restore)
+#if __ALTIVEC__
+ lvx %v31, 0, %r3
+ addi %r3, %r3, 32
+#endif
ld %r31, 176(%r3)
ld %r30, 168(%r3)
ld %r29, 160(%r3)
@@ -295,7 +318,11 @@ DEFUN(jmp_restore)
mr %r3, %r4
blr
-#elif __aarch64__
+#elif __aarch64__ || __arm64__
+
+#if __APPLE__
+ .section __TEXT,__text,regular,pure_instructions
+#endif
DEFUN(jmp_save)
stp x19, x20, [x0, 0]
@@ -329,6 +356,202 @@ DEFUN(jmp_restore)
mov w0, w1
br x30
+#if __APPLE__
+ .subsections_via_symbols
+#endif
+
+#elif _MIPS_SZPTR == 32
+
+ .set noreorder
+
+DEFUN(jmp_save)
+ sw $16, 0($4)
+ sw $17, 4($4)
+ sw $18, 8($4)
+ sw $19, 12($4)
+ sw $20, 16($4)
+ sw $21, 20($4)
+ sw $22, 24($4)
+ sw $23, 28($4)
+ sw $28, 32($4)
+ sw $29, 36($4)
+ sw $30, 40($4)
+ sw $ra, 44($4)
+ jr $ra
+ li $2, 0
+
+DEFUN(jmp_restore)
+ lw $16, 0($4)
+ lw $17, 4($4)
+ lw $18, 8($4)
+ lw $19, 12($4)
+ lw $20, 16($4)
+ lw $21, 20($4)
+ lw $22, 24($4)
+ lw $23, 28($4)
+ lw $28, 32($4)
+ lw $29, 36($4)
+ lw $ra, 44($4)
+ lw $30, 40($4)
+ jr $ra
+ move $2, $5
+
+#elif _MIPS_SZPTR == 64
+
+ .set noreorder
+
+DEFUN(jmp_save)
+ sd $16, 0($4)
+ sd $17, 8($4)
+ sd $18, 16($4)
+ sd $19, 24($4)
+ sd $20, 32($4)
+ sd $21, 40($4)
+ sd $22, 48($4)
+ sd $23, 56($4)
+ sd $28, 64($4)
+ sd $29, 72($4)
+ sd $30, 80($4)
+ sd $ra, 88($4)
+ jr $ra
+ li $2, 0
+
+DEFUN(jmp_restore)
+ ld $16, 0($4)
+ ld $17, 8($4)
+ ld $18, 16($4)
+ ld $19, 24($4)
+ ld $20, 32($4)
+ ld $21, 40($4)
+ ld $22, 48($4)
+ ld $23, 56($4)
+ ld $28, 64($4)
+ ld $29, 72($4)
+ ld $ra, 80($4)
+ ld $30, 88($4)
+ jr $ra
+ move $2, $5
+
+#elif __riscv
+
+DEFUN(jmp_save)
+ sd ra, 0(a0)
+ sd sp, 8(a0)
+ sd fp, 16(a0)
+ sd s1, 24(a0)
+ sd s2, 32(a0)
+ sd s3, 40(a0)
+ sd s4, 48(a0)
+ sd s5, 56(a0)
+ sd s6, 64(a0)
+ sd s7, 72(a0)
+ sd s8, 80(a0)
+ sd s9, 88(a0)
+ sd s10, 96(a0)
+ sd s11, 104(a0)
+#if 0 && !__riscv_float_abi_soft
+ fsd fs0, 112(a0)
+ fsd fs1, 120(a0)
+ fsd fs2, 128(a0)
+ fsd fs3, 136(a0)
+ fsd fs4, 144(a0)
+ fsd fs5, 152(a0)
+ fsd fs6, 160(a0)
+ fsd fs7, 168(a0)
+ fsd fs8, 176(a0)
+ fsd fs9, 184(a0)
+ fsd fs10, 192(a0)
+ fsd fs11, 200(a0)
+#endif
+ li a0, 0
+ ret
+
+DEFUN(jmp_restore)
+ ld ra, 0(a0)
+ ld sp, 8(a0)
+ ld fp, 16(a0)
+ ld s1, 24(a0)
+ ld s2, 32(a0)
+ ld s3, 40(a0)
+ ld s4, 48(a0)
+ ld s5, 56(a0)
+ ld s6, 64(a0)
+ ld s7, 72(a0)
+ ld s8, 80(a0)
+ ld s9, 88(a0)
+ ld s10, 96(a0)
+ ld s11, 104(a0)
+#if 0 && !__riscv_float_abi_soft
+ fld fs0, 112(a0)
+ fld fs1, 120(a0)
+ fld fs2, 128(a0)
+ fld fs3, 136(a0)
+ fld fs4, 144(a0)
+ fld fs5, 152(a0)
+ fld fs6, 160(a0)
+ fld fs7, 168(a0)
+ fld fs8, 176(a0)
+ fld fs9, 184(a0)
+ fld fs10, 192(a0)
+ fld fs11, 200(a0)
+#endif
+ mv a0, a1
+ ret
+
+#elif __loongarch64
+
+DEFUN(jmp_save)
+ st.d $ra, $a0, 0
+ st.d $sp, $a0, 8
+ st.d $fp, $a0, 16
+ st.d $s0, $a0, 24
+ st.d $s1, $a0, 32
+ st.d $s2, $a0, 40
+ st.d $s3, $a0, 48
+ st.d $s4, $a0, 56
+ st.d $s5, $a0, 64
+ st.d $s6, $a0, 72
+ st.d $s7, $a0, 80
+ st.d $s8, $a0, 88
+#if 0 && !__loongarch64_soft_float
+ fst.d $fs0, $a0, 96
+ fst.d $fs1, $a0, 104
+ fst.d $fs2, $a0, 112
+ fst.d $fs3, $a0, 120
+ fst.d $fs4, $a0, 128
+ fst.d $fs5, $a0, 136
+ fst.d $fs6, $a0, 144
+ fst.d $fs7, $a0, 152
+#endif
+ xor $v0, $v0, $v0
+ jirl $zero, $ra, 0
+
+DEFUN(jmp_restore)
+ ld.d $ra, $a0, 0
+ ld.d $sp, $a0, 8
+ ld.d $fp, $a0, 16
+ ld.d $s0, $a0, 24
+ ld.d $s1, $a0, 32
+ ld.d $s2, $a0, 40
+ ld.d $s3, $a0, 48
+ ld.d $s4, $a0, 56
+ ld.d $s5, $a0, 64
+ ld.d $s6, $a0, 72
+ ld.d $s7, $a0, 80
+ ld.d $s8, $a0, 88
+#if 0 && !__loongarch64_soft_float
+ fld.d $fs0, $a0, 96
+ fld.d $fs1, $a0, 104
+ fld.d $fs2, $a0, 112
+ fld.d $fs3, $a0, 120
+ fld.d $fs4, $a0, 128
+ fld.d $fs5, $a0, 136
+ fld.d $fs6, $a0, 144
+ fld.d $fs7, $a0, 152
+#endif
+ add.d $v0, $a1, $zero
+ jirl $zero, $ra, 0
+
#else
#error port me!
#endif
diff --git a/lex.yy.c.patch b/lex.yy.c.patch
new file mode 100644
index 00000000..b722d2f6
--- /dev/null
+++ b/lex.yy.c.patch
@@ -0,0 +1,13 @@
+--- lex.yy.c.shipped 2023-12-28 00:00:00.000000000 -0800
++++ lex.yy.c.shipped 2023-12-28 00:00:00.000000000 -0800
+@@ -4804,8 +4804,8 @@
+ /* Create the reject buffer large enough to save one state per allowed character. */
+ if ( ! yyg->yy_state_buf )
+ yyg->yy_state_buf = (yy_state_type *)yyalloc(YY_STATE_BUF_SIZE , yyscanner);
+- if ( ! yyg->yy_state_buf )
+- YY_FATAL_ERROR( "out of dynamic memory in yylex()" );
++ if ( ! yyg->yy_state_buf )
++ YY_FATAL_ERROR( "out of dynamic memory in yylex()" );
+
+ if ( ! yyg->yy_start )
+ yyg->yy_start = 1; /* first start state */
diff --git a/lex.yy.c.shipped b/lex.yy.c.shipped
new file mode 100644
index 00000000..625c0552
--- /dev/null
+++ b/lex.yy.c.shipped
@@ -0,0 +1,7955 @@
+
+#line 3 "lex.yy.c"
+
+#define YY_INT_ALIGNED short int
+
+/* A lexical scanner generated by flex */
+
+#define FLEX_SCANNER
+#define YY_FLEX_MAJOR_VERSION 2
+#define YY_FLEX_MINOR_VERSION 6
+#define YY_FLEX_SUBMINOR_VERSION 4
+#if YY_FLEX_SUBMINOR_VERSION > 0
+#define FLEX_BETA
+#endif
+
+#ifdef yyget_lval
+#define yyget_lval_ALREADY_DEFINED
+#else
+#define yyget_lval yyget_lval
+#endif
+
+#ifdef yyset_lval
+#define yyset_lval_ALREADY_DEFINED
+#else
+#define yyset_lval yyset_lval
+#endif
+
+/* First, we deal with platform-specific or compiler-specific issues. */
+
+/* begin standard C headers. */
+#include <stdio.h>
+#include <string.h>
+#include <errno.h>
+#include <stdlib.h>
+
+/* end standard C headers. */
+
+/* flex integer type definitions */
+
+#ifndef FLEXINT_H
+#define FLEXINT_H
+
+/* C99 systems have <inttypes.h>. Non-C99 systems may or may not. */
+
+#if defined (__STDC_VERSION__) && __STDC_VERSION__ >= 199901L
+
+/* C99 says to define __STDC_LIMIT_MACROS before including stdint.h,
+ * if you want the limit (max/min) macros for int types.
+ */
+#ifndef __STDC_LIMIT_MACROS
+#define __STDC_LIMIT_MACROS 1
+#endif
+
+#include <inttypes.h>
+typedef int8_t flex_int8_t;
+typedef uint8_t flex_uint8_t;
+typedef int16_t flex_int16_t;
+typedef uint16_t flex_uint16_t;
+typedef int32_t flex_int32_t;
+typedef uint32_t flex_uint32_t;
+#else
+typedef signed char flex_int8_t;
+typedef short int flex_int16_t;
+typedef int flex_int32_t;
+typedef unsigned char flex_uint8_t;
+typedef unsigned short int flex_uint16_t;
+typedef unsigned int flex_uint32_t;
+
+/* Limits of integral types. */
+#ifndef INT8_MIN
+#define INT8_MIN (-128)
+#endif
+#ifndef INT16_MIN
+#define INT16_MIN (-32767-1)
+#endif
+#ifndef INT32_MIN
+#define INT32_MIN (-2147483647-1)
+#endif
+#ifndef INT8_MAX
+#define INT8_MAX (127)
+#endif
+#ifndef INT16_MAX
+#define INT16_MAX (32767)
+#endif
+#ifndef INT32_MAX
+#define INT32_MAX (2147483647)
+#endif
+#ifndef UINT8_MAX
+#define UINT8_MAX (255U)
+#endif
+#ifndef UINT16_MAX
+#define UINT16_MAX (65535U)
+#endif
+#ifndef UINT32_MAX
+#define UINT32_MAX (4294967295U)
+#endif
+
+#ifndef SIZE_MAX
+#define SIZE_MAX (~(size_t)0)
+#endif
+
+#endif /* ! C99 */
+
+#endif /* ! FLEXINT_H */
+
+/* begin standard C++ headers. */
+
+/* TODO: this is always defined, so inline it */
+#define yyconst const
+
+#if defined(__GNUC__) && __GNUC__ >= 3
+#define yynoreturn __attribute__((__noreturn__))
+#else
+#define yynoreturn
+#endif
+
+/* Returned upon end-of-file. */
+#define YY_NULL 0
+
+/* Promotes a possibly negative, possibly signed char to an
+ * integer in range [0..255] for use as an array index.
+ */
+#define YY_SC_TO_UI(c) ((YY_CHAR) (c))
+
+/* An opaque pointer. */
+#ifndef YY_TYPEDEF_YY_SCANNER_T
+#define YY_TYPEDEF_YY_SCANNER_T
+typedef void* yyscan_t;
+#endif
+
+/* For convenience, these vars (plus the bison vars far below)
+ are macros in the reentrant scanner. */
+#define yyin yyg->yyin_r
+#define yyout yyg->yyout_r
+#define yyextra yyg->yyextra_r
+#define yyleng yyg->yyleng_r
+#define yytext yyg->yytext_r
+#define yylineno (YY_CURRENT_BUFFER_LVALUE->yy_bs_lineno)
+#define yycolumn (YY_CURRENT_BUFFER_LVALUE->yy_bs_column)
+#define yy_flex_debug yyg->yy_flex_debug_r
+
+/* Enter a start condition. This macro really ought to take a parameter,
+ * but we do it the disgusting crufty way forced on us by the ()-less
+ * definition of BEGIN.
+ */
+#define BEGIN yyg->yy_start = 1 + 2 *
+/* Translate the current start state into a value that can be later handed
+ * to BEGIN to return to the state. The YYSTATE alias is for lex
+ * compatibility.
+ */
+#define YY_START ((yyg->yy_start - 1) / 2)
+#define YYSTATE YY_START
+/* Action number for EOF rule of a given start state. */
+#define YY_STATE_EOF(state) (YY_END_OF_BUFFER + state + 1)
+/* Special action meaning "start processing a new file". */
+#define YY_NEW_FILE yyrestart( yyin , yyscanner )
+#define YY_END_OF_BUFFER_CHAR 0
+
+/* Size of default input buffer. */
+#ifndef YY_BUF_SIZE
+#ifdef __ia64__
+/* On IA-64, the buffer size is 16k, not 8k.
+ * Moreover, YY_BUF_SIZE is 2*YY_READ_BUF_SIZE in the general case.
+ * Ditto for the __ia64__ case accordingly.
+ */
+#define YY_BUF_SIZE 32768
+#else
+#define YY_BUF_SIZE 16384
+#endif /* __ia64__ */
+#endif
+
+/* The state buf must be large enough to hold one state per character in the main buffer.
+ */
+#define YY_STATE_BUF_SIZE ((YY_BUF_SIZE + 2) * sizeof(yy_state_type))
+
+#ifndef YY_TYPEDEF_YY_BUFFER_STATE
+#define YY_TYPEDEF_YY_BUFFER_STATE
+typedef struct yy_buffer_state *YY_BUFFER_STATE;
+#endif
+
+#ifndef YY_TYPEDEF_YY_SIZE_T
+#define YY_TYPEDEF_YY_SIZE_T
+typedef size_t yy_size_t;
+#endif
+
+#define EOB_ACT_CONTINUE_SCAN 0
+#define EOB_ACT_END_OF_FILE 1
+#define EOB_ACT_LAST_MATCH 2
+
+ #define YY_LESS_LINENO(n)
+ #define YY_LINENO_REWIND_TO(ptr)
+
+/* Return all but the first "n" matched characters back to the input stream. */
+#define yyless(n) \
+ do \
+ { \
+ /* Undo effects of setting up yytext. */ \
+ int yyless_macro_arg = (n); \
+ YY_LESS_LINENO(yyless_macro_arg);\
+ *yy_cp = yyg->yy_hold_char; \
+ YY_RESTORE_YY_MORE_OFFSET \
+ yyg->yy_c_buf_p = yy_cp = yy_bp + yyless_macro_arg - YY_MORE_ADJ; \
+ YY_DO_BEFORE_ACTION; /* set up yytext again */ \
+ } \
+ while ( 0 )
+#define unput(c) yyunput( c, yyg->yytext_ptr , yyscanner )
+
+#ifndef YY_STRUCT_YY_BUFFER_STATE
+#define YY_STRUCT_YY_BUFFER_STATE
+struct yy_buffer_state
+ {
+ FILE *yy_input_file;
+
+ char *yy_ch_buf; /* input buffer */
+ char *yy_buf_pos; /* current position in input buffer */
+
+ /* Size of input buffer in bytes, not including room for EOB
+ * characters.
+ */
+ int yy_buf_size;
+
+ /* Number of characters read into yy_ch_buf, not including EOB
+ * characters.
+ */
+ int yy_n_chars;
+
+ /* Whether we "own" the buffer - i.e., we know we created it,
+ * and can realloc() it to grow it, and should free() it to
+ * delete it.
+ */
+ int yy_is_our_buffer;
+
+ /* Whether this is an "interactive" input source; if so, and
+ * if we're using stdio for input, then we want to use getc()
+ * instead of fread(), to make sure we stop fetching input after
+ * each newline.
+ */
+ int yy_is_interactive;
+
+ /* Whether we're considered to be at the beginning of a line.
+ * If so, '^' rules will be active on the next match, otherwise
+ * not.
+ */
+ int yy_at_bol;
+
+ int yy_bs_lineno; /**< The line count. */
+ int yy_bs_column; /**< The column count. */
+
+ /* Whether to try to fill the input buffer when we reach the
+ * end of it.
+ */
+ int yy_fill_buffer;
+
+ int yy_buffer_status;
+
+#define YY_BUFFER_NEW 0
+#define YY_BUFFER_NORMAL 1
+ /* When an EOF's been seen but there's still some text to process
+ * then we mark the buffer as YY_EOF_PENDING, to indicate that we
+ * shouldn't try reading from the input source any more. We might
+ * still have a bunch of tokens to match, though, because of
+ * possible backing-up.
+ *
+ * When we actually see the EOF, we change the status to "new"
+ * (via yyrestart()), so that the user can continue scanning by
+ * just pointing yyin at a new input file.
+ */
+#define YY_BUFFER_EOF_PENDING 2
+
+ };
+#endif /* !YY_STRUCT_YY_BUFFER_STATE */
+
+/* We provide macros for accessing buffer states in case in the
+ * future we want to put the buffer states in a more general
+ * "scanner state".
+ *
+ * Returns the top of the stack, or NULL.
+ */
+#define YY_CURRENT_BUFFER ( yyg->yy_buffer_stack \
+ ? yyg->yy_buffer_stack[yyg->yy_buffer_stack_top] \
+ : NULL)
+/* Same as previous macro, but useful when we know that the buffer stack is not
+ * NULL or when we need an lvalue. For internal use only.
+ */
+#define YY_CURRENT_BUFFER_LVALUE yyg->yy_buffer_stack[yyg->yy_buffer_stack_top]
+
+void yyrestart ( FILE *input_file , yyscan_t yyscanner );
+void yy_switch_to_buffer ( YY_BUFFER_STATE new_buffer , yyscan_t yyscanner );
+YY_BUFFER_STATE yy_create_buffer ( FILE *file, int size , yyscan_t yyscanner );
+void yy_delete_buffer ( YY_BUFFER_STATE b , yyscan_t yyscanner );
+void yy_flush_buffer ( YY_BUFFER_STATE b , yyscan_t yyscanner );
+void yypush_buffer_state ( YY_BUFFER_STATE new_buffer , yyscan_t yyscanner );
+void yypop_buffer_state ( yyscan_t yyscanner );
+
+static void yyensure_buffer_stack ( yyscan_t yyscanner );
+static void yy_load_buffer_state ( yyscan_t yyscanner );
+static void yy_init_buffer ( YY_BUFFER_STATE b, FILE *file , yyscan_t yyscanner );
+#define YY_FLUSH_BUFFER yy_flush_buffer( YY_CURRENT_BUFFER , yyscanner)
+
+YY_BUFFER_STATE yy_scan_buffer ( char *base, yy_size_t size , yyscan_t yyscanner );
+YY_BUFFER_STATE yy_scan_string ( const char *yy_str , yyscan_t yyscanner );
+YY_BUFFER_STATE yy_scan_bytes ( const char *bytes, int len , yyscan_t yyscanner );
+
+void *yyalloc ( yy_size_t , yyscan_t yyscanner );
+void *yyrealloc ( void *, yy_size_t , yyscan_t yyscanner );
+void yyfree ( void * , yyscan_t yyscanner );
+
+#define yy_new_buffer yy_create_buffer
+#define yy_set_interactive(is_interactive) \
+ { \
+ if ( ! YY_CURRENT_BUFFER ){ \
+ yyensure_buffer_stack (yyscanner); \
+ YY_CURRENT_BUFFER_LVALUE = \
+ yy_create_buffer( yyin, YY_BUF_SIZE , yyscanner); \
+ } \
+ YY_CURRENT_BUFFER_LVALUE->yy_is_interactive = is_interactive; \
+ }
+#define yy_set_bol(at_bol) \
+ { \
+ if ( ! YY_CURRENT_BUFFER ){\
+ yyensure_buffer_stack (yyscanner); \
+ YY_CURRENT_BUFFER_LVALUE = \
+ yy_create_buffer( yyin, YY_BUF_SIZE , yyscanner); \
+ } \
+ YY_CURRENT_BUFFER_LVALUE->yy_at_bol = at_bol; \
+ }
+#define YY_AT_BOL() (YY_CURRENT_BUFFER_LVALUE->yy_at_bol)
+
+/* Begin user sect3 */
+typedef flex_uint8_t YY_CHAR;
+
+typedef int yy_state_type;
+
+#define yytext_ptr yytext_r
+
+static yy_state_type yy_get_previous_state ( yyscan_t yyscanner );
+static yy_state_type yy_try_NUL_trans ( yy_state_type current_state , yyscan_t yyscanner);
+static int yy_get_next_buffer ( yyscan_t yyscanner );
+static void yynoreturn yy_fatal_error ( const char* msg , yyscan_t yyscanner );
+
+/* Done after the current pattern has been matched and before the
+ * corresponding action - sets up yytext.
+ */
+#define YY_DO_BEFORE_ACTION \
+ yyg->yytext_ptr = yy_bp; \
+ yyleng = (int) (yy_cp - yy_bp); \
+ yyg->yy_hold_char = *yy_cp; \
+ *yy_cp = '\0'; \
+ yyg->yy_c_buf_p = yy_cp;
+#define YY_NUM_RULES 169
+#define YY_END_OF_BUFFER 170
+/* This struct is not used in this scanner,
+ but its presence is necessary. */
+struct yy_trans_info
+ {
+ flex_int32_t yy_verify;
+ flex_int32_t yy_nxt;
+ };
+static const flex_int16_t yy_acclist[1787] =
+ { 0,
+ 65, 65, 65, 65, 65, 65, 65, 65, 141, 141,
+ 141, 141, 152, 152, 166, 166, 170, 117, 169, 118,
+ 169, 118, 169, 116, 169, 120, 169, 117, 169, 117,
+ 169, 117, 169, 120, 169, 101, 102, 169, 65, 101,
+ 102, 169, 87, 169, 87, 101, 102, 169, 66, 101,
+ 102, 169, 101, 102, 169, 58, 101, 102, 169, 64,
+ 101, 102, 169, 101, 102, 169, 92, 101, 102, 169,
+ 88, 101, 102, 169, 1, 2, 21, 101, 102, 169,
+ 16402, 100, 101, 102, 169, 86, 101, 102, 169, 21,
+ 101, 102, 169,16402, 58, 101, 102, 169, 101, 102,
+
+ 169, 70, 101, 102, 169, 57, 101, 102, 169, 64,
+ 101, 102, 169, 102, 169, 102, 169, 102, 169, 102,
+ 169, 65, 101, 102, 169, 22, 101, 102, 169,16403,
+ 75, 101, 102, 169, 61, 101, 102, 169, 22, 101,
+ 102, 169,16403, 61, 101, 102, 169, 92, 101, 102,
+ 169, 1, 2, 22, 101, 102, 169,16403, 22, 101,
+ 102, 169,16403, 59, 101, 102, 169, 22, 101, 102,
+ 169,16403, 62, 101, 102, 169, 102, 169, 102, 169,
+ 102, 169, 65, 101, 102, 169, 23, 101, 102, 169,
+ 16404, 75, 101, 102, 169, 23, 101, 102, 169,16404,
+
+ 92, 101, 102, 169, 1, 2, 23, 101, 102, 169,
+ 16404, 23, 101, 102, 169,16404, 59, 101, 102, 169,
+ 23, 101, 102, 169,16404, 102, 169, 102, 169, 102,
+ 169, 114, 115, 169, 114, 115, 169, 108, 169, 108,
+ 114, 115, 169, 110, 114, 115, 169, 103, 110, 114,
+ 115, 169, 113, 114, 115, 169, 115, 169, 115, 169,
+ 115, 169, 115, 169, 109, 169, 109, 114, 115, 169,
+ 149, 155, 169, 149, 155, 169, 135, 169, 135, 149,
+ 155, 169, 123, 149, 155, 169, 149, 155, 169, 155,
+ 169, 155, 169, 155, 169, 155, 169, 134, 149, 155,
+
+ 169, 136, 169, 136, 149, 155, 169, 133, 134, 149,
+ 155, 169, 133, 134, 149, 155, 169, 133, 134, 149,
+ 155, 169, 134, 155, 169, 134, 155, 169, 134, 155,
+ 169, 134, 155, 169, 137, 169, 137, 149, 155, 169,
+ 140, 149, 155, 169, 149, 155, 169, 124, 149, 155,
+ 169, 65, 101, 102, 169, 101, 102, 169, 101, 102,
+ 169, 92, 101, 102, 169, 1, 2, 12, 21, 101,
+ 102, 169,16402, 59, 101, 102, 169, 101, 102, 169,
+ 141, 149, 155, 169, 138, 169, 138, 149, 155, 169,
+ 149, 155, 169, 149, 155, 169, 154, 169, 152, 154,
+
+ 169, 153, 169, 153, 154, 169, 151, 154, 169, 150,
+ 154, 169, 160, 167, 169, 166, 167, 169, 165, 169,
+ 165, 167, 169, 161, 164, 167, 169, 160, 167, 169,
+ 164, 167, 169, 160, 167, 169, 156, 160, 167, 169,
+ 156, 160, 167, 169, 100, 160, 167, 169, 160, 167,
+ 169, 160, 167, 169, 160, 167, 169, 163, 164, 167,
+ 169, 148, 169, 148, 149, 155, 169, 142, 149, 155,
+ 169, 149, 155, 169, 168, 169, 169, 117, 117, 117,
+ 117, 118, 116, 122, 119, 117, 117, 117, 122, 65,
+ 91, 87, 71, 69, 67, 73, 1, 2, 90, 5,
+
+ 6, 93, 1, 2, 21,16402, 21,16402, 21,16402,
+ 100, 99, 95, 95, 99, 96, 99, 97, 99, 98,
+ 99, 101, 65, 91, 22, 24,16403, 22,16403, 22,
+ 24,16403, 22,16403, 22,16403, 82, 76, 81, 79,
+ 78, 77, 80, 1, 2, 22, 24,16403, 60, 5,
+ 6, 1, 2, 22, 24,16403, 22, 24,16403, 22,
+ 24,16403, 22,16403, 24, 22,16403, 22,16403, 22,
+ 16403, 11, 22,16403, 95, 22, 101,16403, 65, 91,
+ 23, 25,16404, 23,16404, 23, 25,16404, 23,16404,
+ 23,16404, 1, 2, 23, 25,16404, 85, 5, 6,
+
+ 1, 2, 23, 25,16404, 23, 25,16404, 23, 25,
+ 16404, 23,16404, 25, 23,16404, 23,16404, 23,16404,
+ 11, 23,16404, 23, 101,16404, 108, 112, 107, 107,
+ 112, 104, 112, 111, 112, 105, 112, 106, 112, 112,
+ 114, 109, 135, 131, 127, 128, 127, 128, 131, 125,
+ 131, 129, 131, 130, 131, 149, 136, 133, 132, 133,
+ 132, 133, 137, 139, 11, 139, 139, 126, 131, 65,
+ 91, 1, 2, 12, 1, 2, 12, 21,16402, 141,
+ 138, 128, 128, 131, 152, 153, 160, 166, 165, 160,
+ 156, 160, 156, 160, 160, 160, 156, 160, 100, 160,
+
+ 160, 160, 160, 162, 148, 147, 143, 147, 146, 147,
+ 122, 117, 122, 121, 121, 122, 89, 94, 72, 74,
+ 68, 3, 3, 3, 63, 1, 2, 5, 6, 7,
+ 7, 7, 2, 10, 5, 6, 7, 10, 8210, 7,
+ 10, 7, 10, 5, 6, 21,16402, 8210, 95, 97,
+ 97, 97, 22, 24,16403, 22, 24,16403, 22, 24,
+ 16403, 22, 24,16403, 8211, 22, 24,16403, 22, 24,
+ 16403, 22, 24,16403, 24, 24, 84, 83, 22, 24,
+ 16403, 22,16403, 22,16403, 5, 6, 8211, 1, 2,
+ 22, 24,16403, 22, 24,16403, 8, 5, 6, 8,
+
+ 8, 8, 2, 8, 10, 10, 5, 6, 8, 10,
+ 8211, 8, 10, 10, 8, 10, 10, 10, 10, 22,
+ 24,16403, 5, 6, 22, 24,16403, 22, 24,16403,
+ 22, 24,16403, 24, 22, 24,16403, 24, 22, 24,
+ 16403, 22,16403, 22,16403, 11, 22, 24,16403, 23,
+ 25,16404, 23, 25,16404, 23, 25,16404, 23, 25,
+ 16404, 8212, 23, 25,16404, 23, 25,16404, 23, 25,
+ 16404, 25, 25, 23, 25,16404, 23,16404, 23,16404,
+ 5, 6, 8212, 1, 2, 23, 25,16404, 23, 25,
+ 16404, 9, 5, 6, 9, 9, 9, 2, 9, 10,
+
+ 10, 5, 6, 9, 10, 8212, 9, 10, 10, 9,
+ 10, 10, 10, 10, 23, 25,16404, 5, 6, 23,
+ 25,16404, 23, 25,16404, 23, 25,16404, 25, 23,
+ 25,16404, 25, 23, 25,16404, 23,16404, 23,16404,
+ 11, 23, 25,16404, 107, 107, 105, 105, 105, 127,
+ 128, 127, 128, 129, 129, 129, 11, 3, 16, 3,
+ 14, 1, 2, 12, 2, 10, 8210, 128, 128, 84,
+ 160, 83, 160, 156, 160, 160, 156, 160, 160, 160,
+ 160, 121, 5, 6, 7, 7, 5, 6, 3, 4,
+ 4, 3, 4, 3, 4, 54, 54, 54, 54, 54,
+
+ 54, 35, 5, 6, 7, 10, 6, 5, 6, 7,
+ 2, 5, 6, 7, 8210, 5, 6, 7, 5, 6,
+ 7, 21,16402, 7, 21,16402, 5, 6, 8, 8,
+ 5, 6, 22, 24,16403, 22, 24,16403, 22, 24,
+ 16403, 22, 24,16403, 22, 24,16403, 22, 24,16403,
+ 24, 24, 24, 24, 22, 24,16403, 22, 24,16403,
+ 22, 24,16403, 5, 6, 8, 8211, 8, 8, 8,
+ 6, 8, 8, 5, 6, 8, 8, 8, 8, 8,
+ 8, 5, 6, 8, 2, 5, 6, 8, 8211, 8,
+ 5, 6, 8, 8, 22, 24,16403, 22, 24,16403,
+
+ 5, 6, 8, 22, 24,16403, 8, 22, 24,16403,
+ 24, 22, 24,16403, 22, 24,16403, 22, 24,16403,
+ 11, 22, 24,16403, 5, 6, 9, 9, 5, 6,
+ 23, 25,16404, 23, 25,16404, 23, 25,16404, 23,
+ 25,16404, 23, 25,16404, 23, 25,16404, 25, 25,
+ 25, 25, 23, 25,16404, 23, 25,16404, 23, 25,
+ 16404, 5, 6, 9, 8212, 9, 9, 9, 6, 9,
+ 9, 5, 6, 9, 9, 9, 9, 9, 9, 5,
+ 6, 9, 2, 5, 6, 9, 8212, 9, 5, 6,
+ 9, 9, 23, 25,16404, 23, 25,16404, 5, 6,
+
+ 9, 23, 25,16404, 9, 23, 25,16404, 25, 23,
+ 25,16404, 23, 25,16404, 23, 25,16404, 17, 15,
+ 13, 11, 23, 25,16404, 3, 4, 16, 3, 4,
+ 14, 2, 160, 160, 160, 3, 3, 3, 26, 34,
+ 36, 48, 48, 48, 48, 48, 48, 43, 43, 43,
+ 43, 43, 43, 51, 6, 7, 7, 5, 6, 6,
+ 7, 10, 7, 10, 6, 7, 8210, 5, 6, 8,
+ 22, 24,16403, 22, 24,16403, 22, 24,16403, 24,
+ 8, 8, 6, 8, 8, 8, 8, 8, 5, 6,
+ 8, 6, 8, 10, 8, 10, 6, 5, 6, 8,
+
+ 8, 22, 24,16403, 8, 22, 24,16403, 8, 22,
+ 24,16403, 8, 22, 24,16403, 8, 22, 24,16403,
+ 8, 8211, 8, 22, 24,16403, 8, 22, 24,16403,
+ 5, 6, 8, 22, 24,16403, 8, 22, 24,16403,
+ 8, 22, 24,16403, 8, 22, 24,16403, 8, 22,
+ 24,16403, 8, 24, 8, 24, 5, 6, 9, 23,
+ 25,16404, 23, 25,16404, 23, 25,16404, 25, 9,
+ 9, 6, 9, 9, 9, 9, 9, 5, 6, 9,
+ 6, 9, 10, 9, 10, 6, 5, 6, 9, 9,
+ 23, 25,16404, 9, 23, 25,16404, 9, 23, 25,
+
+ 16404, 9, 23, 25,16404, 9, 23, 25,16404, 9,
+ 8212, 9, 23, 25,16404, 9, 23, 25,16404, 5,
+ 6, 9, 23, 25,16404, 9, 23, 25,16404, 9,
+ 23, 25,16404, 9, 23, 25,16404, 9, 23, 25,
+ 16404, 9, 25, 9, 25, 160, 159, 157, 6, 7,
+ 7, 38, 38, 38, 38, 38, 38, 55, 55, 55,
+ 55, 55, 55, 56, 46, 46, 46, 46, 46, 46,
+ 28, 42, 42, 42, 42, 42, 42, 27, 27, 27,
+ 27, 27, 27, 6, 7, 6, 7, 6, 8, 8,
+ 6, 8, 8, 8, 6, 8, 8, 6, 8, 6,
+
+ 8, 8, 22, 24,16403, 8, 22, 24,16403, 8,
+ 22, 24,16403, 8, 22, 24,16403, 8, 22, 24,
+ 16403, 8, 22, 24,16403, 8, 8211, 8, 22, 24,
+ 16403, 8, 22, 24,16403, 8, 22, 24,16403, 8,
+ 22, 24,16403, 8, 22, 24,16403, 8, 22, 24,
+ 16403, 8, 24, 8, 24, 8, 24, 8, 24, 6,
+ 9, 9, 6, 9, 9, 9, 6, 9, 9, 6,
+ 9, 6, 9, 9, 23, 25,16404, 9, 23, 25,
+ 16404, 9, 23, 25,16404, 9, 23, 25,16404, 9,
+ 23, 25,16404, 9, 23, 25,16404, 9, 8212, 9,
+
+ 23, 25,16404, 9, 23, 25,16404, 9, 23, 25,
+ 16404, 9, 23, 25,16404, 9, 23, 25,16404, 9,
+ 23, 25,16404, 9, 25, 9, 25, 9, 25, 9,
+ 25, 158, 145, 145, 31, 31, 31, 31, 31, 31,
+ 30, 52, 52, 52, 52, 52, 52, 47, 45, 29,
+ 39, 39, 39, 39, 39, 39, 6, 6, 8, 6,
+ 8, 8, 22, 24,16403, 8, 22, 24,16403, 8,
+ 22, 24,16403, 8, 22, 24,16403, 8, 22, 24,
+ 16403, 8, 22, 24,16403, 8, 22, 24,16403, 8,
+ 22, 24,16403, 8, 22, 24,16403, 8, 24, 6,
+
+ 9, 6, 9, 9, 23, 25,16404, 9, 23, 25,
+ 16404, 9, 23, 25,16404, 9, 23, 25,16404, 9,
+ 23, 25,16404, 9, 23, 25,16404, 9, 23, 25,
+ 16404, 9, 23, 25,16404, 9, 23, 25,16404, 9,
+ 25, 32, 32, 32, 32, 32, 32, 50, 50, 50,
+ 50, 50, 50, 33, 33, 33, 33, 33, 33, 40,
+ 40, 40, 40, 40, 40, 41, 41, 41, 41, 41,
+ 41, 44, 37, 37, 37, 37, 37, 37, 53, 49,
+ 49, 49, 49, 49, 49, 144
+ } ;
+
+static const flex_int16_t yy_accept[1765] =
+ { 0,
+ 1, 1, 1, 2, 3, 4, 5, 6, 7, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 8,
+ 9, 10, 11, 12, 13, 14, 15, 16, 17, 17,
+ 17, 17, 17, 18, 20, 22, 24, 26, 28, 30,
+ 32, 34, 36, 39, 43, 45, 49, 53, 56, 60,
+ 64, 67, 71, 75, 82, 86, 90, 95, 99, 102,
+ 106, 110, 114, 116, 118, 120, 122, 126, 131, 135,
+ 139, 144, 148, 152, 159, 164, 168, 173, 177, 179,
+ 181, 183, 187, 192, 196, 201, 205, 212, 217, 221,
+ 226, 228, 230, 232, 235, 238, 240, 244, 248, 253,
+
+ 257, 259, 261, 263, 265, 267, 271, 274, 277, 279,
+ 283, 287, 290, 292, 294, 296, 298, 302, 304, 308,
+ 313, 318, 323, 326, 329, 332, 335, 337, 341, 345,
+ 348, 352, 356, 359, 362, 366, 374, 378, 381, 385,
+ 387, 391, 394, 397, 399, 402, 404, 407, 410, 413,
+ 416, 419, 421, 424, 428, 431, 434, 437, 441, 445,
+ 449, 452, 455, 458, 462, 464, 468, 472, 475, 477,
+ 478, 479, 480, 481, 482, 483, 484, 484, 485, 486,
+ 487, 488, 489, 489, 490, 491, 491, 492, 492, 493,
+ 494, 494, 495, 496, 497, 497, 497, 497, 497, 497,
+
+ 497, 497, 497, 497, 497, 497, 497, 497, 497, 497,
+ 497, 497, 497, 497, 497, 497, 497, 497, 497, 497,
+ 497, 497, 497, 499, 500, 502, 503, 503, 503, 507,
+ 509, 511, 512, 512, 513, 514, 516, 518, 520, 522,
+ 523, 523, 523, 524, 524, 525, 525, 528, 530, 530,
+ 533, 533, 535, 535, 535, 535, 535, 537, 538, 539,
+ 540, 541, 542, 543, 544, 544, 549, 550, 552, 552,
+ 552, 557, 560, 563, 565, 566, 568, 568, 568, 568,
+ 570, 570, 572, 575, 575, 575, 575, 576, 579, 579,
+ 579, 580, 580, 581, 581, 584, 586, 586, 589, 589,
+
+ 591, 591, 591, 591, 593, 593, 598, 599, 601, 601,
+ 601, 606, 609, 612, 614, 615, 617, 617, 617, 617,
+ 619, 619, 621, 624, 624, 624, 624, 627, 627, 627,
+ 627, 627, 628, 629, 630, 632, 634, 636, 638, 640,
+ 641, 642, 642, 642, 643, 643, 643, 644, 645, 647,
+ 650, 652, 654, 656, 657, 657, 657, 658, 659, 661,
+ 663, 664, 664, 665, 665, 667, 668, 670, 671, 672,
+ 672, 672, 675, 675, 675, 680, 680, 681, 681, 682,
+ 683, 685, 686, 687, 688, 689, 690, 691, 693, 695,
+ 696, 697, 699, 701, 702, 703, 704, 705, 706, 707,
+
+ 709, 711, 712, 713, 714, 715, 717, 718, 719, 719,
+ 719, 719, 719, 720, 721, 722, 722, 723, 723, 724,
+ 724, 725, 725, 725, 725, 725, 725, 725, 725, 725,
+ 725, 725, 725, 725, 725, 725, 725, 725, 725, 725,
+ 725, 725, 725, 725, 725, 725, 725, 725, 725, 725,
+ 725, 725, 725, 725, 725, 725, 725, 725, 725, 725,
+ 725, 725, 725, 725, 725, 725, 725, 725, 725, 725,
+ 726, 726, 728, 728, 728, 731, 732, 733, 734, 735,
+ 740, 742, 744, 744, 748, 749, 750, 751, 752, 753,
+ 753, 753, 753, 753, 753, 753, 756, 759, 762, 765,
+
+ 765, 765, 765, 766, 769, 772, 775, 775, 775, 775,
+ 776, 776, 777, 777, 777, 777, 777, 777, 778, 779,
+ 782, 784, 786, 786, 786, 786, 789, 794, 797, 798,
+ 798, 798, 798, 801, 802, 802, 803, 803, 803, 803,
+ 804, 806, 807, 812, 814, 815, 817, 818, 819, 820,
+ 823, 828, 831, 834, 835, 838, 838, 838, 838, 839,
+ 839, 839, 839, 839, 839, 842, 844, 846, 846, 846,
+ 846, 850, 850, 850, 850, 850, 850, 850, 850, 850,
+ 853, 856, 859, 862, 862, 862, 862, 863, 866, 869,
+ 872, 872, 872, 872, 873, 873, 874, 874, 874, 874,
+
+ 874, 874, 877, 879, 881, 881, 881, 881, 884, 889,
+ 892, 893, 893, 893, 893, 896, 897, 897, 898, 898,
+ 898, 898, 899, 901, 902, 907, 909, 910, 912, 913,
+ 914, 915, 918, 923, 926, 929, 930, 933, 933, 933,
+ 933, 934, 934, 934, 934, 934, 934, 937, 939, 941,
+ 941, 941, 941, 941, 941, 941, 945, 945, 945, 945,
+ 946, 947, 948, 949, 950, 950, 952, 954, 955, 956,
+ 957, 957, 958, 958, 960, 960, 962, 962, 965, 966,
+ 968, 969, 970, 972, 974, 976, 977, 979, 980, 981,
+ 982, 982, 982, 983, 983, 986, 987, 989, 989, 991,
+
+ 992, 992, 994, 994, 996, 996, 996, 996, 996, 996,
+ 996, 996, 996, 996, 996, 996, 996, 996, 996, 996,
+ 996, 996, 996, 996, 996, 996, 996, 996, 996, 996,
+ 996, 996, 996, 996, 996, 996, 996, 996, 996, 996,
+ 996, 996, 996, 996, 996, 996, 996, 997, 998, 999,
+ 1000, 1001, 1002, 1002, 1002, 1002, 1002, 1002, 1003, 1003,
+ 1003, 1003, 1003, 1003, 1003, 1003, 1003, 1007, 1008, 1008,
+ 1011, 1011, 1012, 1012, 1016, 1019, 1019, 1024, 1027, 1027,
+ 1030, 1031, 1031, 1033, 1036, 1039, 1042, 1042, 1042, 1042,
+ 1042, 1042, 1045, 1048, 1051, 1051, 1051, 1051, 1051, 1051,
+
+ 1052, 1053, 1054, 1054, 1054, 1054, 1055, 1055, 1055, 1055,
+ 1055, 1055, 1055, 1058, 1061, 1064, 1064, 1064, 1064, 1064,
+ 1064, 1068, 1069, 1070, 1070, 1070, 1070, 1071, 1072, 1073,
+ 1074, 1077, 1078, 1079, 1079, 1079, 1079, 1080, 1080, 1080,
+ 1080, 1081, 1081, 1081, 1081, 1082, 1085, 1085, 1085, 1085,
+ 1086, 1086, 1090, 1091, 1094, 1098, 1101, 1101, 1107, 1111,
+ 1111, 1111, 1111, 1111, 1112, 1112, 1112, 1112, 1112, 1112,
+ 1112, 1112, 1112, 1115, 1118, 1121, 1121, 1121, 1121, 1121,
+ 1121, 1125, 1125, 1125, 1128, 1129, 1129, 1131, 1134, 1137,
+ 1140, 1140, 1140, 1140, 1140, 1140, 1143, 1146, 1149, 1149,
+
+ 1149, 1149, 1149, 1149, 1150, 1151, 1152, 1152, 1152, 1152,
+ 1153, 1153, 1153, 1153, 1153, 1153, 1153, 1156, 1159, 1162,
+ 1162, 1162, 1162, 1162, 1162, 1166, 1167, 1168, 1168, 1168,
+ 1168, 1169, 1170, 1171, 1172, 1175, 1176, 1177, 1177, 1177,
+ 1177, 1178, 1178, 1178, 1178, 1179, 1179, 1179, 1179, 1180,
+ 1183, 1183, 1183, 1183, 1184, 1184, 1188, 1189, 1192, 1196,
+ 1199, 1199, 1205, 1209, 1209, 1209, 1209, 1209, 1210, 1210,
+ 1210, 1210, 1210, 1210, 1210, 1210, 1210, 1213, 1216, 1219,
+ 1219, 1219, 1219, 1219, 1219, 1219, 1220, 1220, 1221, 1221,
+ 1222, 1226, 1226, 1229, 1232, 1233, 1234, 1235, 1236, 1236,
+
+ 1236, 1236, 1236, 1237, 1238, 1239, 1239, 1239, 1239, 1239,
+ 1239, 1239, 1239, 1239, 1239, 1239, 1239, 1239, 1239, 1239,
+ 1239, 1239, 1239, 1239, 1239, 1239, 1239, 1239, 1239, 1239,
+ 1239, 1239, 1239, 1239, 1240, 1240, 1241, 1241, 1241, 1241,
+ 1241, 1241, 1241, 1241, 1241, 1241, 1241, 1242, 1242, 1242,
+ 1242, 1242, 1242, 1243, 1244, 1245, 1245, 1246, 1247, 1248,
+ 1248, 1248, 1248, 1249, 1250, 1251, 1251, 1252, 1253, 1254,
+ 1254, 1254, 1254, 1255, 1255, 1257, 1258, 1260, 1263, 1265,
+ 1265, 1266, 1268, 1268, 1268, 1271, 1274, 1277, 1280, 1280,
+ 1280, 1280, 1280, 1280, 1280, 1280, 1280, 1280, 1281, 1281,
+
+ 1281, 1281, 1281, 1281, 1281, 1281, 1281, 1281, 1281, 1281,
+ 1282, 1282, 1282, 1282, 1282, 1282, 1283, 1283, 1283, 1283,
+ 1285, 1286, 1287, 1287, 1287, 1287, 1287, 1287, 1287, 1287,
+ 1288, 1289, 1289, 1289, 1289, 1289, 1289, 1292, 1292, 1295,
+ 1297, 1297, 1298, 1301, 1305, 1309, 1313, 1317, 1317, 1317,
+ 1317, 1321, 1323, 1327, 1331, 1337, 1341, 1341, 1341, 1341,
+ 1345, 1349, 1353, 1353, 1353, 1353, 1355, 1355, 1357, 1357,
+ 1357, 1357, 1357, 1357, 1357, 1357, 1357, 1357, 1357, 1357,
+ 1357, 1357, 1357, 1360, 1363, 1366, 1369, 1369, 1369, 1369,
+ 1369, 1369, 1369, 1369, 1369, 1369, 1370, 1370, 1370, 1370,
+
+ 1370, 1370, 1370, 1370, 1370, 1370, 1370, 1370, 1371, 1371,
+ 1371, 1371, 1371, 1371, 1372, 1372, 1372, 1372, 1374, 1375,
+ 1376, 1376, 1376, 1376, 1376, 1376, 1376, 1376, 1377, 1378,
+ 1378, 1378, 1378, 1378, 1378, 1381, 1381, 1384, 1386, 1386,
+ 1387, 1390, 1394, 1398, 1402, 1406, 1406, 1406, 1406, 1410,
+ 1412, 1416, 1420, 1426, 1430, 1430, 1430, 1430, 1434, 1438,
+ 1442, 1442, 1442, 1442, 1444, 1444, 1446, 1446, 1446, 1446,
+ 1446, 1446, 1446, 1446, 1446, 1446, 1446, 1446, 1446, 1447,
+ 1448, 1449, 1449, 1449, 1451, 1452, 1452, 1452, 1452, 1452,
+ 1452, 1452, 1452, 1452, 1452, 1452, 1452, 1452, 1452, 1452,
+
+ 1452, 1452, 1452, 1452, 1452, 1452, 1452, 1452, 1452, 1452,
+ 1452, 1452, 1453, 1454, 1455, 1455, 1456, 1457, 1458, 1458,
+ 1459, 1460, 1461, 1462, 1463, 1464, 1464, 1465, 1465, 1465,
+ 1465, 1465, 1466, 1467, 1468, 1469, 1470, 1471, 1471, 1471,
+ 1471, 1472, 1472, 1473, 1474, 1475, 1476, 1477, 1478, 1478,
+ 1478, 1479, 1480, 1481, 1482, 1483, 1484, 1484, 1484, 1486,
+ 1488, 1490, 1491, 1491, 1491, 1491, 1491, 1491, 1491, 1491,
+ 1491, 1491, 1491, 1491, 1491, 1491, 1491, 1493, 1494, 1495,
+ 1497, 1497, 1497, 1497, 1497, 1497, 1497, 1497, 1498, 1500,
+ 1502, 1506, 1510, 1514, 1514, 1514, 1514, 1514, 1514, 1518,
+
+ 1522, 1526, 1526, 1526, 1526, 1528, 1532, 1536, 1540, 1540,
+ 1540, 1540, 1540, 1540, 1544, 1548, 1552, 1552, 1552, 1552,
+ 1552, 1552, 1554, 1556, 1558, 1558, 1558, 1558, 1560, 1560,
+ 1560, 1560, 1560, 1560, 1560, 1560, 1560, 1562, 1563, 1563,
+ 1563, 1563, 1563, 1563, 1563, 1563, 1563, 1563, 1563, 1563,
+ 1563, 1563, 1563, 1565, 1566, 1567, 1569, 1569, 1569, 1569,
+ 1569, 1569, 1569, 1569, 1570, 1572, 1574, 1578, 1582, 1586,
+ 1586, 1586, 1586, 1586, 1586, 1590, 1594, 1598, 1598, 1598,
+ 1598, 1600, 1604, 1608, 1612, 1612, 1612, 1612, 1612, 1612,
+ 1616, 1620, 1624, 1624, 1624, 1624, 1624, 1624, 1626, 1628,
+
+ 1630, 1630, 1630, 1630, 1632, 1632, 1632, 1632, 1632, 1632,
+ 1632, 1632, 1632, 1633, 1634, 1635, 1635, 1635, 1635, 1635,
+ 1635, 1635, 1635, 1635, 1635, 1635, 1635, 1635, 1635, 1635,
+ 1635, 1635, 1636, 1637, 1638, 1639, 1640, 1641, 1641, 1642,
+ 1643, 1644, 1645, 1646, 1647, 1648, 1648, 1648, 1648, 1648,
+ 1649, 1649, 1649, 1650, 1650, 1650, 1651, 1651, 1651, 1651,
+ 1651, 1652, 1653, 1654, 1655, 1656, 1657, 1658, 1658, 1658,
+ 1658, 1658, 1660, 1660, 1660, 1662, 1666, 1670, 1674, 1674,
+ 1674, 1674, 1674, 1674, 1674, 1678, 1682, 1686, 1686, 1686,
+ 1686, 1686, 1686, 1690, 1694, 1698, 1698, 1698, 1698, 1698,
+
+ 1698, 1698, 1698, 1698, 1698, 1700, 1700, 1700, 1700, 1700,
+ 1700, 1700, 1700, 1700, 1700, 1700, 1700, 1700, 1702, 1702,
+ 1702, 1704, 1708, 1712, 1716, 1716, 1716, 1716, 1716, 1716,
+ 1716, 1720, 1724, 1728, 1728, 1728, 1728, 1728, 1728, 1732,
+ 1736, 1740, 1740, 1740, 1740, 1740, 1740, 1740, 1740, 1740,
+ 1740, 1742, 1742, 1742, 1742, 1742, 1742, 1742, 1742, 1742,
+ 1742, 1742, 1742, 1742, 1742, 1742, 1742, 1742, 1742, 1742,
+ 1743, 1744, 1745, 1746, 1747, 1748, 1748, 1749, 1750, 1751,
+ 1752, 1753, 1754, 1754, 1755, 1756, 1757, 1758, 1759, 1760,
+ 1760, 1761, 1762, 1763, 1764, 1765, 1766, 1767, 1768, 1769,
+
+ 1770, 1771, 1772, 1772, 1773, 1773, 1773, 1773, 1773, 1773,
+ 1773, 1773, 1773, 1773, 1773, 1773, 1773, 1773, 1773, 1773,
+ 1773, 1773, 1773, 1773, 1773, 1773, 1773, 1773, 1773, 1773,
+ 1773, 1773, 1773, 1773, 1773, 1773, 1773, 1774, 1775, 1776,
+ 1777, 1778, 1779, 1779, 1780, 1781, 1782, 1783, 1784, 1785,
+ 1786, 1786, 1786, 1786, 1786, 1786, 1786, 1786, 1786, 1786,
+ 1786, 1786, 1787, 1787
+ } ;
+
+static const YY_CHAR yy_ec[256] =
+ { 0,
+ 1, 1, 1, 1, 1, 1, 1, 1, 2, 3,
+ 1, 1, 4, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 5, 6, 7, 8, 6, 9, 9, 10, 11,
+ 12, 13, 14, 15, 16, 17, 18, 19, 20, 21,
+ 21, 21, 21, 21, 21, 22, 22, 23, 24, 6,
+ 25, 6, 26, 27, 28, 28, 29, 30, 31, 29,
+ 32, 33, 32, 34, 32, 32, 32, 35, 32, 32,
+ 32, 36, 37, 38, 32, 32, 39, 32, 32, 32,
+ 40, 41, 42, 43, 32, 44, 45, 46, 47, 48,
+
+ 49, 50, 51, 52, 53, 32, 54, 55, 56, 57,
+ 58, 59, 32, 60, 61, 62, 63, 64, 39, 65,
+ 66, 32, 67, 68, 69, 70, 1, 71, 71, 71,
+ 71, 71, 71, 71, 71, 71, 71, 71, 71, 71,
+ 71, 71, 71, 71, 71, 71, 71, 71, 71, 71,
+ 71, 71, 71, 71, 71, 71, 71, 71, 71, 71,
+ 71, 71, 71, 71, 71, 71, 71, 71, 71, 71,
+ 71, 71, 71, 71, 71, 71, 71, 71, 71, 71,
+ 71, 71, 71, 71, 71, 71, 71, 71, 71, 71,
+ 71, 72, 72, 73, 73, 73, 73, 73, 73, 73,
+
+ 73, 73, 73, 73, 73, 73, 73, 73, 73, 73,
+ 73, 73, 73, 73, 73, 73, 73, 73, 73, 73,
+ 73, 73, 73, 74, 74, 74, 74, 74, 74, 74,
+ 74, 74, 74, 74, 74, 74, 74, 74, 74, 75,
+ 75, 75, 75, 75, 72, 72, 72, 72, 72, 72,
+ 72, 72, 72, 72, 72
+ } ;
+
+static const YY_CHAR yy_meta[76] =
+ { 0,
+ 1, 2, 3, 4, 5, 6, 7, 8, 6, 9,
+ 10, 2, 11, 12, 13, 12, 14, 15, 16, 16,
+ 16, 16, 17, 18, 6, 6, 19, 16, 16, 16,
+ 16, 20, 20, 20, 20, 20, 20, 20, 20, 10,
+ 6, 7, 21, 1, 16, 16, 16, 16, 22, 16,
+ 20, 20, 20, 20, 23, 20, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 10, 1, 7, 11,
+ 1, 1, 24, 24, 24
+ } ;
+
+static const flex_int16_t yy_base[2030] =
+ { 0,
+ 0, 3, 78, 0, 153, 0, 228, 0, 302, 376,
+ 6, 8, 350, 356, 451, 0, 525, 599, 673, 0,
+ 362, 534, 715, 789, 863, 912, 961, 1030, 539, 544,
+ 5784, 5782, 5784, 235,13484, 5780, 5768, 11, 250, 256,
+ 261, 12,13484, 24,13484, 5769,13484, 621, 1099, 5745,
+ 30, 37,13484, 389, 0,13484, 6,13484, 1172,13484,
+ 13484,13484,13484, 5690, 5689, 5686, 551, 633, 1231,13484,
+ 1289, 5743, 12, 682, 707, 724, 50,13484, 5678, 5671,
+ 5667, 572, 731, 5714, 1357, 625, 706, 752, 801, 379,
+ 5664, 5663, 5655,13484, 343,13484, 5720,13484,13484, 1432,
+
+ 13484, 5641, 5637, 5634,13484, 5700,13484, 345,13484, 5697,
+ 13484, 1505,13484, 5626, 5619, 5617,13484,13484, 5679, 0,
+ 41, 1552,13484, 5550, 5530, 5529,13484, 5595, 1595, 1660,
+ 13484, 559, 794, 318, 529, 616, 5586, 61, 366,13484,
+ 5583, 554, 409,13484, 13,13484, 5577,13484,13484, 0,
+ 344,13484, 5576,13484, 420,13484, 601, 649, 822, 1724,
+ 5532, 5510, 5506, 5546,13484, 5555,13484, 840,13484,13484,
+ 509, 584, 678, 690,13484, 5542, 922, 0,13484, 579,
+ 697, 775, 943, 411, 973, 933, 899, 995,13484,13484,
+ 388,13484,13484,13484, 986, 1041, 52, 0, 710, 1750,
+
+ 832, 924, 1036, 805, 1184, 1016, 1002, 990, 1188, 1225,
+ 1172, 1219, 1250, 1093, 1261, 947, 1264, 5472, 5471, 5469,
+ 690, 917, 1163, 530, 1182,13484, 1063, 1813, 1326, 428,
+ 1339, 0, 1167,13484, 557, 808,13484, 1047, 0,13484,
+ 5467, 5462, 1385, 1206, 1307, 1499, 1514, 1569, 1282, 1610,
+ 1297, 1623, 5460, 5448, 5446, 1373, 1685,13484,13484,13484,
+ 13484,13484,13484,13484, 1330, 1881,13484, 1949, 1393, 2024,
+ 0, 1734, 1908, 1915, 703, 1920, 5444, 5443, 5442, 2092,
+ 5486, 2160, 0, 5436, 5434, 5427, 829, 2097, 5422, 5420,
+ 1655, 1399, 1982, 1753, 2100, 2121, 1347, 2133, 1520, 2182,
+
+ 5418, 5416, 5415, 2193, 1403, 2261,13484, 2329, 1514, 2404,
+ 0, 2223, 2288, 2295, 1135, 2300, 5414, 5408, 5406, 2472,
+ 1494, 2540, 0, 5404, 5402, 5401, 2477, 5400, 5394, 627,
+ 541,13484,13484, 558, 867,13484,13484, 1195,13484, 0,
+ 13484, 5385, 5382,13484, 986, 546,13484,13484, 585, 893,
+ 13484, 1600, 0,13484, 5379, 5378,13484, 0, 1390, 2597,
+ 13484, 1028,13484, 1407, 1669, 0,13484, 1269, 659, 1609,
+ 786, 1723, 1766, 1694, 1898, 5402, 1276, 575,13484, 921,
+ 1093, 1101,13484, 0, 1121,13484, 1940, 1496, 2210, 1757,
+ 1991, 2230, 2646, 5384, 5383, 5369,13484,13484,13484,13484,
+
+ 7, 0, 1574, 621,13484, 645, 1283,13484, 1999, 2082,
+ 2486, 2133,13484,13484,13484, 716, 747, 1635, 1742, 0,
+ 2702, 1659, 5347, 5343, 5342, 1001, 5354, 1508, 5355, 1835,
+ 5350, 5355, 5347, 5346, 624, 5332, 1255, 5325, 5334, 259,
+ 5321, 5322, 1871, 1904, 2084, 2225, 2088, 2251, 2266, 2306,
+ 2324, 2463, 2459, 2291, 2752, 2467, 2319, 2491, 2189, 2566,
+ 2507, 2526, 2499, 2520, 2530, 2556, 2561, 5302, 5299, 2202,
+ 2827, 2645, 2367, 0, 2653, 0, 2671, 2688,13484, 2504,
+ 0, 2720, 2587, 2660, 2676, 1380, 1886,13484, 5345, 5294,
+ 2706, 2751, 2895, 2766, 2784, 2902, 2913, 2916, 2924, 5288,
+
+ 5287, 5286, 2724, 2938, 2977, 2998, 5280, 5274, 5273, 2905,
+ 5320, 1866, 5269, 5267, 5266, 5259, 5250,13484,13484, 3001,
+ 3006, 3019, 5248, 5247, 5244, 3087, 3155, 3039, 2111, 5290,
+ 2792, 3011, 3223, 1900, 2993, 3106, 5241, 5237, 5232, 3118,
+ 2626, 5277, 3291, 1942, 3024, 3132, 5223, 5221, 5219, 3168,
+ 3359, 3210, 3250, 2118, 3278, 5218, 5217, 5215, 2140, 5209,
+ 5207, 5195, 5193, 5191, 3318, 3331, 3367, 5189, 5181, 5178,
+ 3435, 5177, 5172, 5171, 2885, 3181, 3503, 3240, 3194, 3392,
+ 3395, 3463, 3471, 5164, 5157, 5143, 2952, 3474, 3512, 3545,
+ 5139, 5129, 5127, 3148, 5174, 2144, 5125, 5115, 5114, 5104,
+
+ 5103, 3548, 3556, 3573, 5102, 5101, 5092, 3641, 3709, 3593,
+ 2735, 5139, 3259, 3323, 3777, 2220, 3161, 3618, 5080, 5077,
+ 5076, 3654, 2889, 5122, 3845, 2246, 3296, 3686, 5073, 5071,
+ 5068, 3722, 3913, 3764, 3804, 2418, 3832, 5065, 5054, 5050,
+ 2423, 5046, 5045, 5042, 5039, 5030, 3872, 3885, 3921, 5028,
+ 5027, 4963, 2102, 3249, 1125, 3989, 4942, 4940, 4932, 1386,
+ 1381, 2933,13484, 4970, 4922, 1573, 1537, 3092,13484, 4968,
+ 4918, 3122, 2535, 2577, 0, 4050, 0, 3406, 3429, 3173,
+ 1656, 1542, 0, 0, 3453, 3308, 3521, 4926, 4925, 4926,
+ 0, 2591,13484, 3794, 3950, 3667, 1547, 799, 1680, 4955,
+
+ 2635, 3205, 4953, 4082, 4895, 4889, 4901, 4907, 4894, 775,
+ 4888, 4877, 4877, 280, 4865, 4870, 1547, 4841, 0, 4841,
+ 4826, 4842, 4831, 1909, 4825, 4824, 4824, 4821, 4817, 4805,
+ 4804, 3744, 3880, 3977, 4017, 4002, 4082, 4033, 4112, 4121,
+ 4140, 4136, 4149, 4176, 4168, 4195,13484, 4214, 4245, 4794,
+ 4790, 4789, 4250, 4274, 4349, 4262, 2772,13484, 4254, 4363,
+ 4438, 4383, 4465, 4461, 4474, 4782, 4379, 3744, 3538, 3813,
+ 4549, 4610, 4039, 3573, 2116, 4211, 3584, 4834, 4618, 4660,
+ 4631, 3606, 4691, 4647, 4709, 4720, 4768, 4759, 4757, 4753,
+ 4751, 4731, 4734, 4745, 4742, 4739, 4732, 4730, 4727, 3704,
+
+ 3888, 2716, 4720, 4716, 4714, 2743, 4709, 4707, 4702, 4696,
+ 4689, 4688, 4773, 4794, 4806, 4684, 4679, 4674, 4673, 4669,
+ 4874, 3016, 2909, 4667, 4656, 4645, 2990, 4942, 3174, 3269,
+ 3631, 3057, 4836, 4644, 4621, 4618, 3084, 4617, 4607, 4600,
+ 4161, 4590, 4577, 4573, 3903, 4295, 4571, 4565, 5017, 4823,
+ 4411, 0, 4470, 4359, 4908, 4911, 4922, 5085, 5092, 3647,
+ 4555, 4495, 4475, 3091, 4471, 4470, 4466, 4462, 4461, 4448,
+ 4447, 4445, 5103, 5106, 5114, 4437, 4433, 4428, 4427, 4412,
+ 5182, 4404, 4957, 5250, 5201, 3658, 5210, 5236, 5274, 5279,
+ 4401, 4400, 4398, 4397, 4389, 5312, 5319, 5333, 4388, 4383,
+
+ 4381, 4376, 4364, 4421, 4620, 3242, 4355, 4348, 4336, 3263,
+ 4334, 4332, 4331, 4326, 4316, 4306, 5355, 5372, 5393, 4296,
+ 4292, 4287, 4284, 4275, 5461, 3430, 3282, 4274, 4268, 4263,
+ 3314, 5529, 3458, 3621, 3930, 3356, 5421, 4262, 4251, 4250,
+ 3386, 4238, 4228, 4207, 4789, 4204, 4201, 4200, 5133, 4855,
+ 4194, 4192, 5604, 5219, 4501, 0, 5172, 5402, 5447, 5489,
+ 5508, 5672, 5679, 3715, 4190, 4189, 4187, 3592, 4186, 4183,
+ 4182, 4177, 4157, 4149, 4146, 4141, 5690, 5693, 5701, 4137,
+ 4135, 4134, 4122, 4121, 837, 909, 3678, 3714, 0, 0,
+ 5769, 4119, 3922, 5830, 4022, 4133, 5879, 5948, 0, 0,
+
+ 3971, 5550, 1914, 4100, 6000, 4108, 2990, 2991, 4127, 4113,
+ 4111, 4091, 4088, 4084, 4084, 4073, 4056, 3005, 4064, 4028,
+ 4033, 4020, 4028, 4018, 4019, 4008, 4005, 4005, 3985, 3985,
+ 3207, 3980, 3412,13484, 3487,13484, 4093, 3783, 3728, 4257,
+ 6050, 4428, 6125, 5138, 4296, 3516,13484, 3695, 4102, 4451,
+ 6200, 4611,13484, 4623, 6231, 4696, 3960, 3959, 3952, 5293,
+ 4752, 6294,13484, 4650, 0, 4922, 3950, 3947, 3946, 4935,
+ 6369, 3549,13484, 5109, 5710, 5312, 4321, 0, 5438, 4262,
+ 4392, 4509, 6437, 5778, 6505, 5793, 5796, 5814, 3944, 3942,
+ 3934, 3932, 3930, 3927, 3909, 3897, 3895, 3749, 3886, 3868,
+
+ 3856, 3846, 3845, 3843, 3842, 3839, 3838, 3830, 3815, 3796,
+ 3812, 3803, 3802, 3792, 3790, 3900, 3783, 3777, 3775, 6573,
+ 5891, 3910, 3774, 3771, 3770, 3765, 3758, 3739, 3734, 5095,
+ 5388, 3724, 3715, 3705, 3703, 3702, 5878, 3691, 0, 5909,
+ 4893, 6081, 5921, 5950, 6088, 6163, 6316, 3686, 3683, 3654,
+ 6377, 5480, 6380, 6461, 6641, 6464, 3648, 3642, 3639, 6472,
+ 6532, 6544, 3588, 3586, 3583, 5518, 3622, 3953, 3564, 3531,
+ 3527, 3526, 3518, 3513, 3511, 3499, 3496, 3495, 3479, 3456,
+ 6709, 5977, 6777, 6607, 6612, 6648, 3445, 3441, 3436, 3429,
+ 3425, 3424, 3414, 3405, 3393, 3973, 3392, 3376, 3366, 3349,
+
+ 3345, 3340, 3337, 3328, 3314, 3301, 3292, 4128, 3289, 3288,
+ 3278, 3276, 3262, 4165, 3261, 3249, 3236, 6845, 6156, 4171,
+ 3231, 3220, 3217, 3216, 3204, 3193, 3185, 5696, 5931, 3181,
+ 3180, 3170, 3168, 3161, 6060, 3140, 0, 6239, 4979, 6675,
+ 6326, 6682, 6716, 6737, 6744, 3102, 3097, 3079, 6805, 5759,
+ 6816, 6869, 6937, 6894, 3076, 3074, 3063, 6908, 6962, 6970,
+ 3053, 3034, 3032, 5964, 3078, 4309, 3029, 3025, 3016, 3011,
+ 3007, 2998, 2986, 2977, 2974, 2972, 2969, 2964, 7044,13484,
+ 13484, 0, 0, 6621, 5568, 2976, 2965, 2970, 2947, 2956,
+ 2901, 0, 3631, 2884, 2894, 2880, 2889, 0, 2886, 2889,
+
+ 3699, 2860, 0, 2875, 2856, 0, 2854, 7114, 7189, 7264,
+ 4134,13484, 3743, 7295, 4660, 2837, 2773, 2751, 4787,13484,
+ 3879, 0, 2731, 2730, 2711, 3885,13484, 4081, 4829, 4148,
+ 5359,13484, 4664, 0, 2709, 2707, 2697, 4744, 4774, 4924,
+ 13484, 5372,13484, 4928, 0, 2694, 2690, 251, 5506, 5122,
+ 13484, 5000, 0, 255, 280, 285, 7358, 5075, 6049, 2316,
+ 7426, 6756, 291, 334, 348, 355, 462, 469, 483, 524,
+ 592, 606, 625, 634, 651, 658, 7494, 7000, 6013, 6657,
+ 670, 686, 702, 725, 732, 737, 758, 6835, 6884, 7009,
+ 7025, 7136, 7209, 774, 780, 806, 817, 828, 7227, 7363,
+
+ 7397, 873, 878, 900, 6927, 7460, 7465, 7519, 915, 937,
+ 938, 948, 953, 7533, 7536, 7547, 958, 965, 977, 1008,
+ 1031, 6277, 6423, 4583, 1036, 1043, 1072, 4627, 1099, 1100,
+ 1108, 1110, 1119, 1125, 1127, 1129, 7615, 7074, 1134, 1135,
+ 1149, 1153, 1164, 1172, 1185, 1189, 1205, 1209, 1219, 1220,
+ 1224, 1236, 7683, 7087, 6952, 7149, 1251, 1259, 1260, 1269,
+ 1271, 1273, 1302, 7059, 7199, 7274, 7574, 7642, 7649, 1325,
+ 1326, 1332, 1346, 1440, 7654, 7717, 7722, 1452, 1461, 1467,
+ 7388, 7725, 7746, 7758, 1485, 1487, 1497, 1508, 1513, 7785,
+ 7799, 7807, 1514, 1519, 1520, 1537, 1542, 6510, 7304, 4656,
+
+ 1555, 1561, 1563, 4825, 1565, 1568, 1570, 1580, 1581, 1597,
+ 1602, 1607,13484,13484, 1645, 0, 5002, 0, 1643, 1647,
+ 1654, 5214, 1652, 5249, 1651, 5302, 1657, 1657, 1659, 1674,
+ 0,13484, 5352, 7838, 1656, 1659, 1670, 5400,13484,13484,
+ 5501, 0, 1675, 1681, 1698, 7901, 5732, 7976, 5709,13484,
+ 5780, 5738,13484, 8051, 5746,13484, 5842, 8126, 8201, 6539,
+ 13484, 5522, 0, 1700, 1709, 1711, 5664, 1718, 1719, 1721,
+ 1733, 8269, 1759, 1822, 8337, 7923, 7998, 8073, 1824, 1826,
+ 1828, 1838, 1851, 1865, 8148, 8209, 8277, 1878, 1879, 1882,
+ 1896, 1914, 8294, 8354, 8362, 1915, 1920, 1921, 1925, 1926,
+
+ 1929, 1935, 1938, 1970, 4833, 2035, 2039, 2041, 2054, 2055,
+ 2057, 2065, 2066, 2068, 2074, 2080, 2098, 8430, 2107, 2117,
+ 8498, 8390, 8417, 8453, 2118, 2126, 2127, 2129, 2131, 2133,
+ 8458, 8470, 8531, 2140, 2155, 2157, 2182, 2187, 8534, 8539,
+ 8542, 2189, 2194, 2199, 2200, 2202, 2204, 2206, 2214, 2219,
+ 4847, 2220, 2226, 2230, 2231, 2236, 2238, 2242, 2257, 2282,
+ 0, 2292, 0, 2289, 0, 2295, 0, 0, 5806,13484,
+ 5860, 0, 2287, 2300, 2301, 8617,13484, 5939, 0, 2305,
+ 2306, 2313, 7100,13484, 6072, 0, 2319, 2320, 2324, 8692,
+ 13484, 6084, 0, 2325, 2329, 2330,13484, 6159, 0, 2350,
+
+ 2410, 2412, 5812,13484, 2413, 2416, 2417, 2431, 2438, 2439,
+ 2441, 2442, 2447, 2450, 2456, 2458, 2460, 2473, 2499, 2504,
+ 2505, 2514, 2517, 2519, 2520, 2531, 2549, 2550, 2553, 2561,
+ 2562, 2566, 2681, 0, 5823, 0,13484, 6172, 0, 2567,
+ 2581, 2592, 5973,13484,13484, 6190, 0, 2600, 2607, 2612,
+ 2633, 2635, 2641, 2643, 2647, 2649, 2664, 2667, 6385, 0,
+ 0,13484,13484, 8767, 8791, 8815, 8839, 8863, 8887, 8911,
+ 8923, 8946, 8970, 8989, 9008, 9027, 9046, 9065, 9084, 9108,
+ 9117, 9133, 9156, 9180, 9204, 9228, 9252, 2915, 9271, 9283,
+ 9306, 2777, 9325, 9344, 9363, 9382, 9401, 9420, 9439, 9458,
+
+ 9477, 9496, 9515, 9534, 9553, 9572, 9591, 9610, 9629, 9648,
+ 9667, 9686, 2944, 3015, 9695, 9703, 3278, 9726, 9738, 9761,
+ 9785, 3061, 9809, 9833, 9857, 9866, 9877, 3099, 9895, 9906,
+ 3101, 9924, 9943, 9962, 9981,10000,10019,10038,10057,10076,
+ 10095,10114,10133,10152,10171,10190,10209,10228,10247,10266,
+ 10285,10304,10323,10342,10361,10380,10399,10418,10437,10456,
+ 10475,10494,10513,10532,10551,10570,10589,10608,10627, 3361,
+ 3497, 3882,10639, 3260,10662,10686, 3287, 3346,10698, 3423,
+ 10721,10744,10755,10773,10792,10811,10830,10849,10868,10887,
+ 10906,10925,10944,10963,10982,11001,11020,11039,11058,11077,
+
+ 11096,11115,11134,11153,11172,11191,11210,11229,11248,11267,
+ 11286,11305,11324,11343,11362,11381,11400,11419,11438,11457,
+ 11476,11495,11514,11533,11552,11571,11590, 3379,11602,11625,
+ 3391, 3461,11634,11657,11681,11700,11719,11738,11757,11776,
+ 11795,11814,11833,11852,11871,11890,11909,11928,11947,11966,
+ 11985,12004,12023,12042,12061,12080,12099,12118,12137,12156,
+ 12175,12194,12213,12232,12251,12270,12289,12308,12327,12346,
+ 12365,12384,12408, 3471, 3547,12420,12443,12467,12491,12515,
+ 12539,12563,12582,12601,12620,12639,12658,12677,12696,12715,
+ 12734,12753,12772,12791,12810,12829,12848,12867,12886,12905,
+
+ 12924,12943,12962,12981,13000,13019,13043,13067,13091,13110,
+ 13121,13139,13158,13177,13196,13215,13234,13253,13272,13291,
+ 13315,13339,13363,13387,13411,13435,13459, 3558, 3595
+ } ;
+
+static const flex_int16_t yy_def[2030] =
+ { 0,
+ 1764, 1764, 1763, 3, 1763, 5, 1763, 7, 1765, 1765,
+ 10, 10, 1766, 1766, 1763, 15, 1766, 1766, 3, 19,
+ 1766, 1766, 1766, 1766, 1767, 1767, 1768, 1768, 1766, 1766,
+ 1769, 1769, 1763, 1770, 1763, 1763, 1763, 1763, 1770, 1770,
+ 1770, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1771, 1772, 1763, 1771, 1763, 1773, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1774, 1763, 1763,
+ 1774, 1763, 1763, 71, 1775, 1776, 71, 1763, 1763, 1763,
+ 1763, 1763, 1777, 69, 1777, 1763, 85, 1778, 1779, 85,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1780, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1781,
+ 1781, 1781, 1763, 1763, 1763, 1763, 1763, 1763, 1782, 1780,
+ 1763, 1763, 1763, 1763, 1763, 1771, 1763, 1763, 1763, 1763,
+ 1763, 130, 130, 1763, 1763, 1763, 1763, 1763, 1763, 1783,
+ 1763, 1763, 1763, 1763, 1783, 1763, 1783, 1783, 1783, 1784,
+ 1783, 1783, 1783, 1763, 1763, 1763, 1763, 1785, 1763, 1763,
+ 1770, 1770, 1770, 1770, 1763, 1763, 1763, 1786, 1763, 1770,
+ 1770, 1770, 1763, 1787, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1788, 49, 1789, 1763,
+
+ 1789, 1789, 1789, 1789, 1789, 1789, 1789, 1789, 1789, 1789,
+ 1789, 1789, 1789, 1789, 1789, 1789, 1789, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1790, 1763, 1763, 1763, 1771, 1771,
+ 1771, 1791, 1763, 1763, 1763, 1763, 1763, 1763, 1792, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1793, 1794, 1763, 1795,
+ 1796, 1794, 1763, 1763, 1763, 1763, 1797, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1793, 1763, 1798, 1763, 1763,
+ 266, 266, 1799, 1800, 1801, 1800, 1763, 1763, 1763, 1802,
+ 1763, 1802, 282, 1763, 1763, 1763, 1763, 1794, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1803, 1804, 1763, 1805, 1806, 1804,
+
+ 1763, 1763, 1763, 1807, 1763, 1803, 1763, 1808, 1763, 1763,
+ 306, 306, 1809, 1810, 1811, 1810, 1763, 1763, 1763, 1812,
+ 1763, 1812, 322, 1763, 1763, 1763, 1804, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1813,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1814, 1763, 1763, 1763, 1763, 1815, 1815, 1815,
+ 1763, 1763, 1763, 1763, 1816, 1816, 1763, 1763, 1763, 1763,
+ 1817, 1763, 1763, 1818, 1819, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1820, 1763, 1763, 1820, 1820, 1820, 1820,
+ 1820, 1820, 1821, 1820, 1820, 1820, 1763, 1763, 1763, 1763,
+
+ 1822, 1823, 1824, 1825, 1763, 1825, 1763, 1763, 1763, 1826,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1827, 1763, 1827, 1828,
+ 1827, 1829, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1829, 1829, 1829, 1829, 1829, 1829, 1829, 1829,
+ 1829, 1829, 1829, 1829, 1829, 1829, 1829, 1829, 1829, 1829,
+ 1829, 1829, 1829, 1829, 1829, 1829, 1829, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1826, 1826, 1826, 1826, 1763, 1763, 475,
+ 1826, 1826, 1763, 1830, 1763, 1763, 1763, 1763, 1831, 1763,
+ 1763, 1763, 1832, 1763, 1763, 1833, 1833, 1834, 1833, 1763,
+
+ 1763, 1763, 1763, 1835, 1836, 1836, 1763, 1763, 1763, 1837,
+ 1763, 1838, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1839,
+ 1840, 1840, 1763, 1763, 1763, 1832, 1833, 527, 1841, 1763,
+ 1763, 1832, 1842, 1843, 1844, 1841, 1763, 1763, 1763, 1763,
+ 1841, 1763, 1842, 1843, 1844, 1841, 1763, 1763, 1763, 527,
+ 1845, 1846, 1846, 1847, 1846, 1763, 1763, 1763, 1848, 1763,
+ 1763, 1763, 1763, 1763, 1849, 1850, 1850, 1763, 1763, 1763,
+ 1849, 1763, 1763, 1763, 1763, 1763, 1851, 1763, 1763, 1852,
+ 1852, 1853, 1852, 1763, 1763, 1763, 1763, 1854, 1855, 1855,
+ 1763, 1763, 1763, 1856, 1763, 1857, 1763, 1763, 1763, 1763,
+
+ 1763, 1858, 1859, 1859, 1763, 1763, 1763, 1851, 1852, 609,
+ 1860, 1763, 1763, 1851, 1861, 1862, 1863, 1860, 1763, 1763,
+ 1763, 1763, 1860, 1763, 1861, 1862, 1863, 1860, 1763, 1763,
+ 1763, 609, 1864, 1865, 1865, 1866, 1865, 1763, 1763, 1763,
+ 1867, 1763, 1763, 1763, 1763, 1763, 1868, 1869, 1869, 1763,
+ 1763, 1763, 1763, 1763, 1870, 1868, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1871, 1763, 1763, 1763, 1763, 1763, 1872,
+ 1763, 1763, 1763, 1873, 1874, 1873, 1875, 1763, 1763, 1763,
+ 1763, 1763, 1876, 1876, 1876, 1876, 1876, 1876, 1876, 1876,
+ 1877, 1878, 1763, 1763, 1879, 1879, 696, 1763, 1873, 1873,
+
+ 1763, 1873, 1880, 676, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1881, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1882, 1882, 1882, 1882, 1882, 1882, 1882, 1882, 1882,
+ 1882, 1882, 1882, 1882, 1882, 1882, 1763, 1882, 1763, 1763,
+ 1763, 1763, 1882, 1882, 1882, 1882, 1763, 1763, 1882, 1882,
+ 1882, 1882, 1882, 1882, 1882, 1763, 1879, 767, 1763, 1879,
+ 1763, 1763, 1763, 767, 696, 696, 1883, 1883, 1763, 1884,
+ 1885, 1763, 1886, 1887, 1888, 1888, 1763, 1763, 1763, 1763,
+ 1763, 1889, 1889, 1889, 1763, 1763, 1763, 1763, 1763, 1890,
+
+ 1890, 1891, 1763, 1763, 1763, 1892, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1893, 1893, 1893, 1763, 1763, 1763, 1763, 1763,
+ 1884, 1885, 1894, 1763, 1763, 1763, 1895, 1886, 1885, 1885,
+ 821, 1896, 1885, 1763, 1763, 1763, 1897, 1763, 1763, 1763,
+ 1898, 1763, 1763, 1763, 1885, 821, 1763, 1763, 1763, 1763,
+ 1763, 821, 1885, 821, 1899, 1900, 828, 1901, 1902, 1903,
+ 1763, 1763, 1763, 1904, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1905, 1905, 1905, 1763, 1763, 1763, 1763, 1763,
+ 1905, 1763, 1763, 1906, 1907, 1763, 1908, 1909, 1910, 1910,
+ 1763, 1763, 1763, 1763, 1763, 1911, 1911, 1911, 1763, 1763,
+
+ 1763, 1763, 1763, 1912, 1912, 1913, 1763, 1763, 1763, 1914,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1915, 1915, 1915, 1763,
+ 1763, 1763, 1763, 1763, 1906, 1907, 1916, 1763, 1763, 1763,
+ 1917, 1908, 1907, 1907, 925, 1918, 1907, 1763, 1763, 1763,
+ 1919, 1763, 1763, 1763, 1920, 1763, 1763, 1763, 1907, 925,
+ 1763, 1763, 1763, 1763, 1763, 925, 1907, 925, 1921, 1922,
+ 932, 1923, 1924, 1925, 1763, 1763, 1763, 1926, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1927, 1927, 1927, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1928, 1928,
+ 1927, 1763, 1929, 1929, 1763, 1930, 1930, 1930, 1931, 1932,
+
+ 1933, 1763, 1929, 1929, 994, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1934, 1763, 1763, 1763, 1935, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1936, 1936, 1936, 1936,
+ 1936, 1936, 1936, 1936, 1936, 1763, 1763, 1936, 1936, 1936,
+ 1936, 1936, 1763, 1936, 1763, 1936, 1763, 1763, 1763, 1936,
+ 1936, 1936, 1763, 1936, 1055, 1936, 1763, 1763, 1763, 1936,
+ 1936, 1763, 1763, 1936, 1933, 1933, 1933, 1075, 1933, 1763,
+ 1933, 1933, 1937, 1763, 1938, 1939, 1939, 1939, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1940, 1763, 1763,
+
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1941,
+ 1763, 1763, 1763, 1763, 1763, 1942, 1763, 1763, 1763, 1938,
+ 1943, 1944, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1945,
+ 1945, 1763, 1763, 1763, 1763, 1763, 1120, 1763, 1120, 1943,
+ 1763, 1937, 1120, 1946, 1946, 1947, 1946, 1763, 1763, 1763,
+ 1948, 1943, 1946, 1946, 1949, 1950, 1763, 1763, 1763, 1951,
+ 1952, 1952, 1763, 1763, 1763, 1953, 1763, 1954, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1955, 1763, 1956, 1957, 1957, 1957, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1958, 1763, 1763, 1763, 1763,
+
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1959, 1763, 1763,
+ 1763, 1763, 1763, 1960, 1763, 1763, 1763, 1956, 1961, 1962,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1963, 1963, 1763,
+ 1763, 1763, 1763, 1763, 1218, 1763, 1218, 1961, 1763, 1955,
+ 1218, 1964, 1964, 1965, 1964, 1763, 1763, 1763, 1966, 1961,
+ 1964, 1964, 1967, 1968, 1763, 1763, 1763, 1969, 1970, 1970,
+ 1763, 1763, 1763, 1971, 1763, 1972, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1973, 1763,
+ 1763, 1974, 1975, 1976, 1976, 1763, 1763, 1763, 1763, 1977,
+ 1763, 1978, 1763, 1763, 1763, 1763, 1763, 1979, 1763, 1763,
+
+ 1763, 1763, 1980, 1763, 1763, 1981, 1763, 1982, 1982, 1982,
+ 1309, 1763, 1309, 1763, 1309, 1763, 1763, 1763, 1309, 1763,
+ 1309, 1314, 1763, 1763, 1763, 1763, 1763, 1309, 1309, 1309,
+ 1309, 1763, 1309, 1314, 1763, 1763, 1763, 1309, 1309, 1763,
+ 1763, 1309, 1763, 1309, 1314, 1763, 1763, 1763, 1309, 1309,
+ 1763, 1309, 1314, 1763, 1763, 1763, 1309, 1763, 1976, 1285,
+ 1983, 1984, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1983, 1984, 1984, 1377,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1984, 1377, 1377,
+ 1985, 1986, 1986, 1763, 1763, 1763, 1763, 1763, 1987, 1988,
+
+ 1988, 1763, 1763, 1763, 1984, 1989, 1990, 1990, 1763, 1763,
+ 1763, 1763, 1763, 1991, 1991, 1991, 1763, 1763, 1763, 1763,
+ 1763, 1992, 1992, 1993, 1763, 1763, 1763, 1994, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1995, 1996, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1995, 1996, 1996, 1453, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1996, 1453, 1453, 1997, 1998, 1998, 1763,
+ 1763, 1763, 1763, 1763, 1999, 2000, 2000, 1763, 1763, 1763,
+ 1996, 2001, 2002, 2002, 1763, 1763, 1763, 1763, 1763, 2003,
+ 2003, 2003, 1763, 1763, 1763, 1763, 1763, 2004, 2004, 2005,
+
+ 1763, 1763, 1763, 2006, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 2007, 1763, 2008, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 2009, 1763, 2010, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 2010, 1534, 1763, 1763, 1763, 2010, 2010, 2010, 1763, 1763,
+ 2010, 1763, 1763, 2010, 1763, 1763, 2010, 2010, 2010, 2010,
+ 1763, 2010, 1534, 1763, 1763, 1763, 2011, 1763, 1763, 1763,
+ 1763, 2012, 1763, 1763, 2012, 2013, 2013, 2013, 1763, 1763,
+ 1763, 1763, 1763, 1763, 2014, 2014, 2014, 1763, 1763, 1763,
+ 1763, 1763, 2015, 2015, 2015, 1763, 1763, 1763, 1763, 1763,
+
+ 1763, 1763, 1763, 1763, 2016, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 2017, 1763, 1763,
+ 2017, 2018, 2018, 2018, 1763, 1763, 1763, 1763, 1763, 1763,
+ 2019, 2019, 2019, 1763, 1763, 1763, 1763, 1763, 2020, 2020,
+ 2020, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 2005, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 2021, 1763, 2022, 1763, 2023, 1763, 2024, 2025, 1763, 1763,
+ 2010, 1534, 1763, 1763, 1763, 2010, 1763, 2010, 1534, 1763,
+ 1763, 1763, 2010, 1763, 2010, 1534, 1763, 1763, 1763, 2010,
+ 1763, 2010, 1534, 1763, 1763, 1763, 1763, 2010, 1534, 1763,
+
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 2026, 1763, 2027, 1763, 2010, 1534, 1763,
+ 1763, 1763, 1763, 1763, 1763, 2010, 1534, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 2028,
+ 2029, 1763, 0, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763
+ } ;
+
+static const flex_int16_t yy_nxt[13560] =
+ { 0,
+ 1763, 1763, 35, 36, 37, 35, 36, 37, 105, 106,
+ 105, 106, 177, 183, 382, 177, 183, 382, 178, 184,
+ 1763, 1763, 233, 179, 179, 185, 38, 1763, 185, 42,
+ 268, 268, 268, 268, 178, 184, 692, 186, 224, 186,
+ 187, 224, 188, 188, 188, 188, 222, 1763, 223, 223,
+ 223, 223, 235, 287, 692, 225, 225, 225, 225, 359,
+ 359, 359, 226, 235, 287, 420, 249, 420, 247, 247,
+ 247, 247, 39, 40, 41, 39, 40, 41, 43, 44,
+ 45, 46, 44, 43, 47, 48, 43, 43, 49, 50,
+ 43, 51, 43, 51, 52, 53, 54, 54, 54, 54,
+
+ 43, 55, 43, 43, 56, 57, 57, 57, 57, 57,
+ 57, 57, 57, 57, 57, 57, 57, 58, 59, 50,
+ 43, 60, 57, 57, 57, 57, 57, 57, 57, 57,
+ 57, 57, 57, 57, 57, 57, 57, 57, 57, 57,
+ 57, 57, 57, 57, 61, 43, 62, 43, 63, 63,
+ 64, 65, 66, 43, 67, 45, 46, 67, 68, 47,
+ 69, 68, 70, 58, 43, 68, 71, 72, 71, 73,
+ 53, 74, 74, 74, 74, 75, 55, 68, 68, 76,
+ 68, 68, 68, 68, 68, 68, 68, 68, 68, 68,
+ 68, 68, 58, 77, 43, 70, 60, 68, 68, 68,
+
+ 68, 68, 68, 68, 68, 68, 68, 68, 68, 68,
+ 68, 68, 68, 68, 68, 68, 68, 68, 68, 43,
+ 43, 78, 68, 63, 63, 79, 80, 81, 43, 82,
+ 45, 46, 82, 83, 47, 84, 83, 70, 58, 50,
+ 83, 85, 72, 85, 86, 83, 87, 87, 87, 87,
+ 88, 55, 83, 83, 89, 83, 83, 83, 83, 83,
+ 83, 83, 83, 83, 83, 83, 83, 58, 90, 50,
+ 70, 60, 83, 83, 83, 83, 83, 83, 83, 83,
+ 83, 83, 83, 83, 83, 83, 83, 83, 83, 83,
+ 83, 83, 83, 83, 43, 43, 62, 83, 63, 63,
+
+ 91, 92, 93, 95, 96, 97, 95, 172, 173, 174,
+ 98, 728, 98, 98, 98, 98, 729, 98, 98, 99,
+ 180, 706, 172, 173, 174, 422, 181, 98, 172, 173,
+ 174, 182, 1015, 172, 173, 174, 372, 372, 372, 372,
+ 1016, 98, 100, 98, 330, 385, 345, 330, 385, 345,
+ 705, 108, 109, 110, 108, 706, 111, 108, 109, 110,
+ 108, 1086, 111, 139, 140, 141, 139, 377, 111, 98,
+ 377, 98, 101, 101, 102, 103, 104, 95, 96, 97,
+ 95, 235, 287, 331, 98, 346, 98, 98, 98, 98,
+ 112, 98, 98, 99, 413, 297, 112, 295, 295, 295,
+
+ 295, 98, 142, 227, 1568, 228, 378, 229, 229, 229,
+ 229, 380, 381, 405, 406, 98, 100, 98, 784, 231,
+ 113, 113, 114, 115, 116, 792, 113, 113, 114, 115,
+ 116, 414, 113, 113, 114, 115, 116, 231, 387, 387,
+ 387, 387, 1763, 98, 233, 98, 101, 101, 102, 103,
+ 104, 117, 107, 118, 119, 107, 117, 117, 117, 117,
+ 117, 117, 117, 117, 117, 117, 117, 117, 117, 120,
+ 120, 120, 120, 117, 117, 117, 117, 117, 120, 120,
+ 120, 120, 120, 120, 120, 120, 120, 120, 120, 120,
+ 117, 117, 117, 117, 117, 120, 120, 120, 120, 120,
+
+ 120, 120, 120, 120, 120, 120, 120, 120, 121, 120,
+ 120, 120, 120, 120, 120, 122, 120, 117, 117, 117,
+ 117, 123, 123, 124, 125, 126, 108, 127, 128, 108,
+ 224, 224, 1098, 224, 224, 139, 140, 141, 139, 1569,
+ 111, 165, 166, 334, 660, 167, 165, 166, 349, 666,
+ 167, 129, 243, 800, 226, 243, 380, 381, 486, 661,
+ 368, 486, 661, 368, 244, 130, 244, 245, 131, 246,
+ 246, 246, 246, 291, 142, 369, 291, 380, 681, 168,
+ 348, 172, 173, 174, 168, 292, 667, 292, 293, 667,
+ 294, 294, 294, 294, 806, 113, 113, 114, 115, 116,
+
+ 108, 127, 128, 108, 113, 113, 114, 115, 116, 113,
+ 113, 114, 115, 116, 113, 113, 114, 115, 116, 388,
+ 389, 389, 389, 405, 406, 129, 224, 190, 330, 224,
+ 373, 330, 374, 191, 375, 375, 375, 375, 192, 130,
+ 248, 307, 131, 308, 308, 308, 308, 693, 406, 249,
+ 226, 172, 173, 174, 180, 250, 172, 173, 174, 251,
+ 407, 193, 813, 407, 194, 390, 195, 331, 721, 113,
+ 113, 114, 115, 116, 132, 252, 1110, 132, 196, 391,
+ 133, 722, 70, 58, 408, 197, 134, 72, 134, 135,
+ 43, 136, 136, 136, 136, 1570, 269, 391, 270, 137,
+
+ 271, 271, 271, 271, 822, 253, 254, 255, 470, 470,
+ 470, 470, 272, 138, 274, 70, 139, 140, 141, 139,
+ 309, 1116, 310, 249, 311, 311, 311, 311, 1571, 275,
+ 272, 281, 200, 251, 417, 417, 312, 282, 296, 282,
+ 1122, 129, 283, 283, 283, 283, 257, 297, 181, 276,
+ 172, 173, 174, 298, 312, 143, 1573, 299, 131, 314,
+ 182, 698, 172, 173, 174, 699, 699, 180, 297, 172,
+ 173, 174, 829, 300, 315, 560, 561, 562, 299, 277,
+ 278, 279, 423, 424, 425, 113, 113, 114, 115, 116,
+ 139, 140, 141, 139, 316, 837, 284, 285, 286, 675,
+
+ 190, 675, 1130, 301, 302, 303, 191, 1574, 321, 486,
+ 235, 192, 486, 698, 322, 129, 322, 1003, 1003, 323,
+ 323, 323, 323, 304, 317, 318, 319, 200, 841, 143,
+ 486, 235, 131, 486, 193, 1010, 1011, 194, 390, 195,
+ 392, 392, 392, 392, 1391, 403, 400, 172, 173, 174,
+ 1582, 370, 391, 449, 200, 986, 986, 400, 371, 113,
+ 113, 114, 115, 116, 145, 146, 147, 145, 661, 334,
+ 391, 661, 148, 324, 325, 326, 1583, 423, 424, 425,
+ 400, 149, 149, 149, 149, 400, 443, 1144, 444, 400,
+ 149, 149, 149, 149, 667, 349, 400, 667, 1584, 400,
+
+ 407, 400, 401, 407, 423, 424, 425, 149, 149, 149,
+ 149, 149, 149, 145, 146, 147, 145, 225, 225, 225,
+ 225, 148, 682, 177, 408, 682, 177, 986, 986, 178,
+ 149, 149, 149, 149, 179, 225, 225, 225, 225, 149,
+ 149, 149, 149, 1399, 183, 178, 200, 183, 1591, 222,
+ 184, 188, 188, 188, 188, 179, 149, 149, 149, 149,
+ 149, 149, 151, 152, 153, 151, 184, 154, 155, 200,
+ 1592, 156, 156, 156, 185, 156, 157, 185, 445, 158,
+ 159, 159, 159, 156, 160, 1406, 186, 345, 186, 187,
+ 345, 188, 188, 188, 188, 415, 423, 424, 425, 416,
+
+ 156, 416, 156, 156, 417, 417, 466, 1599, 1600, 409,
+ 161, 410, 200, 411, 411, 411, 411, 162, 1153, 423,
+ 424, 425, 163, 1601, 200, 412, 346, 156, 1414, 156,
+ 164, 151, 152, 153, 151, 1602, 154, 155, 200, 455,
+ 156, 156, 156, 412, 156, 157, 454, 1603, 158, 159,
+ 159, 159, 156, 160, 418, 707, 418, 708, 200, 419,
+ 419, 419, 423, 424, 425, 487, 487, 487, 453, 156,
+ 488, 156, 156, 653, 423, 424, 425, 227, 1160, 161,
+ 446, 478, 478, 478, 478, 654, 162, 447, 423, 424,
+ 425, 163, 655, 448, 682, 380, 156, 682, 156, 164,
+
+ 198, 1604, 382, 198, 199, 382, 1422, 199, 423, 424,
+ 425, 199, 199, 1609, 199, 200, 199, 199, 199, 199,
+ 199, 200, 385, 199, 199, 385, 199, 199, 199, 199,
+ 199, 199, 199, 199, 199, 199, 199, 199, 989, 199,
+ 989, 463, 1610, 201, 202, 203, 204, 205, 206, 207,
+ 199, 208, 199, 209, 210, 211, 212, 213, 214, 215,
+ 216, 217, 199, 199, 199, 423, 424, 425, 199, 1428,
+ 1611, 218, 219, 220, 235, 236, 237, 227, 1612, 471,
+ 1166, 472, 472, 472, 472, 485, 485, 485, 485, 1613,
+ 238, 238, 238, 412, 200, 855, 473, 864, 474, 873,
+
+ 475, 475, 475, 475, 1184, 1614, 200, 642, 643, 644,
+ 200, 412, 477, 662, 662, 662, 237, 237, 663, 888,
+ 237, 237, 491, 896, 246, 246, 246, 246, 237, 459,
+ 477, 237, 456, 237, 1196, 237, 239, 190, 450, 451,
+ 452, 200, 1615, 191, 423, 424, 425, 200, 192, 256,
+ 256, 256, 256, 257, 258, 904, 423, 424, 425, 910,
+ 423, 424, 425, 259, 260, 261, 262, 263, 264, 457,
+ 368, 193, 200, 368, 194, 917, 195, 377, 460, 1208,
+ 377, 461, 458, 200, 407, 369, 200, 407, 196, 1616,
+ 926, 423, 424, 425, 1214, 197, 248, 423, 424, 425,
+
+ 503, 503, 503, 503, 511, 265, 1617, 266, 266, 266,
+ 266, 250, 462, 464, 724, 251, 378, 725, 465, 512,
+ 467, 1220, 423, 424, 425, 268, 268, 268, 268, 1619,
+ 933, 252, 408, 423, 424, 425, 423, 424, 425, 941,
+ 227, 1228, 228, 1620, 229, 229, 229, 229, 526, 526,
+ 526, 526, 483, 1763, 483, 233, 231, 484, 484, 484,
+ 484, 253, 254, 255, 296, 587, 587, 587, 587, 513,
+ 514, 515, 945, 305, 231, 306, 306, 306, 306, 298,
+ 518, 486, 661, 299, 486, 661, 243, 661, 334, 243,
+ 661, 256, 256, 256, 256, 1467, 1628, 519, 244, 300,
+
+ 244, 245, 1629, 246, 246, 246, 246, 269, 359, 359,
+ 359, 540, 540, 540, 540, 575, 1242, 294, 294, 294,
+ 294, 608, 608, 608, 608, 672, 672, 672, 672, 301,
+ 302, 303, 333, 333, 334, 335, 336, 333, 333, 333,
+ 337, 333, 337, 337, 337, 337, 333, 337, 337, 337,
+ 338, 338, 338, 333, 333, 333, 333, 337, 333, 333,
+ 333, 339, 333, 333, 333, 333, 333, 333, 339, 333,
+ 339, 337, 336, 337, 333, 333, 336, 336, 333, 339,
+ 336, 336, 333, 333, 333, 333, 333, 333, 336, 333,
+ 333, 336, 339, 336, 333, 336, 340, 333, 333, 337,
+
+ 333, 337, 333, 333, 333, 333, 333, 349, 350, 351,
+ 1630, 351, 390, 492, 351, 493, 304, 494, 494, 494,
+ 494, 497, 1475, 352, 352, 352, 391, 595, 309, 495,
+ 249, 1637, 622, 622, 622, 622, 498, 1638, 667, 653,
+ 251, 667, 596, 682, 391, 351, 682, 495, 351, 351,
+ 351, 654, 710, 351, 351, 1482, 499, 1645, 655, 711,
+ 1763, 351, 1763, 474, 351, 712, 351, 1646, 351, 353,
+ 360, 360, 360, 360, 667, 349, 248, 667, 1251, 360,
+ 360, 360, 360, 1647, 1490, 249, 500, 501, 502, 1648,
+ 1649, 250, 597, 598, 599, 251, 360, 360, 360, 360,
+
+ 360, 360, 362, 1019, 363, 363, 1020, 1258, 364, 363,
+ 364, 252, 1650, 365, 365, 365, 365, 505, 668, 668,
+ 668, 363, 673, 669, 673, 1498, 249, 674, 674, 674,
+ 248, 1655, 275, 1656, 363, 1504, 251, 363, 1657, 249,
+ 1658, 253, 254, 255, 180, 250, 172, 173, 174, 251,
+ 1264, 1659, 506, 419, 419, 419, 291, 682, 380, 291,
+ 682, 363, 349, 350, 351, 252, 351, 959, 292, 351,
+ 292, 293, 968, 294, 294, 294, 294, 977, 352, 352,
+ 352, 200, 507, 508, 509, 1660, 367, 365, 365, 365,
+ 365, 1661, 521, 1662, 698, 253, 254, 255, 699, 699,
+
+ 351, 249, 1663, 351, 351, 351, 1664, 275, 351, 351,
+ 1665, 251, 680, 680, 680, 680, 351, 1666, 1667, 351,
+ 1668, 351, 1669, 351, 353, 232, 422, 522, 232, 705,
+ 232, 423, 424, 425, 232, 232, 232, 373, 232, 677,
+ 706, 678, 678, 678, 678, 422, 232, 550, 1763, 550,
+ 249, 705, 551, 551, 551, 551, 701, 523, 524, 525,
+ 702, 702, 702, 232, 496, 232, 232, 576, 706, 577,
+ 422, 578, 578, 578, 578, 685, 685, 685, 685, 705,
+ 373, 706, 496, 579, 679, 679, 679, 679, 1086, 1098,
+ 232, 1110, 232, 232, 426, 427, 428, 429, 430, 431,
+
+ 432, 579, 433, 1116, 434, 435, 436, 437, 438, 439,
+ 440, 441, 442, 479, 479, 479, 479, 479, 479, 479,
+ 479, 479, 479, 479, 479, 479, 479, 479, 479, 1122,
+ 479, 480, 480, 480, 480, 479, 479, 479, 479, 479,
+ 481, 481, 481, 482, 481, 481, 481, 481, 481, 481,
+ 481, 481, 479, 479, 479, 479, 479, 481, 481, 481,
+ 481, 482, 481, 481, 481, 481, 481, 481, 481, 481,
+ 481, 481, 481, 481, 481, 481, 481, 481, 481, 479,
+ 479, 479, 479, 479, 479, 479, 479, 479, 497, 714,
+ 715, 716, 1130, 200, 1576, 269, 1705, 270, 1706, 527,
+
+ 527, 527, 527, 498, 487, 487, 487, 251, 1391, 488,
+ 757, 528, 373, 757, 374, 553, 375, 375, 375, 375,
+ 758, 1707, 274, 499, 249, 732, 200, 274, 698, 528,
+ 554, 249, 699, 699, 251, 1144, 249, 275, 807, 808,
+ 809, 251, 275, 423, 424, 425, 251, 683, 1585, 1708,
+ 555, 733, 1709, 500, 501, 502, 530, 276, 387, 387,
+ 387, 387, 276, 531, 684, 532, 1399, 533, 533, 533,
+ 533, 534, 838, 839, 840, 535, 423, 424, 425, 536,
+ 556, 557, 558, 407, 1710, 1593, 407, 277, 278, 279,
+ 1711, 1712, 277, 278, 279, 1406, 1713, 536, 307, 1153,
+
+ 308, 308, 308, 308, 686, 1414, 686, 408, 1714, 687,
+ 687, 687, 687, 409, 838, 839, 840, 694, 694, 694,
+ 694, 537, 538, 539, 479, 479, 479, 479, 479, 541,
+ 479, 542, 541, 479, 479, 479, 541, 541, 479, 541,
+ 1160, 479, 543, 543, 543, 543, 544, 479, 541, 541,
+ 545, 541, 541, 541, 546, 541, 541, 541, 541, 541,
+ 541, 541, 541, 479, 541, 479, 479, 479, 541, 541,
+ 541, 541, 546, 541, 541, 541, 541, 541, 541, 541,
+ 541, 541, 541, 541, 541, 541, 541, 541, 541, 541,
+ 479, 479, 479, 541, 479, 479, 547, 548, 549, 566,
+
+ 695, 695, 695, 695, 248, 1605, 200, 581, 249, 1715,
+ 200, 1716, 696, 249, 250, 985, 297, 985, 251, 250,
+ 986, 986, 582, 251, 1422, 1717, 299, 1428, 296, 1763,
+ 696, 1763, 474, 823, 567, 1718, 1166, 297, 1184, 252,
+ 589, 734, 583, 298, 1196, 737, 483, 299, 483, 297,
+ 1208, 697, 697, 697, 697, 315, 423, 424, 425, 299,
+ 423, 424, 425, 300, 568, 569, 570, 566, 1214, 253,
+ 254, 255, 584, 585, 586, 590, 249, 1220, 571, 571,
+ 571, 571, 250, 824, 825, 826, 251, 1228, 1622, 296,
+ 865, 866, 867, 301, 302, 303, 1719, 1720, 297, 1467,
+
+ 603, 1721, 567, 1242, 298, 591, 592, 593, 299, 297,
+ 1631, 200, 560, 561, 562, 315, 911, 912, 913, 299,
+ 470, 470, 470, 470, 300, 1722, 390, 1723, 392, 392,
+ 392, 392, 568, 569, 570, 604, 632, 1763, 632, 297,
+ 391, 633, 633, 633, 633, 756, 390, 200, 392, 392,
+ 392, 392, 1475, 580, 301, 302, 303, 1724, 391, 1639,
+ 391, 423, 424, 425, 1725, 605, 606, 607, 581, 1726,
+ 1482, 580, 1727, 200, 1251, 309, 1490, 310, 391, 609,
+ 609, 609, 609, 582, 1728, 735, 736, 299, 200, 1258,
+ 1651, 610, 942, 943, 944, 635, 1729, 423, 424, 425,
+
+ 1730, 1498, 314, 583, 297, 738, 1731, 314, 1504, 610,
+ 636, 297, 1732, 200, 299, 739, 297, 315, 942, 943,
+ 944, 299, 315, 423, 424, 425, 299, 1264, 200, 1763,
+ 637, 1763, 474, 584, 585, 586, 612, 316, 423, 424,
+ 425, 200, 316, 613, 1733, 614, 200, 615, 615, 615,
+ 615, 616, 746, 1734, 1735, 617, 1736, 422, 740, 618,
+ 638, 639, 640, 423, 424, 425, 741, 317, 318, 319,
+ 705, 706, 317, 318, 319, 422, 705, 618, 423, 424,
+ 425, 473, 742, 706, 754, 768, 768, 768, 768, 422,
+ 705, 423, 424, 425, 706, 422, 423, 424, 425, 705,
+
+ 706, 619, 620, 621, 479, 479, 479, 479, 479, 623,
+ 479, 624, 623, 479, 479, 479, 623, 623, 479, 623,
+ 422, 623, 625, 625, 625, 625, 626, 479, 623, 623,
+ 627, 623, 623, 623, 628, 623, 623, 623, 623, 623,
+ 623, 623, 623, 479, 623, 479, 479, 479, 623, 623,
+ 623, 623, 628, 623, 623, 623, 623, 623, 623, 623,
+ 623, 623, 623, 623, 623, 623, 623, 623, 623, 623,
+ 479, 479, 479, 623, 479, 479, 629, 630, 631, 648,
+ 705, 200, 706, 1576, 296, 200, 1751, 1391, 297, 200,
+ 969, 970, 971, 297, 298, 642, 643, 644, 299, 298,
+
+ 409, 1585, 410, 299, 411, 411, 411, 411, 1752, 1399,
+ 743, 1593, 1753, 200, 649, 744, 412, 1406, 745, 300,
+ 1414, 200, 774, 774, 774, 774, 1605, 753, 1754, 200,
+ 1422, 423, 424, 425, 412, 423, 424, 425, 755, 423,
+ 424, 425, 200, 1428, 650, 651, 652, 648, 200, 301,
+ 302, 303, 200, 674, 674, 674, 297, 761, 656, 656,
+ 656, 656, 298, 423, 424, 425, 299, 757, 759, 1622,
+ 757, 423, 424, 425, 1755, 1467, 762, 758, 200, 423,
+ 424, 425, 649, 200, 1631, 763, 760, 1756, 200, 1475,
+ 1639, 701, 423, 424, 425, 993, 993, 993, 423, 424,
+
+ 425, 1757, 423, 424, 425, 697, 697, 697, 697, 999,
+ 999, 999, 650, 651, 652, 360, 360, 360, 360, 1482,
+ 1490, 764, 765, 1651, 360, 360, 360, 360, 423, 424,
+ 425, 1758, 1498, 423, 424, 425, 1504, 422, 423, 424,
+ 425, 360, 360, 360, 360, 360, 360, 232, 823, 701,
+ 232, 705, 232, 1004, 1004, 1004, 232, 232, 232, 227,
+ 232, 471, 706, 472, 472, 472, 472, 473, 232, 474,
+ 422, 475, 475, 475, 475, 412, 776, 705, 777, 777,
+ 777, 777, 706, 477, 769, 232, 769, 232, 232, 770,
+ 770, 770, 770, 412, 485, 485, 485, 485, 824, 825,
+
+ 826, 477, 227, 1576, 771, 1585, 772, 772, 772, 772,
+ 1759, 1593, 232, 1605, 232, 232, 703, 1622, 773, 1631,
+ 704, 704, 704, 704, 268, 268, 268, 268, 1759, 704,
+ 704, 704, 704, 483, 1639, 483, 773, 1651, 775, 775,
+ 775, 775, 503, 503, 503, 503, 704, 704, 704, 704,
+ 704, 704, 747, 747, 747, 747, 747, 927, 747, 748,
+ 705, 747, 747, 747, 422, 492, 747, 706, 747, 779,
+ 779, 779, 779, 757, 749, 747, 757, 705, 747, 422,
+ 492, 706, 493, 758, 494, 494, 494, 494, 1099, 1100,
+ 1101, 747, 489, 747, 748, 747, 495, 782, 489, 782,
+
+ 705, 422, 783, 783, 783, 783, 531, 928, 929, 930,
+ 828, 828, 828, 828, 495, 807, 808, 809, 747, 747,
+ 747, 706, 747, 747, 750, 751, 752, 479, 479, 479,
+ 479, 479, 479, 479, 479, 479, 479, 479, 479, 479,
+ 479, 479, 479, 705, 479, 767, 767, 767, 767, 479,
+ 479, 479, 479, 479, 481, 481, 481, 482, 481, 481,
+ 481, 481, 481, 481, 481, 481, 479, 479, 479, 479,
+ 479, 481, 481, 481, 481, 482, 481, 481, 481, 481,
+ 481, 481, 481, 481, 481, 481, 481, 481, 481, 481,
+ 481, 481, 481, 479, 479, 479, 479, 479, 479, 479,
+
+ 479, 479, 530, 308, 308, 308, 308, 422, 1531, 497,
+ 1530, 927, 801, 780, 780, 780, 780, 534, 249, 1529,
+ 497, 535, 1528, 785, 498, 781, 421, 802, 251, 249,
+ 421, 497, 249, 1527, 1526, 498, 421, 1525, 275, 251,
+ 249, 1524, 251, 781, 499, 793, 498, 801, 1523, 1522,
+ 251, 662, 662, 662, 249, 499, 663, 1521, 786, 664,
+ 554, 928, 929, 930, 251, 664, 499, 537, 538, 539,
+ 587, 587, 587, 587, 500, 501, 502, 803, 804, 805,
+ 794, 1111, 1112, 1113, 505, 500, 501, 502, 787, 788,
+ 789, 1033, 1035, 249, 1033, 1035, 500, 501, 502, 275,
+
+ 530, 1034, 1036, 251, 1520, 505, 1046, 1519, 814, 1046,
+ 795, 796, 797, 521, 249, 827, 1047, 249, 530, 506,
+ 275, 1518, 249, 554, 251, 1517, 521, 251, 275, 1516,
+ 670, 530, 251, 534, 647, 249, 670, 535, 823, 1512,
+ 506, 275, 977, 815, 641, 251, 827, 634, 522, 507,
+ 508, 509, 550, 1763, 550, 249, 1511, 551, 551, 551,
+ 551, 522, 1117, 1118, 1119, 842, 843, 844, 968, 496,
+ 507, 508, 509, 816, 817, 818, 691, 1510, 523, 524,
+ 525, 959, 691, 537, 538, 539, 1509, 496, 824, 825,
+ 826, 523, 524, 525, 530, 1508, 842, 843, 844, 1264,
+
+ 1266, 531, 1497, 532, 1496, 821, 821, 821, 821, 534,
+ 668, 668, 668, 535, 421, 669, 489, 536, 489, 845,
+ 421, 845, 489, 1258, 846, 846, 846, 846, 823, 1123,
+ 1124, 1125, 269, 1489, 849, 536, 850, 850, 850, 850,
+ 672, 672, 672, 672, 1488, 853, 1251, 853, 851, 1474,
+ 854, 854, 854, 854, 823, 905, 838, 839, 840, 537,
+ 538, 539, 497, 865, 866, 867, 851, 1473, 612, 269,
+ 906, 270, 1242, 527, 527, 527, 527, 498, 824, 825,
+ 826, 251, 1763, 931, 249, 528, 551, 551, 551, 551,
+ 905, 485, 485, 485, 485, 576, 823, 499, 496, 883,
+
+ 883, 883, 883, 528, 824, 825, 826, 886, 1072, 886,
+ 611, 1072, 887, 887, 887, 887, 496, 553, 1073, 701,
+ 907, 908, 909, 702, 702, 702, 249, 500, 501, 502,
+ 830, 1463, 554, 946, 947, 948, 251, 531, 945, 532,
+ 1462, 831, 831, 831, 831, 832, 824, 825, 826, 535,
+ 1461, 1228, 555, 833, 576, 1460, 577, 553, 578, 578,
+ 578, 578, 987, 941, 987, 822, 249, 988, 988, 988,
+ 579, 833, 554, 613, 1459, 676, 251, 932, 932, 932,
+ 932, 676, 556, 557, 558, 553, 933, 1458, 579, 676,
+ 1457, 832, 555, 676, 249, 834, 835, 836, 830, 676,
+
+ 554, 1220, 999, 612, 251, 531, 1452, 532, 999, 852,
+ 852, 852, 852, 832, 1197, 1198, 1199, 535, 931, 1451,
+ 555, 833, 556, 557, 558, 874, 687, 687, 687, 687,
+ 612, 1214, 1450, 822, 249, 911, 912, 913, 566, 833,
+ 498, 824, 825, 826, 251, 616, 926, 249, 1449, 617,
+ 556, 557, 558, 250, 1209, 1210, 1211, 251, 1448, 1208,
+ 875, 1000, 602, 834, 835, 836, 856, 1000, 946, 947,
+ 948, 1447, 990, 567, 566, 857, 990, 858, 858, 858,
+ 858, 859, 990, 249, 917, 860, 1215, 1216, 1217, 250,
+ 876, 877, 878, 251, 990, 619, 620, 621, 594, 581,
+
+ 990, 499, 581, 568, 569, 570, 1282, 1446, 297, 567,
+ 910, 297, 1282, 1033, 582, 1445, 1033, 582, 299, 904,
+ 373, 299, 677, 1034, 678, 678, 678, 678, 1221, 1222,
+ 1223, 861, 862, 863, 583, 1005, 1444, 583, 1005, 568,
+ 569, 570, 874, 373, 1005, 677, 1443, 995, 995, 995,
+ 995, 249, 927, 881, 881, 881, 881, 498, 942, 943,
+ 944, 251, 1196, 588, 584, 585, 586, 584, 585, 586,
+ 889, 685, 685, 685, 685, 1442, 1283, 875, 581, 297,
+ 927, 897, 1283, 391, 896, 315, 1514, 297, 1035, 299,
+ 297, 1035, 1514, 582, 580, 1441, 636, 299, 1036, 888,
+
+ 299, 391, 928, 929, 930, 890, 1440, 876, 877, 878,
+ 612, 1439, 664, 583, 664, 1184, 898, 1046, 664, 589,
+ 1046, 884, 884, 884, 884, 616, 565, 1047, 297, 617,
+ 928, 929, 930, 885, 315, 891, 892, 893, 299, 687,
+ 687, 687, 687, 584, 585, 586, 899, 900, 901, 1436,
+ 1072, 885, 589, 1072, 590, 918, 1077, 1077, 1077, 1077,
+ 1073, 297, 1515, 603, 297, 873, 559, 315, 1515, 552,
+ 636, 299, 297, 1761, 299, 619, 620, 621, 315, 1761,
+ 603, 1435, 299, 864, 591, 592, 593, 590, 1434, 297,
+ 919, 774, 774, 774, 774, 315, 855, 1433, 604, 299,
+
+ 776, 1432, 777, 777, 777, 777, 632, 1763, 632, 297,
+ 1762, 633, 633, 633, 633, 604, 1762, 591, 592, 593,
+ 920, 921, 922, 580, 783, 783, 783, 783, 605, 606,
+ 607, 949, 1326, 949, 1166, 1326, 950, 950, 950, 950,
+ 927, 580, 1327, 936, 1168, 605, 606, 607, 612, 831,
+ 831, 831, 831, 1421, 1167, 613, 1420, 614, 1160, 925,
+ 925, 925, 925, 616, 969, 970, 971, 617, 309, 1168,
+ 953, 618, 954, 954, 954, 954, 887, 887, 887, 887,
+ 483, 1763, 483, 1763, 955, 775, 775, 775, 775, 618,
+ 928, 929, 930, 928, 929, 930, 988, 988, 988, 957,
+
+ 1340, 957, 955, 1340, 958, 958, 958, 958, 927, 1413,
+ 1341, 801, 1412, 619, 620, 621, 581, 200, 1153, 1169,
+ 1170, 1171, 1265, 309, 1398, 310, 802, 609, 609, 609,
+ 609, 582, 988, 988, 988, 299, 1763, 1266, 297, 610,
+ 633, 633, 633, 633, 1763, 1033, 801, 1763, 1033, 1329,
+ 200, 583, 580, 1397, 1763, 1034, 1144, 610, 928, 929,
+ 930, 529, 1075, 1075, 1075, 1075, 200, 423, 424, 425,
+ 580, 635, 1387, 841, 1076, 1386, 803, 804, 805, 1310,
+ 297, 584, 585, 586, 934, 1385, 636, 1267, 1268, 1269,
+ 299, 613, 1076, 614, 1130, 935, 935, 935, 935, 936,
+
+ 423, 424, 425, 617, 1384, 200, 637, 937, 409, 837,
+ 1001, 635, 1002, 1002, 1002, 1002, 423, 424, 425, 926,
+ 297, 1099, 1100, 1101, 773, 937, 636, 1763, 1383, 474,
+ 299, 770, 770, 770, 770, 829, 638, 639, 640, 635,
+ 1382, 1381, 773, 1309, 1122, 1376, 637, 1375, 297, 938,
+ 939, 940, 934, 1116, 636, 423, 424, 425, 299, 613,
+ 1374, 614, 822, 956, 956, 956, 956, 936, 1111, 1112,
+ 1113, 617, 1373, 1372, 637, 937, 638, 639, 640, 978,
+ 1763, 1035, 1110, 1763, 1035, 520, 1326, 926, 297, 1326,
+ 1763, 1036, 648, 937, 582, 801, 1327, 670, 299, 670,
+
+ 1371, 297, 200, 670, 638, 639, 640, 298, 813, 510,
+ 802, 299, 1370, 806, 979, 1369, 800, 938, 939, 940,
+ 960, 846, 846, 846, 846, 823, 1368, 649, 648, 961,
+ 801, 962, 962, 962, 962, 963, 701, 297, 1367, 964,
+ 993, 993, 993, 298, 980, 981, 982, 299, 935, 935,
+ 935, 935, 423, 424, 425, 583, 1098, 650, 651, 652,
+ 803, 804, 805, 649, 473, 504, 474, 1366, 475, 475,
+ 475, 475, 1117, 1118, 1119, 824, 825, 826, 1763, 792,
+ 477, 1763, 1123, 1124, 1125, 965, 966, 967, 1763, 1284,
+ 1284, 1284, 1284, 650, 651, 652, 978, 496, 477, 200,
+
+ 1365, 1285, 784, 1763, 1364, 297, 1763, 991, 991, 991,
+ 991, 582, 1363, 1763, 1086, 299, 706, 705, 1763, 1285,
+ 422, 1763, 706, 1037, 200, 1429, 1430, 1431, 1763, 705,
+ 422, 979, 1307, 1306, 1763, 1305, 373, 1763, 677, 200,
+ 995, 995, 995, 995, 1763, 1197, 1198, 1199, 1039, 423,
+ 424, 425, 1080, 1304, 1080, 200, 1303, 1081, 1081, 1081,
+ 1081, 980, 981, 982, 703, 1038, 1302, 1301, 994, 994,
+ 994, 994, 1300, 1299, 423, 424, 425, 994, 994, 994,
+ 994, 1298, 1549, 1763, 1297, 1549, 1763, 1041, 1296, 423,
+ 424, 425, 1550, 1763, 994, 994, 994, 994, 994, 994,
+
+ 704, 704, 704, 704, 200, 423, 424, 425, 1295, 704,
+ 704, 704, 704, 1763, 701, 200, 1763, 1294, 702, 702,
+ 702, 1293, 1763, 1763, 200, 1763, 704, 704, 704, 704,
+ 704, 704, 1763, 1292, 200, 1763, 1291, 1763, 1763, 1040,
+ 1763, 1763, 1290, 200, 1763, 1763, 1308, 1763, 1289, 1552,
+ 1046, 1763, 1552, 1046, 423, 424, 425, 1288, 200, 1553,
+ 1047, 1287, 200, 1330, 1042, 423, 424, 425, 1131, 1763,
+ 1043, 200, 1763, 1286, 423, 424, 425, 1763, 422, 1763,
+ 1763, 1279, 1546, 823, 423, 424, 425, 1763, 1044, 320,
+ 200, 1278, 647, 423, 424, 425, 1763, 1045, 200, 1763,
+
+ 1209, 1210, 1211, 1131, 1277, 1276, 1763, 977, 423, 424,
+ 425, 313, 423, 424, 425, 1763, 1275, 200, 1763, 641,
+ 1048, 423, 424, 425, 1763, 1763, 1763, 1274, 1049, 1082,
+ 1082, 1082, 1082, 1132, 1133, 1134, 200, 1215, 1216, 1217,
+ 423, 424, 425, 1221, 1222, 1223, 1050, 634, 423, 424,
+ 425, 1763, 1273, 1272, 1763, 1763, 968, 1271, 1763, 1270,
+ 959, 1763, 1236, 1763, 611, 1763, 1763, 423, 424, 425,
+ 1234, 1233, 200, 1763, 945, 1763, 200, 1227, 1763, 200,
+ 1081, 1081, 1081, 1081, 200, 1763, 423, 424, 425, 426,
+ 427, 428, 429, 430, 431, 432, 200, 433, 1226, 434,
+
+ 435, 436, 437, 438, 439, 440, 441, 442, 941, 1763,
+ 1060, 1051, 1061, 1137, 1137, 1137, 1137, 1311, 200, 1052,
+ 1225, 1224, 423, 424, 425, 829, 423, 424, 425, 423,
+ 424, 425, 933, 1213, 423, 424, 425, 474, 1212, 770,
+ 770, 770, 770, 829, 926, 1207, 423, 424, 425, 1053,
+ 1053, 1053, 1053, 1053, 602, 1053, 1054, 1206, 1053, 1053,
+ 1053, 1328, 1205, 1053, 1763, 1053, 917, 1763, 423, 424,
+ 425, 1055, 1053, 1763, 1763, 1053, 295, 1143, 1143, 1143,
+ 1143, 1505, 1506, 1507, 1763, 200, 1204, 1763, 1053, 829,
+ 1053, 1054, 1053, 473, 1763, 474, 594, 475, 475, 475,
+
+ 475, 1203, 1202, 1056, 910, 200, 1201, 829, 474, 477,
+ 1360, 1360, 1360, 1360, 1062, 1053, 1053, 1053, 1200, 1053,
+ 1053, 1057, 1058, 1059, 1141, 904, 1141, 477, 905, 1142,
+ 1142, 1142, 1142, 1070, 1195, 423, 424, 425, 1063, 1063,
+ 1063, 1063, 1063, 906, 1063, 1064, 588, 1063, 1063, 1063,
+ 200, 1194, 1063, 1193, 1063, 423, 424, 425, 896, 1192,
+ 1065, 1063, 1072, 905, 1063, 1072, 1763, 580, 1191, 1763,
+ 1190, 888, 1073, 200, 280, 1763, 1763, 1063, 1763, 1063,
+ 1064, 1063, 1180, 200, 1319, 1763, 1066, 200, 854, 854,
+ 854, 854, 823, 907, 908, 909, 200, 565, 1179, 1331,
+
+ 423, 424, 425, 1178, 1063, 1063, 1063, 873, 1063, 1063,
+ 1067, 1068, 1069, 1071, 1239, 273, 1239, 1177, 559, 1240,
+ 1240, 1240, 1240, 423, 424, 425, 1074, 1082, 1082, 1082,
+ 1082, 1176, 552, 423, 424, 425, 1175, 423, 424, 425,
+ 1174, 864, 824, 825, 826, 1173, 423, 424, 425, 479,
+ 479, 479, 479, 479, 479, 479, 479, 479, 479, 479,
+ 479, 479, 479, 479, 479, 1172, 479, 1078, 1078, 1078,
+ 1078, 479, 479, 479, 479, 479, 481, 481, 481, 1079,
+ 481, 481, 481, 481, 481, 481, 481, 481, 479, 479,
+ 479, 479, 479, 481, 481, 481, 481, 1079, 481, 481,
+
+ 481, 481, 481, 481, 481, 481, 481, 481, 481, 481,
+ 481, 481, 481, 481, 481, 479, 479, 479, 479, 479,
+ 479, 479, 479, 479, 227, 855, 771, 905, 772, 772,
+ 772, 772, 492, 200, 1083, 1138, 1084, 1084, 1084, 1084,
+ 773, 529, 906, 1136, 853, 200, 853, 1135, 851, 854,
+ 854, 854, 854, 823, 1087, 1606, 1607, 1608, 773, 1338,
+ 841, 1763, 905, 249, 1763, 1763, 851, 830, 1763, 554,
+ 1129, 1763, 200, 251, 531, 1763, 532, 1128, 831, 831,
+ 831, 831, 832, 423, 424, 425, 535, 837, 1127, 1088,
+ 833, 1126, 907, 908, 909, 423, 424, 425, 530, 1429,
+
+ 1430, 1431, 822, 824, 825, 826, 1547, 532, 833, 1085,
+ 1085, 1085, 1085, 534, 829, 1115, 785, 535, 200, 1089,
+ 1090, 1091, 423, 424, 425, 249, 1114, 785, 1652, 1653,
+ 1654, 275, 834, 835, 836, 251, 249, 822, 793, 1109,
+ 1339, 793, 275, 520, 1108, 1555, 251, 249, 1555, 1107,
+ 249, 786, 793, 554, 813, 1556, 554, 251, 247, 1106,
+ 251, 249, 786, 537, 538, 539, 510, 554, 423, 424,
+ 425, 251, 1105, 794, 200, 1763, 794, 1104, 1763, 806,
+ 814, 787, 788, 789, 1103, 1763, 1102, 794, 1763, 249,
+ 800, 1763, 787, 788, 789, 554, 1229, 1097, 1763, 251,
+
+ 504, 814, 1096, 795, 796, 797, 795, 796, 797, 1095,
+ 249, 927, 792, 814, 1342, 815, 554, 795, 796, 797,
+ 251, 1094, 249, 496, 423, 424, 425, 1093, 554, 1092,
+ 1763, 1229, 251, 1763, 1557, 1548, 815, 269, 784, 849,
+ 1763, 850, 850, 850, 850, 816, 817, 818, 815, 845,
+ 233, 845, 199, 851, 846, 846, 846, 846, 823, 706,
+ 705, 1230, 1231, 1232, 422, 1032, 816, 817, 818, 1763,
+ 1031, 851, 1030, 1235, 1235, 1235, 1235, 1029, 816, 817,
+ 818, 830, 1028, 1551, 1027, 933, 1026, 1025, 531, 1024,
+ 532, 1023, 852, 852, 852, 852, 832, 1505, 1506, 1507,
+
+ 535, 1022, 1021, 933, 833, 1606, 1607, 1608, 824, 825,
+ 826, 1142, 1142, 1142, 1142, 1145, 822, 1018, 497, 1652,
+ 1653, 1654, 833, 1017, 249, 1340, 1014, 249, 1340, 1763,
+ 1146, 1013, 1763, 1151, 251, 1341, 1763, 251, 1763, 1763,
+ 1152, 1152, 1152, 1152, 200, 1012, 834, 835, 836, 530,
+ 1147, 1009, 529, 499, 1008, 1007, 531, 200, 532, 1006,
+ 1120, 1120, 1120, 1120, 534, 422, 1349, 703, 535, 1763,
+ 529, 576, 1121, 1181, 998, 1182, 1182, 1182, 1182, 997,
+ 1148, 1149, 1150, 500, 501, 502, 996, 955, 354, 1350,
+ 1121, 669, 341, 663, 423, 424, 425, 1240, 1240, 1240,
+
+ 1240, 1763, 327, 1538, 1763, 955, 1538, 423, 424, 425,
+ 992, 1763, 320, 1539, 537, 538, 539, 479, 479, 479,
+ 479, 479, 541, 479, 542, 541, 479, 479, 479, 541,
+ 541, 479, 541, 984, 479, 1139, 1139, 1139, 1139, 544,
+ 479, 541, 541, 545, 541, 541, 541, 1140, 541, 541,
+ 541, 541, 541, 541, 541, 541, 479, 541, 479, 479,
+ 479, 541, 541, 541, 541, 1140, 541, 541, 541, 541,
+ 541, 541, 541, 541, 541, 541, 541, 541, 541, 541,
+ 541, 541, 541, 479, 479, 479, 541, 479, 479, 547,
+ 548, 549, 1154, 1567, 1567, 1567, 1567, 983, 647, 1161,
+
+ 976, 857, 1131, 1155, 1155, 1155, 1155, 1156, 249, 313,
+ 874, 860, 975, 874, 275, 974, 641, 823, 251, 249,
+ 973, 874, 249, 1763, 972, 498, 1763, 1147, 498, 251,
+ 249, 200, 251, 1763, 1162, 634, 498, 1131, 952, 1326,
+ 251, 951, 1326, 611, 931, 875, 952, 951, 875, 1327,
+ 611, 950, 950, 950, 950, 927, 875, 1157, 1158, 1159,
+ 200, 931, 924, 1357, 1163, 1164, 1165, 1132, 1133, 1134,
+ 1560, 923, 602, 916, 295, 876, 877, 878, 876, 877,
+ 878, 423, 424, 425, 915, 914, 876, 877, 878, 874,
+ 958, 958, 958, 958, 927, 594, 596, 903, 249, 902,
+
+ 881, 881, 881, 881, 498, 928, 929, 930, 251, 588,
+ 423, 424, 425, 895, 957, 1549, 957, 612, 1549, 958,
+ 958, 958, 958, 927, 875, 1550, 614, 894, 1183, 1183,
+ 1183, 1183, 616, 309, 580, 953, 617, 954, 954, 954,
+ 954, 288, 882, 1185, 928, 929, 930, 280, 880, 955,
+ 1552, 879, 297, 1552, 876, 877, 878, 934, 636, 565,
+ 1553, 872, 299, 273, 613, 871, 614, 955, 935, 935,
+ 935, 935, 936, 928, 929, 930, 617, 870, 1186, 559,
+ 937, 889, 619, 620, 621, 869, 889, 868, 552, 848,
+ 297, 847, 926, 529, 1340, 297, 315, 1340, 937, 827,
+
+ 299, 315, 848, 1555, 1341, 299, 1555, 847, 1187, 1188,
+ 1189, 529, 827, 1556, 820, 200, 890, 819, 520, 897,
+ 812, 890, 938, 939, 940, 1358, 897, 1358, 297, 247,
+ 1359, 1359, 1359, 1359, 636, 297, 811, 810, 299, 510,
+ 897, 636, 512, 799, 798, 299, 891, 892, 893, 297,
+ 504, 891, 892, 893, 898, 636, 791, 790, 496, 299,
+ 1763, 898, 918, 1763, 240, 423, 424, 425, 488, 766,
+ 1763, 297, 199, 1763, 200, 898, 1763, 636, 731, 918,
+ 730, 299, 727, 1763, 899, 900, 901, 726, 297, 723,
+ 720, 899, 900, 901, 636, 1131, 719, 919, 299, 718,
+
+ 918, 1538, 717, 713, 1538, 899, 900, 901, 709, 297,
+ 823, 1539, 706, 705, 919, 636, 1763, 422, 1554, 299,
+ 1241, 1241, 1241, 1241, 423, 424, 425, 920, 921, 922,
+ 1131, 690, 933, 1558, 949, 919, 949, 689, 688, 950,
+ 950, 950, 950, 927, 920, 921, 922, 653, 671, 354,
+ 933, 1080, 665, 1080, 1243, 341, 1360, 1360, 1360, 1360,
+ 1132, 1133, 1134, 297, 659, 920, 921, 922, 934, 1244,
+ 327, 658, 657, 299, 320, 613, 646, 614, 645, 956,
+ 956, 956, 956, 936, 313, 601, 600, 617, 295, 1245,
+ 574, 937, 288, 928, 929, 930, 581, 573, 1405, 1405,
+
+ 1405, 1405, 823, 926, 572, 297, 280, 1763, 257, 937,
+ 1763, 1249, 564, 563, 273, 299, 517, 1763, 516, 1246,
+ 1247, 1248, 1763, 200, 1763, 1423, 1250, 1250, 1250, 1250,
+ 247, 583, 490, 938, 939, 940, 612, 240, 611, 469,
+ 1424, 468, 199, 613, 200, 614, 176, 1218, 1218, 1218,
+ 1218, 616, 824, 825, 826, 617, 611, 398, 397, 1219,
+ 1423, 584, 585, 586, 409, 396, 1001, 1559, 1002, 1002,
+ 1002, 1002, 395, 423, 424, 425, 394, 1219, 386, 383,
+ 773, 1080, 1763, 1080, 1763, 379, 1360, 1360, 1360, 1360,
+ 1425, 1426, 1427, 376, 423, 424, 425, 361, 773, 356,
+
+ 355, 619, 620, 621, 479, 479, 479, 479, 479, 623,
+ 479, 624, 623, 479, 479, 479, 623, 623, 479, 623,
+ 354, 623, 1237, 1237, 1237, 1237, 626, 479, 623, 623,
+ 627, 623, 623, 623, 1238, 623, 623, 623, 623, 623,
+ 623, 623, 623, 479, 623, 479, 479, 479, 623, 623,
+ 623, 623, 1238, 623, 623, 623, 623, 623, 623, 623,
+ 623, 623, 623, 623, 623, 623, 623, 623, 623, 623,
+ 479, 479, 479, 623, 479, 479, 629, 630, 631, 1252,
+ 474, 357, 1359, 1359, 1359, 1359, 1259, 356, 961, 355,
+ 1253, 1253, 1253, 1253, 1254, 297, 354, 978, 964, 347,
+
+ 978, 315, 344, 1229, 343, 299, 297, 342, 978, 297,
+ 1549, 341, 582, 1549, 1245, 582, 299, 297, 927, 299,
+ 1550, 1260, 332, 582, 473, 329, 474, 299, 1075, 1075,
+ 1075, 1075, 979, 328, 327, 979, 304, 290, 1229, 1552,
+ 1076, 289, 1552, 979, 1255, 1256, 1257, 1555, 288, 1553,
+ 1555, 1261, 1262, 1263, 200, 267, 242, 1556, 1076, 241,
+ 240, 221, 980, 981, 982, 980, 981, 982, 1230, 1231,
+ 1232, 189, 176, 980, 981, 982, 978, 1481, 1481, 1481,
+ 1481, 927, 175, 1763, 170, 297, 170, 991, 991, 991,
+ 991, 582, 492, 1676, 1083, 299, 1084, 1084, 1084, 1084,
+
+ 1087, 1763, 200, 1087, 423, 424, 425, 1703, 851, 249,
+ 1703, 979, 249, 1703, 1763, 554, 1703, 1704, 554, 251,
+ 1763, 1087, 251, 1704, 1743, 1763, 851, 1743, 1763, 1763,
+ 249, 928, 929, 930, 1744, 1088, 554, 1763, 1088, 1763,
+ 251, 980, 981, 982, 703, 1683, 1763, 1763, 994, 994,
+ 994, 994, 423, 424, 425, 1763, 1088, 994, 994, 994,
+ 994, 1763, 1763, 1763, 200, 1089, 1090, 1091, 1089, 1090,
+ 1091, 1763, 1763, 1763, 994, 994, 994, 994, 994, 994,
+ 1280, 1280, 200, 1280, 1763, 1280, 1089, 1090, 1091, 1280,
+ 1280, 1280, 1763, 1280, 1763, 1763, 1137, 1137, 1137, 1137,
+
+ 1763, 1280, 1763, 1690, 1379, 1763, 1379, 1763, 829, 1380,
+ 1380, 1380, 1380, 823, 423, 424, 425, 1763, 1280, 1763,
+ 1280, 1280, 1388, 1763, 1388, 1763, 829, 1389, 1389, 1389,
+ 1389, 823, 423, 424, 425, 1763, 1763, 1763, 1229, 1143,
+ 1143, 1143, 1143, 1763, 1763, 1280, 1763, 1280, 1280, 1281,
+ 1281, 829, 1281, 927, 1281, 1763, 1763, 1145, 1281, 1281,
+ 1281, 200, 1281, 824, 825, 826, 249, 1763, 1763, 829,
+ 1281, 1499, 1146, 1229, 1743, 1763, 251, 1743, 1763, 1763,
+ 1763, 824, 825, 826, 1744, 1763, 1500, 1281, 1763, 1281,
+ 1281, 576, 1147, 1181, 1763, 1182, 1182, 1182, 1182, 1763,
+
+ 1763, 1763, 1763, 1230, 1231, 1232, 1499, 955, 1763, 1763,
+ 1763, 423, 424, 425, 1281, 1763, 1281, 1281, 704, 704,
+ 704, 704, 1148, 1149, 1150, 955, 1763, 704, 704, 704,
+ 704, 1380, 1380, 1380, 1380, 823, 1501, 1502, 1503, 1763,
+ 1763, 1763, 1763, 1763, 704, 704, 704, 704, 704, 704,
+ 1312, 1312, 1312, 1312, 1312, 1763, 1312, 1313, 1763, 1312,
+ 1312, 1312, 1763, 1763, 1312, 474, 1312, 1359, 1359, 1359,
+ 1359, 1763, 1314, 1312, 1763, 1763, 1312, 1763, 1235, 1235,
+ 1235, 1235, 1763, 1763, 1763, 824, 825, 826, 530, 1312,
+ 933, 1312, 1313, 1312, 200, 1145, 1763, 532, 1315, 1390,
+
+ 1390, 1390, 1390, 534, 249, 1763, 200, 535, 933, 1763,
+ 1146, 1763, 1763, 1763, 251, 1763, 1312, 1312, 1312, 1763,
+ 1312, 1312, 1316, 1317, 1318, 1320, 1320, 1320, 1320, 1320,
+ 1147, 1320, 1321, 1763, 1320, 1320, 1320, 1763, 1763, 1320,
+ 1763, 1320, 1763, 1763, 423, 424, 425, 1322, 1320, 1763,
+ 1763, 1320, 1763, 537, 538, 539, 423, 424, 425, 1763,
+ 1148, 1149, 1150, 1763, 1320, 1763, 1320, 1321, 1320, 1455,
+ 1392, 1455, 1763, 1763, 1456, 1456, 1456, 1456, 927, 249,
+ 1763, 200, 1763, 1763, 1763, 275, 1763, 1763, 1763, 251,
+ 1763, 1320, 1320, 1320, 200, 1320, 1320, 1323, 1324, 1325,
+
+ 1332, 1332, 1332, 1332, 1332, 1393, 1332, 1333, 1763, 1332,
+ 1332, 1332, 200, 1763, 1332, 1763, 1332, 1763, 1763, 1763,
+ 1763, 1763, 1334, 1332, 1763, 1763, 1332, 1763, 928, 929,
+ 930, 423, 424, 425, 1763, 1394, 1395, 1396, 1763, 1332,
+ 1763, 1332, 1333, 1332, 423, 424, 425, 1763, 1763, 1763,
+ 1763, 1763, 1464, 1763, 1464, 1763, 1763, 1465, 1465, 1465,
+ 1465, 927, 423, 424, 425, 1763, 1332, 1332, 1332, 1763,
+ 1332, 1332, 1335, 1336, 1337, 426, 427, 428, 429, 430,
+ 431, 432, 1763, 433, 1423, 434, 435, 436, 437, 438,
+ 439, 440, 441, 442, 1343, 1343, 1343, 1343, 1343, 1424,
+
+ 1343, 1344, 1763, 1343, 1343, 1343, 1763, 1763, 1343, 1763,
+ 1343, 928, 929, 930, 1763, 1763, 1345, 1343, 1763, 1423,
+ 1343, 1763, 1763, 1145, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 249, 1343, 1763, 1343, 1344, 1343, 1146, 1763,
+ 1763, 1763, 251, 1763, 1241, 1241, 1241, 1241, 1763, 1425,
+ 1426, 1427, 1763, 1763, 1763, 1763, 933, 1763, 1147, 1763,
+ 1343, 1343, 1343, 1763, 1343, 1343, 1346, 1347, 1348, 1351,
+ 1351, 1351, 1351, 1351, 933, 1351, 1352, 1763, 1351, 1351,
+ 1351, 1763, 1763, 1351, 1400, 1351, 1763, 1145, 1148, 1149,
+ 1150, 1353, 1351, 249, 1763, 1351, 249, 1763, 1763, 275,
+
+ 1763, 1763, 1146, 251, 1763, 1763, 251, 1763, 1351, 1763,
+ 1351, 1352, 1351, 1760, 1760, 1760, 1763, 1763, 1763, 1401,
+ 1763, 1763, 1147, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1423, 1760, 1760, 1760, 1760, 1351, 1351, 1351, 1763, 1351,
+ 1351, 1354, 1355, 1356, 530, 1424, 1763, 1763, 1763, 1402,
+ 1403, 1404, 1148, 1149, 1150, 1361, 1361, 1361, 1361, 534,
+ 1763, 1763, 1763, 535, 1763, 1423, 1763, 1362, 1145, 1763,
+ 1763, 1407, 1763, 1763, 1763, 1763, 1763, 249, 1763, 1415,
+ 249, 1763, 1763, 1156, 1763, 1362, 275, 251, 249, 1763,
+ 251, 1763, 1763, 1763, 554, 1425, 1426, 1427, 251, 1763,
+
+ 1763, 1763, 1763, 1147, 1763, 1763, 1408, 1763, 1763, 537,
+ 538, 539, 830, 1763, 1416, 1763, 1763, 1499, 1763, 1763,
+ 1763, 532, 1763, 1143, 1143, 1143, 1143, 832, 1763, 1763,
+ 1763, 535, 1500, 1148, 1149, 1150, 1409, 1410, 1411, 1161,
+ 1703, 1763, 1763, 1703, 1417, 1418, 1419, 822, 249, 1763,
+ 1704, 1161, 1499, 1763, 275, 1763, 1763, 1763, 251, 1763,
+ 249, 200, 1763, 1763, 1763, 1763, 275, 1763, 1763, 1763,
+ 251, 1763, 1763, 1763, 1162, 1763, 1763, 834, 835, 836,
+ 830, 1763, 1501, 1502, 1503, 1763, 1162, 531, 1763, 532,
+ 1763, 1377, 1377, 1377, 1377, 832, 1763, 1763, 1763, 535,
+
+ 1763, 1763, 1763, 1378, 1163, 1164, 1165, 1763, 1763, 1763,
+ 1763, 423, 424, 425, 1185, 822, 1163, 1164, 1165, 1185,
+ 1763, 1378, 1763, 297, 1763, 1763, 1763, 1763, 297, 636,
+ 1763, 1763, 1763, 299, 636, 473, 1763, 474, 299, 1075,
+ 1075, 1075, 1075, 1763, 1763, 834, 835, 836, 1154, 1186,
+ 1763, 1076, 1763, 1763, 1186, 1185, 1763, 857, 1763, 1155,
+ 1155, 1155, 1155, 1156, 297, 1763, 1763, 860, 1763, 1076,
+ 636, 1763, 1763, 1763, 299, 1572, 1572, 1572, 1572, 1187,
+ 1188, 1189, 612, 1147, 1187, 1188, 1189, 829, 1763, 1243,
+ 1186, 614, 1763, 1466, 1466, 1466, 1466, 616, 297, 1763,
+
+ 1763, 617, 1763, 1763, 1244, 829, 1763, 1763, 299, 1763,
+ 1763, 1763, 1763, 1157, 1158, 1159, 612, 1763, 1763, 1763,
+ 1187, 1188, 1189, 1243, 1245, 1763, 1763, 1437, 1437, 1437,
+ 1437, 616, 297, 1763, 1763, 617, 1763, 1763, 1244, 1438,
+ 1763, 1763, 299, 1763, 1468, 1763, 1763, 619, 620, 621,
+ 1763, 1243, 1763, 297, 1246, 1247, 1248, 1438, 1245, 315,
+ 297, 1763, 1763, 299, 1763, 1763, 1244, 1763, 1763, 1388,
+ 299, 1388, 1763, 1763, 1389, 1389, 1389, 1389, 823, 1469,
+ 1763, 619, 620, 621, 934, 1763, 1245, 1763, 1246, 1247,
+ 1248, 1763, 1763, 614, 1763, 1241, 1241, 1241, 1241, 936,
+
+ 1763, 1763, 1763, 617, 1763, 1763, 1763, 1763, 1763, 1470,
+ 1471, 1472, 1476, 1763, 1763, 1763, 1246, 1247, 1248, 926,
+ 1763, 297, 1763, 1243, 1763, 1763, 1763, 315, 824, 825,
+ 826, 299, 297, 1763, 1763, 1763, 1763, 1763, 1244, 1763,
+ 1763, 1763, 299, 1763, 1763, 1763, 1763, 1477, 1763, 938,
+ 939, 940, 934, 1389, 1389, 1389, 1389, 823, 1245, 613,
+ 1763, 614, 1763, 1453, 1453, 1453, 1453, 936, 1763, 1763,
+ 1763, 617, 1763, 1763, 1763, 1454, 1243, 1478, 1479, 1480,
+ 1763, 1763, 1763, 1763, 1763, 297, 1763, 926, 1246, 1247,
+ 1248, 1254, 1763, 1454, 1763, 299, 1763, 1763, 1763, 1763,
+
+ 1763, 1483, 1575, 1575, 1575, 1575, 1763, 824, 825, 826,
+ 297, 1245, 1763, 1763, 829, 1491, 315, 938, 939, 940,
+ 299, 1763, 1763, 1763, 297, 1763, 1763, 1763, 1763, 1763,
+ 636, 1763, 829, 1763, 299, 1763, 1484, 1763, 1763, 1763,
+ 1763, 1246, 1247, 1248, 1252, 1405, 1405, 1405, 1405, 823,
+ 1492, 1763, 1763, 961, 1763, 1253, 1253, 1253, 1253, 1254,
+ 1763, 1763, 1763, 964, 1763, 1763, 1485, 1486, 1487, 1259,
+ 1456, 1456, 1456, 1456, 927, 1763, 1763, 1259, 297, 1245,
+ 1493, 1494, 1495, 1763, 315, 1763, 297, 1763, 299, 1763,
+ 1763, 1763, 315, 1763, 1763, 1763, 299, 1763, 1763, 824,
+
+ 825, 826, 1763, 1763, 1260, 1763, 1763, 1763, 1763, 1255,
+ 1256, 1257, 1260, 1379, 1763, 1379, 1763, 1763, 1380, 1380,
+ 1380, 1380, 823, 1763, 928, 929, 930, 1575, 1575, 1575,
+ 1575, 1763, 1577, 1763, 1261, 1262, 1263, 1763, 1763, 829,
+ 1763, 249, 1261, 1262, 1263, 1513, 1513, 554, 1513, 1763,
+ 1513, 251, 1763, 1763, 1513, 1513, 1513, 829, 1513, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1513, 1578, 1763, 1763,
+ 1763, 1763, 824, 825, 826, 1763, 1763, 1465, 1465, 1465,
+ 1465, 927, 1763, 1513, 1763, 1513, 1513, 1464, 1763, 1464,
+ 1763, 1763, 1465, 1465, 1465, 1465, 927, 1579, 1580, 1581,
+
+ 1455, 1743, 1455, 1763, 1743, 1456, 1456, 1456, 1456, 927,
+ 1513, 1744, 1513, 1513, 1532, 1532, 1532, 1532, 1532, 1763,
+ 1532, 1533, 200, 1532, 1532, 1532, 1763, 1763, 1532, 1763,
+ 1532, 928, 929, 930, 1763, 1763, 1534, 1532, 1763, 1763,
+ 1532, 1763, 1763, 1392, 1763, 1763, 928, 929, 930, 1763,
+ 1763, 1763, 249, 1532, 1763, 1532, 1533, 1532, 275, 928,
+ 929, 930, 251, 1763, 1763, 1763, 1763, 1618, 1618, 1618,
+ 1618, 1763, 423, 424, 425, 1763, 1763, 1763, 1393, 933,
+ 1532, 1532, 1532, 1763, 1532, 1532, 1535, 1536, 1537, 1763,
+ 1538, 1763, 1763, 1538, 1763, 1763, 1763, 933, 1763, 1763,
+
+ 1539, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1394, 1395,
+ 1396, 200, 1763, 1763, 1763, 1763, 1392, 1621, 1621, 1621,
+ 1621, 1763, 1763, 1763, 1763, 249, 1763, 1763, 1763, 933,
+ 1763, 275, 1763, 1763, 1586, 251, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 249, 1763, 1763, 1763, 933, 1763, 554,
+ 1763, 1393, 1763, 251, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 423, 424, 425, 1540, 1540, 1540, 1540, 1540, 1587,
+ 1540, 1541, 1763, 1540, 1540, 1540, 1763, 1763, 1540, 1763,
+ 1540, 1394, 1395, 1396, 1763, 1763, 1542, 1540, 1763, 1763,
+ 1540, 1763, 1621, 1621, 1621, 1621, 1763, 1763, 1763, 1588,
+
+ 1589, 1590, 1763, 1540, 933, 1540, 1541, 1540, 1763, 1763,
+ 1763, 1499, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 933, 1763, 1763, 1763, 1500, 1763, 1763, 1763,
+ 1540, 1540, 1540, 1763, 1540, 1540, 1543, 1544, 1545, 426,
+ 427, 428, 429, 430, 431, 432, 1499, 433, 1763, 434,
+ 435, 436, 437, 438, 439, 440, 441, 442, 1561, 1561,
+ 1561, 1561, 1561, 1763, 1561, 1562, 1763, 1561, 1561, 1561,
+ 1400, 1763, 1561, 1763, 1561, 1763, 1501, 1502, 1503, 249,
+ 1563, 1561, 1763, 1763, 1561, 275, 1763, 1763, 1763, 251,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1561, 1763, 1561,
+
+ 1562, 1561, 1763, 1763, 1400, 1401, 1481, 1481, 1481, 1481,
+ 927, 1763, 1763, 249, 1763, 1763, 1763, 1763, 1763, 275,
+ 1763, 1763, 1763, 251, 1561, 1561, 1561, 1763, 1561, 1561,
+ 1564, 1565, 1566, 830, 1763, 1402, 1403, 1404, 1763, 1401,
+ 531, 1763, 532, 1763, 1377, 1377, 1377, 1377, 832, 1763,
+ 1763, 1763, 535, 1763, 1763, 1763, 1378, 1763, 1763, 1763,
+ 928, 929, 930, 1763, 1763, 1763, 1763, 1594, 822, 1402,
+ 1403, 1404, 1407, 1763, 1378, 1763, 249, 1763, 1763, 1763,
+ 1763, 249, 554, 1763, 1763, 1763, 251, 275, 1763, 1763,
+ 1763, 251, 1763, 1763, 1763, 1763, 1763, 1763, 834, 835,
+
+ 836, 830, 1595, 1763, 1763, 1763, 1763, 1408, 531, 1763,
+ 532, 1763, 1377, 1377, 1377, 1377, 832, 1763, 1763, 1763,
+ 535, 1763, 1763, 1763, 1378, 1763, 1407, 1763, 1763, 1763,
+ 1763, 1763, 1596, 1597, 1598, 249, 822, 1409, 1410, 1411,
+ 1415, 275, 1378, 1415, 1763, 251, 1763, 1763, 1763, 249,
+ 1763, 1763, 249, 1763, 1415, 554, 1763, 1763, 554, 251,
+ 1763, 1408, 251, 249, 1763, 1763, 834, 835, 836, 554,
+ 1763, 1763, 1763, 251, 1763, 1416, 1763, 1763, 1416, 1763,
+ 1763, 1623, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1416,
+ 297, 1409, 1410, 1411, 1763, 1763, 636, 1763, 1763, 1763,
+
+ 299, 1763, 1763, 1763, 1763, 1417, 1418, 1419, 1417, 1418,
+ 1419, 1763, 1763, 1763, 1763, 1763, 1624, 1763, 1763, 1417,
+ 1418, 1419, 934, 1763, 1763, 1763, 1763, 1763, 1763, 613,
+ 1763, 614, 1763, 1453, 1453, 1453, 1453, 936, 1763, 1763,
+ 1763, 617, 1763, 1763, 1763, 1454, 1625, 1626, 1627, 1468,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1468, 926, 297, 1763,
+ 1763, 1632, 1763, 1454, 315, 297, 1763, 1763, 299, 1763,
+ 297, 315, 1763, 1763, 1763, 299, 636, 1763, 1763, 1763,
+ 299, 1763, 1763, 1763, 1469, 1763, 1763, 938, 939, 940,
+ 934, 1469, 1763, 1763, 1763, 1763, 1633, 613, 1763, 614,
+
+ 1763, 1453, 1453, 1453, 1453, 936, 1763, 1763, 1763, 617,
+ 1763, 1763, 1763, 1454, 1470, 1471, 1472, 1763, 1763, 1763,
+ 1763, 1470, 1471, 1472, 1476, 926, 1634, 1635, 1636, 1476,
+ 1763, 1454, 1640, 297, 1763, 1763, 1763, 1763, 297, 315,
+ 1763, 297, 1763, 299, 315, 1763, 1763, 636, 299, 1763,
+ 1763, 299, 1763, 1483, 1763, 938, 939, 940, 1763, 1477,
+ 1763, 1763, 297, 1763, 1477, 1483, 1763, 1641, 315, 1763,
+ 1763, 1763, 299, 1763, 297, 1763, 1763, 1763, 1763, 1763,
+ 315, 1763, 1763, 1763, 299, 1763, 1763, 1763, 1484, 1478,
+ 1479, 1480, 1491, 1763, 1478, 1479, 1480, 1642, 1643, 1644,
+
+ 1484, 297, 1763, 1763, 1763, 1763, 1491, 636, 1763, 1763,
+ 1763, 299, 1763, 1763, 1491, 297, 1763, 1763, 1485, 1486,
+ 1487, 636, 1763, 297, 1763, 299, 1763, 1492, 1763, 636,
+ 1485, 1486, 1487, 299, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1492, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1492,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1493, 1494, 1495,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1493, 1494, 1495, 1763, 1763, 1763, 1763, 1763, 1493,
+ 1494, 1495, 426, 427, 428, 429, 430, 431, 432, 1763,
+ 433, 1763, 434, 435, 436, 437, 438, 439, 440, 441,
+
+ 442, 1670, 1670, 1670, 1670, 1670, 1763, 1670, 1671, 1763,
+ 1670, 1670, 1670, 1763, 1763, 1670, 1763, 1670, 1763, 1763,
+ 1763, 1763, 1763, 1672, 1670, 1763, 1763, 1670, 1763, 1763,
+ 1577, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 249,
+ 1670, 1763, 1670, 1671, 1670, 554, 1763, 1763, 1763, 251,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1578, 1763, 1670, 1670, 1670,
+ 1763, 1670, 1670, 1673, 1674, 1675, 1677, 1677, 1677, 1677,
+ 1677, 1763, 1677, 1678, 1763, 1677, 1677, 1677, 1763, 1763,
+ 1677, 1763, 1677, 1763, 1763, 1579, 1580, 1581, 1679, 1677,
+
+ 1763, 1763, 1677, 1763, 1763, 1577, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 249, 1677, 1763, 1677, 1678, 1677,
+ 554, 1763, 1763, 1763, 251, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1578, 1763, 1677, 1677, 1677, 1763, 1677, 1677, 1680, 1681,
+ 1682, 1684, 1684, 1684, 1684, 1684, 1763, 1684, 1685, 1763,
+ 1684, 1684, 1684, 1763, 1763, 1684, 1763, 1684, 1763, 1763,
+ 1579, 1580, 1581, 1686, 1684, 1763, 1763, 1684, 1763, 1763,
+ 1577, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 249,
+ 1684, 1763, 1684, 1685, 1684, 554, 1763, 1763, 1763, 251,
+
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1578, 1763, 1684, 1684, 1684,
+ 1763, 1684, 1684, 1687, 1688, 1689, 1691, 1691, 1691, 1691,
+ 1691, 1763, 1691, 1692, 1763, 1691, 1691, 1691, 1763, 1763,
+ 1691, 1763, 1691, 1763, 1763, 1579, 1580, 1581, 1693, 1691,
+ 1763, 1763, 1691, 1763, 1763, 1586, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 249, 1691, 1763, 1691, 1692, 1691,
+ 554, 1763, 1763, 1763, 251, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1587, 1763, 1691, 1691, 1691, 1763, 1691, 1691, 1694, 1695,
+
+ 1696, 1697, 1697, 1697, 1697, 1697, 1763, 1697, 1698, 1763,
+ 1697, 1697, 1697, 1763, 1763, 1697, 1586, 1697, 1763, 1763,
+ 1588, 1589, 1590, 1699, 1697, 249, 1763, 1697, 1763, 1763,
+ 1763, 554, 1763, 1763, 1763, 251, 1763, 1763, 1763, 1763,
+ 1697, 1763, 1697, 1698, 1697, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1587, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1697, 1697, 1697,
+ 1763, 1697, 1697, 1700, 1701, 1702, 830, 1763, 1763, 1763,
+ 1763, 1588, 1589, 1590, 1586, 532, 1763, 1572, 1572, 1572,
+ 1572, 832, 1763, 249, 1763, 535, 1763, 1763, 1763, 554,
+
+ 1763, 1594, 1763, 251, 1763, 1763, 1763, 1763, 1763, 1763,
+ 249, 822, 1763, 1763, 1763, 1763, 554, 1763, 1763, 1587,
+ 251, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1595, 1763, 1763, 1763,
+ 1763, 834, 835, 836, 830, 1763, 1763, 1763, 1763, 1588,
+ 1589, 1590, 1763, 532, 1763, 1575, 1575, 1575, 1575, 832,
+ 1763, 1594, 1763, 535, 1763, 1763, 1596, 1597, 1598, 1594,
+ 249, 1763, 1763, 1763, 1763, 1763, 554, 1763, 249, 822,
+ 251, 1763, 1763, 1763, 554, 1763, 1763, 1763, 251, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1595, 1623, 1763, 1763,
+
+ 1763, 1763, 1763, 1763, 1595, 1763, 297, 1763, 1763, 834,
+ 835, 836, 636, 1763, 1763, 1763, 299, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1623, 1763, 1596, 1597, 1598, 1763,
+ 1763, 1763, 1624, 297, 1596, 1597, 1598, 934, 1763, 636,
+ 1763, 1763, 1763, 299, 1763, 1763, 614, 1763, 1618, 1618,
+ 1618, 1618, 936, 1763, 1763, 1763, 617, 1763, 1763, 1624,
+ 1623, 1763, 1625, 1626, 1627, 1632, 1763, 1763, 1763, 297,
+ 1763, 1763, 926, 1763, 297, 636, 1763, 1632, 1763, 299,
+ 636, 1763, 1763, 1763, 299, 1763, 297, 1763, 1763, 1625,
+ 1626, 1627, 636, 1763, 1763, 1624, 299, 1763, 1763, 1763,
+
+ 1633, 1763, 938, 939, 940, 934, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1633, 1763, 614, 1763, 1621, 1621, 1621, 1621,
+ 936, 1763, 1763, 1763, 617, 1625, 1626, 1627, 1763, 1763,
+ 1634, 1635, 1636, 1763, 1763, 1763, 1763, 1763, 1632, 1763,
+ 926, 1640, 1634, 1635, 1636, 1763, 1640, 297, 1763, 1640,
+ 297, 1763, 1763, 636, 1763, 297, 636, 299, 297, 1763,
+ 299, 636, 1763, 1763, 636, 299, 1763, 1763, 299, 1763,
+ 938, 939, 940, 1633, 1763, 1763, 1641, 1763, 1763, 1763,
+ 1763, 1641, 1763, 1763, 1641, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+
+ 1763, 1763, 1763, 1634, 1635, 1636, 1642, 1643, 1644, 1763,
+ 1763, 1642, 1643, 1644, 1642, 1643, 1644, 1737, 1737, 1737,
+ 1737, 1737, 1763, 1737, 1738, 1763, 1737, 1737, 1737, 1763,
+ 1763, 1737, 1763, 1737, 1763, 1763, 1763, 1763, 1763, 1739,
+ 1737, 1763, 1763, 1737, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1737, 1763, 1737, 1738,
+ 1737, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1737, 1737, 1737, 1763, 1737, 1737, 1740,
+ 1741, 1742, 1745, 1745, 1745, 1745, 1745, 1763, 1745, 1746,
+
+ 1763, 1745, 1745, 1745, 1763, 1763, 1745, 1763, 1745, 1763,
+ 1763, 1763, 1763, 1763, 1747, 1745, 1763, 1763, 1745, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1745, 1763, 1745, 1746, 1745, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1745, 1745,
+ 1745, 1763, 1745, 1745, 1748, 1749, 1750, 34, 34, 34,
+ 34, 34, 34, 34, 34, 34, 34, 34, 34, 34,
+ 34, 34, 34, 34, 34, 34, 34, 34, 34, 34,
+ 34, 94, 94, 94, 94, 94, 94, 94, 94, 94,
+
+ 94, 94, 94, 94, 94, 94, 94, 94, 94, 94,
+ 94, 94, 94, 94, 94, 107, 107, 107, 107, 107,
+ 107, 107, 107, 107, 107, 107, 107, 107, 107, 107,
+ 107, 107, 107, 107, 107, 107, 107, 107, 107, 144,
+ 144, 144, 144, 144, 144, 144, 144, 144, 144, 144,
+ 144, 144, 144, 144, 144, 144, 144, 144, 144, 144,
+ 144, 144, 144, 150, 150, 150, 150, 150, 150, 150,
+ 150, 150, 150, 150, 150, 150, 150, 150, 150, 150,
+ 150, 150, 150, 150, 150, 150, 150, 169, 169, 169,
+ 169, 169, 169, 169, 169, 169, 169, 169, 169, 169,
+
+ 169, 169, 169, 169, 169, 169, 169, 169, 169, 169,
+ 169, 171, 171, 1763, 1763, 1763, 171, 171, 171, 171,
+ 171, 171, 171, 171, 171, 171, 171, 171, 171, 1763,
+ 171, 171, 171, 171, 171, 230, 230, 1763, 230, 1763,
+ 1763, 1763, 230, 1763, 230, 230, 232, 232, 1763, 1763,
+ 232, 232, 232, 232, 232, 232, 232, 232, 232, 232,
+ 232, 232, 232, 232, 232, 232, 232, 232, 232, 232,
+ 234, 234, 234, 234, 234, 234, 234, 234, 234, 234,
+ 234, 234, 234, 234, 234, 234, 234, 234, 234, 234,
+ 234, 234, 234, 234, 247, 1763, 247, 1763, 1763, 247,
+
+ 247, 1763, 247, 1763, 247, 247, 1763, 247, 247, 247,
+ 247, 247, 247, 273, 1763, 273, 1763, 1763, 273, 273,
+ 1763, 273, 1763, 273, 273, 1763, 273, 273, 273, 273,
+ 273, 273, 280, 1763, 280, 1763, 1763, 280, 280, 1763,
+ 1763, 1763, 280, 280, 1763, 1763, 280, 1763, 280, 280,
+ 280, 295, 1763, 295, 1763, 1763, 295, 295, 1763, 295,
+ 295, 295, 295, 1763, 295, 295, 295, 295, 295, 295,
+ 313, 1763, 313, 1763, 1763, 313, 313, 1763, 313, 313,
+ 313, 313, 1763, 313, 313, 313, 313, 313, 313, 320,
+ 1763, 320, 1763, 1763, 320, 320, 1763, 1763, 320, 320,
+
+ 320, 1763, 1763, 320, 1763, 320, 320, 320, 348, 348,
+ 348, 348, 348, 348, 348, 348, 348, 348, 348, 348,
+ 348, 348, 348, 348, 348, 348, 348, 348, 348, 348,
+ 348, 348, 358, 1763, 1763, 1763, 358, 1763, 358, 358,
+ 366, 366, 366, 1763, 366, 366, 1763, 1763, 366, 1763,
+ 1763, 366, 366, 366, 366, 366, 384, 1763, 1763, 1763,
+ 1763, 384, 1763, 384, 384, 1763, 1763, 384, 1763, 384,
+ 384, 384, 1763, 384, 384, 384, 1763, 384, 384, 384,
+ 393, 393, 1763, 1763, 393, 393, 393, 393, 393, 393,
+ 393, 393, 393, 393, 393, 393, 393, 393, 393, 393,
+
+ 393, 393, 393, 393, 399, 399, 1763, 399, 399, 399,
+ 399, 399, 399, 399, 399, 399, 399, 399, 399, 399,
+ 399, 399, 399, 399, 399, 399, 399, 399, 402, 402,
+ 1763, 402, 402, 402, 402, 402, 402, 402, 402, 402,
+ 402, 402, 402, 402, 402, 402, 402, 402, 402, 402,
+ 402, 402, 404, 404, 404, 404, 404, 404, 404, 404,
+ 404, 404, 404, 404, 404, 404, 404, 404, 404, 404,
+ 404, 404, 404, 404, 404, 404, 422, 1763, 422, 1763,
+ 1763, 422, 422, 1763, 1763, 422, 422, 422, 1763, 1763,
+ 422, 422, 422, 422, 422, 476, 476, 1763, 476, 1763,
+
+ 1763, 1763, 476, 1763, 476, 476, 232, 232, 1763, 1763,
+ 232, 232, 232, 232, 232, 232, 232, 232, 232, 232,
+ 232, 232, 232, 232, 232, 232, 232, 232, 232, 232,
+ 496, 1763, 496, 1763, 1763, 496, 496, 1763, 496, 1763,
+ 496, 496, 1763, 496, 496, 496, 496, 496, 496, 247,
+ 1763, 247, 1763, 1763, 247, 247, 1763, 247, 1763, 247,
+ 247, 1763, 247, 247, 247, 247, 247, 247, 504, 1763,
+ 504, 1763, 1763, 504, 504, 1763, 504, 1763, 504, 504,
+ 1763, 504, 504, 504, 504, 504, 504, 510, 1763, 510,
+ 1763, 1763, 510, 510, 1763, 1763, 1763, 510, 510, 1763,
+
+ 1763, 510, 1763, 510, 510, 510, 520, 1763, 520, 1763,
+ 1763, 520, 520, 1763, 520, 1763, 520, 520, 1763, 520,
+ 520, 520, 520, 520, 520, 529, 1763, 529, 1763, 1763,
+ 529, 529, 529, 529, 1763, 529, 529, 1763, 529, 529,
+ 1763, 529, 529, 529, 552, 1763, 552, 1763, 1763, 552,
+ 552, 1763, 552, 1763, 552, 552, 1763, 552, 552, 552,
+ 552, 552, 552, 273, 1763, 273, 1763, 1763, 273, 273,
+ 1763, 273, 1763, 273, 273, 1763, 273, 273, 273, 273,
+ 273, 273, 559, 1763, 559, 1763, 1763, 559, 559, 1763,
+ 1763, 1763, 559, 1763, 1763, 1763, 559, 559, 559, 559,
+
+ 559, 565, 1763, 565, 1763, 1763, 565, 565, 1763, 565,
+ 1763, 565, 565, 1763, 565, 565, 565, 565, 565, 565,
+ 580, 1763, 580, 1763, 1763, 580, 580, 1763, 580, 580,
+ 580, 580, 1763, 580, 580, 580, 580, 580, 580, 295,
+ 1763, 295, 1763, 1763, 295, 295, 1763, 295, 295, 295,
+ 295, 1763, 295, 295, 295, 295, 295, 295, 588, 1763,
+ 588, 1763, 1763, 588, 588, 1763, 588, 588, 588, 588,
+ 1763, 588, 588, 588, 588, 588, 588, 594, 1763, 594,
+ 1763, 1763, 594, 594, 1763, 1763, 594, 594, 594, 1763,
+ 1763, 594, 1763, 594, 594, 594, 602, 1763, 602, 1763,
+
+ 1763, 602, 602, 1763, 602, 602, 602, 602, 1763, 602,
+ 602, 602, 602, 602, 602, 611, 1763, 611, 1763, 1763,
+ 611, 611, 611, 611, 611, 611, 611, 1763, 611, 611,
+ 1763, 611, 611, 611, 634, 1763, 634, 1763, 1763, 634,
+ 634, 1763, 634, 634, 634, 634, 1763, 634, 634, 634,
+ 634, 634, 634, 313, 1763, 313, 1763, 1763, 313, 313,
+ 1763, 313, 313, 313, 313, 1763, 313, 313, 313, 313,
+ 313, 313, 641, 1763, 641, 1763, 1763, 641, 641, 1763,
+ 1763, 641, 641, 1763, 1763, 1763, 641, 641, 641, 641,
+ 641, 647, 1763, 647, 1763, 1763, 647, 647, 1763, 647,
+
+ 647, 647, 647, 1763, 647, 647, 647, 647, 647, 647,
+ 358, 1763, 1763, 1763, 358, 1763, 358, 358, 366, 1763,
+ 1763, 1763, 366, 1763, 366, 366, 479, 479, 479, 479,
+ 479, 479, 479, 479, 479, 479, 479, 479, 479, 1763,
+ 479, 479, 479, 479, 479, 479, 479, 479, 479, 479,
+ 230, 230, 1763, 230, 1763, 1763, 1763, 230, 1763, 230,
+ 230, 384, 1763, 1763, 1763, 1763, 384, 1763, 384, 384,
+ 1763, 1763, 384, 1763, 384, 384, 384, 1763, 384, 384,
+ 384, 1763, 384, 384, 384, 393, 393, 1763, 1763, 393,
+ 393, 393, 393, 393, 393, 393, 393, 393, 393, 393,
+
+ 393, 393, 393, 393, 393, 393, 393, 393, 393, 402,
+ 402, 1763, 402, 402, 402, 402, 402, 402, 402, 402,
+ 402, 402, 402, 402, 402, 402, 402, 402, 402, 402,
+ 402, 402, 402, 171, 171, 1763, 1763, 1763, 171, 171,
+ 171, 171, 171, 171, 171, 171, 171, 171, 171, 171,
+ 171, 1763, 171, 171, 171, 171, 171, 404, 404, 404,
+ 404, 404, 404, 404, 404, 404, 404, 404, 404, 404,
+ 404, 404, 404, 404, 404, 404, 404, 404, 404, 404,
+ 404, 476, 1763, 1763, 1763, 476, 1763, 476, 476, 700,
+ 1763, 1763, 700, 1763, 1763, 1763, 700, 1763, 700, 700,
+
+ 422, 1763, 422, 1763, 1763, 422, 422, 1763, 1763, 422,
+ 422, 422, 1763, 1763, 422, 422, 422, 422, 422, 778,
+ 1763, 778, 1763, 1763, 1763, 778, 1763, 778, 778, 529,
+ 1763, 529, 1763, 1763, 529, 529, 1763, 1763, 1763, 529,
+ 529, 1763, 529, 529, 1763, 529, 529, 529, 496, 1763,
+ 496, 1763, 1763, 496, 496, 1763, 496, 1763, 496, 496,
+ 1763, 496, 496, 496, 496, 496, 496, 784, 1763, 784,
+ 1763, 1763, 784, 784, 1763, 784, 1763, 784, 784, 1763,
+ 784, 784, 784, 784, 784, 784, 792, 1763, 792, 1763,
+ 1763, 792, 792, 1763, 792, 1763, 792, 792, 1763, 792,
+
+ 792, 792, 792, 792, 792, 504, 1763, 504, 1763, 1763,
+ 504, 504, 1763, 504, 1763, 504, 504, 1763, 504, 504,
+ 504, 504, 504, 504, 800, 1763, 800, 1763, 1763, 800,
+ 800, 1763, 1763, 1763, 800, 800, 1763, 1763, 800, 800,
+ 800, 800, 800, 806, 1763, 806, 1763, 1763, 806, 806,
+ 1763, 1763, 1763, 806, 1763, 1763, 1763, 806, 806, 806,
+ 806, 806, 813, 1763, 813, 1763, 1763, 813, 813, 1763,
+ 813, 1763, 813, 813, 1763, 813, 813, 813, 813, 813,
+ 813, 520, 1763, 520, 1763, 1763, 520, 520, 1763, 520,
+ 1763, 520, 520, 1763, 520, 520, 520, 520, 520, 520,
+
+ 822, 1763, 822, 1763, 1763, 822, 822, 1763, 1763, 1763,
+ 822, 822, 1763, 1763, 822, 822, 822, 822, 822, 829,
+ 1763, 829, 1763, 1763, 829, 829, 829, 829, 1763, 829,
+ 829, 1763, 829, 829, 829, 829, 829, 829, 837, 1763,
+ 837, 1763, 1763, 837, 837, 1763, 1763, 1763, 837, 1763,
+ 1763, 1763, 837, 837, 837, 837, 837, 841, 1763, 841,
+ 1763, 1763, 841, 841, 1763, 1763, 1763, 841, 841, 1763,
+ 1763, 841, 1763, 841, 841, 841, 855, 1763, 855, 1763,
+ 1763, 855, 855, 1763, 855, 1763, 855, 855, 1763, 855,
+ 855, 855, 855, 855, 855, 552, 1763, 552, 1763, 1763,
+
+ 552, 552, 1763, 552, 1763, 552, 552, 1763, 552, 552,
+ 552, 552, 552, 552, 864, 1763, 864, 1763, 1763, 864,
+ 864, 1763, 1763, 1763, 864, 1763, 1763, 1763, 864, 864,
+ 864, 864, 864, 559, 1763, 559, 1763, 1763, 559, 559,
+ 1763, 1763, 1763, 559, 1763, 1763, 1763, 559, 559, 559,
+ 559, 559, 873, 1763, 873, 1763, 1763, 873, 873, 1763,
+ 873, 1763, 873, 873, 1763, 873, 873, 873, 873, 873,
+ 873, 565, 1763, 565, 1763, 1763, 565, 565, 1763, 565,
+ 1763, 565, 565, 1763, 565, 565, 565, 565, 565, 565,
+ 611, 1763, 611, 1763, 1763, 611, 611, 1763, 1763, 611,
+
+ 611, 611, 1763, 611, 611, 1763, 611, 611, 611, 580,
+ 1763, 580, 1763, 1763, 580, 580, 1763, 580, 580, 580,
+ 580, 1763, 580, 580, 580, 580, 580, 580, 888, 1763,
+ 888, 1763, 1763, 888, 888, 1763, 888, 888, 888, 888,
+ 1763, 888, 888, 888, 888, 888, 888, 896, 1763, 896,
+ 1763, 1763, 896, 896, 1763, 896, 896, 896, 896, 1763,
+ 896, 896, 896, 896, 896, 896, 588, 1763, 588, 1763,
+ 1763, 588, 588, 1763, 588, 588, 588, 588, 1763, 588,
+ 588, 588, 588, 588, 588, 904, 1763, 904, 1763, 1763,
+ 904, 904, 1763, 1763, 904, 904, 904, 1763, 1763, 904,
+
+ 904, 904, 904, 904, 910, 1763, 910, 1763, 1763, 910,
+ 910, 1763, 1763, 910, 910, 1763, 1763, 1763, 910, 910,
+ 910, 910, 910, 917, 1763, 917, 1763, 1763, 917, 917,
+ 1763, 917, 917, 917, 917, 1763, 917, 917, 917, 917,
+ 917, 917, 602, 1763, 602, 1763, 1763, 602, 602, 1763,
+ 602, 602, 602, 602, 1763, 602, 602, 602, 602, 602,
+ 602, 926, 1763, 926, 1763, 1763, 926, 926, 1763, 1763,
+ 926, 926, 926, 1763, 1763, 926, 926, 926, 926, 926,
+ 933, 1763, 933, 1763, 1763, 933, 933, 933, 933, 933,
+ 933, 933, 1763, 933, 933, 933, 933, 933, 933, 941,
+
+ 1763, 941, 1763, 1763, 941, 941, 1763, 1763, 941, 941,
+ 1763, 1763, 1763, 941, 941, 941, 941, 941, 945, 1763,
+ 945, 1763, 1763, 945, 945, 1763, 1763, 945, 945, 945,
+ 1763, 1763, 945, 1763, 945, 945, 945, 959, 1763, 959,
+ 1763, 1763, 959, 959, 1763, 959, 959, 959, 959, 1763,
+ 959, 959, 959, 959, 959, 959, 634, 1763, 634, 1763,
+ 1763, 634, 634, 1763, 634, 634, 634, 634, 1763, 634,
+ 634, 634, 634, 634, 634, 968, 1763, 968, 1763, 1763,
+ 968, 968, 1763, 1763, 968, 968, 1763, 1763, 1763, 968,
+ 968, 968, 968, 968, 641, 1763, 641, 1763, 1763, 641,
+
+ 641, 1763, 1763, 641, 641, 1763, 1763, 1763, 641, 641,
+ 641, 641, 641, 977, 1763, 977, 1763, 1763, 977, 977,
+ 1763, 977, 977, 977, 977, 1763, 977, 977, 977, 977,
+ 977, 977, 647, 1763, 647, 1763, 1763, 647, 647, 1763,
+ 647, 647, 647, 647, 1763, 647, 647, 647, 647, 647,
+ 647, 700, 1763, 1763, 700, 1763, 1763, 1763, 700, 1763,
+ 700, 700, 479, 479, 479, 479, 479, 479, 479, 479,
+ 479, 479, 479, 479, 479, 1763, 479, 479, 479, 479,
+ 479, 479, 479, 479, 479, 479, 384, 1763, 1763, 1763,
+ 1763, 384, 1763, 384, 384, 1763, 1763, 384, 1763, 384,
+
+ 384, 384, 1763, 384, 384, 384, 1763, 384, 384, 384,
+ 476, 476, 1763, 476, 1763, 1763, 1763, 476, 1763, 476,
+ 476, 747, 747, 747, 747, 747, 1763, 747, 747, 747,
+ 747, 1763, 1763, 747, 747, 1763, 1763, 747, 747, 747,
+ 1763, 747, 1763, 1763, 747, 422, 1763, 1763, 422, 422,
+ 1763, 422, 1763, 1763, 422, 422, 1763, 1763, 422, 422,
+ 422, 1763, 1763, 422, 422, 422, 422, 422, 778, 1763,
+ 778, 1763, 1763, 1763, 778, 1763, 778, 778, 829, 1763,
+ 829, 1763, 1763, 829, 829, 829, 829, 1763, 829, 829,
+ 1763, 829, 829, 829, 829, 829, 829, 822, 1763, 822,
+
+ 1763, 1763, 822, 822, 1763, 1763, 1763, 822, 822, 1763,
+ 1763, 822, 822, 822, 822, 822, 529, 1763, 529, 1763,
+ 1763, 529, 529, 1763, 529, 1763, 529, 529, 1763, 529,
+ 529, 1763, 529, 529, 529, 1086, 1763, 1086, 1763, 1763,
+ 1086, 1086, 1763, 1086, 1763, 1086, 1086, 1763, 1086, 1086,
+ 1086, 1086, 1086, 1086, 784, 1763, 784, 1763, 1763, 784,
+ 784, 1763, 784, 1763, 784, 784, 1763, 784, 784, 784,
+ 784, 784, 784, 792, 1763, 792, 1763, 1763, 792, 792,
+ 1763, 792, 1763, 792, 792, 1763, 792, 792, 792, 792,
+ 792, 792, 800, 1763, 800, 1763, 1763, 800, 800, 1763,
+
+ 1763, 1763, 800, 800, 1763, 1763, 800, 800, 800, 800,
+ 800, 1098, 1763, 1098, 1763, 1763, 1098, 1098, 1763, 1763,
+ 1763, 1098, 1763, 1763, 1763, 1098, 1098, 1098, 1098, 1098,
+ 806, 1763, 806, 1763, 1763, 806, 806, 1763, 1763, 1763,
+ 806, 1763, 1763, 1763, 806, 806, 806, 806, 806, 813,
+ 1763, 813, 1763, 1763, 813, 813, 1763, 813, 1763, 813,
+ 813, 1763, 813, 813, 813, 813, 813, 813, 1110, 1763,
+ 1110, 1763, 1763, 1110, 1110, 1763, 1763, 1763, 1110, 1763,
+ 1763, 1763, 1110, 1110, 1110, 1110, 1110, 1116, 1763, 1116,
+ 1763, 1763, 1116, 1116, 1763, 1763, 1763, 1116, 1763, 1763,
+
+ 1763, 1116, 1116, 1116, 1116, 1116, 1122, 1763, 1122, 1763,
+ 1763, 1122, 1122, 1763, 1763, 1763, 1122, 1763, 1763, 1763,
+ 1122, 1122, 1122, 1122, 1122, 837, 1763, 837, 1763, 1763,
+ 837, 837, 1763, 1763, 1763, 837, 1763, 1763, 1763, 837,
+ 837, 837, 837, 837, 1130, 1763, 1130, 1763, 1763, 1130,
+ 1130, 1763, 1763, 1763, 1130, 1130, 1763, 1763, 1130, 1130,
+ 1130, 1130, 1130, 1144, 1763, 1144, 1763, 1763, 1144, 1144,
+ 1763, 1144, 1763, 1144, 1144, 1763, 1144, 1144, 1144, 1144,
+ 1144, 1144, 496, 1763, 496, 1763, 1763, 496, 496, 1763,
+ 496, 1763, 496, 496, 1763, 496, 496, 496, 496, 496,
+
+ 496, 1153, 1763, 1153, 1763, 1763, 1153, 1153, 1763, 1153,
+ 1763, 1153, 1153, 1763, 1153, 1153, 1153, 1153, 1153, 1153,
+ 1160, 1763, 1160, 1763, 1763, 1160, 1160, 1763, 1160, 1763,
+ 1160, 1160, 1763, 1160, 1160, 1160, 1160, 1160, 1160, 1166,
+ 1763, 1166, 1763, 1763, 1166, 1166, 1763, 1763, 1763, 1166,
+ 1166, 1763, 1763, 1166, 1763, 1166, 1166, 1166, 864, 1763,
+ 864, 1763, 1763, 864, 864, 1763, 1763, 1763, 864, 1763,
+ 1763, 1763, 864, 864, 864, 864, 864, 873, 1763, 873,
+ 1763, 1763, 873, 873, 1763, 873, 1763, 873, 873, 1763,
+ 873, 873, 873, 873, 873, 873, 933, 1763, 933, 1763,
+
+ 1763, 933, 933, 933, 933, 933, 933, 933, 1763, 933,
+ 933, 933, 933, 933, 933, 926, 1763, 926, 1763, 1763,
+ 926, 926, 1763, 1763, 926, 926, 926, 1763, 1763, 926,
+ 926, 926, 926, 926, 611, 1763, 611, 1763, 1763, 611,
+ 611, 1763, 611, 611, 611, 611, 1763, 611, 611, 1763,
+ 611, 611, 611, 1184, 1763, 1184, 1763, 1763, 1184, 1184,
+ 1763, 1184, 1184, 1184, 1184, 1763, 1184, 1184, 1184, 1184,
+ 1184, 1184, 888, 1763, 888, 1763, 1763, 888, 888, 1763,
+ 888, 888, 888, 888, 1763, 888, 888, 888, 888, 888,
+ 888, 896, 1763, 896, 1763, 1763, 896, 896, 1763, 896,
+
+ 896, 896, 896, 1763, 896, 896, 896, 896, 896, 896,
+ 904, 1763, 904, 1763, 1763, 904, 904, 1763, 1763, 904,
+ 904, 904, 1763, 1763, 904, 904, 904, 904, 904, 1196,
+ 1763, 1196, 1763, 1763, 1196, 1196, 1763, 1763, 1196, 1196,
+ 1763, 1763, 1763, 1196, 1196, 1196, 1196, 1196, 910, 1763,
+ 910, 1763, 1763, 910, 910, 1763, 1763, 910, 910, 1763,
+ 1763, 1763, 910, 910, 910, 910, 910, 917, 1763, 917,
+ 1763, 1763, 917, 917, 1763, 917, 917, 917, 917, 1763,
+ 917, 917, 917, 917, 917, 917, 1208, 1763, 1208, 1763,
+ 1763, 1208, 1208, 1763, 1763, 1208, 1208, 1763, 1763, 1763,
+
+ 1208, 1208, 1208, 1208, 1208, 1214, 1763, 1214, 1763, 1763,
+ 1214, 1214, 1763, 1763, 1214, 1214, 1763, 1763, 1763, 1214,
+ 1214, 1214, 1214, 1214, 1220, 1763, 1220, 1763, 1763, 1220,
+ 1220, 1763, 1763, 1220, 1220, 1763, 1763, 1763, 1220, 1220,
+ 1220, 1220, 1220, 941, 1763, 941, 1763, 1763, 941, 941,
+ 1763, 1763, 941, 941, 1763, 1763, 1763, 941, 941, 941,
+ 941, 941, 1228, 1763, 1228, 1763, 1763, 1228, 1228, 1763,
+ 1763, 1228, 1228, 1228, 1763, 1763, 1228, 1228, 1228, 1228,
+ 1228, 1242, 1763, 1242, 1763, 1763, 1242, 1242, 1763, 1242,
+ 1242, 1242, 1242, 1763, 1242, 1242, 1242, 1242, 1242, 1242,
+
+ 580, 1763, 580, 1763, 1763, 580, 580, 1763, 580, 580,
+ 580, 580, 1763, 580, 580, 580, 580, 580, 580, 1251,
+ 1763, 1251, 1763, 1763, 1251, 1251, 1763, 1251, 1251, 1251,
+ 1251, 1763, 1251, 1251, 1251, 1251, 1251, 1251, 1258, 1763,
+ 1258, 1763, 1763, 1258, 1258, 1763, 1258, 1258, 1258, 1258,
+ 1763, 1258, 1258, 1258, 1258, 1258, 1258, 1264, 1763, 1264,
+ 1763, 1763, 1264, 1264, 1763, 1763, 1264, 1264, 1264, 1763,
+ 1763, 1264, 1763, 1264, 1264, 1264, 968, 1763, 968, 1763,
+ 1763, 968, 968, 1763, 1763, 968, 968, 1763, 1763, 1763,
+ 968, 968, 968, 968, 968, 977, 1763, 977, 1763, 1763,
+
+ 977, 977, 1763, 977, 977, 977, 977, 1763, 977, 977,
+ 977, 977, 977, 977, 700, 1763, 1763, 700, 1763, 1763,
+ 1763, 700, 1763, 700, 700, 384, 1763, 1763, 1763, 1763,
+ 384, 1763, 384, 384, 1763, 1763, 384, 1763, 384, 384,
+ 384, 1763, 384, 384, 384, 1763, 384, 384, 384, 476,
+ 1763, 1763, 1763, 476, 1763, 476, 476, 1053, 1053, 1053,
+ 1053, 1053, 1763, 1053, 1053, 1053, 1053, 1763, 1763, 1053,
+ 1053, 1763, 1763, 1053, 1053, 1053, 1763, 1053, 1763, 1053,
+ 1053, 1063, 1063, 1063, 1063, 1063, 1763, 1063, 1063, 1063,
+ 1063, 1763, 1763, 1063, 1063, 1763, 1763, 1063, 1063, 1063,
+
+ 1763, 1063, 1063, 1763, 1063, 422, 1763, 422, 1763, 1763,
+ 422, 422, 1763, 1763, 422, 422, 422, 1763, 1763, 422,
+ 422, 422, 422, 422, 529, 1763, 529, 1763, 1763, 529,
+ 529, 1763, 1763, 1763, 529, 529, 1763, 529, 529, 1763,
+ 529, 529, 529, 829, 1763, 829, 1763, 1763, 829, 829,
+ 1763, 829, 1763, 829, 829, 1763, 829, 829, 829, 829,
+ 829, 829, 1086, 1763, 1086, 1763, 1763, 1086, 1086, 1763,
+ 1086, 1763, 1086, 1086, 1763, 1086, 1086, 1086, 1086, 1086,
+ 1086, 1098, 1763, 1098, 1763, 1763, 1098, 1098, 1763, 1763,
+ 1763, 1098, 1763, 1763, 1763, 1098, 1098, 1098, 1098, 1098,
+
+ 1110, 1763, 1110, 1763, 1763, 1110, 1110, 1763, 1763, 1763,
+ 1110, 1763, 1763, 1763, 1110, 1110, 1110, 1110, 1110, 1116,
+ 1763, 1116, 1763, 1763, 1116, 1116, 1763, 1763, 1763, 1116,
+ 1763, 1763, 1763, 1116, 1116, 1116, 1116, 1116, 822, 1763,
+ 822, 1763, 1763, 822, 822, 1763, 1763, 1763, 822, 822,
+ 1763, 1763, 822, 822, 822, 822, 822, 1122, 1763, 1122,
+ 1763, 1763, 1122, 1122, 1763, 1763, 1763, 1122, 1763, 1763,
+ 1763, 1122, 1122, 1122, 1122, 1122, 1130, 1763, 1130, 1763,
+ 1763, 1130, 1130, 1763, 1763, 1763, 1130, 1130, 1763, 1763,
+ 1130, 1130, 1130, 1130, 1130, 1144, 1763, 1144, 1763, 1763,
+
+ 1144, 1144, 1763, 1144, 1763, 1144, 1144, 1763, 1144, 1144,
+ 1144, 1144, 1144, 1144, 1391, 1763, 1391, 1763, 1763, 1391,
+ 1391, 1763, 1391, 1763, 1391, 1391, 1763, 1391, 1391, 1391,
+ 1391, 1391, 1391, 1399, 1763, 1399, 1763, 1763, 1399, 1399,
+ 1763, 1399, 1763, 1399, 1399, 1763, 1399, 1399, 1399, 1399,
+ 1399, 1399, 1153, 1763, 1153, 1763, 1763, 1153, 1153, 1763,
+ 1153, 1763, 1153, 1153, 1763, 1153, 1153, 1153, 1153, 1153,
+ 1153, 1406, 1763, 1406, 1763, 1763, 1406, 1406, 1763, 1406,
+ 1763, 1406, 1406, 1763, 1406, 1406, 1406, 1406, 1406, 1406,
+ 1414, 1763, 1414, 1763, 1763, 1414, 1414, 1763, 1414, 1763,
+
+ 1414, 1414, 1763, 1414, 1414, 1414, 1414, 1414, 1414, 1160,
+ 1763, 1160, 1763, 1763, 1160, 1160, 1763, 1160, 1763, 1160,
+ 1160, 1763, 1160, 1160, 1160, 1160, 1160, 1160, 1422, 1763,
+ 1422, 1763, 1763, 1422, 1422, 1763, 1763, 1763, 1422, 1422,
+ 1763, 1763, 1422, 1422, 1422, 1422, 1422, 1428, 1763, 1428,
+ 1763, 1763, 1428, 1428, 1763, 1763, 1763, 1428, 1763, 1763,
+ 1763, 1428, 1428, 1428, 1428, 1428, 611, 1763, 611, 1763,
+ 1763, 611, 611, 1763, 1763, 611, 611, 611, 1763, 611,
+ 611, 1763, 611, 611, 611, 933, 1763, 933, 1763, 1763,
+ 933, 933, 1763, 933, 933, 933, 933, 1763, 933, 933,
+
+ 933, 933, 933, 933, 1184, 1763, 1184, 1763, 1763, 1184,
+ 1184, 1763, 1184, 1184, 1184, 1184, 1763, 1184, 1184, 1184,
+ 1184, 1184, 1184, 1196, 1763, 1196, 1763, 1763, 1196, 1196,
+ 1763, 1763, 1196, 1196, 1763, 1763, 1763, 1196, 1196, 1196,
+ 1196, 1196, 1208, 1763, 1208, 1763, 1763, 1208, 1208, 1763,
+ 1763, 1208, 1208, 1763, 1763, 1763, 1208, 1208, 1208, 1208,
+ 1208, 1214, 1763, 1214, 1763, 1763, 1214, 1214, 1763, 1763,
+ 1214, 1214, 1763, 1763, 1763, 1214, 1214, 1214, 1214, 1214,
+ 926, 1763, 926, 1763, 1763, 926, 926, 1763, 1763, 926,
+ 926, 926, 1763, 1763, 926, 926, 926, 926, 926, 1220,
+
+ 1763, 1220, 1763, 1763, 1220, 1220, 1763, 1763, 1220, 1220,
+ 1763, 1763, 1763, 1220, 1220, 1220, 1220, 1220, 1228, 1763,
+ 1228, 1763, 1763, 1228, 1228, 1763, 1763, 1228, 1228, 1228,
+ 1763, 1763, 1228, 1228, 1228, 1228, 1228, 1242, 1763, 1242,
+ 1763, 1763, 1242, 1242, 1763, 1242, 1242, 1242, 1242, 1763,
+ 1242, 1242, 1242, 1242, 1242, 1242, 1467, 1763, 1467, 1763,
+ 1763, 1467, 1467, 1763, 1467, 1467, 1467, 1467, 1763, 1467,
+ 1467, 1467, 1467, 1467, 1467, 1475, 1763, 1475, 1763, 1763,
+ 1475, 1475, 1763, 1475, 1475, 1475, 1475, 1763, 1475, 1475,
+ 1475, 1475, 1475, 1475, 1251, 1763, 1251, 1763, 1763, 1251,
+
+ 1251, 1763, 1251, 1251, 1251, 1251, 1763, 1251, 1251, 1251,
+ 1251, 1251, 1251, 1482, 1763, 1482, 1763, 1763, 1482, 1482,
+ 1763, 1482, 1482, 1482, 1482, 1763, 1482, 1482, 1482, 1482,
+ 1482, 1482, 1490, 1763, 1490, 1763, 1763, 1490, 1490, 1763,
+ 1490, 1490, 1490, 1490, 1763, 1490, 1490, 1490, 1490, 1490,
+ 1490, 1258, 1763, 1258, 1763, 1763, 1258, 1258, 1763, 1258,
+ 1258, 1258, 1258, 1763, 1258, 1258, 1258, 1258, 1258, 1258,
+ 1498, 1763, 1498, 1763, 1763, 1498, 1498, 1763, 1763, 1498,
+ 1498, 1498, 1763, 1763, 1498, 1498, 1498, 1498, 1498, 1504,
+ 1763, 1504, 1763, 1763, 1504, 1504, 1763, 1763, 1504, 1504,
+
+ 1763, 1763, 1763, 1504, 1504, 1504, 1504, 1504, 384, 384,
+ 384, 1763, 384, 384, 384, 384, 384, 384, 384, 384,
+ 384, 384, 384, 384, 384, 384, 384, 384, 384, 384,
+ 384, 384, 476, 476, 1763, 476, 1763, 1763, 1763, 476,
+ 1763, 476, 476, 1312, 1312, 1312, 1312, 1312, 1763, 1312,
+ 1312, 1312, 1312, 1763, 1763, 1312, 1312, 1763, 1763, 1312,
+ 1312, 1312, 1763, 1312, 1312, 1763, 1312, 1320, 1320, 1320,
+ 1320, 1320, 1763, 1320, 1320, 1320, 1320, 1763, 1763, 1320,
+ 1320, 1763, 1763, 1320, 1320, 1320, 1763, 1320, 1763, 1763,
+ 1320, 1332, 1332, 1332, 1332, 1332, 1763, 1332, 1332, 1332,
+
+ 1332, 1763, 1763, 1332, 1332, 1763, 1763, 1332, 1332, 1332,
+ 1763, 1332, 1763, 1763, 1332, 1343, 1343, 1343, 1343, 1343,
+ 1763, 1343, 1343, 1343, 1343, 1763, 1763, 1343, 1343, 1763,
+ 1763, 1343, 1343, 1343, 1763, 1343, 1763, 1763, 1343, 1351,
+ 1351, 1351, 1351, 1351, 1763, 1351, 1351, 1351, 1351, 1763,
+ 1763, 1351, 1351, 1763, 1763, 1351, 1351, 1351, 1763, 1351,
+ 1763, 1763, 1351, 422, 422, 422, 422, 422, 422, 422,
+ 422, 422, 422, 422, 422, 422, 422, 422, 422, 422,
+ 422, 422, 422, 422, 422, 422, 422, 829, 1763, 829,
+ 1763, 1763, 829, 829, 829, 829, 1763, 829, 829, 1763,
+
+ 829, 829, 829, 829, 829, 829, 822, 1763, 822, 1763,
+ 1763, 822, 822, 1763, 1763, 1763, 822, 822, 1763, 1763,
+ 822, 822, 822, 822, 822, 1576, 1763, 1576, 1763, 1763,
+ 1576, 1576, 1763, 1576, 1763, 1576, 1576, 1763, 1576, 1576,
+ 1576, 1576, 1576, 1576, 1391, 1763, 1391, 1763, 1763, 1391,
+ 1391, 1763, 1391, 1763, 1391, 1391, 1763, 1391, 1391, 1391,
+ 1391, 1391, 1391, 1585, 1763, 1585, 1763, 1763, 1585, 1585,
+ 1763, 1585, 1763, 1585, 1585, 1763, 1585, 1585, 1585, 1585,
+ 1585, 1585, 1399, 1763, 1399, 1763, 1763, 1399, 1399, 1763,
+ 1399, 1763, 1399, 1399, 1763, 1399, 1399, 1399, 1399, 1399,
+
+ 1399, 1593, 1763, 1593, 1763, 1763, 1593, 1593, 1763, 1593,
+ 1763, 1593, 1593, 1763, 1593, 1593, 1593, 1593, 1593, 1593,
+ 1406, 1763, 1406, 1763, 1763, 1406, 1406, 1763, 1406, 1763,
+ 1406, 1406, 1763, 1406, 1406, 1406, 1406, 1406, 1406, 1414,
+ 1763, 1414, 1763, 1763, 1414, 1414, 1763, 1414, 1763, 1414,
+ 1414, 1763, 1414, 1414, 1414, 1414, 1414, 1414, 1422, 1763,
+ 1422, 1763, 1763, 1422, 1422, 1763, 1763, 1763, 1422, 1422,
+ 1763, 1763, 1422, 1422, 1422, 1422, 1422, 1605, 1763, 1605,
+ 1763, 1763, 1605, 1605, 1763, 1763, 1763, 1605, 1763, 1763,
+ 1763, 1605, 1605, 1605, 1605, 1605, 1428, 1763, 1428, 1763,
+
+ 1763, 1428, 1428, 1763, 1763, 1763, 1428, 1763, 1763, 1763,
+ 1428, 1428, 1428, 1428, 1428, 933, 1763, 933, 1763, 1763,
+ 933, 933, 933, 933, 933, 933, 933, 1763, 933, 933,
+ 933, 933, 933, 933, 926, 1763, 926, 1763, 1763, 926,
+ 926, 1763, 1763, 926, 926, 926, 1763, 1763, 926, 926,
+ 926, 926, 926, 1622, 1763, 1622, 1763, 1763, 1622, 1622,
+ 1763, 1622, 1622, 1622, 1622, 1763, 1622, 1622, 1622, 1622,
+ 1622, 1622, 1467, 1763, 1467, 1763, 1763, 1467, 1467, 1763,
+ 1467, 1467, 1467, 1467, 1763, 1467, 1467, 1467, 1467, 1467,
+ 1467, 1631, 1763, 1631, 1763, 1763, 1631, 1631, 1763, 1631,
+
+ 1631, 1631, 1631, 1763, 1631, 1631, 1631, 1631, 1631, 1631,
+ 1475, 1763, 1475, 1763, 1763, 1475, 1475, 1763, 1475, 1475,
+ 1475, 1475, 1763, 1475, 1475, 1475, 1475, 1475, 1475, 1639,
+ 1763, 1639, 1763, 1763, 1639, 1639, 1763, 1639, 1639, 1639,
+ 1639, 1763, 1639, 1639, 1639, 1639, 1639, 1639, 1482, 1763,
+ 1482, 1763, 1763, 1482, 1482, 1763, 1482, 1482, 1482, 1482,
+ 1763, 1482, 1482, 1482, 1482, 1482, 1482, 1490, 1763, 1490,
+ 1763, 1763, 1490, 1490, 1763, 1490, 1490, 1490, 1490, 1763,
+ 1490, 1490, 1490, 1490, 1490, 1490, 1498, 1763, 1498, 1763,
+ 1763, 1498, 1498, 1763, 1763, 1498, 1498, 1498, 1763, 1763,
+
+ 1498, 1498, 1498, 1498, 1498, 1651, 1763, 1651, 1763, 1763,
+ 1651, 1651, 1763, 1763, 1651, 1651, 1763, 1763, 1763, 1651,
+ 1651, 1651, 1651, 1651, 1504, 1763, 1504, 1763, 1763, 1504,
+ 1504, 1763, 1763, 1504, 1504, 1763, 1763, 1763, 1504, 1504,
+ 1504, 1504, 1504, 1532, 1532, 1532, 1532, 1532, 1763, 1532,
+ 1532, 1532, 1532, 1763, 1763, 1532, 1532, 1763, 1763, 1532,
+ 1532, 1532, 1763, 1532, 1763, 1763, 1532, 1540, 1540, 1540,
+ 1540, 1540, 1763, 1540, 1540, 1540, 1540, 1763, 1763, 1540,
+ 1540, 1763, 1763, 1540, 1540, 1540, 1763, 1540, 1763, 1763,
+ 1540, 1561, 1561, 1561, 1561, 1561, 1763, 1561, 1561, 1561,
+
+ 1561, 1763, 1763, 1561, 1561, 1763, 1763, 1561, 1561, 1561,
+ 1763, 1561, 1763, 1763, 1561, 422, 1763, 422, 1763, 1763,
+ 422, 422, 1763, 1763, 422, 422, 422, 1763, 1763, 422,
+ 422, 422, 422, 422, 476, 1763, 476, 1763, 1763, 1763,
+ 476, 1763, 476, 476, 829, 1763, 829, 1763, 1763, 829,
+ 829, 1763, 829, 1763, 829, 829, 1763, 829, 829, 829,
+ 829, 829, 829, 1576, 1763, 1576, 1763, 1763, 1576, 1576,
+ 1763, 1576, 1763, 1576, 1576, 1763, 1576, 1576, 1576, 1576,
+ 1576, 1576, 1585, 1763, 1585, 1763, 1763, 1585, 1585, 1763,
+ 1585, 1763, 1585, 1585, 1763, 1585, 1585, 1585, 1585, 1585,
+
+ 1585, 1593, 1763, 1593, 1763, 1763, 1593, 1593, 1763, 1593,
+ 1763, 1593, 1593, 1763, 1593, 1593, 1593, 1593, 1593, 1593,
+ 1605, 1763, 1605, 1763, 1763, 1605, 1605, 1763, 1763, 1763,
+ 1605, 1763, 1763, 1763, 1605, 1605, 1605, 1605, 1605, 933,
+ 1763, 933, 1763, 1763, 933, 933, 1763, 933, 933, 933,
+ 933, 1763, 933, 933, 933, 933, 933, 933, 1622, 1763,
+ 1622, 1763, 1763, 1622, 1622, 1763, 1622, 1622, 1622, 1622,
+ 1763, 1622, 1622, 1622, 1622, 1622, 1622, 1631, 1763, 1631,
+ 1763, 1763, 1631, 1631, 1763, 1631, 1631, 1631, 1631, 1763,
+ 1631, 1631, 1631, 1631, 1631, 1631, 1639, 1763, 1639, 1763,
+
+ 1763, 1639, 1639, 1763, 1639, 1639, 1639, 1639, 1763, 1639,
+ 1639, 1639, 1639, 1639, 1639, 1670, 1670, 1670, 1670, 1670,
+ 1763, 1670, 1670, 1670, 1670, 1763, 1763, 1670, 1670, 1763,
+ 1763, 1670, 1670, 1670, 1763, 1670, 1763, 1763, 1670, 1677,
+ 1677, 1677, 1677, 1677, 1763, 1677, 1677, 1677, 1677, 1763,
+ 1763, 1677, 1677, 1763, 1763, 1677, 1677, 1677, 1763, 1677,
+ 1763, 1763, 1677, 1684, 1684, 1684, 1684, 1684, 1763, 1684,
+ 1684, 1684, 1684, 1763, 1763, 1684, 1684, 1763, 1763, 1684,
+ 1684, 1684, 1763, 1684, 1763, 1763, 1684, 1691, 1691, 1691,
+ 1691, 1691, 1763, 1691, 1691, 1691, 1691, 1763, 1763, 1691,
+
+ 1691, 1763, 1763, 1691, 1691, 1691, 1763, 1691, 1763, 1763,
+ 1691, 1697, 1697, 1697, 1697, 1697, 1763, 1697, 1697, 1697,
+ 1697, 1763, 1763, 1697, 1697, 1763, 1763, 1697, 1697, 1697,
+ 1763, 1697, 1763, 1763, 1697, 1737, 1737, 1737, 1737, 1737,
+ 1763, 1737, 1737, 1737, 1737, 1763, 1763, 1737, 1737, 1763,
+ 1763, 1737, 1737, 1737, 1763, 1737, 1763, 1763, 1737, 1745,
+ 1745, 1745, 1745, 1745, 1763, 1745, 1745, 1745, 1745, 1763,
+ 1763, 1745, 1745, 1763, 1763, 1745, 1745, 1745, 1763, 1745,
+ 1763, 1763, 1745, 33, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763
+ } ;
+
+static const flex_int16_t yy_chk[13560] =
+ { 0,
+ 0, 0, 1, 1, 1, 2, 2, 2, 11, 11,
+ 12, 12, 38, 42, 145, 38, 42, 145, 38, 42,
+ 57, 0, 57, 38, 42, 44, 1, 0, 44, 2,
+ 73, 73, 73, 73, 38, 42, 401, 44, 52, 44,
+ 44, 52, 44, 44, 44, 44, 51, 0, 51, 51,
+ 51, 51, 77, 77, 401, 52, 52, 52, 52, 121,
+ 121, 121, 52, 138, 138, 197, 77, 197, 77, 77,
+ 77, 77, 1, 1, 1, 2, 2, 2, 3, 3,
+ 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
+ 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
+
+ 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
+ 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
+ 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
+ 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
+ 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
+ 3, 3, 3, 5, 5, 5, 5, 5, 5, 5,
+ 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
+ 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
+ 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
+ 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
+
+ 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
+ 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
+ 5, 5, 5, 5, 5, 5, 5, 5, 7, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+
+ 7, 7, 7, 9, 9, 9, 9, 34, 34, 34,
+ 9, 440, 9, 9, 9, 9, 440, 9, 9, 9,
+ 39, 1348, 39, 39, 39, 1354, 40, 9, 40, 40,
+ 40, 41, 714, 41, 41, 41, 134, 134, 134, 134,
+ 714, 9, 9, 9, 95, 151, 108, 95, 151, 108,
+ 1355, 13, 13, 13, 13, 1356, 13, 14, 14, 14,
+ 14, 1363, 14, 21, 21, 21, 21, 139, 21, 9,
+ 139, 9, 9, 9, 9, 9, 9, 10, 10, 10,
+ 10, 90, 90, 95, 10, 108, 10, 10, 10, 10,
+ 13, 10, 10, 10, 191, 90, 14, 90, 90, 90,
+
+ 90, 10, 21, 54, 1364, 54, 139, 54, 54, 54,
+ 54, 143, 143, 184, 184, 10, 10, 10, 1365, 54,
+ 13, 13, 13, 13, 13, 1366, 14, 14, 14, 14,
+ 14, 191, 21, 21, 21, 21, 21, 54, 155, 155,
+ 155, 155, 230, 10, 230, 10, 10, 10, 10, 10,
+ 10, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 17, 17, 17, 17,
+ 135, 224, 1367, 135, 224, 22, 22, 22, 22, 1368,
+ 22, 29, 29, 331, 331, 29, 30, 30, 346, 346,
+ 30, 17, 67, 1369, 135, 67, 142, 142, 235, 334,
+ 132, 235, 334, 132, 67, 17, 67, 67, 17, 67,
+ 67, 67, 67, 82, 22, 132, 82, 378, 378, 29,
+ 142, 171, 171, 171, 30, 82, 349, 82, 82, 349,
+ 82, 82, 82, 82, 1370, 17, 17, 17, 17, 17,
+
+ 18, 18, 18, 18, 22, 22, 22, 22, 22, 29,
+ 29, 29, 29, 29, 30, 30, 30, 30, 30, 157,
+ 157, 157, 157, 404, 404, 18, 86, 48, 330, 86,
+ 136, 330, 136, 48, 136, 136, 136, 136, 48, 18,
+ 68, 86, 18, 86, 86, 86, 86, 406, 406, 68,
+ 86, 180, 180, 180, 172, 68, 172, 172, 172, 68,
+ 369, 48, 1371, 369, 48, 158, 48, 330, 435, 18,
+ 18, 18, 18, 18, 19, 68, 1372, 19, 48, 158,
+ 19, 435, 19, 19, 369, 48, 19, 19, 19, 19,
+ 19, 19, 19, 19, 19, 1373, 74, 158, 74, 19,
+
+ 74, 74, 74, 74, 1374, 68, 68, 68, 221, 221,
+ 221, 221, 74, 19, 75, 19, 23, 23, 23, 23,
+ 87, 1375, 87, 75, 87, 87, 87, 87, 1376, 75,
+ 74, 76, 199, 75, 416, 416, 87, 76, 83, 76,
+ 1381, 23, 76, 76, 76, 76, 76, 83, 173, 75,
+ 173, 173, 173, 83, 87, 23, 1382, 83, 23, 88,
+ 174, 417, 174, 174, 174, 417, 417, 181, 88, 181,
+ 181, 181, 1383, 83, 88, 275, 275, 275, 88, 75,
+ 75, 75, 199, 199, 199, 23, 23, 23, 23, 23,
+ 24, 24, 24, 24, 88, 1384, 76, 76, 76, 371,
+
+ 133, 371, 1385, 83, 83, 83, 133, 1386, 89, 236,
+ 236, 133, 236, 698, 89, 24, 89, 698, 698, 89,
+ 89, 89, 89, 89, 88, 88, 88, 204, 1387, 24,
+ 287, 287, 24, 287, 133, 710, 710, 133, 159, 133,
+ 159, 159, 159, 159, 1394, 182, 168, 182, 182, 182,
+ 1395, 133, 159, 204, 201, 985, 985, 168, 133, 24,
+ 24, 24, 24, 24, 25, 25, 25, 25, 335, 335,
+ 159, 335, 25, 89, 89, 89, 1396, 204, 204, 204,
+ 168, 25, 25, 25, 25, 168, 201, 1397, 201, 168,
+ 25, 25, 25, 25, 350, 350, 168, 350, 1398, 168,
+
+ 187, 168, 168, 187, 201, 201, 201, 25, 25, 25,
+ 25, 25, 25, 26, 26, 26, 26, 187, 187, 187,
+ 187, 26, 380, 177, 187, 380, 177, 986, 986, 177,
+ 26, 26, 26, 26, 177, 222, 222, 222, 222, 26,
+ 26, 26, 26, 1402, 183, 177, 202, 183, 1403, 186,
+ 183, 186, 186, 186, 186, 183, 26, 26, 26, 26,
+ 26, 26, 27, 27, 27, 27, 183, 27, 27, 216,
+ 1404, 27, 27, 27, 185, 27, 27, 185, 202, 27,
+ 27, 27, 27, 27, 27, 1409, 185, 345, 185, 185,
+ 345, 185, 185, 185, 185, 195, 202, 202, 202, 195,
+
+ 27, 195, 27, 27, 195, 195, 216, 1410, 1411, 188,
+ 27, 188, 208, 188, 188, 188, 188, 27, 1412, 216,
+ 216, 216, 27, 1413, 207, 188, 345, 27, 1417, 27,
+ 27, 28, 28, 28, 28, 1418, 28, 28, 206, 208,
+ 28, 28, 28, 188, 28, 28, 207, 1419, 28, 28,
+ 28, 28, 28, 28, 196, 426, 196, 426, 203, 196,
+ 196, 196, 208, 208, 208, 238, 238, 238, 206, 28,
+ 238, 28, 28, 362, 207, 207, 207, 227, 1420, 28,
+ 203, 227, 227, 227, 227, 362, 28, 203, 206, 206,
+ 206, 28, 362, 203, 381, 381, 28, 381, 28, 28,
+
+ 49, 1421, 382, 49, 49, 382, 1425, 49, 203, 203,
+ 203, 49, 49, 1426, 49, 214, 49, 49, 49, 49,
+ 49, 49, 385, 49, 49, 385, 49, 49, 49, 49,
+ 49, 49, 49, 49, 49, 49, 49, 49, 655, 49,
+ 655, 214, 1427, 49, 49, 49, 49, 49, 49, 49,
+ 49, 49, 49, 49, 49, 49, 49, 49, 49, 49,
+ 49, 49, 49, 49, 49, 214, 214, 214, 49, 1429,
+ 1430, 49, 49, 49, 59, 59, 59, 223, 1431, 223,
+ 1432, 223, 223, 223, 223, 233, 233, 233, 233, 1433,
+ 59, 59, 59, 223, 211, 1434, 225, 1435, 225, 1436,
+
+ 225, 225, 225, 225, 1439, 1440, 205, 315, 315, 315,
+ 209, 223, 225, 338, 338, 338, 59, 59, 338, 1441,
+ 59, 59, 244, 1442, 244, 244, 244, 244, 59, 211,
+ 225, 59, 209, 59, 1443, 59, 59, 69, 205, 205,
+ 205, 212, 1444, 69, 211, 211, 211, 210, 69, 69,
+ 69, 69, 69, 69, 69, 1445, 205, 205, 205, 1446,
+ 209, 209, 209, 69, 69, 69, 69, 69, 69, 210,
+ 368, 69, 213, 368, 69, 1447, 69, 377, 212, 1448,
+ 377, 212, 210, 215, 407, 368, 217, 407, 69, 1449,
+ 1450, 212, 212, 212, 1451, 69, 71, 210, 210, 210,
+
+ 249, 249, 249, 249, 251, 71, 1452, 71, 71, 71,
+ 71, 71, 213, 215, 437, 71, 377, 437, 215, 251,
+ 217, 1457, 213, 213, 213, 245, 245, 245, 245, 1458,
+ 1459, 71, 245, 215, 215, 215, 217, 217, 217, 1460,
+ 229, 1461, 229, 1462, 229, 229, 229, 229, 265, 265,
+ 265, 265, 231, 231, 231, 231, 229, 231, 231, 231,
+ 231, 71, 71, 71, 85, 297, 297, 297, 297, 251,
+ 251, 251, 1463, 85, 229, 85, 85, 85, 85, 85,
+ 256, 486, 661, 85, 486, 661, 243, 660, 660, 243,
+ 660, 256, 256, 256, 256, 1470, 1471, 256, 243, 85,
+
+ 243, 243, 1472, 243, 243, 243, 243, 269, 359, 359,
+ 359, 269, 269, 269, 269, 292, 1473, 292, 292, 292,
+ 292, 305, 305, 305, 305, 364, 364, 364, 364, 85,
+ 85, 85, 100, 100, 100, 100, 100, 100, 100, 100,
+ 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
+ 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
+ 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
+ 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
+ 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
+ 100, 100, 100, 100, 100, 100, 100, 100, 100, 100,
+
+ 100, 100, 100, 100, 100, 100, 100, 112, 112, 112,
+ 1474, 112, 388, 246, 112, 246, 321, 246, 246, 246,
+ 246, 247, 1478, 112, 112, 112, 388, 299, 309, 246,
+ 247, 1479, 309, 309, 309, 309, 247, 1480, 667, 321,
+ 247, 667, 299, 682, 388, 112, 682, 246, 112, 112,
+ 112, 321, 428, 112, 112, 1485, 247, 1486, 321, 428,
+ 697, 112, 697, 697, 112, 428, 112, 1487, 112, 112,
+ 122, 122, 122, 122, 666, 666, 248, 666, 1488, 122,
+ 122, 122, 122, 1489, 1493, 248, 247, 247, 247, 1494,
+ 1495, 248, 299, 299, 299, 248, 122, 122, 122, 122,
+
+ 122, 122, 129, 717, 129, 129, 717, 1496, 129, 129,
+ 129, 248, 1497, 129, 129, 129, 129, 250, 352, 352,
+ 352, 129, 370, 352, 370, 1501, 250, 370, 370, 370,
+ 252, 1502, 250, 1503, 129, 1505, 250, 129, 1506, 252,
+ 1507, 248, 248, 248, 403, 252, 403, 403, 403, 252,
+ 1508, 1509, 250, 418, 418, 418, 291, 681, 681, 291,
+ 681, 129, 130, 130, 130, 252, 130, 1510, 291, 130,
+ 291, 291, 1511, 291, 291, 291, 291, 1512, 130, 130,
+ 130, 422, 250, 250, 250, 1515, 130, 365, 365, 365,
+ 365, 1519, 257, 1520, 699, 252, 252, 252, 699, 699,
+
+ 130, 257, 1521, 130, 130, 130, 1523, 257, 130, 130,
+ 1525, 257, 374, 374, 374, 374, 130, 1527, 1528, 130,
+ 1529, 130, 1530, 130, 130, 160, 1535, 257, 160, 1536,
+ 160, 422, 422, 422, 160, 160, 160, 372, 160, 372,
+ 1537, 372, 372, 372, 372, 1543, 160, 272, 272, 272,
+ 272, 1544, 272, 272, 272, 272, 419, 257, 257, 257,
+ 419, 419, 419, 160, 272, 160, 160, 294, 1545, 294,
+ 1564, 294, 294, 294, 294, 390, 390, 390, 390, 1565,
+ 373, 1566, 272, 294, 373, 373, 373, 373, 1568, 1569,
+ 160, 1570, 160, 160, 200, 200, 200, 200, 200, 200,
+
+ 200, 294, 200, 1571, 200, 200, 200, 200, 200, 200,
+ 200, 200, 200, 228, 228, 228, 228, 228, 228, 228,
+ 228, 228, 228, 228, 228, 228, 228, 228, 228, 1573,
+ 228, 228, 228, 228, 228, 228, 228, 228, 228, 228,
+ 228, 228, 228, 228, 228, 228, 228, 228, 228, 228,
+ 228, 228, 228, 228, 228, 228, 228, 228, 228, 228,
+ 228, 228, 228, 228, 228, 228, 228, 228, 228, 228,
+ 228, 228, 228, 228, 228, 228, 228, 228, 228, 228,
+ 228, 228, 228, 228, 228, 228, 228, 228, 266, 430,
+ 430, 430, 1574, 443, 1579, 266, 1580, 266, 1581, 266,
+
+ 266, 266, 266, 266, 487, 487, 487, 266, 1582, 487,
+ 724, 266, 375, 724, 375, 273, 375, 375, 375, 375,
+ 724, 1583, 274, 266, 273, 443, 444, 276, 1003, 266,
+ 273, 274, 1003, 1003, 273, 1584, 276, 274, 512, 512,
+ 512, 274, 276, 443, 443, 443, 276, 387, 1588, 1589,
+ 273, 444, 1590, 266, 266, 266, 268, 274, 387, 387,
+ 387, 387, 276, 268, 387, 268, 1591, 268, 268, 268,
+ 268, 268, 534, 534, 534, 268, 444, 444, 444, 268,
+ 273, 273, 273, 293, 1592, 1596, 293, 274, 274, 274,
+ 1597, 1598, 276, 276, 276, 1599, 1600, 268, 293, 1601,
+
+ 293, 293, 293, 293, 391, 1602, 391, 293, 1603, 391,
+ 391, 391, 391, 409, 544, 544, 544, 409, 409, 409,
+ 409, 268, 268, 268, 270, 270, 270, 270, 270, 270,
+ 270, 270, 270, 270, 270, 270, 270, 270, 270, 270,
+ 1604, 270, 270, 270, 270, 270, 270, 270, 270, 270,
+ 270, 270, 270, 270, 270, 270, 270, 270, 270, 270,
+ 270, 270, 270, 270, 270, 270, 270, 270, 270, 270,
+ 270, 270, 270, 270, 270, 270, 270, 270, 270, 270,
+ 270, 270, 270, 270, 270, 270, 270, 270, 270, 270,
+ 270, 270, 270, 270, 270, 270, 270, 270, 270, 280,
+
+ 410, 410, 410, 410, 288, 1606, 445, 295, 280, 1607,
+ 447, 1608, 410, 288, 280, 653, 295, 653, 280, 288,
+ 653, 653, 295, 288, 1609, 1610, 295, 1611, 296, 775,
+ 410, 775, 775, 529, 280, 1612, 1613, 296, 1614, 288,
+ 298, 445, 295, 296, 1615, 447, 412, 296, 412, 298,
+ 1616, 412, 412, 412, 412, 298, 445, 445, 445, 298,
+ 447, 447, 447, 296, 280, 280, 280, 282, 1617, 288,
+ 288, 288, 295, 295, 295, 298, 282, 1619, 282, 282,
+ 282, 282, 282, 529, 529, 529, 282, 1620, 1625, 300,
+ 554, 554, 554, 296, 296, 296, 1626, 1627, 300, 1628,
+
+ 304, 1629, 282, 1630, 300, 298, 298, 298, 300, 304,
+ 1634, 459, 559, 559, 559, 304, 596, 596, 596, 304,
+ 470, 470, 470, 470, 300, 1635, 389, 1636, 389, 389,
+ 389, 389, 282, 282, 282, 304, 312, 312, 312, 312,
+ 389, 312, 312, 312, 312, 459, 392, 446, 392, 392,
+ 392, 392, 1637, 312, 300, 300, 300, 1638, 389, 1642,
+ 392, 459, 459, 459, 1643, 304, 304, 304, 306, 1644,
+ 1645, 312, 1646, 448, 1647, 306, 1648, 306, 392, 306,
+ 306, 306, 306, 306, 1649, 446, 446, 306, 449, 1650,
+ 1652, 306, 616, 616, 616, 313, 1653, 446, 446, 446,
+
+ 1654, 1655, 314, 306, 313, 448, 1656, 316, 1657, 306,
+ 313, 314, 1658, 454, 313, 449, 316, 314, 626, 626,
+ 626, 314, 316, 448, 448, 448, 316, 1659, 450, 1360,
+ 313, 1360, 1360, 306, 306, 306, 308, 314, 449, 449,
+ 449, 457, 316, 308, 1660, 308, 451, 308, 308, 308,
+ 308, 308, 454, 1662, 1664, 308, 1666, 1673, 450, 308,
+ 313, 313, 313, 454, 454, 454, 450, 314, 314, 314,
+ 1674, 1675, 316, 316, 316, 1680, 1681, 308, 450, 450,
+ 450, 473, 451, 1682, 457, 473, 473, 473, 473, 1687,
+ 1688, 457, 457, 457, 1689, 1694, 451, 451, 451, 1695,
+
+ 1696, 308, 308, 308, 310, 310, 310, 310, 310, 310,
+ 310, 310, 310, 310, 310, 310, 310, 310, 310, 310,
+ 1700, 310, 310, 310, 310, 310, 310, 310, 310, 310,
+ 310, 310, 310, 310, 310, 310, 310, 310, 310, 310,
+ 310, 310, 310, 310, 310, 310, 310, 310, 310, 310,
+ 310, 310, 310, 310, 310, 310, 310, 310, 310, 310,
+ 310, 310, 310, 310, 310, 310, 310, 310, 310, 310,
+ 310, 310, 310, 310, 310, 310, 310, 310, 310, 320,
+ 1701, 453, 1702, 1705, 327, 452, 1706, 1707, 320, 456,
+ 636, 636, 636, 327, 320, 641, 641, 641, 320, 327,
+
+ 411, 1708, 411, 327, 411, 411, 411, 411, 1709, 1710,
+ 452, 1711, 1712, 458, 320, 453, 411, 1713, 453, 327,
+ 1714, 463, 480, 480, 480, 480, 1715, 456, 1716, 461,
+ 1717, 453, 453, 453, 411, 452, 452, 452, 458, 456,
+ 456, 456, 464, 1718, 320, 320, 320, 322, 462, 327,
+ 327, 327, 465, 673, 673, 673, 322, 463, 322, 322,
+ 322, 322, 322, 458, 458, 458, 322, 460, 461, 1719,
+ 460, 463, 463, 463, 1720, 1721, 464, 460, 466, 461,
+ 461, 461, 322, 467, 1722, 465, 462, 1723, 460, 1724,
+ 1725, 674, 464, 464, 464, 674, 674, 674, 462, 462,
+
+ 462, 1726, 465, 465, 465, 483, 483, 483, 483, 692,
+ 692, 692, 322, 322, 322, 360, 360, 360, 360, 1727,
+ 1728, 466, 467, 1729, 360, 360, 360, 360, 466, 466,
+ 466, 1730, 1731, 467, 467, 467, 1732, 1740, 460, 460,
+ 460, 360, 360, 360, 360, 360, 360, 393, 541, 701,
+ 393, 1741, 393, 701, 701, 701, 393, 393, 393, 472,
+ 393, 472, 1742, 472, 472, 472, 472, 475, 393, 475,
+ 1748, 475, 475, 475, 475, 472, 484, 1749, 484, 484,
+ 484, 484, 1750, 475, 477, 393, 477, 393, 393, 477,
+ 477, 477, 477, 472, 485, 485, 485, 485, 541, 541,
+
+ 541, 475, 478, 1751, 478, 1752, 478, 478, 478, 478,
+ 1733, 1753, 393, 1754, 393, 393, 421, 1755, 478, 1756,
+ 421, 421, 421, 421, 491, 491, 491, 491, 1733, 421,
+ 421, 421, 421, 482, 1757, 482, 478, 1758, 482, 482,
+ 482, 482, 503, 503, 503, 503, 421, 421, 421, 421,
+ 421, 421, 455, 455, 455, 455, 455, 611, 455, 455,
+ 1347, 455, 455, 455, 1346, 492, 455, 1337, 455, 492,
+ 492, 492, 492, 757, 455, 455, 757, 1336, 455, 1335,
+ 494, 1325, 494, 757, 494, 494, 494, 494, 802, 802,
+ 802, 455, 1792, 455, 455, 455, 494, 495, 1792, 495,
+
+ 1324, 1323, 495, 495, 495, 495, 531, 611, 611, 611,
+ 531, 531, 531, 531, 494, 806, 806, 806, 455, 455,
+ 455, 1318, 455, 455, 455, 455, 455, 471, 471, 471,
+ 471, 471, 471, 471, 471, 471, 471, 471, 471, 471,
+ 471, 471, 471, 1317, 471, 471, 471, 471, 471, 471,
+ 471, 471, 471, 471, 471, 471, 471, 471, 471, 471,
+ 471, 471, 471, 471, 471, 471, 471, 471, 471, 471,
+ 471, 471, 471, 471, 471, 471, 471, 471, 471, 471,
+ 471, 471, 471, 471, 471, 471, 471, 471, 471, 471,
+ 471, 471, 471, 471, 471, 471, 471, 471, 471, 471,
+
+ 471, 471, 493, 575, 575, 575, 575, 1316, 1307, 496,
+ 1305, 623, 510, 493, 493, 493, 493, 493, 496, 1304,
+ 497, 493, 1302, 498, 496, 493, 1788, 510, 496, 497,
+ 1788, 499, 498, 1300, 1299, 497, 1788, 1297, 498, 497,
+ 499, 1296, 498, 493, 496, 504, 499, 510, 1295, 1294,
+ 499, 662, 662, 662, 504, 497, 662, 1291, 498, 1813,
+ 504, 623, 623, 623, 504, 1813, 499, 493, 493, 493,
+ 587, 587, 587, 587, 496, 496, 496, 510, 510, 510,
+ 504, 823, 823, 823, 505, 497, 497, 497, 498, 498,
+ 498, 1007, 1008, 505, 1007, 1008, 499, 499, 499, 505,
+
+ 535, 1007, 1008, 505, 1290, 506, 1018, 1289, 520, 1018,
+ 504, 504, 504, 521, 506, 535, 1018, 520, 532, 505,
+ 506, 1288, 521, 520, 506, 1287, 522, 520, 521, 1286,
+ 1814, 545, 521, 532, 1278, 522, 1814, 532, 822, 1277,
+ 506, 522, 1276, 520, 1275, 522, 545, 1274, 521, 505,
+ 505, 505, 528, 528, 528, 528, 1273, 528, 528, 528,
+ 528, 522, 827, 827, 827, 535, 535, 535, 1272, 528,
+ 506, 506, 506, 520, 520, 520, 1822, 1271, 521, 521,
+ 521, 1270, 1822, 532, 532, 532, 1269, 528, 822, 822,
+ 822, 522, 522, 522, 526, 1268, 545, 545, 545, 1267,
+
+ 1265, 526, 1263, 526, 1262, 526, 526, 526, 526, 526,
+ 668, 668, 668, 526, 1828, 668, 1831, 526, 1831, 536,
+ 1828, 536, 1831, 1261, 536, 536, 536, 536, 536, 832,
+ 832, 832, 540, 1257, 540, 526, 540, 540, 540, 540,
+ 672, 672, 672, 672, 1256, 546, 1255, 546, 540, 1248,
+ 546, 546, 546, 546, 546, 594, 837, 837, 837, 526,
+ 526, 526, 527, 864, 864, 864, 540, 1247, 617, 527,
+ 594, 527, 1246, 527, 527, 527, 527, 527, 536, 536,
+ 536, 527, 550, 617, 550, 527, 550, 550, 550, 550,
+ 594, 680, 680, 680, 680, 576, 829, 527, 550, 576,
+
+ 576, 576, 576, 527, 546, 546, 546, 579, 1031, 579,
+ 1236, 1031, 579, 579, 579, 579, 550, 552, 1031, 702,
+ 594, 594, 594, 702, 702, 702, 552, 527, 527, 527,
+ 533, 1234, 552, 617, 617, 617, 552, 533, 1233, 533,
+ 1232, 533, 533, 533, 533, 533, 829, 829, 829, 533,
+ 1231, 1230, 552, 533, 578, 1227, 578, 553, 578, 578,
+ 578, 578, 654, 1226, 654, 533, 553, 654, 654, 654,
+ 578, 533, 553, 613, 1225, 1874, 553, 613, 613, 613,
+ 613, 1874, 552, 552, 552, 555, 1224, 1223, 578, 1817,
+ 1222, 830, 553, 1817, 555, 533, 533, 533, 543, 1817,
+
+ 555, 1221, 1877, 627, 555, 543, 1217, 543, 1877, 543,
+ 543, 543, 543, 543, 906, 906, 906, 543, 627, 1216,
+ 555, 543, 553, 553, 553, 565, 686, 686, 686, 686,
+ 614, 1215, 1213, 543, 565, 910, 910, 910, 566, 543,
+ 565, 830, 830, 830, 565, 614, 1212, 566, 1211, 614,
+ 555, 555, 555, 566, 927, 927, 927, 566, 1210, 1209,
+ 565, 1878, 1207, 543, 543, 543, 551, 1878, 627, 627,
+ 627, 1206, 1870, 566, 567, 551, 1870, 551, 551, 551,
+ 551, 551, 1870, 567, 1205, 551, 931, 931, 931, 567,
+ 565, 565, 565, 567, 1928, 614, 614, 614, 1204, 580,
+
+ 1928, 551, 581, 566, 566, 566, 1931, 1203, 580, 567,
+ 1202, 581, 1931, 1033, 580, 1201, 1033, 581, 580, 1200,
+ 678, 581, 678, 1033, 678, 678, 678, 678, 936, 936,
+ 936, 551, 551, 551, 580, 1880, 1199, 581, 1880, 567,
+ 567, 567, 571, 679, 1880, 679, 1198, 679, 679, 679,
+ 679, 571, 926, 571, 571, 571, 571, 571, 941, 941,
+ 941, 571, 1197, 1195, 580, 580, 580, 581, 581, 581,
+ 582, 685, 685, 685, 685, 1194, 1932, 571, 583, 582,
+ 933, 588, 1932, 685, 1193, 582, 1974, 583, 1035, 582,
+ 588, 1035, 1974, 583, 1192, 1191, 588, 583, 1035, 1190,
+
+ 588, 685, 926, 926, 926, 582, 1189, 571, 571, 571,
+ 577, 1188, 1871, 583, 1871, 1187, 588, 1046, 1871, 589,
+ 1046, 577, 577, 577, 577, 577, 1180, 1046, 589, 577,
+ 933, 933, 933, 577, 589, 582, 582, 582, 589, 687,
+ 687, 687, 687, 583, 583, 583, 588, 588, 588, 1179,
+ 1072, 577, 590, 1072, 589, 602, 769, 769, 769, 769,
+ 1072, 590, 1975, 603, 602, 1178, 1177, 590, 1975, 1176,
+ 602, 590, 603, 2028, 602, 577, 577, 577, 603, 2028,
+ 604, 1175, 603, 1174, 589, 589, 589, 590, 1173, 604,
+ 602, 774, 774, 774, 774, 604, 1172, 1171, 603, 604,
+
+ 777, 1170, 777, 777, 777, 777, 610, 610, 610, 610,
+ 2029, 610, 610, 610, 610, 604, 2029, 590, 590, 590,
+ 602, 602, 602, 610, 782, 782, 782, 782, 603, 603,
+ 603, 618, 1293, 618, 1169, 1293, 618, 618, 618, 618,
+ 618, 610, 1293, 934, 1167, 604, 604, 604, 608, 831,
+ 831, 831, 831, 1165, 860, 608, 1164, 608, 1163, 608,
+ 608, 608, 608, 608, 968, 968, 968, 608, 622, 860,
+ 622, 608, 622, 622, 622, 622, 886, 886, 886, 886,
+ 696, 696, 696, 696, 622, 696, 696, 696, 696, 608,
+ 618, 618, 618, 934, 934, 934, 987, 987, 987, 628,
+
+ 1301, 628, 622, 1301, 628, 628, 628, 628, 628, 1159,
+ 1301, 800, 1158, 608, 608, 608, 609, 1048, 1157, 860,
+ 860, 860, 964, 609, 1150, 609, 800, 609, 609, 609,
+ 609, 609, 988, 988, 988, 609, 632, 964, 632, 609,
+ 632, 632, 632, 632, 1313, 732, 800, 1313, 732, 1048,
+ 1039, 609, 632, 1149, 1313, 732, 1148, 609, 628, 628,
+ 628, 1138, 768, 768, 768, 768, 732, 1048, 1048, 1048,
+ 632, 634, 1136, 1135, 768, 1134, 800, 800, 800, 1039,
+ 634, 609, 609, 609, 615, 1133, 634, 964, 964, 964,
+ 634, 615, 768, 615, 1132, 615, 615, 615, 615, 615,
+
+ 1039, 1039, 1039, 615, 1129, 1038, 634, 615, 694, 1128,
+ 694, 635, 694, 694, 694, 694, 732, 732, 732, 615,
+ 635, 1098, 1098, 1098, 694, 615, 635, 770, 1127, 770,
+ 635, 770, 770, 770, 770, 1126, 634, 634, 634, 637,
+ 1125, 1124, 694, 1038, 1123, 1119, 635, 1118, 637, 615,
+ 615, 615, 625, 1117, 637, 1038, 1038, 1038, 637, 625,
+ 1115, 625, 1114, 625, 625, 625, 625, 625, 1110, 1110,
+ 1110, 625, 1113, 1112, 637, 625, 635, 635, 635, 647,
+ 1321, 733, 1111, 1321, 733, 1109, 1326, 625, 647, 1326,
+ 1321, 733, 648, 625, 647, 801, 1326, 1872, 647, 1872,
+
+ 1108, 648, 733, 1872, 637, 637, 637, 648, 1107, 1106,
+ 801, 648, 1105, 1104, 647, 1103, 1102, 625, 625, 625,
+ 633, 845, 845, 845, 845, 845, 1101, 648, 649, 633,
+ 801, 633, 633, 633, 633, 633, 993, 649, 1100, 633,
+ 993, 993, 993, 649, 647, 647, 647, 649, 935, 935,
+ 935, 935, 733, 733, 733, 633, 1099, 648, 648, 648,
+ 801, 801, 801, 649, 695, 1097, 695, 1096, 695, 695,
+ 695, 695, 1116, 1116, 1116, 845, 845, 845, 734, 1095,
+ 695, 734, 1122, 1122, 1122, 633, 633, 633, 734, 1001,
+ 1001, 1001, 1001, 649, 649, 649, 656, 1094, 695, 734,
+
+ 1093, 1001, 1092, 736, 1091, 656, 736, 656, 656, 656,
+ 656, 656, 1090, 736, 1089, 656, 1069, 1068, 735, 1001,
+ 1067, 735, 1059, 734, 736, 1168, 1168, 1168, 735, 1058,
+ 1057, 656, 1032, 1030, 738, 1029, 995, 738, 995, 735,
+ 995, 995, 995, 995, 738, 1196, 1196, 1196, 736, 734,
+ 734, 734, 773, 1028, 773, 738, 1027, 773, 773, 773,
+ 773, 656, 656, 656, 676, 735, 1026, 1025, 676, 676,
+ 676, 676, 1024, 1023, 736, 736, 736, 676, 676, 676,
+ 676, 1022, 1328, 737, 1021, 1328, 737, 738, 1020, 735,
+ 735, 735, 1328, 737, 676, 676, 676, 676, 676, 676,
+
+ 704, 704, 704, 704, 737, 738, 738, 738, 1019, 704,
+ 704, 704, 704, 739, 1004, 1037, 739, 1017, 1004, 1004,
+ 1004, 1016, 740, 739, 1049, 740, 704, 704, 704, 704,
+ 704, 704, 740, 1015, 739, 1311, 1014, 742, 1311, 737,
+ 742, 741, 1013, 740, 741, 1311, 1037, 742, 1012, 1330,
+ 743, 741, 1330, 743, 737, 737, 737, 1011, 742, 1330,
+ 743, 1010, 741, 1049, 739, 1037, 1037, 1037, 841, 745,
+ 740, 743, 745, 1009, 1049, 1049, 1049, 744, 1006, 745,
+ 744, 996, 1311, 841, 739, 739, 739, 744, 741, 992,
+ 745, 984, 983, 740, 740, 740, 746, 742, 744, 746,
+
+ 1208, 1208, 1208, 841, 982, 981, 746, 980, 742, 742,
+ 742, 976, 741, 741, 741, 748, 975, 746, 748, 974,
+ 744, 743, 743, 743, 776, 748, 776, 973, 745, 776,
+ 776, 776, 776, 841, 841, 841, 748, 1214, 1214, 1214,
+ 745, 745, 745, 1220, 1220, 1220, 746, 972, 744, 744,
+ 744, 753, 971, 970, 753, 759, 969, 967, 759, 966,
+ 965, 753, 952, 756, 951, 759, 756, 746, 746, 746,
+ 948, 947, 753, 756, 946, 754, 759, 944, 754, 1040,
+ 1080, 1080, 1080, 1080, 756, 754, 748, 748, 748, 749,
+ 749, 749, 749, 749, 749, 749, 754, 749, 943, 749,
+
+ 749, 749, 749, 749, 749, 749, 749, 749, 942, 846,
+ 756, 753, 759, 846, 846, 846, 846, 1040, 1045, 754,
+ 940, 939, 753, 753, 753, 846, 759, 759, 759, 1040,
+ 1040, 1040, 938, 930, 756, 756, 756, 1077, 929, 1077,
+ 1077, 1077, 1077, 846, 928, 924, 754, 754, 754, 755,
+ 755, 755, 755, 755, 923, 755, 755, 922, 755, 755,
+ 755, 1045, 921, 755, 760, 755, 920, 760, 1045, 1045,
+ 1045, 755, 755, 854, 760, 755, 916, 854, 854, 854,
+ 854, 1266, 1266, 1266, 762, 760, 915, 762, 755, 854,
+ 755, 755, 755, 767, 762, 767, 914, 767, 767, 767,
+
+ 767, 913, 912, 755, 911, 762, 909, 854, 1081, 767,
+ 1081, 1081, 1081, 1081, 760, 755, 755, 755, 908, 755,
+ 755, 755, 755, 755, 851, 907, 851, 767, 904, 851,
+ 851, 851, 851, 762, 903, 760, 760, 760, 761, 761,
+ 761, 761, 761, 904, 761, 761, 902, 761, 761, 761,
+ 1042, 901, 761, 900, 761, 762, 762, 762, 899, 895,
+ 761, 761, 764, 904, 761, 764, 763, 894, 893, 763,
+ 892, 891, 764, 1050, 882, 765, 763, 761, 765, 761,
+ 761, 761, 880, 764, 1042, 765, 761, 763, 853, 853,
+ 853, 853, 853, 904, 904, 904, 765, 879, 878, 1050,
+
+ 1042, 1042, 1042, 877, 761, 761, 761, 876, 761, 761,
+ 761, 761, 761, 763, 955, 872, 955, 871, 870, 955,
+ 955, 955, 955, 1050, 1050, 1050, 765, 1082, 1082, 1082,
+ 1082, 869, 868, 764, 764, 764, 867, 763, 763, 763,
+ 866, 865, 853, 853, 853, 863, 765, 765, 765, 771,
+ 771, 771, 771, 771, 771, 771, 771, 771, 771, 771,
+ 771, 771, 771, 771, 771, 862, 771, 771, 771, 771,
+ 771, 771, 771, 771, 771, 771, 771, 771, 771, 771,
+ 771, 771, 771, 771, 771, 771, 771, 771, 771, 771,
+ 771, 771, 771, 771, 771, 771, 771, 771, 771, 771,
+
+ 771, 771, 771, 771, 771, 771, 771, 771, 771, 771,
+ 771, 771, 771, 771, 771, 771, 771, 771, 771, 771,
+ 771, 771, 771, 771, 772, 861, 772, 905, 772, 772,
+ 772, 772, 779, 1052, 779, 848, 779, 779, 779, 779,
+ 772, 847, 905, 844, 781, 1054, 781, 843, 779, 781,
+ 781, 781, 781, 781, 784, 1424, 1424, 1424, 772, 1052,
+ 842, 1315, 905, 784, 1315, 1333, 779, 780, 1333, 784,
+ 840, 1315, 1064, 784, 780, 1333, 780, 839, 780, 780,
+ 780, 780, 780, 1052, 1052, 1052, 780, 838, 836, 784,
+ 780, 835, 905, 905, 905, 1054, 1054, 1054, 783, 1428,
+
+ 1428, 1428, 780, 781, 781, 781, 1315, 783, 780, 783,
+ 783, 783, 783, 783, 834, 826, 785, 783, 1056, 784,
+ 784, 784, 1064, 1064, 1064, 785, 825, 786, 1500, 1500,
+ 1500, 785, 780, 780, 780, 785, 786, 824, 792, 820,
+ 1056, 793, 786, 819, 818, 1338, 786, 792, 1338, 817,
+ 793, 785, 794, 792, 816, 1338, 793, 792, 812, 811,
+ 793, 794, 786, 783, 783, 783, 810, 794, 1056, 1056,
+ 1056, 794, 809, 792, 1061, 1339, 793, 808, 1339, 807,
+ 813, 785, 785, 785, 805, 1339, 804, 794, 1319, 813,
+ 803, 1319, 786, 786, 786, 813, 945, 799, 1319, 813,
+
+ 798, 814, 797, 792, 792, 792, 793, 793, 793, 796,
+ 814, 945, 795, 815, 1061, 813, 814, 794, 794, 794,
+ 814, 791, 815, 790, 1061, 1061, 1061, 789, 815, 788,
+ 1329, 945, 815, 1329, 1339, 1319, 814, 850, 787, 850,
+ 1329, 850, 850, 850, 850, 813, 813, 813, 815, 833,
+ 778, 833, 766, 850, 833, 833, 833, 833, 833, 752,
+ 751, 945, 945, 945, 750, 731, 814, 814, 814, 950,
+ 730, 850, 729, 950, 950, 950, 950, 728, 815, 815,
+ 815, 821, 727, 1329, 726, 950, 725, 723, 821, 722,
+ 821, 721, 821, 821, 821, 821, 821, 1504, 1504, 1504,
+
+ 821, 720, 718, 950, 821, 1605, 1605, 1605, 833, 833,
+ 833, 1141, 1141, 1141, 1141, 855, 821, 716, 856, 1651,
+ 1651, 1651, 821, 715, 855, 1340, 713, 856, 1340, 1344,
+ 855, 712, 1344, 856, 855, 1340, 857, 856, 857, 1344,
+ 857, 857, 857, 857, 1066, 711, 821, 821, 821, 828,
+ 855, 709, 857, 856, 708, 707, 828, 1070, 828, 706,
+ 828, 828, 828, 828, 828, 705, 1066, 703, 828, 700,
+ 857, 883, 828, 883, 690, 883, 883, 883, 883, 689,
+ 855, 855, 855, 856, 856, 856, 688, 883, 671, 1070,
+ 828, 670, 665, 664, 1066, 1066, 1066, 1239, 1239, 1239,
+
+ 1239, 1352, 659, 1517, 1352, 883, 1517, 1070, 1070, 1070,
+ 658, 1352, 657, 1517, 828, 828, 828, 849, 849, 849,
+ 849, 849, 849, 849, 849, 849, 849, 849, 849, 849,
+ 849, 849, 849, 652, 849, 849, 849, 849, 849, 849,
+ 849, 849, 849, 849, 849, 849, 849, 849, 849, 849,
+ 849, 849, 849, 849, 849, 849, 849, 849, 849, 849,
+ 849, 849, 849, 849, 849, 849, 849, 849, 849, 849,
+ 849, 849, 849, 849, 849, 849, 849, 849, 849, 849,
+ 849, 849, 849, 849, 849, 849, 849, 849, 849, 849,
+ 849, 849, 858, 1358, 1358, 1358, 1358, 651, 650, 859,
+
+ 646, 858, 1130, 858, 858, 858, 858, 858, 859, 645,
+ 873, 858, 644, 874, 859, 643, 642, 1130, 859, 873,
+ 640, 875, 874, 1350, 639, 873, 1350, 858, 874, 873,
+ 875, 1074, 874, 1350, 859, 638, 875, 1130, 631, 1044,
+ 875, 630, 1044, 629, 624, 873, 621, 620, 874, 1044,
+ 619, 949, 949, 949, 949, 949, 875, 858, 858, 858,
+ 1044, 612, 607, 1074, 859, 859, 859, 1130, 1130, 1130,
+ 1350, 606, 605, 601, 600, 873, 873, 873, 874, 874,
+ 874, 1074, 1074, 1074, 599, 598, 875, 875, 875, 881,
+ 957, 957, 957, 957, 957, 597, 595, 593, 881, 592,
+
+ 881, 881, 881, 881, 881, 949, 949, 949, 881, 591,
+ 1044, 1044, 1044, 586, 885, 1522, 885, 887, 1522, 885,
+ 885, 885, 885, 885, 881, 1522, 887, 585, 887, 887,
+ 887, 887, 887, 954, 584, 954, 887, 954, 954, 954,
+ 954, 574, 573, 888, 957, 957, 957, 572, 570, 954,
+ 1524, 569, 888, 1524, 881, 881, 881, 884, 888, 568,
+ 1524, 564, 888, 563, 884, 562, 884, 954, 884, 884,
+ 884, 884, 884, 885, 885, 885, 884, 561, 888, 560,
+ 884, 889, 887, 887, 887, 558, 890, 557, 556, 549,
+ 889, 548, 884, 547, 1060, 890, 889, 1060, 884, 542,
+
+ 889, 890, 539, 1526, 1060, 890, 1526, 538, 888, 888,
+ 888, 537, 530, 1526, 525, 1060, 889, 524, 523, 896,
+ 517, 890, 884, 884, 884, 1076, 897, 1076, 896, 516,
+ 1076, 1076, 1076, 1076, 896, 897, 515, 514, 896, 513,
+ 898, 897, 511, 509, 508, 897, 889, 889, 889, 898,
+ 507, 890, 890, 890, 896, 898, 502, 501, 500, 898,
+ 1331, 897, 917, 1331, 490, 1060, 1060, 1060, 489, 469,
+ 1331, 917, 468, 1342, 1533, 898, 1342, 917, 442, 918,
+ 441, 917, 439, 1342, 896, 896, 896, 438, 918, 436,
+ 434, 897, 897, 897, 918, 1131, 433, 917, 918, 432,
+
+ 919, 1538, 431, 429, 1538, 898, 898, 898, 427, 919,
+ 1131, 1538, 425, 424, 918, 919, 958, 423, 1331, 919,
+ 958, 958, 958, 958, 1533, 1533, 1533, 917, 917, 917,
+ 1131, 396, 958, 1342, 937, 919, 937, 395, 394, 937,
+ 937, 937, 937, 937, 918, 918, 918, 376, 356, 355,
+ 958, 1079, 343, 1079, 959, 342, 1079, 1079, 1079, 1079,
+ 1131, 1131, 1131, 959, 329, 919, 919, 919, 925, 959,
+ 328, 326, 325, 959, 324, 925, 319, 925, 318, 925,
+ 925, 925, 925, 925, 317, 303, 302, 925, 301, 959,
+ 290, 925, 289, 937, 937, 937, 960, 286, 1152, 1152,
+
+ 1152, 1152, 1152, 925, 285, 960, 284, 1349, 281, 925,
+ 1349, 960, 279, 278, 277, 960, 255, 1349, 254, 959,
+ 959, 959, 961, 1541, 961, 1166, 961, 961, 961, 961,
+ 253, 960, 242, 925, 925, 925, 932, 241, 961, 220,
+ 1166, 219, 218, 932, 1562, 932, 176, 932, 932, 932,
+ 932, 932, 1152, 1152, 1152, 932, 961, 166, 164, 932,
+ 1166, 960, 960, 960, 1002, 163, 1002, 1349, 1002, 1002,
+ 1002, 1002, 162, 1541, 1541, 1541, 161, 932, 153, 147,
+ 1002, 1285, 1285, 1285, 1285, 141, 1285, 1285, 1285, 1285,
+ 1166, 1166, 1166, 137, 1562, 1562, 1562, 128, 1002, 126,
+
+ 125, 932, 932, 932, 953, 953, 953, 953, 953, 953,
+ 953, 953, 953, 953, 953, 953, 953, 953, 953, 953,
+ 124, 953, 953, 953, 953, 953, 953, 953, 953, 953,
+ 953, 953, 953, 953, 953, 953, 953, 953, 953, 953,
+ 953, 953, 953, 953, 953, 953, 953, 953, 953, 953,
+ 953, 953, 953, 953, 953, 953, 953, 953, 953, 953,
+ 953, 953, 953, 953, 953, 953, 953, 953, 953, 953,
+ 953, 953, 953, 953, 953, 953, 953, 953, 953, 962,
+ 1567, 119, 1567, 1567, 1567, 1567, 963, 116, 962, 115,
+ 962, 962, 962, 962, 962, 963, 114, 977, 962, 110,
+
+ 978, 963, 106, 1228, 104, 963, 977, 103, 979, 978,
+ 1549, 102, 977, 1549, 962, 978, 977, 979, 1228, 978,
+ 1549, 963, 97, 979, 1075, 93, 1075, 979, 1075, 1075,
+ 1075, 1075, 977, 92, 91, 978, 84, 81, 1228, 1552,
+ 1075, 80, 1552, 979, 962, 962, 962, 1555, 79, 1552,
+ 1555, 963, 963, 963, 1547, 72, 66, 1555, 1075, 65,
+ 64, 50, 977, 977, 977, 978, 978, 978, 1228, 1228,
+ 1228, 46, 37, 979, 979, 979, 991, 1250, 1250, 1250,
+ 1250, 1250, 36, 33, 32, 991, 31, 991, 991, 991,
+ 991, 991, 1084, 1547, 1084, 991, 1084, 1084, 1084, 1084,
+
+ 1086, 0, 1551, 1087, 1547, 1547, 1547, 1669, 1084, 1086,
+ 1669, 991, 1087, 1703, 0, 1086, 1703, 1669, 1087, 1086,
+ 0, 1088, 1087, 1703, 1735, 0, 1084, 1735, 0, 0,
+ 1088, 1250, 1250, 1250, 1735, 1086, 1088, 0, 1087, 0,
+ 1088, 991, 991, 991, 994, 1551, 0, 0, 994, 994,
+ 994, 994, 1551, 1551, 1551, 0, 1088, 994, 994, 994,
+ 994, 0, 0, 0, 1557, 1086, 1086, 1086, 1087, 1087,
+ 1087, 0, 0, 0, 994, 994, 994, 994, 994, 994,
+ 997, 997, 1671, 997, 0, 997, 1088, 1088, 1088, 997,
+ 997, 997, 1137, 997, 0, 0, 1137, 1137, 1137, 1137,
+
+ 0, 997, 0, 1557, 1121, 0, 1121, 0, 1137, 1121,
+ 1121, 1121, 1121, 1121, 1557, 1557, 1557, 0, 997, 0,
+ 997, 997, 1140, 0, 1140, 0, 1137, 1140, 1140, 1140,
+ 1140, 1140, 1671, 1671, 1671, 1143, 0, 0, 1229, 1143,
+ 1143, 1143, 1143, 0, 0, 997, 0, 997, 997, 998,
+ 998, 1143, 998, 1229, 998, 0, 0, 1144, 998, 998,
+ 998, 1678, 998, 1121, 1121, 1121, 1144, 0, 0, 1143,
+ 998, 1264, 1144, 1229, 1743, 0, 1144, 1743, 0, 0,
+ 0, 1140, 1140, 1140, 1743, 0, 1264, 998, 0, 998,
+ 998, 1182, 1144, 1182, 0, 1182, 1182, 1182, 1182, 0,
+
+ 0, 0, 0, 1229, 1229, 1229, 1264, 1182, 0, 0,
+ 0, 1678, 1678, 1678, 998, 0, 998, 998, 1005, 1005,
+ 1005, 1005, 1144, 1144, 1144, 1182, 0, 1005, 1005, 1005,
+ 1005, 1379, 1379, 1379, 1379, 1379, 1264, 1264, 1264, 0,
+ 0, 0, 0, 0, 1005, 1005, 1005, 1005, 1005, 1005,
+ 1041, 1041, 1041, 1041, 1041, 0, 1041, 1041, 0, 1041,
+ 1041, 1041, 0, 1359, 1041, 1359, 1041, 1359, 1359, 1359,
+ 1359, 0, 1041, 1041, 1235, 0, 1041, 0, 1235, 1235,
+ 1235, 1235, 0, 0, 0, 1379, 1379, 1379, 1142, 1041,
+ 1235, 1041, 1041, 1041, 1685, 1145, 0, 1142, 1041, 1142,
+
+ 1142, 1142, 1142, 1142, 1145, 0, 1692, 1142, 1235, 0,
+ 1145, 0, 0, 0, 1145, 0, 1041, 1041, 1041, 0,
+ 1041, 1041, 1041, 1041, 1041, 1043, 1043, 1043, 1043, 1043,
+ 1145, 1043, 1043, 0, 1043, 1043, 1043, 0, 0, 1043,
+ 0, 1043, 0, 0, 1685, 1685, 1685, 1043, 1043, 0,
+ 0, 1043, 0, 1142, 1142, 1142, 1692, 1692, 1692, 0,
+ 1145, 1145, 1145, 0, 1043, 0, 1043, 1043, 1043, 1219,
+ 1146, 1219, 0, 0, 1219, 1219, 1219, 1219, 1219, 1146,
+ 0, 1698, 0, 0, 0, 1146, 0, 0, 0, 1146,
+ 0, 1043, 1043, 1043, 1738, 1043, 1043, 1043, 1043, 1043,
+
+ 1051, 1051, 1051, 1051, 1051, 1146, 1051, 1051, 0, 1051,
+ 1051, 1051, 1746, 0, 1051, 0, 1051, 0, 0, 0,
+ 0, 0, 1051, 1051, 0, 0, 1051, 0, 1219, 1219,
+ 1219, 1698, 1698, 1698, 0, 1146, 1146, 1146, 0, 1051,
+ 0, 1051, 1051, 1051, 1738, 1738, 1738, 0, 0, 0,
+ 0, 0, 1238, 0, 1238, 0, 0, 1238, 1238, 1238,
+ 1238, 1238, 1746, 1746, 1746, 0, 1051, 1051, 1051, 0,
+ 1051, 1051, 1051, 1051, 1051, 1055, 1055, 1055, 1055, 1055,
+ 1055, 1055, 0, 1055, 1422, 1055, 1055, 1055, 1055, 1055,
+ 1055, 1055, 1055, 1055, 1062, 1062, 1062, 1062, 1062, 1422,
+
+ 1062, 1062, 0, 1062, 1062, 1062, 0, 0, 1062, 0,
+ 1062, 1238, 1238, 1238, 0, 0, 1062, 1062, 0, 1422,
+ 1062, 0, 0, 1147, 0, 0, 0, 0, 0, 0,
+ 0, 0, 1147, 1062, 0, 1062, 1062, 1062, 1147, 0,
+ 1241, 0, 1147, 0, 1241, 1241, 1241, 1241, 0, 1422,
+ 1422, 1422, 0, 0, 0, 0, 1241, 0, 1147, 0,
+ 1062, 1062, 1062, 0, 1062, 1062, 1062, 1062, 1062, 1071,
+ 1071, 1071, 1071, 1071, 1241, 1071, 1071, 0, 1071, 1071,
+ 1071, 0, 0, 1071, 1151, 1071, 0, 1153, 1147, 1147,
+ 1147, 1071, 1071, 1151, 0, 1071, 1153, 0, 0, 1151,
+
+ 0, 0, 1153, 1151, 0, 0, 1153, 0, 1071, 0,
+ 1071, 1071, 1071, 1759, 1759, 1759, 0, 0, 0, 1151,
+ 0, 0, 1153, 0, 0, 0, 0, 0, 0, 0,
+ 1423, 1759, 1759, 1759, 1759, 1071, 1071, 1071, 0, 1071,
+ 1071, 1071, 1071, 1071, 1083, 1423, 0, 0, 0, 1151,
+ 1151, 1151, 1153, 1153, 1153, 1083, 1083, 1083, 1083, 1083,
+ 0, 0, 0, 1083, 0, 1423, 0, 1083, 1154, 0,
+ 0, 1156, 0, 0, 0, 0, 0, 1154, 0, 1160,
+ 1156, 0, 0, 1154, 0, 1083, 1156, 1154, 1160, 0,
+ 1156, 0, 0, 0, 1160, 1423, 1423, 1423, 1160, 0,
+
+ 0, 0, 0, 1154, 0, 0, 1156, 0, 0, 1083,
+ 1083, 1083, 1085, 0, 1160, 0, 0, 1498, 0, 0,
+ 0, 1085, 0, 1085, 1085, 1085, 1085, 1085, 0, 0,
+ 0, 1085, 1498, 1154, 1154, 1154, 1156, 1156, 1156, 1161,
+ 1560, 0, 0, 1560, 1160, 1160, 1160, 1085, 1161, 0,
+ 1560, 1162, 1498, 0, 1161, 0, 0, 0, 1161, 0,
+ 1162, 1560, 0, 0, 0, 0, 1162, 0, 0, 0,
+ 1162, 0, 0, 0, 1161, 0, 0, 1085, 1085, 1085,
+ 1120, 0, 1498, 1498, 1498, 0, 1162, 1120, 0, 1120,
+ 0, 1120, 1120, 1120, 1120, 1120, 0, 0, 0, 1120,
+
+ 0, 0, 0, 1120, 1161, 1161, 1161, 0, 0, 0,
+ 0, 1560, 1560, 1560, 1184, 1120, 1162, 1162, 1162, 1185,
+ 0, 1120, 0, 1184, 0, 0, 0, 0, 1185, 1184,
+ 0, 0, 0, 1184, 1185, 1284, 0, 1284, 1185, 1284,
+ 1284, 1284, 1284, 0, 0, 1120, 1120, 1120, 1155, 1184,
+ 0, 1284, 0, 0, 1185, 1186, 0, 1155, 0, 1155,
+ 1155, 1155, 1155, 1155, 1186, 0, 0, 1155, 0, 1284,
+ 1186, 1380, 0, 0, 1186, 1380, 1380, 1380, 1380, 1184,
+ 1184, 1184, 1240, 1155, 1185, 1185, 1185, 1380, 0, 1242,
+ 1186, 1240, 0, 1240, 1240, 1240, 1240, 1240, 1242, 0,
+
+ 0, 1240, 0, 0, 1242, 1380, 0, 0, 1242, 0,
+ 0, 0, 0, 1155, 1155, 1155, 1181, 0, 0, 0,
+ 1186, 1186, 1186, 1243, 1242, 0, 0, 1181, 1181, 1181,
+ 1181, 1181, 1243, 0, 0, 1181, 0, 0, 1243, 1181,
+ 0, 0, 1243, 0, 1244, 0, 0, 1240, 1240, 1240,
+ 0, 1245, 0, 1244, 1242, 1242, 1242, 1181, 1243, 1244,
+ 1245, 0, 0, 1244, 0, 0, 1245, 0, 0, 1362,
+ 1245, 1362, 0, 0, 1362, 1362, 1362, 1362, 1362, 1244,
+ 0, 1181, 1181, 1181, 1183, 0, 1245, 0, 1243, 1243,
+ 1243, 0, 0, 1183, 0, 1183, 1183, 1183, 1183, 1183,
+
+ 0, 0, 0, 1183, 0, 0, 0, 0, 0, 1244,
+ 1244, 1244, 1249, 0, 0, 0, 1245, 1245, 1245, 1183,
+ 0, 1249, 0, 1251, 0, 0, 0, 1249, 1362, 1362,
+ 1362, 1249, 1251, 0, 0, 0, 0, 0, 1251, 0,
+ 0, 0, 1251, 0, 0, 0, 0, 1249, 0, 1183,
+ 1183, 1183, 1218, 1388, 1388, 1388, 1388, 1388, 1251, 1218,
+ 0, 1218, 0, 1218, 1218, 1218, 1218, 1218, 0, 0,
+ 0, 1218, 0, 0, 0, 1218, 1252, 1249, 1249, 1249,
+ 0, 0, 0, 0, 0, 1252, 0, 1218, 1251, 1251,
+ 1251, 1252, 0, 1218, 0, 1252, 0, 0, 1389, 0,
+
+ 0, 1254, 1389, 1389, 1389, 1389, 0, 1388, 1388, 1388,
+ 1254, 1252, 0, 0, 1389, 1258, 1254, 1218, 1218, 1218,
+ 1254, 0, 0, 0, 1258, 0, 0, 0, 0, 0,
+ 1258, 0, 1389, 0, 1258, 0, 1254, 0, 0, 0,
+ 0, 1252, 1252, 1252, 1253, 1405, 1405, 1405, 1405, 1405,
+ 1258, 0, 0, 1253, 0, 1253, 1253, 1253, 1253, 1253,
+ 0, 0, 0, 1253, 0, 0, 1254, 1254, 1254, 1259,
+ 1455, 1455, 1455, 1455, 1455, 0, 0, 1260, 1259, 1253,
+ 1258, 1258, 1258, 0, 1259, 0, 1260, 0, 1259, 0,
+ 0, 0, 1260, 0, 0, 0, 1260, 0, 0, 1405,
+
+ 1405, 1405, 0, 0, 1259, 0, 0, 0, 0, 1253,
+ 1253, 1253, 1260, 1378, 0, 1378, 0, 0, 1378, 1378,
+ 1378, 1378, 1378, 1390, 1455, 1455, 1455, 1390, 1390, 1390,
+ 1390, 0, 1391, 0, 1259, 1259, 1259, 0, 0, 1390,
+ 0, 1391, 1260, 1260, 1260, 1279, 1279, 1391, 1279, 0,
+ 1279, 1391, 0, 0, 1279, 1279, 1279, 1390, 1279, 0,
+ 0, 0, 0, 0, 0, 0, 1279, 1391, 0, 0,
+ 0, 0, 1378, 1378, 1378, 0, 0, 1464, 1464, 1464,
+ 1464, 1464, 0, 1279, 0, 1279, 1279, 1438, 0, 1438,
+ 0, 0, 1438, 1438, 1438, 1438, 1438, 1391, 1391, 1391,
+
+ 1454, 1683, 1454, 0, 1683, 1454, 1454, 1454, 1454, 1454,
+ 1279, 1683, 1279, 1279, 1308, 1308, 1308, 1308, 1308, 0,
+ 1308, 1308, 1683, 1308, 1308, 1308, 0, 0, 1308, 0,
+ 1308, 1464, 1464, 1464, 0, 0, 1308, 1308, 0, 0,
+ 1308, 0, 0, 1392, 0, 0, 1438, 1438, 1438, 0,
+ 0, 0, 1392, 1308, 0, 1308, 1308, 1308, 1392, 1454,
+ 1454, 1454, 1392, 1456, 0, 0, 0, 1456, 1456, 1456,
+ 1456, 0, 1683, 1683, 1683, 0, 0, 0, 1392, 1456,
+ 1308, 1308, 1308, 0, 1308, 1308, 1308, 1308, 1308, 1309,
+ 1309, 1309, 1309, 1309, 0, 1309, 0, 1456, 1309, 1309,
+
+ 1309, 0, 0, 1309, 0, 1309, 0, 0, 1392, 1392,
+ 1392, 1309, 1309, 1465, 0, 1309, 1393, 1465, 1465, 1465,
+ 1465, 0, 0, 0, 0, 1393, 0, 0, 1309, 1465,
+ 1309, 1393, 1309, 0, 1399, 1393, 0, 0, 0, 0,
+ 0, 0, 0, 1399, 0, 0, 0, 1465, 0, 1399,
+ 0, 1393, 0, 1399, 0, 1309, 1309, 1309, 0, 1309,
+ 1309, 1309, 1309, 1309, 1310, 1310, 1310, 1310, 1310, 1399,
+ 1310, 1310, 0, 1310, 1310, 1310, 0, 0, 1310, 0,
+ 1310, 1393, 1393, 1393, 0, 0, 1310, 1310, 1466, 0,
+ 1310, 0, 1466, 1466, 1466, 1466, 0, 0, 0, 1399,
+
+ 1399, 1399, 0, 1310, 1466, 1310, 1310, 1310, 0, 0,
+ 0, 1499, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 1466, 0, 0, 0, 1499, 0, 0, 0,
+ 1310, 1310, 1310, 0, 1310, 1310, 1310, 1310, 1310, 1314,
+ 1314, 1314, 1314, 1314, 1314, 1314, 1499, 1314, 0, 1314,
+ 1314, 1314, 1314, 1314, 1314, 1314, 1314, 1314, 1357, 1357,
+ 1357, 1357, 1357, 0, 1357, 1357, 0, 1357, 1357, 1357,
+ 1400, 0, 1357, 0, 1357, 0, 1499, 1499, 1499, 1400,
+ 1357, 1357, 0, 0, 1357, 1400, 0, 0, 0, 1400,
+ 0, 0, 0, 0, 0, 0, 0, 1357, 0, 1357,
+
+ 1357, 1357, 0, 0, 1401, 1400, 1481, 1481, 1481, 1481,
+ 1481, 0, 0, 1401, 0, 0, 0, 0, 0, 1401,
+ 0, 0, 0, 1401, 1357, 1357, 1357, 0, 1357, 1357,
+ 1357, 1357, 1357, 1361, 0, 1400, 1400, 1400, 0, 1401,
+ 1361, 0, 1361, 0, 1361, 1361, 1361, 1361, 1361, 0,
+ 0, 0, 1361, 0, 0, 0, 1361, 0, 0, 0,
+ 1481, 1481, 1481, 0, 0, 0, 0, 1406, 1361, 1401,
+ 1401, 1401, 1407, 0, 1361, 0, 1406, 0, 0, 0,
+ 0, 1407, 1406, 0, 0, 0, 1406, 1407, 0, 0,
+ 0, 1407, 0, 0, 0, 0, 0, 0, 1361, 1361,
+
+ 1361, 1377, 1406, 0, 0, 0, 0, 1407, 1377, 0,
+ 1377, 0, 1377, 1377, 1377, 1377, 1377, 0, 0, 0,
+ 1377, 0, 0, 0, 1377, 0, 1408, 0, 0, 0,
+ 0, 0, 1406, 1406, 1406, 1408, 1377, 1407, 1407, 1407,
+ 1414, 1408, 1377, 1415, 0, 1408, 0, 0, 0, 1414,
+ 0, 0, 1415, 0, 1416, 1414, 0, 0, 1415, 1414,
+ 0, 1408, 1415, 1416, 0, 0, 1377, 1377, 1377, 1416,
+ 0, 0, 0, 1416, 0, 1414, 0, 0, 1415, 0,
+ 0, 1467, 0, 0, 0, 0, 0, 0, 0, 1416,
+ 1467, 1408, 1408, 1408, 0, 0, 1467, 0, 0, 0,
+
+ 1467, 0, 0, 0, 0, 1414, 1414, 1414, 1415, 1415,
+ 1415, 0, 0, 0, 0, 0, 1467, 0, 0, 1416,
+ 1416, 1416, 1437, 0, 0, 0, 0, 0, 0, 1437,
+ 0, 1437, 0, 1437, 1437, 1437, 1437, 1437, 0, 0,
+ 0, 1437, 0, 0, 0, 1437, 1467, 1467, 1467, 1468,
+ 0, 0, 0, 0, 0, 0, 1469, 1437, 1468, 0,
+ 0, 1475, 0, 1437, 1468, 1469, 0, 0, 1468, 0,
+ 1475, 1469, 0, 0, 0, 1469, 1475, 0, 0, 0,
+ 1475, 0, 0, 0, 1468, 0, 0, 1437, 1437, 1437,
+ 1453, 1469, 0, 0, 0, 0, 1475, 1453, 0, 1453,
+
+ 0, 1453, 1453, 1453, 1453, 1453, 0, 0, 0, 1453,
+ 0, 0, 0, 1453, 1468, 1468, 1468, 0, 0, 0,
+ 0, 1469, 1469, 1469, 1476, 1453, 1475, 1475, 1475, 1477,
+ 0, 1453, 1482, 1476, 0, 0, 0, 0, 1477, 1476,
+ 0, 1482, 0, 1476, 1477, 0, 0, 1482, 1477, 0,
+ 0, 1482, 0, 1483, 0, 1453, 1453, 1453, 0, 1476,
+ 0, 0, 1483, 0, 1477, 1484, 0, 1482, 1483, 0,
+ 0, 0, 1483, 0, 1484, 0, 0, 0, 0, 0,
+ 1484, 0, 0, 0, 1484, 0, 0, 0, 1483, 1476,
+ 1476, 1476, 1490, 0, 1477, 1477, 1477, 1482, 1482, 1482,
+
+ 1484, 1490, 0, 0, 0, 0, 1491, 1490, 0, 0,
+ 0, 1490, 0, 0, 1492, 1491, 0, 0, 1483, 1483,
+ 1483, 1491, 0, 1492, 0, 1491, 0, 1490, 0, 1492,
+ 1484, 1484, 1484, 1492, 0, 0, 0, 0, 0, 0,
+ 0, 1491, 0, 0, 0, 0, 0, 0, 0, 1492,
+ 0, 0, 0, 0, 0, 0, 0, 1490, 1490, 1490,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 1491, 1491, 1491, 0, 0, 0, 0, 0, 1492,
+ 1492, 1492, 1534, 1534, 1534, 1534, 1534, 1534, 1534, 0,
+ 1534, 0, 1534, 1534, 1534, 1534, 1534, 1534, 1534, 1534,
+
+ 1534, 1546, 1546, 1546, 1546, 1546, 0, 1546, 1546, 0,
+ 1546, 1546, 1546, 0, 0, 1546, 0, 1546, 0, 0,
+ 0, 0, 0, 1546, 1546, 0, 0, 1546, 0, 0,
+ 1576, 0, 0, 0, 0, 0, 0, 0, 0, 1576,
+ 1546, 0, 1546, 1546, 1546, 1576, 0, 0, 0, 1576,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 1576, 0, 1546, 1546, 1546,
+ 0, 1546, 1546, 1546, 1546, 1546, 1548, 1548, 1548, 1548,
+ 1548, 0, 1548, 1548, 0, 1548, 1548, 1548, 0, 0,
+ 1548, 0, 1548, 0, 0, 1576, 1576, 1576, 1548, 1548,
+
+ 0, 0, 1548, 0, 0, 1577, 0, 0, 0, 0,
+ 0, 0, 0, 0, 1577, 1548, 0, 1548, 1548, 1548,
+ 1577, 0, 0, 0, 1577, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 1577, 0, 1548, 1548, 1548, 0, 1548, 1548, 1548, 1548,
+ 1548, 1554, 1554, 1554, 1554, 1554, 0, 1554, 1554, 0,
+ 1554, 1554, 1554, 0, 0, 1554, 0, 1554, 0, 0,
+ 1577, 1577, 1577, 1554, 1554, 0, 0, 1554, 0, 0,
+ 1578, 0, 0, 0, 0, 0, 0, 0, 0, 1578,
+ 1554, 0, 1554, 1554, 1554, 1578, 0, 0, 0, 1578,
+
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 1578, 0, 1554, 1554, 1554,
+ 0, 1554, 1554, 1554, 1554, 1554, 1558, 1558, 1558, 1558,
+ 1558, 0, 1558, 1558, 0, 1558, 1558, 1558, 0, 0,
+ 1558, 0, 1558, 0, 0, 1578, 1578, 1578, 1558, 1558,
+ 0, 0, 1558, 0, 0, 1585, 0, 0, 0, 0,
+ 0, 0, 0, 0, 1585, 1558, 0, 1558, 1558, 1558,
+ 1585, 0, 0, 0, 1585, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 1585, 0, 1558, 1558, 1558, 0, 1558, 1558, 1558, 1558,
+
+ 1558, 1559, 1559, 1559, 1559, 1559, 0, 1559, 1559, 0,
+ 1559, 1559, 1559, 0, 0, 1559, 1586, 1559, 0, 0,
+ 1585, 1585, 1585, 1559, 1559, 1586, 0, 1559, 0, 0,
+ 0, 1586, 0, 0, 0, 1586, 0, 0, 0, 0,
+ 1559, 0, 1559, 1559, 1559, 0, 0, 0, 0, 0,
+ 0, 1586, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 1559, 1559, 1559,
+ 0, 1559, 1559, 1559, 1559, 1559, 1572, 0, 0, 0,
+ 0, 1586, 1586, 1586, 1587, 1572, 0, 1572, 1572, 1572,
+ 1572, 1572, 0, 1587, 0, 1572, 0, 0, 0, 1587,
+
+ 0, 1593, 0, 1587, 0, 0, 0, 0, 0, 0,
+ 1593, 1572, 0, 0, 0, 0, 1593, 0, 0, 1587,
+ 1593, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 1593, 0, 0, 0,
+ 0, 1572, 1572, 1572, 1575, 0, 0, 0, 0, 1587,
+ 1587, 1587, 0, 1575, 0, 1575, 1575, 1575, 1575, 1575,
+ 0, 1594, 0, 1575, 0, 0, 1593, 1593, 1593, 1595,
+ 1594, 0, 0, 0, 0, 0, 1594, 0, 1595, 1575,
+ 1594, 0, 0, 0, 1595, 0, 0, 0, 1595, 0,
+ 0, 0, 0, 0, 0, 0, 1594, 1622, 0, 0,
+
+ 0, 0, 0, 0, 1595, 0, 1622, 0, 0, 1575,
+ 1575, 1575, 1622, 0, 0, 0, 1622, 0, 0, 0,
+ 0, 0, 0, 0, 1623, 0, 1594, 1594, 1594, 0,
+ 0, 0, 1622, 1623, 1595, 1595, 1595, 1618, 0, 1623,
+ 0, 0, 0, 1623, 0, 0, 1618, 0, 1618, 1618,
+ 1618, 1618, 1618, 0, 0, 0, 1618, 0, 0, 1623,
+ 1624, 0, 1622, 1622, 1622, 1631, 0, 0, 0, 1624,
+ 0, 0, 1618, 0, 1631, 1624, 0, 1632, 0, 1624,
+ 1631, 0, 0, 0, 1631, 0, 1632, 0, 0, 1623,
+ 1623, 1623, 1632, 0, 0, 1624, 1632, 0, 0, 0,
+
+ 1631, 0, 1618, 1618, 1618, 1621, 0, 0, 0, 0,
+ 0, 0, 1632, 0, 1621, 0, 1621, 1621, 1621, 1621,
+ 1621, 0, 0, 0, 1621, 1624, 1624, 1624, 0, 0,
+ 1631, 1631, 1631, 0, 0, 0, 0, 0, 1633, 0,
+ 1621, 1639, 1632, 1632, 1632, 0, 1640, 1633, 0, 1641,
+ 1639, 0, 0, 1633, 0, 1640, 1639, 1633, 1641, 0,
+ 1639, 1640, 0, 0, 1641, 1640, 0, 0, 1641, 0,
+ 1621, 1621, 1621, 1633, 0, 0, 1639, 0, 0, 0,
+ 0, 1640, 0, 0, 1641, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+
+ 0, 0, 0, 1633, 1633, 1633, 1639, 1639, 1639, 0,
+ 0, 1640, 1640, 1640, 1641, 1641, 1641, 1676, 1676, 1676,
+ 1676, 1676, 0, 1676, 1676, 0, 1676, 1676, 1676, 0,
+ 0, 1676, 0, 1676, 0, 0, 0, 0, 0, 1676,
+ 1676, 0, 0, 1676, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 1676, 0, 1676, 1676,
+ 1676, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 1676, 1676, 1676, 0, 1676, 1676, 1676,
+ 1676, 1676, 1690, 1690, 1690, 1690, 1690, 0, 1690, 1690,
+
+ 0, 1690, 1690, 1690, 0, 0, 1690, 0, 1690, 0,
+ 0, 0, 0, 0, 1690, 1690, 0, 0, 1690, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 1690, 0, 1690, 1690, 1690, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 1690, 1690,
+ 1690, 0, 1690, 1690, 1690, 1690, 1690, 1764, 1764, 1764,
+ 1764, 1764, 1764, 1764, 1764, 1764, 1764, 1764, 1764, 1764,
+ 1764, 1764, 1764, 1764, 1764, 1764, 1764, 1764, 1764, 1764,
+ 1764, 1765, 1765, 1765, 1765, 1765, 1765, 1765, 1765, 1765,
+
+ 1765, 1765, 1765, 1765, 1765, 1765, 1765, 1765, 1765, 1765,
+ 1765, 1765, 1765, 1765, 1765, 1766, 1766, 1766, 1766, 1766,
+ 1766, 1766, 1766, 1766, 1766, 1766, 1766, 1766, 1766, 1766,
+ 1766, 1766, 1766, 1766, 1766, 1766, 1766, 1766, 1766, 1767,
+ 1767, 1767, 1767, 1767, 1767, 1767, 1767, 1767, 1767, 1767,
+ 1767, 1767, 1767, 1767, 1767, 1767, 1767, 1767, 1767, 1767,
+ 1767, 1767, 1767, 1768, 1768, 1768, 1768, 1768, 1768, 1768,
+ 1768, 1768, 1768, 1768, 1768, 1768, 1768, 1768, 1768, 1768,
+ 1768, 1768, 1768, 1768, 1768, 1768, 1768, 1769, 1769, 1769,
+ 1769, 1769, 1769, 1769, 1769, 1769, 1769, 1769, 1769, 1769,
+
+ 1769, 1769, 1769, 1769, 1769, 1769, 1769, 1769, 1769, 1769,
+ 1769, 1770, 1770, 0, 0, 0, 1770, 1770, 1770, 1770,
+ 1770, 1770, 1770, 1770, 1770, 1770, 1770, 1770, 1770, 0,
+ 1770, 1770, 1770, 1770, 1770, 1771, 1771, 0, 1771, 0,
+ 0, 0, 1771, 0, 1771, 1771, 1772, 1772, 0, 0,
+ 1772, 1772, 1772, 1772, 1772, 1772, 1772, 1772, 1772, 1772,
+ 1772, 1772, 1772, 1772, 1772, 1772, 1772, 1772, 1772, 1772,
+ 1773, 1773, 1773, 1773, 1773, 1773, 1773, 1773, 1773, 1773,
+ 1773, 1773, 1773, 1773, 1773, 1773, 1773, 1773, 1773, 1773,
+ 1773, 1773, 1773, 1773, 1774, 0, 1774, 0, 0, 1774,
+
+ 1774, 0, 1774, 0, 1774, 1774, 0, 1774, 1774, 1774,
+ 1774, 1774, 1774, 1775, 0, 1775, 0, 0, 1775, 1775,
+ 0, 1775, 0, 1775, 1775, 0, 1775, 1775, 1775, 1775,
+ 1775, 1775, 1776, 0, 1776, 0, 0, 1776, 1776, 0,
+ 0, 0, 1776, 1776, 0, 0, 1776, 0, 1776, 1776,
+ 1776, 1777, 0, 1777, 0, 0, 1777, 1777, 0, 1777,
+ 1777, 1777, 1777, 0, 1777, 1777, 1777, 1777, 1777, 1777,
+ 1778, 0, 1778, 0, 0, 1778, 1778, 0, 1778, 1778,
+ 1778, 1778, 0, 1778, 1778, 1778, 1778, 1778, 1778, 1779,
+ 0, 1779, 0, 0, 1779, 1779, 0, 0, 1779, 1779,
+
+ 1779, 0, 0, 1779, 0, 1779, 1779, 1779, 1780, 1780,
+ 1780, 1780, 1780, 1780, 1780, 1780, 1780, 1780, 1780, 1780,
+ 1780, 1780, 1780, 1780, 1780, 1780, 1780, 1780, 1780, 1780,
+ 1780, 1780, 1781, 0, 0, 0, 1781, 0, 1781, 1781,
+ 1782, 1782, 1782, 0, 1782, 1782, 0, 0, 1782, 0,
+ 0, 1782, 1782, 1782, 1782, 1782, 1783, 0, 0, 0,
+ 0, 1783, 0, 1783, 1783, 0, 0, 1783, 0, 1783,
+ 1783, 1783, 0, 1783, 1783, 1783, 0, 1783, 1783, 1783,
+ 1784, 1784, 0, 0, 1784, 1784, 1784, 1784, 1784, 1784,
+ 1784, 1784, 1784, 1784, 1784, 1784, 1784, 1784, 1784, 1784,
+
+ 1784, 1784, 1784, 1784, 1785, 1785, 0, 1785, 1785, 1785,
+ 1785, 1785, 1785, 1785, 1785, 1785, 1785, 1785, 1785, 1785,
+ 1785, 1785, 1785, 1785, 1785, 1785, 1785, 1785, 1786, 1786,
+ 0, 1786, 1786, 1786, 1786, 1786, 1786, 1786, 1786, 1786,
+ 1786, 1786, 1786, 1786, 1786, 1786, 1786, 1786, 1786, 1786,
+ 1786, 1786, 1787, 1787, 1787, 1787, 1787, 1787, 1787, 1787,
+ 1787, 1787, 1787, 1787, 1787, 1787, 1787, 1787, 1787, 1787,
+ 1787, 1787, 1787, 1787, 1787, 1787, 1789, 0, 1789, 0,
+ 0, 1789, 1789, 0, 0, 1789, 1789, 1789, 0, 0,
+ 1789, 1789, 1789, 1789, 1789, 1790, 1790, 0, 1790, 0,
+
+ 0, 0, 1790, 0, 1790, 1790, 1791, 1791, 0, 0,
+ 1791, 1791, 1791, 1791, 1791, 1791, 1791, 1791, 1791, 1791,
+ 1791, 1791, 1791, 1791, 1791, 1791, 1791, 1791, 1791, 1791,
+ 1793, 0, 1793, 0, 0, 1793, 1793, 0, 1793, 0,
+ 1793, 1793, 0, 1793, 1793, 1793, 1793, 1793, 1793, 1794,
+ 0, 1794, 0, 0, 1794, 1794, 0, 1794, 0, 1794,
+ 1794, 0, 1794, 1794, 1794, 1794, 1794, 1794, 1795, 0,
+ 1795, 0, 0, 1795, 1795, 0, 1795, 0, 1795, 1795,
+ 0, 1795, 1795, 1795, 1795, 1795, 1795, 1796, 0, 1796,
+ 0, 0, 1796, 1796, 0, 0, 0, 1796, 1796, 0,
+
+ 0, 1796, 0, 1796, 1796, 1796, 1797, 0, 1797, 0,
+ 0, 1797, 1797, 0, 1797, 0, 1797, 1797, 0, 1797,
+ 1797, 1797, 1797, 1797, 1797, 1798, 0, 1798, 0, 0,
+ 1798, 1798, 1798, 1798, 0, 1798, 1798, 0, 1798, 1798,
+ 0, 1798, 1798, 1798, 1799, 0, 1799, 0, 0, 1799,
+ 1799, 0, 1799, 0, 1799, 1799, 0, 1799, 1799, 1799,
+ 1799, 1799, 1799, 1800, 0, 1800, 0, 0, 1800, 1800,
+ 0, 1800, 0, 1800, 1800, 0, 1800, 1800, 1800, 1800,
+ 1800, 1800, 1801, 0, 1801, 0, 0, 1801, 1801, 0,
+ 0, 0, 1801, 0, 0, 0, 1801, 1801, 1801, 1801,
+
+ 1801, 1802, 0, 1802, 0, 0, 1802, 1802, 0, 1802,
+ 0, 1802, 1802, 0, 1802, 1802, 1802, 1802, 1802, 1802,
+ 1803, 0, 1803, 0, 0, 1803, 1803, 0, 1803, 1803,
+ 1803, 1803, 0, 1803, 1803, 1803, 1803, 1803, 1803, 1804,
+ 0, 1804, 0, 0, 1804, 1804, 0, 1804, 1804, 1804,
+ 1804, 0, 1804, 1804, 1804, 1804, 1804, 1804, 1805, 0,
+ 1805, 0, 0, 1805, 1805, 0, 1805, 1805, 1805, 1805,
+ 0, 1805, 1805, 1805, 1805, 1805, 1805, 1806, 0, 1806,
+ 0, 0, 1806, 1806, 0, 0, 1806, 1806, 1806, 0,
+ 0, 1806, 0, 1806, 1806, 1806, 1807, 0, 1807, 0,
+
+ 0, 1807, 1807, 0, 1807, 1807, 1807, 1807, 0, 1807,
+ 1807, 1807, 1807, 1807, 1807, 1808, 0, 1808, 0, 0,
+ 1808, 1808, 1808, 1808, 1808, 1808, 1808, 0, 1808, 1808,
+ 0, 1808, 1808, 1808, 1809, 0, 1809, 0, 0, 1809,
+ 1809, 0, 1809, 1809, 1809, 1809, 0, 1809, 1809, 1809,
+ 1809, 1809, 1809, 1810, 0, 1810, 0, 0, 1810, 1810,
+ 0, 1810, 1810, 1810, 1810, 0, 1810, 1810, 1810, 1810,
+ 1810, 1810, 1811, 0, 1811, 0, 0, 1811, 1811, 0,
+ 0, 1811, 1811, 0, 0, 0, 1811, 1811, 1811, 1811,
+ 1811, 1812, 0, 1812, 0, 0, 1812, 1812, 0, 1812,
+
+ 1812, 1812, 1812, 0, 1812, 1812, 1812, 1812, 1812, 1812,
+ 1815, 0, 0, 0, 1815, 0, 1815, 1815, 1816, 0,
+ 0, 0, 1816, 0, 1816, 1816, 1818, 1818, 1818, 1818,
+ 1818, 1818, 1818, 1818, 1818, 1818, 1818, 1818, 1818, 0,
+ 1818, 1818, 1818, 1818, 1818, 1818, 1818, 1818, 1818, 1818,
+ 1819, 1819, 0, 1819, 0, 0, 0, 1819, 0, 1819,
+ 1819, 1820, 0, 0, 0, 0, 1820, 0, 1820, 1820,
+ 0, 0, 1820, 0, 1820, 1820, 1820, 0, 1820, 1820,
+ 1820, 0, 1820, 1820, 1820, 1821, 1821, 0, 0, 1821,
+ 1821, 1821, 1821, 1821, 1821, 1821, 1821, 1821, 1821, 1821,
+
+ 1821, 1821, 1821, 1821, 1821, 1821, 1821, 1821, 1821, 1823,
+ 1823, 0, 1823, 1823, 1823, 1823, 1823, 1823, 1823, 1823,
+ 1823, 1823, 1823, 1823, 1823, 1823, 1823, 1823, 1823, 1823,
+ 1823, 1823, 1823, 1824, 1824, 0, 0, 0, 1824, 1824,
+ 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
+ 1824, 0, 1824, 1824, 1824, 1824, 1824, 1825, 1825, 1825,
+ 1825, 1825, 1825, 1825, 1825, 1825, 1825, 1825, 1825, 1825,
+ 1825, 1825, 1825, 1825, 1825, 1825, 1825, 1825, 1825, 1825,
+ 1825, 1826, 0, 0, 0, 1826, 0, 1826, 1826, 1827,
+ 0, 0, 1827, 0, 0, 0, 1827, 0, 1827, 1827,
+
+ 1829, 0, 1829, 0, 0, 1829, 1829, 0, 0, 1829,
+ 1829, 1829, 0, 0, 1829, 1829, 1829, 1829, 1829, 1830,
+ 0, 1830, 0, 0, 0, 1830, 0, 1830, 1830, 1832,
+ 0, 1832, 0, 0, 1832, 1832, 0, 0, 0, 1832,
+ 1832, 0, 1832, 1832, 0, 1832, 1832, 1832, 1833, 0,
+ 1833, 0, 0, 1833, 1833, 0, 1833, 0, 1833, 1833,
+ 0, 1833, 1833, 1833, 1833, 1833, 1833, 1834, 0, 1834,
+ 0, 0, 1834, 1834, 0, 1834, 0, 1834, 1834, 0,
+ 1834, 1834, 1834, 1834, 1834, 1834, 1835, 0, 1835, 0,
+ 0, 1835, 1835, 0, 1835, 0, 1835, 1835, 0, 1835,
+
+ 1835, 1835, 1835, 1835, 1835, 1836, 0, 1836, 0, 0,
+ 1836, 1836, 0, 1836, 0, 1836, 1836, 0, 1836, 1836,
+ 1836, 1836, 1836, 1836, 1837, 0, 1837, 0, 0, 1837,
+ 1837, 0, 0, 0, 1837, 1837, 0, 0, 1837, 1837,
+ 1837, 1837, 1837, 1838, 0, 1838, 0, 0, 1838, 1838,
+ 0, 0, 0, 1838, 0, 0, 0, 1838, 1838, 1838,
+ 1838, 1838, 1839, 0, 1839, 0, 0, 1839, 1839, 0,
+ 1839, 0, 1839, 1839, 0, 1839, 1839, 1839, 1839, 1839,
+ 1839, 1840, 0, 1840, 0, 0, 1840, 1840, 0, 1840,
+ 0, 1840, 1840, 0, 1840, 1840, 1840, 1840, 1840, 1840,
+
+ 1841, 0, 1841, 0, 0, 1841, 1841, 0, 0, 0,
+ 1841, 1841, 0, 0, 1841, 1841, 1841, 1841, 1841, 1842,
+ 0, 1842, 0, 0, 1842, 1842, 1842, 1842, 0, 1842,
+ 1842, 0, 1842, 1842, 1842, 1842, 1842, 1842, 1843, 0,
+ 1843, 0, 0, 1843, 1843, 0, 0, 0, 1843, 0,
+ 0, 0, 1843, 1843, 1843, 1843, 1843, 1844, 0, 1844,
+ 0, 0, 1844, 1844, 0, 0, 0, 1844, 1844, 0,
+ 0, 1844, 0, 1844, 1844, 1844, 1845, 0, 1845, 0,
+ 0, 1845, 1845, 0, 1845, 0, 1845, 1845, 0, 1845,
+ 1845, 1845, 1845, 1845, 1845, 1846, 0, 1846, 0, 0,
+
+ 1846, 1846, 0, 1846, 0, 1846, 1846, 0, 1846, 1846,
+ 1846, 1846, 1846, 1846, 1847, 0, 1847, 0, 0, 1847,
+ 1847, 0, 0, 0, 1847, 0, 0, 0, 1847, 1847,
+ 1847, 1847, 1847, 1848, 0, 1848, 0, 0, 1848, 1848,
+ 0, 0, 0, 1848, 0, 0, 0, 1848, 1848, 1848,
+ 1848, 1848, 1849, 0, 1849, 0, 0, 1849, 1849, 0,
+ 1849, 0, 1849, 1849, 0, 1849, 1849, 1849, 1849, 1849,
+ 1849, 1850, 0, 1850, 0, 0, 1850, 1850, 0, 1850,
+ 0, 1850, 1850, 0, 1850, 1850, 1850, 1850, 1850, 1850,
+ 1851, 0, 1851, 0, 0, 1851, 1851, 0, 0, 1851,
+
+ 1851, 1851, 0, 1851, 1851, 0, 1851, 1851, 1851, 1852,
+ 0, 1852, 0, 0, 1852, 1852, 0, 1852, 1852, 1852,
+ 1852, 0, 1852, 1852, 1852, 1852, 1852, 1852, 1853, 0,
+ 1853, 0, 0, 1853, 1853, 0, 1853, 1853, 1853, 1853,
+ 0, 1853, 1853, 1853, 1853, 1853, 1853, 1854, 0, 1854,
+ 0, 0, 1854, 1854, 0, 1854, 1854, 1854, 1854, 0,
+ 1854, 1854, 1854, 1854, 1854, 1854, 1855, 0, 1855, 0,
+ 0, 1855, 1855, 0, 1855, 1855, 1855, 1855, 0, 1855,
+ 1855, 1855, 1855, 1855, 1855, 1856, 0, 1856, 0, 0,
+ 1856, 1856, 0, 0, 1856, 1856, 1856, 0, 0, 1856,
+
+ 1856, 1856, 1856, 1856, 1857, 0, 1857, 0, 0, 1857,
+ 1857, 0, 0, 1857, 1857, 0, 0, 0, 1857, 1857,
+ 1857, 1857, 1857, 1858, 0, 1858, 0, 0, 1858, 1858,
+ 0, 1858, 1858, 1858, 1858, 0, 1858, 1858, 1858, 1858,
+ 1858, 1858, 1859, 0, 1859, 0, 0, 1859, 1859, 0,
+ 1859, 1859, 1859, 1859, 0, 1859, 1859, 1859, 1859, 1859,
+ 1859, 1860, 0, 1860, 0, 0, 1860, 1860, 0, 0,
+ 1860, 1860, 1860, 0, 0, 1860, 1860, 1860, 1860, 1860,
+ 1861, 0, 1861, 0, 0, 1861, 1861, 1861, 1861, 1861,
+ 1861, 1861, 0, 1861, 1861, 1861, 1861, 1861, 1861, 1862,
+
+ 0, 1862, 0, 0, 1862, 1862, 0, 0, 1862, 1862,
+ 0, 0, 0, 1862, 1862, 1862, 1862, 1862, 1863, 0,
+ 1863, 0, 0, 1863, 1863, 0, 0, 1863, 1863, 1863,
+ 0, 0, 1863, 0, 1863, 1863, 1863, 1864, 0, 1864,
+ 0, 0, 1864, 1864, 0, 1864, 1864, 1864, 1864, 0,
+ 1864, 1864, 1864, 1864, 1864, 1864, 1865, 0, 1865, 0,
+ 0, 1865, 1865, 0, 1865, 1865, 1865, 1865, 0, 1865,
+ 1865, 1865, 1865, 1865, 1865, 1866, 0, 1866, 0, 0,
+ 1866, 1866, 0, 0, 1866, 1866, 0, 0, 0, 1866,
+ 1866, 1866, 1866, 1866, 1867, 0, 1867, 0, 0, 1867,
+
+ 1867, 0, 0, 1867, 1867, 0, 0, 0, 1867, 1867,
+ 1867, 1867, 1867, 1868, 0, 1868, 0, 0, 1868, 1868,
+ 0, 1868, 1868, 1868, 1868, 0, 1868, 1868, 1868, 1868,
+ 1868, 1868, 1869, 0, 1869, 0, 0, 1869, 1869, 0,
+ 1869, 1869, 1869, 1869, 0, 1869, 1869, 1869, 1869, 1869,
+ 1869, 1873, 0, 0, 1873, 0, 0, 0, 1873, 0,
+ 1873, 1873, 1875, 1875, 1875, 1875, 1875, 1875, 1875, 1875,
+ 1875, 1875, 1875, 1875, 1875, 0, 1875, 1875, 1875, 1875,
+ 1875, 1875, 1875, 1875, 1875, 1875, 1876, 0, 0, 0,
+ 0, 1876, 0, 1876, 1876, 0, 0, 1876, 0, 1876,
+
+ 1876, 1876, 0, 1876, 1876, 1876, 0, 1876, 1876, 1876,
+ 1879, 1879, 0, 1879, 0, 0, 0, 1879, 0, 1879,
+ 1879, 1881, 1881, 1881, 1881, 1881, 0, 1881, 1881, 1881,
+ 1881, 0, 0, 1881, 1881, 0, 0, 1881, 1881, 1881,
+ 0, 1881, 0, 0, 1881, 1882, 0, 0, 1882, 1882,
+ 0, 1882, 0, 0, 1882, 1882, 0, 0, 1882, 1882,
+ 1882, 0, 0, 1882, 1882, 1882, 1882, 1882, 1883, 0,
+ 1883, 0, 0, 0, 1883, 0, 1883, 1883, 1884, 0,
+ 1884, 0, 0, 1884, 1884, 1884, 1884, 0, 1884, 1884,
+ 0, 1884, 1884, 1884, 1884, 1884, 1884, 1885, 0, 1885,
+
+ 0, 0, 1885, 1885, 0, 0, 0, 1885, 1885, 0,
+ 0, 1885, 1885, 1885, 1885, 1885, 1886, 0, 1886, 0,
+ 0, 1886, 1886, 0, 1886, 0, 1886, 1886, 0, 1886,
+ 1886, 0, 1886, 1886, 1886, 1887, 0, 1887, 0, 0,
+ 1887, 1887, 0, 1887, 0, 1887, 1887, 0, 1887, 1887,
+ 1887, 1887, 1887, 1887, 1888, 0, 1888, 0, 0, 1888,
+ 1888, 0, 1888, 0, 1888, 1888, 0, 1888, 1888, 1888,
+ 1888, 1888, 1888, 1889, 0, 1889, 0, 0, 1889, 1889,
+ 0, 1889, 0, 1889, 1889, 0, 1889, 1889, 1889, 1889,
+ 1889, 1889, 1890, 0, 1890, 0, 0, 1890, 1890, 0,
+
+ 0, 0, 1890, 1890, 0, 0, 1890, 1890, 1890, 1890,
+ 1890, 1891, 0, 1891, 0, 0, 1891, 1891, 0, 0,
+ 0, 1891, 0, 0, 0, 1891, 1891, 1891, 1891, 1891,
+ 1892, 0, 1892, 0, 0, 1892, 1892, 0, 0, 0,
+ 1892, 0, 0, 0, 1892, 1892, 1892, 1892, 1892, 1893,
+ 0, 1893, 0, 0, 1893, 1893, 0, 1893, 0, 1893,
+ 1893, 0, 1893, 1893, 1893, 1893, 1893, 1893, 1894, 0,
+ 1894, 0, 0, 1894, 1894, 0, 0, 0, 1894, 0,
+ 0, 0, 1894, 1894, 1894, 1894, 1894, 1895, 0, 1895,
+ 0, 0, 1895, 1895, 0, 0, 0, 1895, 0, 0,
+
+ 0, 1895, 1895, 1895, 1895, 1895, 1896, 0, 1896, 0,
+ 0, 1896, 1896, 0, 0, 0, 1896, 0, 0, 0,
+ 1896, 1896, 1896, 1896, 1896, 1897, 0, 1897, 0, 0,
+ 1897, 1897, 0, 0, 0, 1897, 0, 0, 0, 1897,
+ 1897, 1897, 1897, 1897, 1898, 0, 1898, 0, 0, 1898,
+ 1898, 0, 0, 0, 1898, 1898, 0, 0, 1898, 1898,
+ 1898, 1898, 1898, 1899, 0, 1899, 0, 0, 1899, 1899,
+ 0, 1899, 0, 1899, 1899, 0, 1899, 1899, 1899, 1899,
+ 1899, 1899, 1900, 0, 1900, 0, 0, 1900, 1900, 0,
+ 1900, 0, 1900, 1900, 0, 1900, 1900, 1900, 1900, 1900,
+
+ 1900, 1901, 0, 1901, 0, 0, 1901, 1901, 0, 1901,
+ 0, 1901, 1901, 0, 1901, 1901, 1901, 1901, 1901, 1901,
+ 1902, 0, 1902, 0, 0, 1902, 1902, 0, 1902, 0,
+ 1902, 1902, 0, 1902, 1902, 1902, 1902, 1902, 1902, 1903,
+ 0, 1903, 0, 0, 1903, 1903, 0, 0, 0, 1903,
+ 1903, 0, 0, 1903, 0, 1903, 1903, 1903, 1904, 0,
+ 1904, 0, 0, 1904, 1904, 0, 0, 0, 1904, 0,
+ 0, 0, 1904, 1904, 1904, 1904, 1904, 1905, 0, 1905,
+ 0, 0, 1905, 1905, 0, 1905, 0, 1905, 1905, 0,
+ 1905, 1905, 1905, 1905, 1905, 1905, 1906, 0, 1906, 0,
+
+ 0, 1906, 1906, 1906, 1906, 1906, 1906, 1906, 0, 1906,
+ 1906, 1906, 1906, 1906, 1906, 1907, 0, 1907, 0, 0,
+ 1907, 1907, 0, 0, 1907, 1907, 1907, 0, 0, 1907,
+ 1907, 1907, 1907, 1907, 1908, 0, 1908, 0, 0, 1908,
+ 1908, 0, 1908, 1908, 1908, 1908, 0, 1908, 1908, 0,
+ 1908, 1908, 1908, 1909, 0, 1909, 0, 0, 1909, 1909,
+ 0, 1909, 1909, 1909, 1909, 0, 1909, 1909, 1909, 1909,
+ 1909, 1909, 1910, 0, 1910, 0, 0, 1910, 1910, 0,
+ 1910, 1910, 1910, 1910, 0, 1910, 1910, 1910, 1910, 1910,
+ 1910, 1911, 0, 1911, 0, 0, 1911, 1911, 0, 1911,
+
+ 1911, 1911, 1911, 0, 1911, 1911, 1911, 1911, 1911, 1911,
+ 1912, 0, 1912, 0, 0, 1912, 1912, 0, 0, 1912,
+ 1912, 1912, 0, 0, 1912, 1912, 1912, 1912, 1912, 1913,
+ 0, 1913, 0, 0, 1913, 1913, 0, 0, 1913, 1913,
+ 0, 0, 0, 1913, 1913, 1913, 1913, 1913, 1914, 0,
+ 1914, 0, 0, 1914, 1914, 0, 0, 1914, 1914, 0,
+ 0, 0, 1914, 1914, 1914, 1914, 1914, 1915, 0, 1915,
+ 0, 0, 1915, 1915, 0, 1915, 1915, 1915, 1915, 0,
+ 1915, 1915, 1915, 1915, 1915, 1915, 1916, 0, 1916, 0,
+ 0, 1916, 1916, 0, 0, 1916, 1916, 0, 0, 0,
+
+ 1916, 1916, 1916, 1916, 1916, 1917, 0, 1917, 0, 0,
+ 1917, 1917, 0, 0, 1917, 1917, 0, 0, 0, 1917,
+ 1917, 1917, 1917, 1917, 1918, 0, 1918, 0, 0, 1918,
+ 1918, 0, 0, 1918, 1918, 0, 0, 0, 1918, 1918,
+ 1918, 1918, 1918, 1919, 0, 1919, 0, 0, 1919, 1919,
+ 0, 0, 1919, 1919, 0, 0, 0, 1919, 1919, 1919,
+ 1919, 1919, 1920, 0, 1920, 0, 0, 1920, 1920, 0,
+ 0, 1920, 1920, 1920, 0, 0, 1920, 1920, 1920, 1920,
+ 1920, 1921, 0, 1921, 0, 0, 1921, 1921, 0, 1921,
+ 1921, 1921, 1921, 0, 1921, 1921, 1921, 1921, 1921, 1921,
+
+ 1922, 0, 1922, 0, 0, 1922, 1922, 0, 1922, 1922,
+ 1922, 1922, 0, 1922, 1922, 1922, 1922, 1922, 1922, 1923,
+ 0, 1923, 0, 0, 1923, 1923, 0, 1923, 1923, 1923,
+ 1923, 0, 1923, 1923, 1923, 1923, 1923, 1923, 1924, 0,
+ 1924, 0, 0, 1924, 1924, 0, 1924, 1924, 1924, 1924,
+ 0, 1924, 1924, 1924, 1924, 1924, 1924, 1925, 0, 1925,
+ 0, 0, 1925, 1925, 0, 0, 1925, 1925, 1925, 0,
+ 0, 1925, 0, 1925, 1925, 1925, 1926, 0, 1926, 0,
+ 0, 1926, 1926, 0, 0, 1926, 1926, 0, 0, 0,
+ 1926, 1926, 1926, 1926, 1926, 1927, 0, 1927, 0, 0,
+
+ 1927, 1927, 0, 1927, 1927, 1927, 1927, 0, 1927, 1927,
+ 1927, 1927, 1927, 1927, 1929, 0, 0, 1929, 0, 0,
+ 0, 1929, 0, 1929, 1929, 1930, 0, 0, 0, 0,
+ 1930, 0, 1930, 1930, 0, 0, 1930, 0, 1930, 1930,
+ 1930, 0, 1930, 1930, 1930, 0, 1930, 1930, 1930, 1933,
+ 0, 0, 0, 1933, 0, 1933, 1933, 1934, 1934, 1934,
+ 1934, 1934, 0, 1934, 1934, 1934, 1934, 0, 0, 1934,
+ 1934, 0, 0, 1934, 1934, 1934, 0, 1934, 0, 1934,
+ 1934, 1935, 1935, 1935, 1935, 1935, 0, 1935, 1935, 1935,
+ 1935, 0, 0, 1935, 1935, 0, 0, 1935, 1935, 1935,
+
+ 0, 1935, 1935, 0, 1935, 1936, 0, 1936, 0, 0,
+ 1936, 1936, 0, 0, 1936, 1936, 1936, 0, 0, 1936,
+ 1936, 1936, 1936, 1936, 1937, 0, 1937, 0, 0, 1937,
+ 1937, 0, 0, 0, 1937, 1937, 0, 1937, 1937, 0,
+ 1937, 1937, 1937, 1938, 0, 1938, 0, 0, 1938, 1938,
+ 0, 1938, 0, 1938, 1938, 0, 1938, 1938, 1938, 1938,
+ 1938, 1938, 1939, 0, 1939, 0, 0, 1939, 1939, 0,
+ 1939, 0, 1939, 1939, 0, 1939, 1939, 1939, 1939, 1939,
+ 1939, 1940, 0, 1940, 0, 0, 1940, 1940, 0, 0,
+ 0, 1940, 0, 0, 0, 1940, 1940, 1940, 1940, 1940,
+
+ 1941, 0, 1941, 0, 0, 1941, 1941, 0, 0, 0,
+ 1941, 0, 0, 0, 1941, 1941, 1941, 1941, 1941, 1942,
+ 0, 1942, 0, 0, 1942, 1942, 0, 0, 0, 1942,
+ 0, 0, 0, 1942, 1942, 1942, 1942, 1942, 1943, 0,
+ 1943, 0, 0, 1943, 1943, 0, 0, 0, 1943, 1943,
+ 0, 0, 1943, 1943, 1943, 1943, 1943, 1944, 0, 1944,
+ 0, 0, 1944, 1944, 0, 0, 0, 1944, 0, 0,
+ 0, 1944, 1944, 1944, 1944, 1944, 1945, 0, 1945, 0,
+ 0, 1945, 1945, 0, 0, 0, 1945, 1945, 0, 0,
+ 1945, 1945, 1945, 1945, 1945, 1946, 0, 1946, 0, 0,
+
+ 1946, 1946, 0, 1946, 0, 1946, 1946, 0, 1946, 1946,
+ 1946, 1946, 1946, 1946, 1947, 0, 1947, 0, 0, 1947,
+ 1947, 0, 1947, 0, 1947, 1947, 0, 1947, 1947, 1947,
+ 1947, 1947, 1947, 1948, 0, 1948, 0, 0, 1948, 1948,
+ 0, 1948, 0, 1948, 1948, 0, 1948, 1948, 1948, 1948,
+ 1948, 1948, 1949, 0, 1949, 0, 0, 1949, 1949, 0,
+ 1949, 0, 1949, 1949, 0, 1949, 1949, 1949, 1949, 1949,
+ 1949, 1950, 0, 1950, 0, 0, 1950, 1950, 0, 1950,
+ 0, 1950, 1950, 0, 1950, 1950, 1950, 1950, 1950, 1950,
+ 1951, 0, 1951, 0, 0, 1951, 1951, 0, 1951, 0,
+
+ 1951, 1951, 0, 1951, 1951, 1951, 1951, 1951, 1951, 1952,
+ 0, 1952, 0, 0, 1952, 1952, 0, 1952, 0, 1952,
+ 1952, 0, 1952, 1952, 1952, 1952, 1952, 1952, 1953, 0,
+ 1953, 0, 0, 1953, 1953, 0, 0, 0, 1953, 1953,
+ 0, 0, 1953, 1953, 1953, 1953, 1953, 1954, 0, 1954,
+ 0, 0, 1954, 1954, 0, 0, 0, 1954, 0, 0,
+ 0, 1954, 1954, 1954, 1954, 1954, 1955, 0, 1955, 0,
+ 0, 1955, 1955, 0, 0, 1955, 1955, 1955, 0, 1955,
+ 1955, 0, 1955, 1955, 1955, 1956, 0, 1956, 0, 0,
+ 1956, 1956, 0, 1956, 1956, 1956, 1956, 0, 1956, 1956,
+
+ 1956, 1956, 1956, 1956, 1957, 0, 1957, 0, 0, 1957,
+ 1957, 0, 1957, 1957, 1957, 1957, 0, 1957, 1957, 1957,
+ 1957, 1957, 1957, 1958, 0, 1958, 0, 0, 1958, 1958,
+ 0, 0, 1958, 1958, 0, 0, 0, 1958, 1958, 1958,
+ 1958, 1958, 1959, 0, 1959, 0, 0, 1959, 1959, 0,
+ 0, 1959, 1959, 0, 0, 0, 1959, 1959, 1959, 1959,
+ 1959, 1960, 0, 1960, 0, 0, 1960, 1960, 0, 0,
+ 1960, 1960, 0, 0, 0, 1960, 1960, 1960, 1960, 1960,
+ 1961, 0, 1961, 0, 0, 1961, 1961, 0, 0, 1961,
+ 1961, 1961, 0, 0, 1961, 1961, 1961, 1961, 1961, 1962,
+
+ 0, 1962, 0, 0, 1962, 1962, 0, 0, 1962, 1962,
+ 0, 0, 0, 1962, 1962, 1962, 1962, 1962, 1963, 0,
+ 1963, 0, 0, 1963, 1963, 0, 0, 1963, 1963, 1963,
+ 0, 0, 1963, 1963, 1963, 1963, 1963, 1964, 0, 1964,
+ 0, 0, 1964, 1964, 0, 1964, 1964, 1964, 1964, 0,
+ 1964, 1964, 1964, 1964, 1964, 1964, 1965, 0, 1965, 0,
+ 0, 1965, 1965, 0, 1965, 1965, 1965, 1965, 0, 1965,
+ 1965, 1965, 1965, 1965, 1965, 1966, 0, 1966, 0, 0,
+ 1966, 1966, 0, 1966, 1966, 1966, 1966, 0, 1966, 1966,
+ 1966, 1966, 1966, 1966, 1967, 0, 1967, 0, 0, 1967,
+
+ 1967, 0, 1967, 1967, 1967, 1967, 0, 1967, 1967, 1967,
+ 1967, 1967, 1967, 1968, 0, 1968, 0, 0, 1968, 1968,
+ 0, 1968, 1968, 1968, 1968, 0, 1968, 1968, 1968, 1968,
+ 1968, 1968, 1969, 0, 1969, 0, 0, 1969, 1969, 0,
+ 1969, 1969, 1969, 1969, 0, 1969, 1969, 1969, 1969, 1969,
+ 1969, 1970, 0, 1970, 0, 0, 1970, 1970, 0, 1970,
+ 1970, 1970, 1970, 0, 1970, 1970, 1970, 1970, 1970, 1970,
+ 1971, 0, 1971, 0, 0, 1971, 1971, 0, 0, 1971,
+ 1971, 1971, 0, 0, 1971, 1971, 1971, 1971, 1971, 1972,
+ 0, 1972, 0, 0, 1972, 1972, 0, 0, 1972, 1972,
+
+ 0, 0, 0, 1972, 1972, 1972, 1972, 1972, 1973, 1973,
+ 1973, 0, 1973, 1973, 1973, 1973, 1973, 1973, 1973, 1973,
+ 1973, 1973, 1973, 1973, 1973, 1973, 1973, 1973, 1973, 1973,
+ 1973, 1973, 1976, 1976, 0, 1976, 0, 0, 0, 1976,
+ 0, 1976, 1976, 1977, 1977, 1977, 1977, 1977, 0, 1977,
+ 1977, 1977, 1977, 0, 0, 1977, 1977, 0, 0, 1977,
+ 1977, 1977, 0, 1977, 1977, 0, 1977, 1978, 1978, 1978,
+ 1978, 1978, 0, 1978, 1978, 1978, 1978, 0, 0, 1978,
+ 1978, 0, 0, 1978, 1978, 1978, 0, 1978, 0, 0,
+ 1978, 1979, 1979, 1979, 1979, 1979, 0, 1979, 1979, 1979,
+
+ 1979, 0, 0, 1979, 1979, 0, 0, 1979, 1979, 1979,
+ 0, 1979, 0, 0, 1979, 1980, 1980, 1980, 1980, 1980,
+ 0, 1980, 1980, 1980, 1980, 0, 0, 1980, 1980, 0,
+ 0, 1980, 1980, 1980, 0, 1980, 0, 0, 1980, 1981,
+ 1981, 1981, 1981, 1981, 0, 1981, 1981, 1981, 1981, 0,
+ 0, 1981, 1981, 0, 0, 1981, 1981, 1981, 0, 1981,
+ 0, 0, 1981, 1982, 1982, 1982, 1982, 1982, 1982, 1982,
+ 1982, 1982, 1982, 1982, 1982, 1982, 1982, 1982, 1982, 1982,
+ 1982, 1982, 1982, 1982, 1982, 1982, 1982, 1983, 0, 1983,
+ 0, 0, 1983, 1983, 1983, 1983, 0, 1983, 1983, 0,
+
+ 1983, 1983, 1983, 1983, 1983, 1983, 1984, 0, 1984, 0,
+ 0, 1984, 1984, 0, 0, 0, 1984, 1984, 0, 0,
+ 1984, 1984, 1984, 1984, 1984, 1985, 0, 1985, 0, 0,
+ 1985, 1985, 0, 1985, 0, 1985, 1985, 0, 1985, 1985,
+ 1985, 1985, 1985, 1985, 1986, 0, 1986, 0, 0, 1986,
+ 1986, 0, 1986, 0, 1986, 1986, 0, 1986, 1986, 1986,
+ 1986, 1986, 1986, 1987, 0, 1987, 0, 0, 1987, 1987,
+ 0, 1987, 0, 1987, 1987, 0, 1987, 1987, 1987, 1987,
+ 1987, 1987, 1988, 0, 1988, 0, 0, 1988, 1988, 0,
+ 1988, 0, 1988, 1988, 0, 1988, 1988, 1988, 1988, 1988,
+
+ 1988, 1989, 0, 1989, 0, 0, 1989, 1989, 0, 1989,
+ 0, 1989, 1989, 0, 1989, 1989, 1989, 1989, 1989, 1989,
+ 1990, 0, 1990, 0, 0, 1990, 1990, 0, 1990, 0,
+ 1990, 1990, 0, 1990, 1990, 1990, 1990, 1990, 1990, 1991,
+ 0, 1991, 0, 0, 1991, 1991, 0, 1991, 0, 1991,
+ 1991, 0, 1991, 1991, 1991, 1991, 1991, 1991, 1992, 0,
+ 1992, 0, 0, 1992, 1992, 0, 0, 0, 1992, 1992,
+ 0, 0, 1992, 1992, 1992, 1992, 1992, 1993, 0, 1993,
+ 0, 0, 1993, 1993, 0, 0, 0, 1993, 0, 0,
+ 0, 1993, 1993, 1993, 1993, 1993, 1994, 0, 1994, 0,
+
+ 0, 1994, 1994, 0, 0, 0, 1994, 0, 0, 0,
+ 1994, 1994, 1994, 1994, 1994, 1995, 0, 1995, 0, 0,
+ 1995, 1995, 1995, 1995, 1995, 1995, 1995, 0, 1995, 1995,
+ 1995, 1995, 1995, 1995, 1996, 0, 1996, 0, 0, 1996,
+ 1996, 0, 0, 1996, 1996, 1996, 0, 0, 1996, 1996,
+ 1996, 1996, 1996, 1997, 0, 1997, 0, 0, 1997, 1997,
+ 0, 1997, 1997, 1997, 1997, 0, 1997, 1997, 1997, 1997,
+ 1997, 1997, 1998, 0, 1998, 0, 0, 1998, 1998, 0,
+ 1998, 1998, 1998, 1998, 0, 1998, 1998, 1998, 1998, 1998,
+ 1998, 1999, 0, 1999, 0, 0, 1999, 1999, 0, 1999,
+
+ 1999, 1999, 1999, 0, 1999, 1999, 1999, 1999, 1999, 1999,
+ 2000, 0, 2000, 0, 0, 2000, 2000, 0, 2000, 2000,
+ 2000, 2000, 0, 2000, 2000, 2000, 2000, 2000, 2000, 2001,
+ 0, 2001, 0, 0, 2001, 2001, 0, 2001, 2001, 2001,
+ 2001, 0, 2001, 2001, 2001, 2001, 2001, 2001, 2002, 0,
+ 2002, 0, 0, 2002, 2002, 0, 2002, 2002, 2002, 2002,
+ 0, 2002, 2002, 2002, 2002, 2002, 2002, 2003, 0, 2003,
+ 0, 0, 2003, 2003, 0, 2003, 2003, 2003, 2003, 0,
+ 2003, 2003, 2003, 2003, 2003, 2003, 2004, 0, 2004, 0,
+ 0, 2004, 2004, 0, 0, 2004, 2004, 2004, 0, 0,
+
+ 2004, 2004, 2004, 2004, 2004, 2005, 0, 2005, 0, 0,
+ 2005, 2005, 0, 0, 2005, 2005, 0, 0, 0, 2005,
+ 2005, 2005, 2005, 2005, 2006, 0, 2006, 0, 0, 2006,
+ 2006, 0, 0, 2006, 2006, 0, 0, 0, 2006, 2006,
+ 2006, 2006, 2006, 2007, 2007, 2007, 2007, 2007, 0, 2007,
+ 2007, 2007, 2007, 0, 0, 2007, 2007, 0, 0, 2007,
+ 2007, 2007, 0, 2007, 0, 0, 2007, 2008, 2008, 2008,
+ 2008, 2008, 0, 2008, 2008, 2008, 2008, 0, 0, 2008,
+ 2008, 0, 0, 2008, 2008, 2008, 0, 2008, 0, 0,
+ 2008, 2009, 2009, 2009, 2009, 2009, 0, 2009, 2009, 2009,
+
+ 2009, 0, 0, 2009, 2009, 0, 0, 2009, 2009, 2009,
+ 0, 2009, 0, 0, 2009, 2010, 0, 2010, 0, 0,
+ 2010, 2010, 0, 0, 2010, 2010, 2010, 0, 0, 2010,
+ 2010, 2010, 2010, 2010, 2011, 0, 2011, 0, 0, 0,
+ 2011, 0, 2011, 2011, 2012, 0, 2012, 0, 0, 2012,
+ 2012, 0, 2012, 0, 2012, 2012, 0, 2012, 2012, 2012,
+ 2012, 2012, 2012, 2013, 0, 2013, 0, 0, 2013, 2013,
+ 0, 2013, 0, 2013, 2013, 0, 2013, 2013, 2013, 2013,
+ 2013, 2013, 2014, 0, 2014, 0, 0, 2014, 2014, 0,
+ 2014, 0, 2014, 2014, 0, 2014, 2014, 2014, 2014, 2014,
+
+ 2014, 2015, 0, 2015, 0, 0, 2015, 2015, 0, 2015,
+ 0, 2015, 2015, 0, 2015, 2015, 2015, 2015, 2015, 2015,
+ 2016, 0, 2016, 0, 0, 2016, 2016, 0, 0, 0,
+ 2016, 0, 0, 0, 2016, 2016, 2016, 2016, 2016, 2017,
+ 0, 2017, 0, 0, 2017, 2017, 0, 2017, 2017, 2017,
+ 2017, 0, 2017, 2017, 2017, 2017, 2017, 2017, 2018, 0,
+ 2018, 0, 0, 2018, 2018, 0, 2018, 2018, 2018, 2018,
+ 0, 2018, 2018, 2018, 2018, 2018, 2018, 2019, 0, 2019,
+ 0, 0, 2019, 2019, 0, 2019, 2019, 2019, 2019, 0,
+ 2019, 2019, 2019, 2019, 2019, 2019, 2020, 0, 2020, 0,
+
+ 0, 2020, 2020, 0, 2020, 2020, 2020, 2020, 0, 2020,
+ 2020, 2020, 2020, 2020, 2020, 2021, 2021, 2021, 2021, 2021,
+ 0, 2021, 2021, 2021, 2021, 0, 0, 2021, 2021, 0,
+ 0, 2021, 2021, 2021, 0, 2021, 0, 0, 2021, 2022,
+ 2022, 2022, 2022, 2022, 0, 2022, 2022, 2022, 2022, 0,
+ 0, 2022, 2022, 0, 0, 2022, 2022, 2022, 0, 2022,
+ 0, 0, 2022, 2023, 2023, 2023, 2023, 2023, 0, 2023,
+ 2023, 2023, 2023, 0, 0, 2023, 2023, 0, 0, 2023,
+ 2023, 2023, 0, 2023, 0, 0, 2023, 2024, 2024, 2024,
+ 2024, 2024, 0, 2024, 2024, 2024, 2024, 0, 0, 2024,
+
+ 2024, 0, 0, 2024, 2024, 2024, 0, 2024, 0, 0,
+ 2024, 2025, 2025, 2025, 2025, 2025, 0, 2025, 2025, 2025,
+ 2025, 0, 0, 2025, 2025, 0, 0, 2025, 2025, 2025,
+ 0, 2025, 0, 0, 2025, 2026, 2026, 2026, 2026, 2026,
+ 0, 2026, 2026, 2026, 2026, 0, 0, 2026, 2026, 0,
+ 0, 2026, 2026, 2026, 0, 2026, 0, 0, 2026, 2027,
+ 2027, 2027, 2027, 2027, 0, 2027, 2027, 2027, 2027, 0,
+ 0, 2027, 2027, 0, 0, 2027, 2027, 2027, 0, 2027,
+ 0, 0, 2027, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763,
+ 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763, 1763
+ } ;
+
+#define YY_TRAILING_MASK 0x2000
+#define YY_TRAILING_HEAD_MASK 0x4000
+#define REJECT \
+{ \
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */ \
+yy_cp = yyg->yy_full_match; /* restore poss. backed-over text */ \
+yyg->yy_lp = yyg->yy_full_lp; /* restore orig. accepting pos. */ \
+yyg->yy_state_ptr = yyg->yy_full_state; /* restore orig. state */ \
+yy_current_state = *yyg->yy_state_ptr; /* restore curr. state */ \
+++yyg->yy_lp; \
+goto find_rule; \
+}
+
+#define yymore() yymore_used_but_not_detected
+#define YY_MORE_ADJ 0
+#define YY_RESTORE_YY_MORE_OFFSET
+#line 1 "parser.l"
+/* Copyright 2009-2023
+ * Kaz Kylheku <kaz@kylheku.com>
+ * Vancouver, Canada
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ */
+#line 30 "parser.l"
+
+#include <stdio.h>
+#include <string.h>
+#include <stdarg.h>
+#include <stdlib.h>
+#include <limits.h>
+#include <wchar.h>
+#include <signal.h>
+#include "config.h"
+#include "lib.h"
+#include "gc.h"
+#include "stream.h"
+#include "utf8.h"
+#include "signal.h"
+#include "unwind.h"
+#include "hash.h"
+#include "y.tab.h"
+#include "parser.h"
+#include "txr.h"
+
+#define YY_INPUT(buf, result, max_size) \
+ do { \
+ val self = lit("parser"); \
+ val n = get_bytes(self, yyextra->stream, \
+ coerce(mem_t *, buf), max_size); \
+ result = c_num(n, self); \
+ } while (0)
+
+#define YY_DECL \
+ static int yylex_impl(YYSTYPE *yylval_param, yyscan_t yyscanner)
+
+#define YY_FATAL_ERROR(msg) lex_irrecoverable_error(msg)
+
+int opt_loglevel = 1; /* 0 - quiet; 1 - normal; 2 - verbose */
+
+val form_to_ln_hash;
+
+static int directive_tok(scanner_t *yyg, int tok, int state);
+
+#define FLEX_NUM_VERSION 10000*YY_FLEX_MAJOR_VERSION + \
+ 100*YY_FLEX_MINOR_VERSION + \
+ YY_FLEX_SUBMINOR_VERSION
+
+#if FLEX_NUM_VERSION < 20509
+int yylex_destroy(void)
+{
+ return 0;
+}
+#endif
+
+/* Missing prototypes not generated by flex. */
+int yyget_column(yyscan_t);
+void yyset_column (int column_no, yyscan_t yyscanner);
+
+/* The following function is all that libflex provides.
+ By providing it here, we eliminate the need to link libflex. */
+#define YY_SKIP_YYWRAP
+INLINE int yywrap(yyscan_t scanner)
+{
+ (void) scanner;
+ return 1;
+}
+
+void yyerror(scanner_t *scanner, parser_t *parser, const char *s)
+{
+ yyerrorf(scanner, lit("~a"), string_utf8(s), nao);
+ if (parser->prepared_msg) {
+ yyerrorf(scanner, lit("~a"), parser->prepared_msg, nao);
+ parser->prepared_msg = nil;
+ }
+}
+
+void yyerrorf(scanner_t *scanner, val fmt, ...)
+{
+ parser_t *parser = yyget_extra(scanner);
+
+ if (opt_loglevel >= 1) {
+ va_list vl;
+ va_start (vl, fmt);
+ if (opt_compat && opt_compat <= 114)
+ format(std_error, lit("~a: (~a:~d): "), prog_string,
+ parser->name, num(parser->lineno), nao);
+ else
+ format(std_error, lit("~a:~d: "),
+ parser->name, num(parser->lineno), nao);
+
+ vformat(std_error, fmt, vl);
+ put_char(chr('\n'), std_error);
+ va_end (vl);
+ }
+ parser->errors++;
+}
+
+static void yyerrprepf(scanner_t *scanner, val fmt, ...)
+{
+ parser_t *parser = yyget_extra(scanner);
+
+ if (opt_loglevel >= 1) {
+ va_list vl;
+ va_start (vl, fmt);
+ set(mkloc(parser->prepared_msg, parser->parser),
+ vformat_to_string(fmt, vl));
+ va_end (vl);
+ }
+}
+
+static void lex_irrecoverable_error(const char *msg8)
+{
+ val msg = string_utf8(msg8);
+ uw_throwf(error_s, lit("error in parser: ~a"), msg, nao);
+}
+
+static void out_of_range_float(scanner_t *scanner, const char *tok)
+{
+ yyerrorf(scanner, lit("out-of-range floating-point literal: ~a"),
+ string_utf8(tok), nao);
+}
+
+static wchar_t char_esc(int letter)
+{
+ switch (letter) {
+ case ' ': return L' ';
+ case 'a': return L'\a';
+ case 'b': return L'\b';
+ case 't': return L'\t';
+ case 'n': return L'\n';
+ case 'v': return L'\v';
+ case 'f': return L'\f';
+ case 'r': return L'\r';
+ case 'e': return 27;
+ case '"': return L'"';
+ case '\'': return L'\'';
+ case '`': return L'`';
+ case '/': return L'/';
+ case '@': return L'@';
+ case '\\': return L'\\';
+ }
+
+ internal_error("unhandled escape character");
+}
+
+static wchar_t num_esc(scanner_t *scn, char *num)
+{
+ long val = 0;
+
+ if (num[0] == 'x' || num[0] == 'u') {
+ if (strlen(num) > 7)
+ yyerror(scn, yyget_extra(scn), "too many digits in hex character escape");
+ else
+ val = strtol(num + 1, 0, 16);
+ } else {
+ if (num[0] == 'o')
+ num++;
+ if (strlen(num) > 8)
+ yyerror(scn, yyget_extra(scn), "too many digits in octal character escape");
+ else
+ val = strtol(num, 0, 8);
+ }
+
+ if (val < 0 || val > 0x10FFFF || convert(wchar_t, val) != val) {
+ yyerror(scn, yyget_extra(scn), "numeric character escape out of range");
+ val = 0;
+ }
+
+ return val;
+}
+
+static wchar_t *unicode_ident(scanner_t *scn, const char *lex)
+{
+ wchar_t *wlex = utf8_dup_from(lex), *ptr = wlex, wch;
+
+ while ((wch = *ptr++)) {
+ if (wch < 0x1680 || (wch >= 0x3000 && wch < 0xdc00))
+ continue;
+
+ if ((wch >= 0xdc00 && wch <= 0xdcff) ||
+ (wch >= 0xd800 && wch <= 0xdbff) ||
+#if FULL_UNICODE
+ (wch >= 0xf0000 && wch <= 0xffffd) ||
+ (wch >= 0x100000 && wch <= 0x10fffd) ||
+#endif
+ (wch >= 0xe000 && wch <= 0xf8ff) ||
+ (wch == 0xfffe) ||
+ (wch == 0xffff))
+ {
+ yyerror(scn, yyget_extra(scn),
+ "disallowed Unicode character in identifier");
+ break;
+ }
+
+ switch (wch) {
+ case 0x1680: case 0x180e: case 0x2000: case 0x2001: case 0x2002:
+ case 0x2003: case 0x2004: case 0x2005: case 0x2006: case 0x2007:
+ case 0x2008: case 0x2009: case 0x200a: case 0x2028: case 0x2029:
+ case 0x205f: case 0x3000:
+ yyerror(scn, yyget_extra(scn),
+ "Unicode space occurs in identifier");
+ break;
+ default:
+ continue;
+ }
+
+ break;
+ }
+
+ return wlex;
+}
+
+static char *remove_char(char *str, int c)
+{
+ char *dst = str, *src = str;
+
+ while (*src) {
+ int ch = *src++;
+ if (ch != c)
+ *dst++ = ch;
+ }
+
+ *dst = 0;
+
+ return str;
+}
+
+#line 4514 "lex.yy.c"
+#define YY_NO_INPUT 1
+
+#line 4517 "lex.yy.c"
+
+#define INITIAL 0
+#define SPECIAL 1
+#define BRACED 2
+#define NESTED 3
+#define REGEX 4
+#define SREGEX 5
+#define STRLIT 6
+#define CHRLIT 7
+#define QSILIT 8
+#define QSPECIAL 9
+#define WLIT 10
+#define QWLIT 11
+#define BUFLIT 12
+#define JSON 13
+#define JLIT 14
+#define JMARKER 15
+
+#ifndef YY_NO_UNISTD_H
+/* Special case for "unistd.h", since it is non-ANSI. We include it way
+ * down here because we want the user's section 1 to have been scanned first.
+ * The user has a chance to override it with an option.
+ */
+#include <unistd.h>
+#endif
+
+#define YY_EXTRA_TYPE parser_t *
+
+/* Holds the entire state of the reentrant scanner. */
+struct yyguts_t
+ {
+
+ /* User-defined. Not touched by flex. */
+ YY_EXTRA_TYPE yyextra_r;
+
+ /* The rest are the same as the globals declared in the non-reentrant scanner. */
+ FILE *yyin_r, *yyout_r;
+ size_t yy_buffer_stack_top; /**< index of top of stack. */
+ size_t yy_buffer_stack_max; /**< capacity of stack. */
+ YY_BUFFER_STATE * yy_buffer_stack; /**< Stack as an array. */
+ char yy_hold_char;
+ int yy_n_chars;
+ int yyleng_r;
+ char *yy_c_buf_p;
+ int yy_init;
+ int yy_start;
+ int yy_did_buffer_switch_on_eof;
+ int yy_start_stack_ptr;
+ int yy_start_stack_depth;
+ int *yy_start_stack;
+ yy_state_type yy_last_accepting_state;
+ char* yy_last_accepting_cpos;
+
+ int yylineno_r;
+ int yy_flex_debug_r;
+
+ yy_state_type *yy_state_buf;
+ yy_state_type *yy_state_ptr;
+ char *yy_full_match;
+ int yy_lp;
+
+ /* These are only needed for trailing context rules,
+ * but there's no conditional variable for that yet. */
+ int yy_looking_for_trail_begin;
+ int yy_full_lp;
+ int *yy_full_state;
+
+ char *yytext_r;
+ int yy_more_flag;
+ int yy_more_len;
+
+ YYSTYPE * yylval_r;
+
+ }; /* end struct yyguts_t */
+
+static int yy_init_globals ( yyscan_t yyscanner );
+
+ /* This must go here because YYSTYPE and YYLTYPE are included
+ * from bison output in section 1.*/
+ # define yylval yyg->yylval_r
+
+int yylex_init (yyscan_t* scanner);
+
+int yylex_init_extra ( YY_EXTRA_TYPE user_defined, yyscan_t* scanner);
+
+/* Accessor methods to globals.
+ These are made visible to non-reentrant scanners for convenience. */
+
+int yylex_destroy ( yyscan_t yyscanner );
+
+int yyget_debug ( yyscan_t yyscanner );
+
+void yyset_debug ( int debug_flag , yyscan_t yyscanner );
+
+YY_EXTRA_TYPE yyget_extra ( yyscan_t yyscanner );
+
+void yyset_extra ( YY_EXTRA_TYPE user_defined , yyscan_t yyscanner );
+
+FILE *yyget_in ( yyscan_t yyscanner );
+
+void yyset_in ( FILE * _in_str , yyscan_t yyscanner );
+
+FILE *yyget_out ( yyscan_t yyscanner );
+
+void yyset_out ( FILE * _out_str , yyscan_t yyscanner );
+
+ int yyget_leng ( yyscan_t yyscanner );
+
+char *yyget_text ( yyscan_t yyscanner );
+
+int yyget_lineno ( yyscan_t yyscanner );
+
+void yyset_lineno ( int _line_number , yyscan_t yyscanner );
+
+int yyget_column ( yyscan_t yyscanner );
+
+void yyset_column ( int _column_no , yyscan_t yyscanner );
+
+YYSTYPE * yyget_lval ( yyscan_t yyscanner );
+
+void yyset_lval ( YYSTYPE * yylval_param , yyscan_t yyscanner );
+
+/* Macros after this point can all be overridden by user definitions in
+ * section 1.
+ */
+
+#ifndef YY_SKIP_YYWRAP
+#ifdef __cplusplus
+extern "C" int yywrap ( yyscan_t yyscanner );
+#else
+extern int yywrap ( yyscan_t yyscanner );
+#endif
+#endif
+
+#ifndef YY_NO_UNPUT
+
+ static void yyunput ( int c, char *buf_ptr , yyscan_t yyscanner);
+
+#endif
+
+#ifndef yytext_ptr
+static void yy_flex_strncpy ( char *, const char *, int , yyscan_t yyscanner);
+#endif
+
+#ifdef YY_NEED_STRLEN
+static int yy_flex_strlen ( const char * , yyscan_t yyscanner);
+#endif
+
+#ifndef YY_NO_INPUT
+#ifdef __cplusplus
+static int yyinput ( yyscan_t yyscanner );
+#else
+static int input ( yyscan_t yyscanner );
+#endif
+
+#endif
+
+ static void yy_push_state ( int _new_state , yyscan_t yyscanner);
+
+ static void yy_pop_state ( yyscan_t yyscanner );
+
+ static int yy_top_state ( yyscan_t yyscanner );
+
+/* Amount of stuff to slurp up with each read. */
+#ifndef YY_READ_BUF_SIZE
+#ifdef __ia64__
+/* On IA-64, the buffer size is 16k, not 8k */
+#define YY_READ_BUF_SIZE 16384
+#else
+#define YY_READ_BUF_SIZE 8192
+#endif /* __ia64__ */
+#endif
+
+/* Copy whatever the last rule matched to the standard output. */
+#ifndef ECHO
+/* This used to be an fputs(), but since the string might contain NUL's,
+ * we now use fwrite().
+ */
+#define ECHO do { if (fwrite( yytext, (size_t) yyleng, 1, yyout )) {} } while (0)
+#endif
+
+/* Gets input and stuffs it into "buf". number of characters read, or YY_NULL,
+ * is returned in "result".
+ */
+#ifndef YY_INPUT
+#define YY_INPUT(buf,result,max_size) \
+ if ( YY_CURRENT_BUFFER_LVALUE->yy_is_interactive ) \
+ { \
+ int c = '*'; \
+ int n; \
+ for ( n = 0; n < max_size && \
+ (c = getc( yyin )) != EOF && c != '\n'; ++n ) \
+ buf[n] = (char) c; \
+ if ( c == '\n' ) \
+ buf[n++] = (char) c; \
+ if ( c == EOF && ferror( yyin ) ) \
+ YY_FATAL_ERROR( "input in flex scanner failed" ); \
+ result = n; \
+ } \
+ else \
+ { \
+ errno=0; \
+ while ( (result = (int) fread(buf, 1, (yy_size_t) max_size, yyin)) == 0 && ferror(yyin)) \
+ { \
+ if( errno != EINTR) \
+ { \
+ YY_FATAL_ERROR( "input in flex scanner failed" ); \
+ break; \
+ } \
+ errno=0; \
+ clearerr(yyin); \
+ } \
+ }\
+\
+
+#endif
+
+/* No semi-colon after return; correct usage is to write "yyterminate();" -
+ * we don't want an extra ';' after the "return" because that will cause
+ * some compilers to complain about unreachable statements.
+ */
+#ifndef yyterminate
+#define yyterminate() return YY_NULL
+#endif
+
+/* Number of entries by which start-condition stack grows. */
+#ifndef YY_START_STACK_INCR
+#define YY_START_STACK_INCR 25
+#endif
+
+/* Report a fatal error. */
+#ifndef YY_FATAL_ERROR
+#define YY_FATAL_ERROR(msg) yy_fatal_error( msg , yyscanner)
+#endif
+
+/* end tables serialization structures and prototypes */
+
+/* Default declaration of generated scanner - a define so the user can
+ * easily add parameters.
+ */
+#ifndef YY_DECL
+#define YY_DECL_IS_OURS 1
+
+extern int yylex \
+ (YYSTYPE * yylval_param , yyscan_t yyscanner);
+
+#define YY_DECL int yylex \
+ (YYSTYPE * yylval_param , yyscan_t yyscanner)
+#endif /* !YY_DECL */
+
+/* Code executed at the beginning of each rule, after yytext and yyleng
+ * have been set up.
+ */
+#ifndef YY_USER_ACTION
+#define YY_USER_ACTION
+#endif
+
+/* Code executed at the end of each rule. */
+#ifndef YY_BREAK
+#define YY_BREAK /*LINTED*/break;
+#endif
+
+#define YY_RULE_SETUP \
+ if ( yyleng > 0 ) \
+ YY_CURRENT_BUFFER_LVALUE->yy_at_bol = \
+ (yytext[yyleng - 1] == '\n'); \
+ YY_USER_ACTION
+
+/** The main scanner function which does all the work.
+ */
+YY_DECL
+{
+ yy_state_type yy_current_state;
+ char *yy_cp, *yy_bp;
+ int yy_act;
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+
+ yylval = yylval_param;
+
+ if ( !yyg->yy_init )
+ {
+ yyg->yy_init = 1;
+
+#ifdef YY_USER_INIT
+ YY_USER_INIT;
+#endif
+
+ /* Create the reject buffer large enough to save one state per allowed character. */
+ if ( ! yyg->yy_state_buf )
+ yyg->yy_state_buf = (yy_state_type *)yyalloc(YY_STATE_BUF_SIZE , yyscanner);
+ if ( ! yyg->yy_state_buf )
+ YY_FATAL_ERROR( "out of dynamic memory in yylex()" );
+
+ if ( ! yyg->yy_start )
+ yyg->yy_start = 1; /* first start state */
+
+ if ( ! yyin )
+ yyin = stdin;
+
+ if ( ! yyout )
+ yyout = stdout;
+
+ if ( ! YY_CURRENT_BUFFER ) {
+ yyensure_buffer_stack (yyscanner);
+ YY_CURRENT_BUFFER_LVALUE =
+ yy_create_buffer( yyin, YY_BUF_SIZE , yyscanner);
+ }
+
+ yy_load_buffer_state( yyscanner );
+ }
+
+ {
+#line 325 "parser.l"
+
+
+#line 4833 "lex.yy.c"
+
+ while ( /*CONSTCOND*/1 ) /* loops until end-of-file is reached */
+ {
+ yy_cp = yyg->yy_c_buf_p;
+
+ /* Support of yytext. */
+ *yy_cp = yyg->yy_hold_char;
+
+ /* yy_bp points to the position in yy_ch_buf of the start of
+ * the current run.
+ */
+ yy_bp = yy_cp;
+
+ yy_current_state = yyg->yy_start;
+ yy_current_state += YY_AT_BOL();
+
+ yyg->yy_state_ptr = yyg->yy_state_buf;
+ *yyg->yy_state_ptr++ = yy_current_state;
+
+yy_match:
+ do
+ {
+ YY_CHAR yy_c = yy_ec[YY_SC_TO_UI(*yy_cp)] ;
+ while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state )
+ {
+ yy_current_state = (int) yy_def[yy_current_state];
+ if ( yy_current_state >= 1764 )
+ yy_c = yy_meta[yy_c];
+ }
+ yy_current_state = yy_nxt[yy_base[yy_current_state] + yy_c];
+ *yyg->yy_state_ptr++ = yy_current_state;
+ ++yy_cp;
+ }
+ while ( yy_current_state != 1763 );
+
+yy_find_action:
+ yy_current_state = *--yyg->yy_state_ptr;
+ yyg->yy_lp = yy_accept[yy_current_state];
+find_rule: /* we branch to this label when backing up */
+ for ( ; ; ) /* until we find what rule we matched */
+ {
+ if ( yyg->yy_lp && yyg->yy_lp < yy_accept[yy_current_state + 1] )
+ {
+ yy_act = yy_acclist[yyg->yy_lp];
+ if ( yy_act & YY_TRAILING_HEAD_MASK ||
+ yyg->yy_looking_for_trail_begin )
+ {
+ if ( yy_act == yyg->yy_looking_for_trail_begin )
+ {
+ yyg->yy_looking_for_trail_begin = 0;
+ yy_act &= ~YY_TRAILING_HEAD_MASK;
+ break;
+ }
+ }
+ else if ( yy_act & YY_TRAILING_MASK )
+ {
+ yyg->yy_looking_for_trail_begin = yy_act & ~YY_TRAILING_MASK;
+ yyg->yy_looking_for_trail_begin |= YY_TRAILING_HEAD_MASK;
+ }
+ else
+ {
+ yyg->yy_full_match = yy_cp;
+ yyg->yy_full_state = yyg->yy_state_ptr;
+ yyg->yy_full_lp = yyg->yy_lp;
+ break;
+ }
+ ++yyg->yy_lp;
+ goto find_rule;
+ }
+ --yy_cp;
+ yy_current_state = *--yyg->yy_state_ptr;
+ yyg->yy_lp = yy_accept[yy_current_state];
+ }
+
+ YY_DO_BEFORE_ACTION;
+
+do_action: /* This label is used only to access EOF actions. */
+
+ switch ( yy_act )
+ { /* beginning of action switch */
+case 1:
+YY_RULE_SETUP
+#line 327 "parser.l"
+{
+ val str = string_own(utf8_dup_from(yytext));
+
+ if (yy_top_state(yyscanner) == INITIAL
+ || yy_top_state(yyscanner) == QSILIT
+ || yy_top_state(yyscanner) == QWLIT)
+ yy_pop_state(yyscanner);
+
+ yylval->val = int_str(str, num(10));
+ return NUMBER;
+}
+ YY_BREAK
+case 2:
+YY_RULE_SETUP
+#line 339 "parser.l"
+{
+ val str = string_own(utf8_dup_from(remove_char(yytext, ',')));
+
+ if (yy_top_state(yyscanner) == INITIAL
+ || yy_top_state(yyscanner) == QSILIT
+ || yy_top_state(yyscanner) == QWLIT)
+ yy_pop_state(yyscanner);
+
+ yylval->val = int_str(str, num(10));
+ return NUMBER;
+}
+ YY_BREAK
+case 3:
+YY_RULE_SETUP
+#line 351 "parser.l"
+{
+ val str = string_own(utf8_dup_from(remove_char(yytext + 2, ',')));
+ int base;
+
+ switch (yytext[1]) {
+ case 'x': base = 16; break;
+ case 'o': base = 8; break;
+ case 'b': default: base = 2; break;
+ }
+
+ if (yy_top_state(yyscanner) == INITIAL
+ || yy_top_state(yyscanner) == QSILIT
+ || yy_top_state(yyscanner) == QWLIT)
+ yy_pop_state(yyscanner);
+
+ yylval->val = int_str(str, num_fast(base));
+ return NUMBER;
+}
+ YY_BREAK
+case 4:
+YY_RULE_SETUP
+#line 370 "parser.l"
+{
+ int base = 0;
+ val str = string_own(utf8_dup_from(yytext + 2));
+
+ switch (yytext[1]) {
+ case 'x': base = 16; break;
+ case 'o': base = 8; break;
+ case 'b': default: base = 2; break;
+ }
+
+ yyerrorf(yyg, lit("trailing junk in numeric literal: ~a~a~a"),
+ chr(yytext[0]), chr(yytext[1]), str, nao);
+
+ if (yy_top_state(yyscanner) == INITIAL
+ || yy_top_state(yyscanner) == QSILIT
+ || yy_top_state(yyscanner) == QWLIT)
+ yy_pop_state(yyscanner);
+
+ yylval->val = int_str(str, num_fast(base));
+ return NUMBER;
+}
+ YY_BREAK
+case 5:
+YY_RULE_SETUP
+#line 392 "parser.l"
+{
+ if (yy_top_state(yyscanner) == INITIAL
+ || yy_top_state(yyscanner) == QSILIT
+ || yy_top_state(yyscanner) == QWLIT)
+ yy_pop_state(yyscanner);
+
+ if ((yylval->val = flo_str_utf8(yytext)) == nil)
+ out_of_range_float(yyg, yytext);
+
+ return NUMBER;
+}
+ YY_BREAK
+case 6:
+YY_RULE_SETUP
+#line 404 "parser.l"
+{
+ if (yy_top_state(yyscanner) == INITIAL
+ || yy_top_state(yyscanner) == QSILIT
+ || yy_top_state(yyscanner) == QWLIT)
+ yy_pop_state(yyscanner);
+
+ remove_char(yytext, ',');
+
+ if ((yylval->val = flo_str_utf8(yytext)) == nil)
+ out_of_range_float(yyg, yytext);
+
+ return NUMBER;
+}
+ YY_BREAK
+case 7:
+#line 420 "parser.l"
+case 8:
+#line 421 "parser.l"
+case 9:
+YY_RULE_SETUP
+#line 421 "parser.l"
+{
+ val str = string_utf8(yytext);
+
+ yyerrorf(yyg, lit("trailing junk in floating-point literal: ~a"), str, nao);
+
+ if (yy_top_state(yyscanner) == INITIAL
+ || yy_top_state(yyscanner) == QSILIT
+ || yy_top_state(yyscanner) == QWLIT)
+ yy_pop_state(yyscanner);
+
+ if ((yylval->val = flo_str_utf8(yytext)) == nil)
+ out_of_range_float(yyg, yytext);
+
+ return NUMBER;
+}
+ YY_BREAK
+case 10:
+/* rule 10 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_cp - 1);
+yyg->yy_c_buf_p = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 437 "parser.l"
+{
+ if (yy_top_state(yyscanner) == INITIAL
+ || yy_top_state(yyscanner) == QSILIT
+ || yy_top_state(yyscanner) == QWLIT)
+ yy_pop_state(yyscanner);
+
+ if ((yylval->val = flo_str_utf8(yytext)) == nil)
+ out_of_range_float(yyg, yytext);
+
+ return NUMBER;
+}
+ YY_BREAK
+case 11:
+#line 450 "parser.l"
+case 12:
+YY_RULE_SETUP
+#line 450 "parser.l"
+{
+ val str = string_own(utf8_dup_from(yytext + 1));
+
+ if (yy_top_state(yyscanner) == INITIAL
+ || yy_top_state(yyscanner) == QSILIT
+ || yy_top_state(yyscanner) == QWLIT)
+ yy_pop_state(yyscanner);
+ yylval->val = int_str(str, num(10));
+ return METANUM;
+}
+ YY_BREAK
+case 13:
+#line 462 "parser.l"
+case 14:
+YY_RULE_SETUP
+#line 462 "parser.l"
+{
+ val str = string_own(utf8_dup_from(yytext + 3));
+
+ if (yy_top_state(yyscanner) == INITIAL
+ || yy_top_state(yyscanner) == QSILIT
+ || yy_top_state(yyscanner) == QWLIT)
+ yy_pop_state(yyscanner);
+ yylval->val = int_str(str, num(16));
+ return METANUM;
+}
+ YY_BREAK
+case 15:
+#line 474 "parser.l"
+case 16:
+YY_RULE_SETUP
+#line 474 "parser.l"
+{
+ val str = string_own(utf8_dup_from(yytext + 3));
+
+ if (yy_top_state(yyscanner) == INITIAL
+ || yy_top_state(yyscanner) == QSILIT
+ || yy_top_state(yyscanner) == QWLIT)
+ yy_pop_state(yyscanner);
+ yylval->val = int_str(str, num(8));
+ return METANUM;
+}
+ YY_BREAK
+case 17:
+YY_RULE_SETUP
+#line 485 "parser.l"
+{
+ val str = string_own(utf8_dup_from(yytext + 3));
+
+ if (yy_top_state(yyscanner) == INITIAL
+ || yy_top_state(yyscanner) == QSILIT
+ || yy_top_state(yyscanner) == QWLIT)
+ yy_pop_state(yyscanner);
+ yylval->val = int_str(str, num(2));
+ return METANUM;
+}
+ YY_BREAK
+case 18:
+#line 497 "parser.l"
+case 19:
+#line 498 "parser.l"
+case 20:
+YY_RULE_SETUP
+#line 498 "parser.l"
+{
+ yyerrorf(yyg, lit("cramped floating-point literal: "
+ "space needed between ~a and dot."),
+ string_own(utf8_dup_from(yytext)),
+ nao);
+
+ if (yy_top_state(yyscanner) == INITIAL
+ || yy_top_state(yyscanner) == QSILIT
+ || yy_top_state(yyscanner) == QWLIT)
+ yy_pop_state(yyscanner);
+
+ yylval->lexeme = unicode_ident(yyg, yytext);
+ return SYMTOK;
+}
+ YY_BREAK
+case 21:
+#line 515 "parser.l"
+case 22:
+#line 516 "parser.l"
+case 23:
+YY_RULE_SETUP
+#line 516 "parser.l"
+{
+ if (yy_top_state(yyscanner) == INITIAL
+ || yy_top_state(yyscanner) == QSILIT
+ || yy_top_state(yyscanner) == QWLIT)
+ yy_pop_state(yyscanner);
+
+ yylval->lexeme = unicode_ident(yyg, yytext);
+ return SYMTOK;
+}
+ YY_BREAK
+case 24:
+#line 527 "parser.l"
+case 25:
+YY_RULE_SETUP
+#line 527 "parser.l"
+{
+ if (yy_top_state(yyscanner) == INITIAL
+ || yy_top_state(yyscanner) == QSILIT
+ || yy_top_state(yyscanner) == QWLIT)
+ yy_pop_state(yyscanner);
+
+ yyerrorf(yyg, lit("bad token: ~a"),
+ string_own(utf8_dup_from(yytext)),
+ nao);
+ yylval->lexeme = unicode_ident(yyg, yytext);
+ return SYMTOK;
+}
+ YY_BREAK
+case 26:
+YY_RULE_SETUP
+#line 540 "parser.l"
+{
+ return directive_tok(yyg, ALL, 0);
+}
+ YY_BREAK
+case 27:
+/* rule 27 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_cp - 1);
+yyg->yy_c_buf_p = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 544 "parser.l"
+{
+ return directive_tok(yyg, SOME, NESTED);
+}
+ YY_BREAK
+case 28:
+YY_RULE_SETUP
+#line 548 "parser.l"
+{
+ return directive_tok(yyg, NONE, 0);
+}
+ YY_BREAK
+case 29:
+YY_RULE_SETUP
+#line 552 "parser.l"
+{
+ return directive_tok(yyg, MAYBE, 0);
+}
+ YY_BREAK
+case 30:
+YY_RULE_SETUP
+#line 556 "parser.l"
+{
+ return directive_tok(yyg, CASES, 0);
+}
+ YY_BREAK
+case 31:
+/* rule 31 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_cp - 1);
+yyg->yy_c_buf_p = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 560 "parser.l"
+{
+ return directive_tok(yyg, BLOCK, NESTED);
+}
+ YY_BREAK
+case 32:
+/* rule 32 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_cp - 1);
+yyg->yy_c_buf_p = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 564 "parser.l"
+{
+ return directive_tok(yyg, CHOOSE, NESTED);
+}
+ YY_BREAK
+case 33:
+/* rule 33 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_cp - 1);
+yyg->yy_c_buf_p = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 568 "parser.l"
+{
+ return directive_tok(yyg, GATHER, NESTED);
+}
+ YY_BREAK
+case 34:
+YY_RULE_SETUP
+#line 572 "parser.l"
+{
+ return directive_tok(yyg, AND, 0);
+}
+ YY_BREAK
+case 35:
+YY_RULE_SETUP
+#line 576 "parser.l"
+{
+ return directive_tok(yyg, OR, 0);
+}
+ YY_BREAK
+case 36:
+YY_RULE_SETUP
+#line 580 "parser.l"
+{
+ return directive_tok(yyg, END, 0);
+}
+ YY_BREAK
+case 37:
+/* rule 37 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_cp - 1);
+yyg->yy_c_buf_p = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 584 "parser.l"
+{
+ return directive_tok(yyg, COLLECT, NESTED);
+}
+ YY_BREAK
+case 38:
+/* rule 38 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_cp - 1);
+yyg->yy_c_buf_p = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 588 "parser.l"
+{
+ return directive_tok(yyg, COLL, NESTED);
+}
+ YY_BREAK
+case 39:
+/* rule 39 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_cp - 1);
+yyg->yy_c_buf_p = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 592 "parser.l"
+{
+ return directive_tok(yyg, UNTIL, NESTED);
+}
+ YY_BREAK
+case 40:
+/* rule 40 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_cp - 1);
+yyg->yy_c_buf_p = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 596 "parser.l"
+{
+ return directive_tok(yyg, OUTPUT, NESTED);
+}
+ YY_BREAK
+case 41:
+/* rule 41 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_cp - 1);
+yyg->yy_c_buf_p = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 600 "parser.l"
+{
+ return directive_tok(yyg, REPEAT, NESTED);
+}
+ YY_BREAK
+case 42:
+/* rule 42 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_cp - 1);
+yyg->yy_c_buf_p = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 604 "parser.l"
+{
+ return directive_tok(yyg, PUSH, NESTED);
+}
+ YY_BREAK
+case 43:
+/* rule 43 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_cp - 1);
+yyg->yy_c_buf_p = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 608 "parser.l"
+{
+ return directive_tok(yyg, REP, NESTED);
+}
+ YY_BREAK
+case 44:
+YY_RULE_SETUP
+#line 612 "parser.l"
+{
+ return directive_tok(yyg, SINGLE, 0);
+}
+ YY_BREAK
+case 45:
+YY_RULE_SETUP
+#line 616 "parser.l"
+{
+ return directive_tok(yyg, FIRST, 0);
+}
+ YY_BREAK
+case 46:
+/* rule 46 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_cp - 1);
+yyg->yy_c_buf_p = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 620 "parser.l"
+{
+ return directive_tok(yyg, LAST, NESTED);
+}
+ YY_BREAK
+case 47:
+YY_RULE_SETUP
+#line 624 "parser.l"
+{
+ return directive_tok(yyg, EMPTY, 0);
+}
+ YY_BREAK
+case 48:
+/* rule 48 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_cp - 1);
+yyg->yy_c_buf_p = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 628 "parser.l"
+{
+ return directive_tok(yyg, MOD, NESTED);
+}
+ YY_BREAK
+case 49:
+/* rule 49 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_cp - 1);
+yyg->yy_c_buf_p = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 632 "parser.l"
+{
+ return directive_tok(yyg, MODLAST, NESTED);
+}
+ YY_BREAK
+case 50:
+/* rule 50 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_cp - 1);
+yyg->yy_c_buf_p = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 636 "parser.l"
+{
+ return directive_tok(yyg, DEFINE, NESTED);
+}
+ YY_BREAK
+case 51:
+YY_RULE_SETUP
+#line 640 "parser.l"
+{
+ return directive_tok(yyg, TRY, 0);
+}
+ YY_BREAK
+case 52:
+/* rule 52 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_cp - 1);
+yyg->yy_c_buf_p = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 644 "parser.l"
+{
+ return directive_tok(yyg, CATCH, NESTED);
+}
+ YY_BREAK
+case 53:
+YY_RULE_SETUP
+#line 648 "parser.l"
+{
+ return directive_tok(yyg, FINALLY, 0);
+}
+ YY_BREAK
+case 54:
+/* rule 54 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_cp - 1);
+yyg->yy_c_buf_p = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 652 "parser.l"
+{
+ return directive_tok(yyg, IF, NESTED);
+}
+ YY_BREAK
+case 55:
+/* rule 55 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_cp - 1);
+yyg->yy_c_buf_p = yy_cp -= 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 656 "parser.l"
+{
+ return directive_tok(yyg, ELIF, NESTED);
+}
+ YY_BREAK
+case 56:
+YY_RULE_SETUP
+#line 660 "parser.l"
+{
+ return directive_tok(yyg, ELSE, 0);
+}
+ YY_BREAK
+case 57:
+YY_RULE_SETUP
+#line 664 "parser.l"
+{
+ yy_push_state(BRACED, yyscanner);
+ yylval->lineno = yyextra->lineno;
+ return yytext[0];
+}
+ YY_BREAK
+case 58:
+YY_RULE_SETUP
+#line 670 "parser.l"
+{
+ yy_push_state(NESTED, yyscanner);
+ yylval->lineno = yyextra->lineno;
+ return yytext[0];
+}
+ YY_BREAK
+case 59:
+YY_RULE_SETUP
+#line 676 "parser.l"
+{
+ yylval->lineno = yyextra->lineno;
+ return (opt_compat && opt_compat <= 248) ? OLD_AT : '@';
+}
+ YY_BREAK
+case 60:
+YY_RULE_SETUP
+#line 681 "parser.l"
+{
+ yylval->chr = '*';
+ return SPLICE;
+}
+ YY_BREAK
+case 61:
+YY_RULE_SETUP
+#line 686 "parser.l"
+{
+ yylval->chr = yytext[0];
+ return yytext[0];
+}
+ YY_BREAK
+case 62:
+YY_RULE_SETUP
+#line 691 "parser.l"
+{
+ yy_pop_state(yyscanner);
+ if (yy_top_state(yyscanner) == INITIAL
+ || yy_top_state(yyscanner) == QSILIT
+ || yy_top_state(yyscanner) == QWLIT)
+ yy_pop_state(yyscanner);
+ return yytext[0];
+}
+ YY_BREAK
+case 63:
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+yyg->yy_c_buf_p = yy_cp = yy_bp + 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 700 "parser.l"
+{
+ yyerrorf(yyg, lit("cramped floating-point literal: "
+ "space or 0 needed between ~a and dot."),
+ string_own(utf8_dup_from(yytext)),
+ nao);
+
+ yy_pop_state(yyscanner);
+ if (yy_top_state(yyscanner) == INITIAL
+ || yy_top_state(yyscanner) == QSILIT
+ || yy_top_state(yyscanner) == QWLIT)
+ yy_pop_state(yyscanner);
+ return yytext[0];
+}
+ YY_BREAK
+case 64:
+YY_RULE_SETUP
+#line 715 "parser.l"
+{
+ yy_pop_state(yyscanner);
+ if (yy_top_state(yyscanner) == INITIAL
+ || yy_top_state(yyscanner) == QSILIT
+ || yy_top_state(yyscanner) == QWLIT)
+ yy_pop_state(yyscanner);
+ return yytext[0];
+}
+ YY_BREAK
+case 65:
+YY_RULE_SETUP
+#line 724 "parser.l"
+{
+ /* Eat whitespace in directive */
+}
+ YY_BREAK
+case 66:
+YY_RULE_SETUP
+#line 728 "parser.l"
+{
+ yy_push_state(STRLIT, yyscanner);
+ return '"';
+}
+ YY_BREAK
+case 67:
+YY_RULE_SETUP
+#line 733 "parser.l"
+{
+ yy_push_state(CHRLIT, yyscanner);
+ yylval->lineno = yyextra->lineno;
+ return HASH_BACKSLASH;
+}
+ YY_BREAK
+case 68:
+YY_RULE_SETUP
+#line 739 "parser.l"
+{
+ yy_push_state(BUFLIT, yyscanner);
+ yylval->lineno = yyextra->lineno;
+ return HASH_B_QUOTE;
+}
+ YY_BREAK
+case 69:
+YY_RULE_SETUP
+#line 745 "parser.l"
+{
+ yy_push_state(REGEX, yyscanner);
+ yylval->lineno = yyextra->lineno;
+ return HASH_SLASH;
+}
+ YY_BREAK
+case 70:
+YY_RULE_SETUP
+#line 751 "parser.l"
+{
+ yy_push_state(QSILIT, yyscanner);
+ return '`';
+}
+ YY_BREAK
+case 71:
+YY_RULE_SETUP
+#line 756 "parser.l"
+{
+ yy_push_state(WLIT, yyscanner);
+ yylval->lineno = yyextra->lineno;
+ return WORDS;
+}
+ YY_BREAK
+case 72:
+YY_RULE_SETUP
+#line 762 "parser.l"
+{
+ yy_push_state(WLIT, yyscanner);
+ yylval->lineno = yyextra->lineno;
+ return WSPLICE;
+}
+ YY_BREAK
+case 73:
+YY_RULE_SETUP
+#line 768 "parser.l"
+{
+ yy_push_state(QWLIT, yyscanner);
+ yylval->lineno = yyextra->lineno;
+ return QWORDS;
+}
+ YY_BREAK
+case 74:
+YY_RULE_SETUP
+#line 774 "parser.l"
+{
+ yy_push_state(QWLIT, yyscanner);
+ yylval->lineno = yyextra->lineno;
+ return QWSPLICE;
+}
+ YY_BREAK
+case 75:
+YY_RULE_SETUP
+#line 780 "parser.l"
+{
+ return '#';
+}
+ YY_BREAK
+case 76:
+YY_RULE_SETUP
+#line 784 "parser.l"
+{
+ yylval->lineno = yyextra->lineno;
+ return HASH_H;
+}
+ YY_BREAK
+case 77:
+YY_RULE_SETUP
+#line 789 "parser.l"
+{
+ yylval->lineno = yyextra->lineno;
+ return HASH_S;
+}
+ YY_BREAK
+case 78:
+YY_RULE_SETUP
+#line 794 "parser.l"
+{
+ yylval->lineno = yyextra->lineno;
+ return HASH_R;
+}
+ YY_BREAK
+case 79:
+YY_RULE_SETUP
+#line 799 "parser.l"
+{
+ yylval->lineno = yyextra->lineno;
+ return HASH_N;
+}
+ YY_BREAK
+case 80:
+YY_RULE_SETUP
+#line 804 "parser.l"
+{
+ yylval->lineno = yyextra->lineno;
+ return HASH_T;
+}
+ YY_BREAK
+case 81:
+YY_RULE_SETUP
+#line 809 "parser.l"
+{
+ yylval->lineno = yyextra->lineno;
+ yy_push_state(JSON, yyscanner);
+ return HASH_J;
+}
+ YY_BREAK
+case 82:
+YY_RULE_SETUP
+#line 815 "parser.l"
+{
+ yylval->lineno = yyextra->lineno;
+ return HASH_SEMI;
+}
+ YY_BREAK
+case 83:
+YY_RULE_SETUP
+#line 820 "parser.l"
+{
+ val str = string_own(utf8_dup_from(yytext + 1));
+ yylval->val = int_str(str, num(10));
+ return HASH_N_EQUALS;
+}
+ YY_BREAK
+case 84:
+YY_RULE_SETUP
+#line 826 "parser.l"
+{
+ val str = string_own(utf8_dup_from(yytext + 1));
+ yylval->val = int_str(str, num(10));
+ return HASH_N_HASH;
+}
+ YY_BREAK
+case 85:
+YY_RULE_SETUP
+#line 832 "parser.l"
+{
+ yylval->lineno = yyextra->lineno;
+ return (opt_compat && opt_compat <= 185) ? OLD_DOTDOT : DOTDOT;
+}
+ YY_BREAK
+case 86:
+YY_RULE_SETUP
+#line 837 "parser.l"
+{
+ yy_pop_state(yyscanner);
+ yylval->lexeme = chk_strdup(L"@");
+ return TEXT;
+}
+ YY_BREAK
+case 87:
+/* rule 87 can match eol */
+YY_RULE_SETUP
+#line 843 "parser.l"
+{
+ yyextra->lineno++;
+}
+ YY_BREAK
+case 88:
+YY_RULE_SETUP
+#line 847 "parser.l"
+{
+ yy_push_state(REGEX, yyscanner);
+ return '/';
+}
+ YY_BREAK
+case 89:
+YY_RULE_SETUP
+#line 852 "parser.l"
+{
+ yylval->chr = '.';
+ return CONSDOT;
+}
+ YY_BREAK
+case 90:
+YY_RULE_SETUP
+#line 857 "parser.l"
+{
+ yylval->chr = '.';
+ return LAMBDOT;
+}
+ YY_BREAK
+case 91:
+YY_RULE_SETUP
+#line 862 "parser.l"
+{
+ yylval->chr = '.';
+ return UREFDOT;
+}
+ YY_BREAK
+case 92:
+YY_RULE_SETUP
+#line 867 "parser.l"
+{
+ yylval->chr = '.';
+ return '.';
+}
+ YY_BREAK
+case 93:
+YY_RULE_SETUP
+#line 872 "parser.l"
+{
+ yylval->chr = '.';
+ return OREFDOT;
+}
+ YY_BREAK
+case 94:
+YY_RULE_SETUP
+#line 877 "parser.l"
+{
+ yylval->chr = '.';
+ return UOREFDOT;
+}
+ YY_BREAK
+case 95:
+/* rule 95 can match eol */
+YY_RULE_SETUP
+#line 882 "parser.l"
+{
+ if (YYSTATE == SPECIAL)
+ yy_pop_state(yyscanner); /* @\ continuation */
+ yyextra->lineno++;
+}
+ YY_BREAK
+case 96:
+YY_RULE_SETUP
+#line 888 "parser.l"
+{
+ wchar_t lexeme[2];
+ lexeme[0] = char_esc(yytext[1]);
+ lexeme[1] = 0;
+ yylval->lexeme = chk_strdup(lexeme);
+ yy_pop_state(yyscanner);
+ return TEXT;
+}
+ YY_BREAK
+case 97:
+YY_RULE_SETUP
+#line 897 "parser.l"
+{
+ wchar_t lexeme[2];
+ lexeme[0] = num_esc(yyg, yytext + 1);
+ lexeme[1] = 0;
+ yylval->lexeme = chk_strdup(lexeme);
+
+ {
+ char lastchar = yytext[yyleng-1];
+ if (lastchar == ';' && opt_compat && opt_compat <= 109)
+ unput(lastchar);
+ }
+
+ yy_pop_state(yyscanner);
+ return TEXT;
+}
+ YY_BREAK
+case 98:
+YY_RULE_SETUP
+#line 913 "parser.l"
+{
+ yyerrorf(yyg, lit("\\x escape without digits"), nao);
+}
+ YY_BREAK
+case 99:
+YY_RULE_SETUP
+#line 917 "parser.l"
+{
+ yyerrorf(yyg, lit("unrecognized escape \\~a"), chr(yytext[1]), nao);
+}
+ YY_BREAK
+case 100:
+YY_RULE_SETUP
+#line 921 "parser.l"
+{
+ /* comment */
+}
+ YY_BREAK
+case 101:
+YY_RULE_SETUP
+#line 925 "parser.l"
+{
+ val ch = chr_str(string_utf8(yytext), zero);
+ if (chr_isspace(ch))
+ yyerrprepf(yyg, lit("unexpected whitespace character #\\x~,02x"),
+ ch, nao);
+ else if (chr_isunisp(ch))
+ yyerrprepf(yyg, lit("unexpected Unicode space character #\\x~,02x"),
+ ch, nao);
+ else if (chr_iscntrl(ch))
+ yyerrprepf(yyg, lit("unexpected control character #\\x~,02x"),
+ ch, nao);
+ else
+ yyerrprepf(yyg, lit("unexpected character #\\~a"),
+ ch, nao);
+ return ERRTOK;
+}
+ YY_BREAK
+case 102:
+YY_RULE_SETUP
+#line 942 "parser.l"
+{
+ yyerrprepf(yyg, lit("non-UTF-8 byte #x~02x in directive"),
+ num(convert(unsigned char, yytext[0])), nao);
+ return ERRTOK;
+}
+ YY_BREAK
+case 103:
+YY_RULE_SETUP
+#line 948 "parser.l"
+{
+ yylval->chr = '/';
+ return (YYSTATE == SREGEX) ? REGCHAR : '/';
+}
+ YY_BREAK
+case 104:
+YY_RULE_SETUP
+#line 953 "parser.l"
+{
+ yylval->chr = char_esc(yytext[1]);
+ return REGCHAR;
+}
+ YY_BREAK
+case 105:
+YY_RULE_SETUP
+#line 958 "parser.l"
+{
+ yylval->chr = num_esc(yyg, yytext + 1);
+ return REGCHAR;
+}
+ YY_BREAK
+case 106:
+YY_RULE_SETUP
+#line 963 "parser.l"
+{
+ yylval->chr = yytext[1];
+ return REGTOKEN;
+}
+ YY_BREAK
+case 107:
+/* rule 107 can match eol */
+YY_RULE_SETUP
+#line 968 "parser.l"
+{
+ yyextra->lineno++;
+}
+ YY_BREAK
+case 108:
+/* rule 108 can match eol */
+YY_RULE_SETUP
+#line 972 "parser.l"
+{
+ yyextra->lineno++;
+ yyerrprepf(yyg, lit("newline in regex"), nao);
+ return ERRTOK;
+}
+ YY_BREAK
+case 109:
+/* rule 109 can match eol */
+YY_RULE_SETUP
+#line 978 "parser.l"
+{
+ yyextra->lineno++;
+ yylval->chr = yytext[0];
+ return REGCHAR;
+}
+ YY_BREAK
+case 110:
+YY_RULE_SETUP
+#line 984 "parser.l"
+{
+ yylval->chr = yytext[0];
+ return yytext[0];
+}
+ YY_BREAK
+case 111:
+YY_RULE_SETUP
+#line 989 "parser.l"
+{
+ yylval->chr = yytext[1];
+ return REGCHAR;
+}
+ YY_BREAK
+case 112:
+YY_RULE_SETUP
+#line 994 "parser.l"
+{
+ if (opt_compat && opt_compat <= 105) {
+ yylval->chr = yytext[1];
+ return REGCHAR;
+ }
+
+ if (yytext[1] == 'x')
+ yyerrprepf(yyg, lit("\\x escape without digits in regex"), nao);
+ else
+ yyerrprepf(yyg, lit("unrecognized escape in regex"), nao);
+ return ERRTOK;
+}
+ YY_BREAK
+case 113:
+YY_RULE_SETUP
+#line 1007 "parser.l"
+{
+ yyerrprepf(yyg, lit("dangling backslash in regex"), nao);
+ return ERRTOK;
+}
+ YY_BREAK
+case 114:
+YY_RULE_SETUP
+#line 1012 "parser.l"
+{
+ wchar_t wchr[8];
+ if (utf8_from_buf(wchr, coerce(unsigned char *, yytext), yyleng) != 2) {
+ yylval->lexeme = chk_strdup(wchr);
+ return TEXT;
+ }
+ yylval->chr = wchr[0];
+ return REGCHAR;
+}
+ YY_BREAK
+case 115:
+YY_RULE_SETUP
+#line 1022 "parser.l"
+{
+ yylval->chr = convert(unsigned char, yytext[0]) + 0xDC00;
+ return REGCHAR;
+}
+ YY_BREAK
+case 116:
+YY_RULE_SETUP
+#line 1027 "parser.l"
+{
+ yylval->lexeme = utf8_dup_from(yytext);
+ return SPACE;
+}
+ YY_BREAK
+case 117:
+YY_RULE_SETUP
+#line 1032 "parser.l"
+{
+ yylval->lexeme = utf8_dup_from(yytext);
+ return TEXT;
+}
+ YY_BREAK
+case 118:
+/* rule 118 can match eol */
+YY_RULE_SETUP
+#line 1037 "parser.l"
+{
+ yyextra->lineno++;
+ return '\n';
+}
+ YY_BREAK
+case 119:
+YY_RULE_SETUP
+#line 1042 "parser.l"
+{
+ yy_push_state(SPECIAL, yyscanner);
+ return '*';
+}
+ YY_BREAK
+case 120:
+YY_RULE_SETUP
+#line 1047 "parser.l"
+{
+ yy_push_state(SPECIAL, yyscanner);
+}
+ YY_BREAK
+case 121:
+/* rule 121 can match eol */
+YY_RULE_SETUP
+#line 1051 "parser.l"
+{
+ /* eat whole line comment */
+ yyextra->lineno++;
+}
+ YY_BREAK
+case 122:
+YY_RULE_SETUP
+#line 1056 "parser.l"
+{
+ /* comment to end of line */
+}
+ YY_BREAK
+case 123:
+YY_RULE_SETUP
+#line 1060 "parser.l"
+{
+ yy_pop_state(yyscanner);
+ return yytext[0];
+}
+ YY_BREAK
+case 124:
+YY_RULE_SETUP
+#line 1065 "parser.l"
+{
+ yy_pop_state(yyscanner);
+ return yytext[0];
+}
+ YY_BREAK
+case 125:
+YY_RULE_SETUP
+#line 1070 "parser.l"
+{
+ yylval->chr = char_esc(yytext[1]);
+ return LITCHAR;
+}
+ YY_BREAK
+case 126:
+YY_RULE_SETUP
+#line 1075 "parser.l"
+{
+ yylval->chr = char_esc(yytext[1]);
+ return LITCHAR;
+}
+ YY_BREAK
+case 127:
+/* rule 127 can match eol */
+YY_RULE_SETUP
+#line 1080 "parser.l"
+{
+ yyextra->lineno++;
+}
+ YY_BREAK
+case 128:
+/* rule 128 can match eol */
+YY_RULE_SETUP
+#line 1084 "parser.l"
+{
+ yyextra->lineno++;
+
+ if (!opt_compat || opt_compat > 109)
+ return ' ';
+}
+ YY_BREAK
+case 129:
+YY_RULE_SETUP
+#line 1092 "parser.l"
+{
+ yylval->chr = num_esc(yyg, yytext+1);
+ return LITCHAR;
+}
+ YY_BREAK
+case 130:
+YY_RULE_SETUP
+#line 1097 "parser.l"
+{
+ yyerrorf(yyg, lit("\\x escape without digits"), nao);
+}
+ YY_BREAK
+case 131:
+YY_RULE_SETUP
+#line 1101 "parser.l"
+{
+ yyerrorf(yyg, lit("unrecognized escape: \\~a"), chr(yytext[1]), nao);
+}
+ YY_BREAK
+case 132:
+YY_RULE_SETUP
+#line 1105 "parser.l"
+{
+ yylval->chr = num_esc(yyg, yytext);
+ return LITCHAR;
+}
+ YY_BREAK
+case 133:
+YY_RULE_SETUP
+#line 1110 "parser.l"
+{
+ yylval->lexeme = utf8_dup_from(yytext);
+ return SYMTOK;
+}
+ YY_BREAK
+case 134:
+YY_RULE_SETUP
+#line 1115 "parser.l"
+{
+ yylval->lexeme = utf8_dup_from(yytext);
+ return SYMTOK; /* hack */
+}
+ YY_BREAK
+case 135:
+/* rule 135 can match eol */
+YY_RULE_SETUP
+#line 1120 "parser.l"
+{
+ yyerrprepf(yyg, lit("newline in string literal"), nao);
+ yyextra->lineno++;
+ yylval->chr = yytext[0];
+ return ERRTOK;
+}
+ YY_BREAK
+case 136:
+/* rule 136 can match eol */
+YY_RULE_SETUP
+#line 1127 "parser.l"
+{
+ yyerrprepf(yyg, lit("newline in character literal"), nao);
+ yyextra->lineno++;
+ yylval->chr = yytext[0];
+ return ERRTOK;
+}
+ YY_BREAK
+case 137:
+/* rule 137 can match eol */
+YY_RULE_SETUP
+#line 1134 "parser.l"
+{
+ yyerrprepf(yyg, lit("newline in string quasiliteral"), nao);
+ yyextra->lineno++;
+ yylval->chr = yytext[0];
+ return ERRTOK;
+}
+ YY_BREAK
+case 138:
+/* rule 138 can match eol */
+YY_RULE_SETUP
+#line 1141 "parser.l"
+{
+ yyextra->lineno++;
+
+ if (opt_compat && opt_compat <= 109)
+ return ' ';
+
+ yyerrprepf(yyg, lit("newline in word list literal"), nao);
+ yylval->chr = yytext[0];
+ return ERRTOK;
+}
+ YY_BREAK
+case 139:
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+yyg->yy_c_buf_p = yy_cp = yy_bp + 1;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 1152 "parser.l"
+{
+ yy_push_state(QSPECIAL, yyscanner);
+ return yytext[0];
+}
+ YY_BREAK
+case 140:
+YY_RULE_SETUP
+#line 1157 "parser.l"
+{
+ yyerrprepf(yyg, lit("malformed @ expression in quasiliteral"), nao);
+ return ERRTOK;
+}
+ YY_BREAK
+case 141:
+YY_RULE_SETUP
+#line 1162 "parser.l"
+{
+ return ' ';
+}
+ YY_BREAK
+case 142:
+YY_RULE_SETUP
+#line 1166 "parser.l"
+{
+ yy_pop_state(yyscanner);
+ return yytext[0];
+}
+ YY_BREAK
+case 143:
+YY_RULE_SETUP
+#line 1171 "parser.l"
+{
+ yylval->chr = char_esc(yytext[1]);
+ return LITCHAR;
+}
+ YY_BREAK
+case 144:
+YY_RULE_SETUP
+#line 1176 "parser.l"
+{
+ wchar_t ch0, ch1;
+ yytext[6] = 0;
+ ch0 = num_esc(yyg, yytext + 1);
+ ch1 = num_esc(yyg, yytext + 7);
+ yylval->chr = ((ch0 - 0xD800) << 10 | (ch1 - 0xDC00)) + 0x10000;
+ return LITCHAR;
+}
+ YY_BREAK
+case 145:
+YY_RULE_SETUP
+#line 1185 "parser.l"
+{
+ wchar_t ch = num_esc(yyg, yytext + 1);
+ yylval->chr = if3(ch, ch, 0xDC00);
+ return LITCHAR;
+}
+ YY_BREAK
+case 146:
+YY_RULE_SETUP
+#line 1191 "parser.l"
+{
+ yyerrorf(yyg, lit("JSON \\u escape needs four digits"), nao);
+}
+ YY_BREAK
+case 147:
+YY_RULE_SETUP
+#line 1195 "parser.l"
+{
+ yyerrorf(yyg, lit("unrecognized JSON escape: \\~a"), chr(yytext[1]), nao);
+}
+ YY_BREAK
+case 148:
+/* rule 148 can match eol */
+YY_RULE_SETUP
+#line 1199 "parser.l"
+{
+ yyerrprepf(yyg, lit("newline in JSON string"), nao);
+ yyextra->lineno++;
+ yylval->chr = yytext[0];
+ return ERRTOK;
+}
+ YY_BREAK
+case 149:
+YY_RULE_SETUP
+#line 1206 "parser.l"
+{
+ wchar_t wchr[8];
+ if (utf8_from_buf(wchr, coerce(unsigned char *, yytext), yyleng) != 2) {
+ yylval->lexeme = chk_strdup(wchr);
+ return TEXT;
+ }
+ yylval->chr = wchr[0];
+ return LITCHAR;
+}
+ YY_BREAK
+case 150:
+YY_RULE_SETUP
+#line 1216 "parser.l"
+{
+ yylval->chr = strtol(yytext, 0, 16);
+ return LITCHAR;
+}
+ YY_BREAK
+case 151:
+YY_RULE_SETUP
+#line 1221 "parser.l"
+{
+ return '\'';
+}
+ YY_BREAK
+case 152:
+YY_RULE_SETUP
+#line 1225 "parser.l"
+{
+}
+ YY_BREAK
+case 153:
+/* rule 153 can match eol */
+YY_RULE_SETUP
+#line 1228 "parser.l"
+{
+ yyextra->lineno++;
+}
+ YY_BREAK
+case 154:
+YY_RULE_SETUP
+#line 1232 "parser.l"
+{
+ yyerrorf(yyg, lit("bad character ~s in buffer literal"),
+ chr(yytext[0]), nao);
+}
+ YY_BREAK
+case 155:
+YY_RULE_SETUP
+#line 1237 "parser.l"
+{
+ yylval->chr = convert(unsigned char, yytext[0]) + 0xDC00;
+ return LITCHAR;
+}
+ YY_BREAK
+case 156:
+YY_RULE_SETUP
+#line 1242 "parser.l"
+{
+ if ((yylval->val = flo_str_utf8(yytext)) == nil)
+ out_of_range_float(yyg, yytext);
+ return NUMBER;
+}
+ YY_BREAK
+case 157:
+/* rule 157 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_bp + 4);
+yyg->yy_c_buf_p = yy_cp = yy_bp + 4;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 1248 "parser.l"
+{
+ yylval->val = t;
+ return JSKW;
+}
+ YY_BREAK
+case 158:
+/* rule 158 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_bp + 5);
+yyg->yy_c_buf_p = yy_cp = yy_bp + 5;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 1253 "parser.l"
+{
+ yylval->val = nil;
+ return JSKW;
+}
+ YY_BREAK
+case 159:
+/* rule 159 can match eol */
+*yy_cp = yyg->yy_hold_char; /* undo effects of setting up yytext */
+YY_LINENO_REWIND_TO(yy_bp + 4);
+yyg->yy_c_buf_p = yy_cp = yy_bp + 4;
+YY_DO_BEFORE_ACTION; /* set up yytext again */
+YY_RULE_SETUP
+#line 1258 "parser.l"
+{
+ yylval->val = null_s;
+ return JSKW;
+}
+ YY_BREAK
+case 160:
+YY_RULE_SETUP
+#line 1263 "parser.l"
+{
+ if (strcmp("true", yytext) == 0) {
+ yylval->val = t;
+ return JSKW;
+ }
+
+ if (strcmp("false", yytext) == 0) {
+ yylval->val = nil;
+ return JSKW;
+ }
+
+ if (strcmp("null", yytext) == 0) {
+ yylval->val = null_s;
+ return JSKW;
+ }
+
+ {
+ val str = string_own(utf8_dup_from(yytext));
+ yyerrorf(yyg, lit("unrecognized JSON syntax: ~a"), str, nao);
+ }
+}
+ YY_BREAK
+case 161:
+YY_RULE_SETUP
+#line 1285 "parser.l"
+{
+ yy_push_state(JLIT, yyscanner);
+ return yytext[0];
+}
+ YY_BREAK
+case 162:
+YY_RULE_SETUP
+#line 1290 "parser.l"
+{
+ yy_push_state(JMARKER, yyscanner);
+ yy_push_state(NESTED, yyscanner);
+ return JSPLICE;
+}
+ YY_BREAK
+case 163:
+YY_RULE_SETUP
+#line 1296 "parser.l"
+{
+ yy_push_state(JMARKER, yyscanner);
+ yy_push_state(NESTED, yyscanner);
+ return yytext[0];
+}
+ YY_BREAK
+case 164:
+YY_RULE_SETUP
+#line 1302 "parser.l"
+{
+ return yytext[0];
+}
+ YY_BREAK
+case 165:
+/* rule 165 can match eol */
+YY_RULE_SETUP
+#line 1306 "parser.l"
+{
+ yyextra->lineno++;
+}
+ YY_BREAK
+case 166:
+YY_RULE_SETUP
+#line 1310 "parser.l"
+{
+}
+ YY_BREAK
+case 167:
+YY_RULE_SETUP
+#line 1313 "parser.l"
+{
+ yyerrorf(yyg, lit("bad character ~s in JSON literal"),
+ chr(yytext[0]), nao);
+}
+ YY_BREAK
+case 168:
+YY_RULE_SETUP
+#line 1318 "parser.l"
+{
+ internal_error("scanner processed input JMARKER state");
+}
+ YY_BREAK
+case 169:
+YY_RULE_SETUP
+#line 1322 "parser.l"
+ECHO;
+ YY_BREAK
+#line 6526 "lex.yy.c"
+ case YY_STATE_EOF(INITIAL):
+ case YY_STATE_EOF(SPECIAL):
+ case YY_STATE_EOF(BRACED):
+ case YY_STATE_EOF(NESTED):
+ case YY_STATE_EOF(REGEX):
+ case YY_STATE_EOF(SREGEX):
+ case YY_STATE_EOF(STRLIT):
+ case YY_STATE_EOF(CHRLIT):
+ case YY_STATE_EOF(QSILIT):
+ case YY_STATE_EOF(QSPECIAL):
+ case YY_STATE_EOF(WLIT):
+ case YY_STATE_EOF(QWLIT):
+ case YY_STATE_EOF(BUFLIT):
+ case YY_STATE_EOF(JSON):
+ case YY_STATE_EOF(JLIT):
+ case YY_STATE_EOF(JMARKER):
+ yyterminate();
+
+ case YY_END_OF_BUFFER:
+ {
+ /* Amount of text matched not including the EOB char. */
+ int yy_amount_of_matched_text = (int) (yy_cp - yyg->yytext_ptr) - 1;
+
+ /* Undo the effects of YY_DO_BEFORE_ACTION. */
+ *yy_cp = yyg->yy_hold_char;
+ YY_RESTORE_YY_MORE_OFFSET
+
+ if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_NEW )
+ {
+ /* We're scanning a new file or input source. It's
+ * possible that this happened because the user
+ * just pointed yyin at a new source and called
+ * yylex(). If so, then we have to assure
+ * consistency between YY_CURRENT_BUFFER and our
+ * globals. Here is the right place to do so, because
+ * this is the first action (other than possibly a
+ * back-up) that will match for the new input source.
+ */
+ yyg->yy_n_chars = YY_CURRENT_BUFFER_LVALUE->yy_n_chars;
+ YY_CURRENT_BUFFER_LVALUE->yy_input_file = yyin;
+ YY_CURRENT_BUFFER_LVALUE->yy_buffer_status = YY_BUFFER_NORMAL;
+ }
+
+ /* Note that here we test for yy_c_buf_p "<=" to the position
+ * of the first EOB in the buffer, since yy_c_buf_p will
+ * already have been incremented past the NUL character
+ * (since all states make transitions on EOB to the
+ * end-of-buffer state). Contrast this with the test
+ * in input().
+ */
+ if ( yyg->yy_c_buf_p <= &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[yyg->yy_n_chars] )
+ { /* This was really a NUL. */
+ yy_state_type yy_next_state;
+
+ yyg->yy_c_buf_p = yyg->yytext_ptr + yy_amount_of_matched_text;
+
+ yy_current_state = yy_get_previous_state( yyscanner );
+
+ /* Okay, we're now positioned to make the NUL
+ * transition. We couldn't have
+ * yy_get_previous_state() go ahead and do it
+ * for us because it doesn't know how to deal
+ * with the possibility of jamming (and we don't
+ * want to build jamming into it because then it
+ * will run more slowly).
+ */
+
+ yy_next_state = yy_try_NUL_trans( yy_current_state , yyscanner);
+
+ yy_bp = yyg->yytext_ptr + YY_MORE_ADJ;
+
+ if ( yy_next_state )
+ {
+ /* Consume the NUL. */
+ yy_cp = ++yyg->yy_c_buf_p;
+ yy_current_state = yy_next_state;
+ goto yy_match;
+ }
+
+ else
+ {
+ yy_cp = yyg->yy_c_buf_p;
+ goto yy_find_action;
+ }
+ }
+
+ else switch ( yy_get_next_buffer( yyscanner ) )
+ {
+ case EOB_ACT_END_OF_FILE:
+ {
+ yyg->yy_did_buffer_switch_on_eof = 0;
+
+ if ( yywrap( yyscanner ) )
+ {
+ /* Note: because we've taken care in
+ * yy_get_next_buffer() to have set up
+ * yytext, we can now set up
+ * yy_c_buf_p so that if some total
+ * hoser (like flex itself) wants to
+ * call the scanner after we return the
+ * YY_NULL, it'll still work - another
+ * YY_NULL will get returned.
+ */
+ yyg->yy_c_buf_p = yyg->yytext_ptr + YY_MORE_ADJ;
+
+ yy_act = YY_STATE_EOF(YY_START);
+ goto do_action;
+ }
+
+ else
+ {
+ if ( ! yyg->yy_did_buffer_switch_on_eof )
+ YY_NEW_FILE;
+ }
+ break;
+ }
+
+ case EOB_ACT_CONTINUE_SCAN:
+ yyg->yy_c_buf_p =
+ yyg->yytext_ptr + yy_amount_of_matched_text;
+
+ yy_current_state = yy_get_previous_state( yyscanner );
+
+ yy_cp = yyg->yy_c_buf_p;
+ yy_bp = yyg->yytext_ptr + YY_MORE_ADJ;
+ goto yy_match;
+
+ case EOB_ACT_LAST_MATCH:
+ yyg->yy_c_buf_p =
+ &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[yyg->yy_n_chars];
+
+ yy_current_state = yy_get_previous_state( yyscanner );
+
+ yy_cp = yyg->yy_c_buf_p;
+ yy_bp = yyg->yytext_ptr + YY_MORE_ADJ;
+ goto yy_find_action;
+ }
+ break;
+ }
+
+ default:
+ YY_FATAL_ERROR(
+ "fatal flex scanner internal error--no action found" );
+ } /* end of action switch */
+ } /* end of scanning one token */
+ } /* end of user's declarations */
+} /* end of yylex */
+
+/* yy_get_next_buffer - try to read in a new buffer
+ *
+ * Returns a code representing an action:
+ * EOB_ACT_LAST_MATCH -
+ * EOB_ACT_CONTINUE_SCAN - continue scanning from current position
+ * EOB_ACT_END_OF_FILE - end of file
+ */
+static int yy_get_next_buffer (yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ char *dest = YY_CURRENT_BUFFER_LVALUE->yy_ch_buf;
+ char *source = yyg->yytext_ptr;
+ int number_to_move, i;
+ int ret_val;
+
+ if ( yyg->yy_c_buf_p > &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[yyg->yy_n_chars + 1] )
+ YY_FATAL_ERROR(
+ "fatal flex scanner internal error--end of buffer missed" );
+
+ if ( YY_CURRENT_BUFFER_LVALUE->yy_fill_buffer == 0 )
+ { /* Don't try to fill the buffer, so this is an EOF. */
+ if ( yyg->yy_c_buf_p - yyg->yytext_ptr - YY_MORE_ADJ == 1 )
+ {
+ /* We matched a single character, the EOB, so
+ * treat this as a final EOF.
+ */
+ return EOB_ACT_END_OF_FILE;
+ }
+
+ else
+ {
+ /* We matched some text prior to the EOB, first
+ * process it.
+ */
+ return EOB_ACT_LAST_MATCH;
+ }
+ }
+
+ /* Try to read more data. */
+
+ /* First move last chars to start of buffer. */
+ number_to_move = (int) (yyg->yy_c_buf_p - yyg->yytext_ptr - 1);
+
+ for ( i = 0; i < number_to_move; ++i )
+ *(dest++) = *(source++);
+
+ if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_EOF_PENDING )
+ /* don't do the read, it's not guaranteed to return an EOF,
+ * just force an EOF
+ */
+ YY_CURRENT_BUFFER_LVALUE->yy_n_chars = yyg->yy_n_chars = 0;
+
+ else
+ {
+ int num_to_read =
+ YY_CURRENT_BUFFER_LVALUE->yy_buf_size - number_to_move - 1;
+
+ while ( num_to_read <= 0 )
+ { /* Not enough room in the buffer - grow it. */
+
+ YY_FATAL_ERROR(
+"input buffer overflow, can't enlarge buffer because scanner uses REJECT" );
+
+ }
+
+ if ( num_to_read > YY_READ_BUF_SIZE )
+ num_to_read = YY_READ_BUF_SIZE;
+
+ /* Read in more data. */
+ YY_INPUT( (&YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move]),
+ yyg->yy_n_chars, num_to_read );
+
+ YY_CURRENT_BUFFER_LVALUE->yy_n_chars = yyg->yy_n_chars;
+ }
+
+ if ( yyg->yy_n_chars == 0 )
+ {
+ if ( number_to_move == YY_MORE_ADJ )
+ {
+ ret_val = EOB_ACT_END_OF_FILE;
+ yyrestart( yyin , yyscanner);
+ }
+
+ else
+ {
+ ret_val = EOB_ACT_LAST_MATCH;
+ YY_CURRENT_BUFFER_LVALUE->yy_buffer_status =
+ YY_BUFFER_EOF_PENDING;
+ }
+ }
+
+ else
+ ret_val = EOB_ACT_CONTINUE_SCAN;
+
+ if ((yyg->yy_n_chars + number_to_move) > YY_CURRENT_BUFFER_LVALUE->yy_buf_size) {
+ /* Extend the array by 50%, plus the number we really need. */
+ int new_size = yyg->yy_n_chars + number_to_move + (yyg->yy_n_chars >> 1);
+ YY_CURRENT_BUFFER_LVALUE->yy_ch_buf = (char *) yyrealloc(
+ (void *) YY_CURRENT_BUFFER_LVALUE->yy_ch_buf, (yy_size_t) new_size , yyscanner );
+ if ( ! YY_CURRENT_BUFFER_LVALUE->yy_ch_buf )
+ YY_FATAL_ERROR( "out of dynamic memory in yy_get_next_buffer()" );
+ /* "- 2" to take care of EOB's */
+ YY_CURRENT_BUFFER_LVALUE->yy_buf_size = (int) (new_size - 2);
+ }
+
+ yyg->yy_n_chars += number_to_move;
+ YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[yyg->yy_n_chars] = YY_END_OF_BUFFER_CHAR;
+ YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[yyg->yy_n_chars + 1] = YY_END_OF_BUFFER_CHAR;
+
+ yyg->yytext_ptr = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[0];
+
+ return ret_val;
+}
+
+/* yy_get_previous_state - get the state just before the EOB char was reached */
+
+ static yy_state_type yy_get_previous_state (yyscan_t yyscanner)
+{
+ yy_state_type yy_current_state;
+ char *yy_cp;
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+
+ yy_current_state = yyg->yy_start;
+ yy_current_state += YY_AT_BOL();
+
+ yyg->yy_state_ptr = yyg->yy_state_buf;
+ *yyg->yy_state_ptr++ = yy_current_state;
+
+ for ( yy_cp = yyg->yytext_ptr + YY_MORE_ADJ; yy_cp < yyg->yy_c_buf_p; ++yy_cp )
+ {
+ YY_CHAR yy_c = (*yy_cp ? yy_ec[YY_SC_TO_UI(*yy_cp)] : 1);
+ while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state )
+ {
+ yy_current_state = (int) yy_def[yy_current_state];
+ if ( yy_current_state >= 1764 )
+ yy_c = yy_meta[yy_c];
+ }
+ yy_current_state = yy_nxt[yy_base[yy_current_state] + yy_c];
+ *yyg->yy_state_ptr++ = yy_current_state;
+ }
+
+ return yy_current_state;
+}
+
+/* yy_try_NUL_trans - try to make a transition on the NUL character
+ *
+ * synopsis
+ * next_state = yy_try_NUL_trans( current_state );
+ */
+ static yy_state_type yy_try_NUL_trans (yy_state_type yy_current_state , yyscan_t yyscanner)
+{
+ int yy_is_jam;
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner; /* This var may be unused depending upon options. */
+
+ YY_CHAR yy_c = 1;
+ while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state )
+ {
+ yy_current_state = (int) yy_def[yy_current_state];
+ if ( yy_current_state >= 1764 )
+ yy_c = yy_meta[yy_c];
+ }
+ yy_current_state = yy_nxt[yy_base[yy_current_state] + yy_c];
+ yy_is_jam = (yy_current_state == 1763);
+ if ( ! yy_is_jam )
+ *yyg->yy_state_ptr++ = yy_current_state;
+
+ (void)yyg;
+ return yy_is_jam ? 0 : yy_current_state;
+}
+
+#ifndef YY_NO_UNPUT
+
+ static void yyunput (int c, char * yy_bp , yyscan_t yyscanner)
+{
+ char *yy_cp;
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+
+ yy_cp = yyg->yy_c_buf_p;
+
+ /* undo effects of setting up yytext */
+ *yy_cp = yyg->yy_hold_char;
+
+ if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 )
+ { /* need to shift things up to make room */
+ /* +2 for EOB chars. */
+ int number_to_move = yyg->yy_n_chars + 2;
+ char *dest = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[
+ YY_CURRENT_BUFFER_LVALUE->yy_buf_size + 2];
+ char *source =
+ &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move];
+
+ while ( source > YY_CURRENT_BUFFER_LVALUE->yy_ch_buf )
+ *--dest = *--source;
+
+ yy_cp += (int) (dest - source);
+ yy_bp += (int) (dest - source);
+ YY_CURRENT_BUFFER_LVALUE->yy_n_chars =
+ yyg->yy_n_chars = (int) YY_CURRENT_BUFFER_LVALUE->yy_buf_size;
+
+ if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 )
+ YY_FATAL_ERROR( "flex scanner push-back overflow" );
+ }
+
+ *--yy_cp = (char) c;
+
+ yyg->yytext_ptr = yy_bp;
+ yyg->yy_hold_char = *yy_cp;
+ yyg->yy_c_buf_p = yy_cp;
+}
+
+#endif
+
+#ifndef YY_NO_INPUT
+#ifdef __cplusplus
+ static int yyinput (yyscan_t yyscanner)
+#else
+ static int input (yyscan_t yyscanner)
+#endif
+
+{
+ int c;
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+
+ *yyg->yy_c_buf_p = yyg->yy_hold_char;
+
+ if ( *yyg->yy_c_buf_p == YY_END_OF_BUFFER_CHAR )
+ {
+ /* yy_c_buf_p now points to the character we want to return.
+ * If this occurs *before* the EOB characters, then it's a
+ * valid NUL; if not, then we've hit the end of the buffer.
+ */
+ if ( yyg->yy_c_buf_p < &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[yyg->yy_n_chars] )
+ /* This was really a NUL. */
+ *yyg->yy_c_buf_p = '\0';
+
+ else
+ { /* need more input */
+ int offset = (int) (yyg->yy_c_buf_p - yyg->yytext_ptr);
+ ++yyg->yy_c_buf_p;
+
+ switch ( yy_get_next_buffer( yyscanner ) )
+ {
+ case EOB_ACT_LAST_MATCH:
+ /* This happens because yy_g_n_b()
+ * sees that we've accumulated a
+ * token and flags that we need to
+ * try matching the token before
+ * proceeding. But for input(),
+ * there's no matching to consider.
+ * So convert the EOB_ACT_LAST_MATCH
+ * to EOB_ACT_END_OF_FILE.
+ */
+
+ /* Reset buffer status. */
+ yyrestart( yyin , yyscanner);
+
+ /*FALLTHROUGH*/
+
+ case EOB_ACT_END_OF_FILE:
+ {
+ if ( yywrap( yyscanner ) )
+ return 0;
+
+ if ( ! yyg->yy_did_buffer_switch_on_eof )
+ YY_NEW_FILE;
+#ifdef __cplusplus
+ return yyinput(yyscanner);
+#else
+ return input(yyscanner);
+#endif
+ }
+
+ case EOB_ACT_CONTINUE_SCAN:
+ yyg->yy_c_buf_p = yyg->yytext_ptr + offset;
+ break;
+ }
+ }
+ }
+
+ c = *(unsigned char *) yyg->yy_c_buf_p; /* cast for 8-bit char's */
+ *yyg->yy_c_buf_p = '\0'; /* preserve yytext */
+ yyg->yy_hold_char = *++yyg->yy_c_buf_p;
+
+ YY_CURRENT_BUFFER_LVALUE->yy_at_bol = (c == '\n');
+
+ return c;
+}
+#endif /* ifndef YY_NO_INPUT */
+
+/** Immediately switch to a different input stream.
+ * @param input_file A readable stream.
+ * @param yyscanner The scanner object.
+ * @note This function does not reset the start condition to @c INITIAL .
+ */
+ void yyrestart (FILE * input_file , yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+
+ if ( ! YY_CURRENT_BUFFER ){
+ yyensure_buffer_stack (yyscanner);
+ YY_CURRENT_BUFFER_LVALUE =
+ yy_create_buffer( yyin, YY_BUF_SIZE , yyscanner);
+ }
+
+ yy_init_buffer( YY_CURRENT_BUFFER, input_file , yyscanner);
+ yy_load_buffer_state( yyscanner );
+}
+
+/** Switch to a different input buffer.
+ * @param new_buffer The new input buffer.
+ * @param yyscanner The scanner object.
+ */
+ void yy_switch_to_buffer (YY_BUFFER_STATE new_buffer , yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+
+ /* TODO. We should be able to replace this entire function body
+ * with
+ * yypop_buffer_state();
+ * yypush_buffer_state(new_buffer);
+ */
+ yyensure_buffer_stack (yyscanner);
+ if ( YY_CURRENT_BUFFER == new_buffer )
+ return;
+
+ if ( YY_CURRENT_BUFFER )
+ {
+ /* Flush out information for old buffer. */
+ *yyg->yy_c_buf_p = yyg->yy_hold_char;
+ YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = yyg->yy_c_buf_p;
+ YY_CURRENT_BUFFER_LVALUE->yy_n_chars = yyg->yy_n_chars;
+ }
+
+ YY_CURRENT_BUFFER_LVALUE = new_buffer;
+ yy_load_buffer_state( yyscanner );
+
+ /* We don't actually know whether we did this switch during
+ * EOF (yywrap()) processing, but the only time this flag
+ * is looked at is after yywrap() is called, so it's safe
+ * to go ahead and always set it.
+ */
+ yyg->yy_did_buffer_switch_on_eof = 1;
+}
+
+static void yy_load_buffer_state (yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ yyg->yy_n_chars = YY_CURRENT_BUFFER_LVALUE->yy_n_chars;
+ yyg->yytext_ptr = yyg->yy_c_buf_p = YY_CURRENT_BUFFER_LVALUE->yy_buf_pos;
+ yyin = YY_CURRENT_BUFFER_LVALUE->yy_input_file;
+ yyg->yy_hold_char = *yyg->yy_c_buf_p;
+}
+
+/** Allocate and initialize an input buffer state.
+ * @param file A readable stream.
+ * @param size The character buffer size in bytes. When in doubt, use @c YY_BUF_SIZE.
+ * @param yyscanner The scanner object.
+ * @return the allocated buffer state.
+ */
+ YY_BUFFER_STATE yy_create_buffer (FILE * file, int size , yyscan_t yyscanner)
+{
+ YY_BUFFER_STATE b;
+
+ b = (YY_BUFFER_STATE) yyalloc( sizeof( struct yy_buffer_state ) , yyscanner );
+ if ( ! b )
+ YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" );
+
+ b->yy_buf_size = size;
+
+ /* yy_ch_buf has to be 2 characters longer than the size given because
+ * we need to put in 2 end-of-buffer characters.
+ */
+ b->yy_ch_buf = (char *) yyalloc( (yy_size_t) (b->yy_buf_size + 2) , yyscanner );
+ if ( ! b->yy_ch_buf )
+ YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" );
+
+ b->yy_is_our_buffer = 1;
+
+ yy_init_buffer( b, file , yyscanner);
+
+ return b;
+}
+
+/** Destroy the buffer.
+ * @param b a buffer created with yy_create_buffer()
+ * @param yyscanner The scanner object.
+ */
+ void yy_delete_buffer (YY_BUFFER_STATE b , yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+
+ if ( ! b )
+ return;
+
+ if ( b == YY_CURRENT_BUFFER ) /* Not sure if we should pop here. */
+ YY_CURRENT_BUFFER_LVALUE = (YY_BUFFER_STATE) 0;
+
+ if ( b->yy_is_our_buffer )
+ yyfree( (void *) b->yy_ch_buf , yyscanner );
+
+ yyfree( (void *) b , yyscanner );
+}
+
+/* Initializes or reinitializes a buffer.
+ * This function is sometimes called more than once on the same buffer,
+ * such as during a yyrestart() or at EOF.
+ */
+ static void yy_init_buffer (YY_BUFFER_STATE b, FILE * file , yyscan_t yyscanner)
+
+{
+ int oerrno = errno;
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+
+ yy_flush_buffer( b , yyscanner);
+
+ b->yy_input_file = file;
+ b->yy_fill_buffer = 1;
+
+ /* If b is the current buffer, then yy_init_buffer was _probably_
+ * called from yyrestart() or through yy_get_next_buffer.
+ * In that case, we don't want to reset the lineno or column.
+ */
+ if (b != YY_CURRENT_BUFFER){
+ b->yy_bs_lineno = 1;
+ b->yy_bs_column = 0;
+ }
+
+ b->yy_is_interactive = 0;
+
+ errno = oerrno;
+}
+
+/** Discard all buffered characters. On the next scan, YY_INPUT will be called.
+ * @param b the buffer state to be flushed, usually @c YY_CURRENT_BUFFER.
+ * @param yyscanner The scanner object.
+ */
+ void yy_flush_buffer (YY_BUFFER_STATE b , yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ if ( ! b )
+ return;
+
+ b->yy_n_chars = 0;
+
+ /* We always need two end-of-buffer characters. The first causes
+ * a transition to the end-of-buffer state. The second causes
+ * a jam in that state.
+ */
+ b->yy_ch_buf[0] = YY_END_OF_BUFFER_CHAR;
+ b->yy_ch_buf[1] = YY_END_OF_BUFFER_CHAR;
+
+ b->yy_buf_pos = &b->yy_ch_buf[0];
+
+ b->yy_at_bol = 1;
+ b->yy_buffer_status = YY_BUFFER_NEW;
+
+ if ( b == YY_CURRENT_BUFFER )
+ yy_load_buffer_state( yyscanner );
+}
+
+/** Pushes the new state onto the stack. The new state becomes
+ * the current state. This function will allocate the stack
+ * if necessary.
+ * @param new_buffer The new state.
+ * @param yyscanner The scanner object.
+ */
+void yypush_buffer_state (YY_BUFFER_STATE new_buffer , yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ if (new_buffer == NULL)
+ return;
+
+ yyensure_buffer_stack(yyscanner);
+
+ /* This block is copied from yy_switch_to_buffer. */
+ if ( YY_CURRENT_BUFFER )
+ {
+ /* Flush out information for old buffer. */
+ *yyg->yy_c_buf_p = yyg->yy_hold_char;
+ YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = yyg->yy_c_buf_p;
+ YY_CURRENT_BUFFER_LVALUE->yy_n_chars = yyg->yy_n_chars;
+ }
+
+ /* Only push if top exists. Otherwise, replace top. */
+ if (YY_CURRENT_BUFFER)
+ yyg->yy_buffer_stack_top++;
+ YY_CURRENT_BUFFER_LVALUE = new_buffer;
+
+ /* copied from yy_switch_to_buffer. */
+ yy_load_buffer_state( yyscanner );
+ yyg->yy_did_buffer_switch_on_eof = 1;
+}
+
+/** Removes and deletes the top of the stack, if present.
+ * The next element becomes the new top.
+ * @param yyscanner The scanner object.
+ */
+void yypop_buffer_state (yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ if (!YY_CURRENT_BUFFER)
+ return;
+
+ yy_delete_buffer(YY_CURRENT_BUFFER , yyscanner);
+ YY_CURRENT_BUFFER_LVALUE = NULL;
+ if (yyg->yy_buffer_stack_top > 0)
+ --yyg->yy_buffer_stack_top;
+
+ if (YY_CURRENT_BUFFER) {
+ yy_load_buffer_state( yyscanner );
+ yyg->yy_did_buffer_switch_on_eof = 1;
+ }
+}
+
+/* Allocates the stack if it does not exist.
+ * Guarantees space for at least one push.
+ */
+static void yyensure_buffer_stack (yyscan_t yyscanner)
+{
+ yy_size_t num_to_alloc;
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+
+ if (!yyg->yy_buffer_stack) {
+
+ /* First allocation is just for 2 elements, since we don't know if this
+ * scanner will even need a stack. We use 2 instead of 1 to avoid an
+ * immediate realloc on the next call.
+ */
+ num_to_alloc = 1; /* After all that talk, this was set to 1 anyways... */
+ yyg->yy_buffer_stack = (struct yy_buffer_state**)yyalloc
+ (num_to_alloc * sizeof(struct yy_buffer_state*)
+ , yyscanner);
+ if ( ! yyg->yy_buffer_stack )
+ YY_FATAL_ERROR( "out of dynamic memory in yyensure_buffer_stack()" );
+
+ memset(yyg->yy_buffer_stack, 0, num_to_alloc * sizeof(struct yy_buffer_state*));
+
+ yyg->yy_buffer_stack_max = num_to_alloc;
+ yyg->yy_buffer_stack_top = 0;
+ return;
+ }
+
+ if (yyg->yy_buffer_stack_top >= (yyg->yy_buffer_stack_max) - 1){
+
+ /* Increase the buffer to prepare for a possible push. */
+ yy_size_t grow_size = 8 /* arbitrary grow size */;
+
+ num_to_alloc = yyg->yy_buffer_stack_max + grow_size;
+ yyg->yy_buffer_stack = (struct yy_buffer_state**)yyrealloc
+ (yyg->yy_buffer_stack,
+ num_to_alloc * sizeof(struct yy_buffer_state*)
+ , yyscanner);
+ if ( ! yyg->yy_buffer_stack )
+ YY_FATAL_ERROR( "out of dynamic memory in yyensure_buffer_stack()" );
+
+ /* zero only the new slots.*/
+ memset(yyg->yy_buffer_stack + yyg->yy_buffer_stack_max, 0, grow_size * sizeof(struct yy_buffer_state*));
+ yyg->yy_buffer_stack_max = num_to_alloc;
+ }
+}
+
+/** Setup the input buffer state to scan directly from a user-specified character buffer.
+ * @param base the character buffer
+ * @param size the size in bytes of the character buffer
+ * @param yyscanner The scanner object.
+ * @return the newly allocated buffer state object.
+ */
+YY_BUFFER_STATE yy_scan_buffer (char * base, yy_size_t size , yyscan_t yyscanner)
+{
+ YY_BUFFER_STATE b;
+
+ if ( size < 2 ||
+ base[size-2] != YY_END_OF_BUFFER_CHAR ||
+ base[size-1] != YY_END_OF_BUFFER_CHAR )
+ /* They forgot to leave room for the EOB's. */
+ return NULL;
+
+ b = (YY_BUFFER_STATE) yyalloc( sizeof( struct yy_buffer_state ) , yyscanner );
+ if ( ! b )
+ YY_FATAL_ERROR( "out of dynamic memory in yy_scan_buffer()" );
+
+ b->yy_buf_size = (int) (size - 2); /* "- 2" to take care of EOB's */
+ b->yy_buf_pos = b->yy_ch_buf = base;
+ b->yy_is_our_buffer = 0;
+ b->yy_input_file = NULL;
+ b->yy_n_chars = b->yy_buf_size;
+ b->yy_is_interactive = 0;
+ b->yy_at_bol = 1;
+ b->yy_fill_buffer = 0;
+ b->yy_buffer_status = YY_BUFFER_NEW;
+
+ yy_switch_to_buffer( b , yyscanner );
+
+ return b;
+}
+
+/** Setup the input buffer state to scan a string. The next call to yylex() will
+ * scan from a @e copy of @a str.
+ * @param yystr a NUL-terminated string to scan
+ * @param yyscanner The scanner object.
+ * @return the newly allocated buffer state object.
+ * @note If you want to scan bytes that may contain NUL values, then use
+ * yy_scan_bytes() instead.
+ */
+YY_BUFFER_STATE yy_scan_string (const char * yystr , yyscan_t yyscanner)
+{
+
+ return yy_scan_bytes( yystr, (int) strlen(yystr) , yyscanner);
+}
+
+/** Setup the input buffer state to scan the given bytes. The next call to yylex() will
+ * scan from a @e copy of @a bytes.
+ * @param yybytes the byte buffer to scan
+ * @param _yybytes_len the number of bytes in the buffer pointed to by @a bytes.
+ * @param yyscanner The scanner object.
+ * @return the newly allocated buffer state object.
+ */
+YY_BUFFER_STATE yy_scan_bytes (const char * yybytes, int _yybytes_len , yyscan_t yyscanner)
+{
+ YY_BUFFER_STATE b;
+ char *buf;
+ yy_size_t n;
+ int i;
+
+ /* Get memory for full buffer, including space for trailing EOB's. */
+ n = (yy_size_t) (_yybytes_len + 2);
+ buf = (char *) yyalloc( n , yyscanner );
+ if ( ! buf )
+ YY_FATAL_ERROR( "out of dynamic memory in yy_scan_bytes()" );
+
+ for ( i = 0; i < _yybytes_len; ++i )
+ buf[i] = yybytes[i];
+
+ buf[_yybytes_len] = buf[_yybytes_len+1] = YY_END_OF_BUFFER_CHAR;
+
+ b = yy_scan_buffer( buf, n , yyscanner);
+ if ( ! b )
+ YY_FATAL_ERROR( "bad buffer in yy_scan_bytes()" );
+
+ /* It's okay to grow etc. this buffer, and we should throw it
+ * away when we're done.
+ */
+ b->yy_is_our_buffer = 1;
+
+ return b;
+}
+
+ static void yy_push_state (int _new_state , yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ if ( yyg->yy_start_stack_ptr >= yyg->yy_start_stack_depth )
+ {
+ yy_size_t new_size;
+
+ yyg->yy_start_stack_depth += YY_START_STACK_INCR;
+ new_size = (yy_size_t) yyg->yy_start_stack_depth * sizeof( int );
+
+ if ( ! yyg->yy_start_stack )
+ yyg->yy_start_stack = (int *) yyalloc( new_size , yyscanner );
+
+ else
+ yyg->yy_start_stack = (int *) yyrealloc(
+ (void *) yyg->yy_start_stack, new_size , yyscanner );
+
+ if ( ! yyg->yy_start_stack )
+ YY_FATAL_ERROR( "out of memory expanding start-condition stack" );
+ }
+
+ yyg->yy_start_stack[yyg->yy_start_stack_ptr++] = YY_START;
+
+ BEGIN(_new_state);
+}
+
+ static void yy_pop_state (yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ if ( --yyg->yy_start_stack_ptr < 0 )
+ YY_FATAL_ERROR( "start-condition stack underflow" );
+
+ BEGIN(yyg->yy_start_stack[yyg->yy_start_stack_ptr]);
+}
+
+ static int yy_top_state (yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ return yyg->yy_start_stack[yyg->yy_start_stack_ptr - 1];
+}
+
+#ifndef YY_EXIT_FAILURE
+#define YY_EXIT_FAILURE 2
+#endif
+
+static void yynoreturn yy_fatal_error (const char* msg , yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ (void)yyg;
+ fprintf( stderr, "%s\n", msg );
+ exit( YY_EXIT_FAILURE );
+}
+
+/* Redefine yyless() so it works in section 3 code. */
+
+#undef yyless
+#define yyless(n) \
+ do \
+ { \
+ /* Undo effects of setting up yytext. */ \
+ int yyless_macro_arg = (n); \
+ YY_LESS_LINENO(yyless_macro_arg);\
+ yytext[yyleng] = yyg->yy_hold_char; \
+ yyg->yy_c_buf_p = yytext + yyless_macro_arg; \
+ yyg->yy_hold_char = *yyg->yy_c_buf_p; \
+ *yyg->yy_c_buf_p = '\0'; \
+ yyleng = yyless_macro_arg; \
+ } \
+ while ( 0 )
+
+/* Accessor methods (get/set functions) to struct members. */
+
+/** Get the user-defined data for this scanner.
+ * @param yyscanner The scanner object.
+ */
+YY_EXTRA_TYPE yyget_extra (yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ return yyextra;
+}
+
+/** Get the current line number.
+ * @param yyscanner The scanner object.
+ */
+int yyget_lineno (yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+
+ if (! YY_CURRENT_BUFFER)
+ return 0;
+
+ return yylineno;
+}
+
+/** Get the current column number.
+ * @param yyscanner The scanner object.
+ */
+int yyget_column (yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+
+ if (! YY_CURRENT_BUFFER)
+ return 0;
+
+ return yycolumn;
+}
+
+/** Get the input stream.
+ * @param yyscanner The scanner object.
+ */
+FILE *yyget_in (yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ return yyin;
+}
+
+/** Get the output stream.
+ * @param yyscanner The scanner object.
+ */
+FILE *yyget_out (yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ return yyout;
+}
+
+/** Get the length of the current token.
+ * @param yyscanner The scanner object.
+ */
+int yyget_leng (yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ return yyleng;
+}
+
+/** Get the current token.
+ * @param yyscanner The scanner object.
+ */
+
+char *yyget_text (yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ return yytext;
+}
+
+/** Set the user-defined data. This data is never touched by the scanner.
+ * @param user_defined The data to be associated with this scanner.
+ * @param yyscanner The scanner object.
+ */
+void yyset_extra (YY_EXTRA_TYPE user_defined , yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ yyextra = user_defined ;
+}
+
+/** Set the current line number.
+ * @param _line_number line number
+ * @param yyscanner The scanner object.
+ */
+void yyset_lineno (int _line_number , yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+
+ /* lineno is only valid if an input buffer exists. */
+ if (! YY_CURRENT_BUFFER )
+ YY_FATAL_ERROR( "yyset_lineno called with no buffer" );
+
+ yylineno = _line_number;
+}
+
+/** Set the current column.
+ * @param _column_no column number
+ * @param yyscanner The scanner object.
+ */
+void yyset_column (int _column_no , yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+
+ /* column is only valid if an input buffer exists. */
+ if (! YY_CURRENT_BUFFER )
+ YY_FATAL_ERROR( "yyset_column called with no buffer" );
+
+ yycolumn = _column_no;
+}
+
+/** Set the input stream. This does not discard the current
+ * input buffer.
+ * @param _in_str A readable stream.
+ * @param yyscanner The scanner object.
+ * @see yy_switch_to_buffer
+ */
+void yyset_in (FILE * _in_str , yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ yyin = _in_str ;
+}
+
+void yyset_out (FILE * _out_str , yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ yyout = _out_str ;
+}
+
+int yyget_debug (yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ return yy_flex_debug;
+}
+
+void yyset_debug (int _bdebug , yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ yy_flex_debug = _bdebug ;
+}
+
+/* Accessor methods for yylval and yylloc */
+
+YYSTYPE * yyget_lval (yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ return yylval;
+}
+
+void yyset_lval (YYSTYPE * yylval_param , yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ yylval = yylval_param;
+}
+
+/* User-visible API */
+
+/* yylex_init is special because it creates the scanner itself, so it is
+ * the ONLY reentrant function that doesn't take the scanner as the last argument.
+ * That's why we explicitly handle the declaration, instead of using our macros.
+ */
+int yylex_init(yyscan_t* ptr_yy_globals)
+{
+ if (ptr_yy_globals == NULL){
+ errno = EINVAL;
+ return 1;
+ }
+
+ *ptr_yy_globals = (yyscan_t) yyalloc ( sizeof( struct yyguts_t ), NULL );
+
+ if (*ptr_yy_globals == NULL){
+ errno = ENOMEM;
+ return 1;
+ }
+
+ /* By setting to 0xAA, we expose bugs in yy_init_globals. Leave at 0x00 for releases. */
+ memset(*ptr_yy_globals,0x00,sizeof(struct yyguts_t));
+
+ return yy_init_globals ( *ptr_yy_globals );
+}
+
+/* yylex_init_extra has the same functionality as yylex_init, but follows the
+ * convention of taking the scanner as the last argument. Note however, that
+ * this is a *pointer* to a scanner, as it will be allocated by this call (and
+ * is the reason, too, why this function also must handle its own declaration).
+ * The user defined value in the first argument will be available to yyalloc in
+ * the yyextra field.
+ */
+int yylex_init_extra( YY_EXTRA_TYPE yy_user_defined, yyscan_t* ptr_yy_globals )
+{
+ struct yyguts_t dummy_yyguts;
+
+ yyset_extra (yy_user_defined, &dummy_yyguts);
+
+ if (ptr_yy_globals == NULL){
+ errno = EINVAL;
+ return 1;
+ }
+
+ *ptr_yy_globals = (yyscan_t) yyalloc ( sizeof( struct yyguts_t ), &dummy_yyguts );
+
+ if (*ptr_yy_globals == NULL){
+ errno = ENOMEM;
+ return 1;
+ }
+
+ /* By setting to 0xAA, we expose bugs in
+ yy_init_globals. Leave at 0x00 for releases. */
+ memset(*ptr_yy_globals,0x00,sizeof(struct yyguts_t));
+
+ yyset_extra (yy_user_defined, *ptr_yy_globals);
+
+ return yy_init_globals ( *ptr_yy_globals );
+}
+
+static int yy_init_globals (yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ /* Initialization is the same as for the non-reentrant scanner.
+ * This function is called from yylex_destroy(), so don't allocate here.
+ */
+
+ yyg->yy_buffer_stack = NULL;
+ yyg->yy_buffer_stack_top = 0;
+ yyg->yy_buffer_stack_max = 0;
+ yyg->yy_c_buf_p = NULL;
+ yyg->yy_init = 0;
+ yyg->yy_start = 0;
+
+ yyg->yy_start_stack_ptr = 0;
+ yyg->yy_start_stack_depth = 0;
+ yyg->yy_start_stack = NULL;
+
+ yyg->yy_state_buf = 0;
+ yyg->yy_state_ptr = 0;
+ yyg->yy_full_match = 0;
+ yyg->yy_lp = 0;
+
+/* Defined in main.c */
+#ifdef YY_STDINIT
+ yyin = stdin;
+ yyout = stdout;
+#else
+ yyin = NULL;
+ yyout = NULL;
+#endif
+
+ /* For future reference: Set errno on error, since we are called by
+ * yylex_init()
+ */
+ return 0;
+}
+
+/* yylex_destroy is for both reentrant and non-reentrant scanners. */
+int yylex_destroy (yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+
+ /* Pop the buffer stack, destroying each element. */
+ while(YY_CURRENT_BUFFER){
+ yy_delete_buffer( YY_CURRENT_BUFFER , yyscanner );
+ YY_CURRENT_BUFFER_LVALUE = NULL;
+ yypop_buffer_state(yyscanner);
+ }
+
+ /* Destroy the stack itself. */
+ yyfree(yyg->yy_buffer_stack , yyscanner);
+ yyg->yy_buffer_stack = NULL;
+
+ /* Destroy the start condition stack. */
+ yyfree( yyg->yy_start_stack , yyscanner );
+ yyg->yy_start_stack = NULL;
+
+ yyfree ( yyg->yy_state_buf , yyscanner);
+ yyg->yy_state_buf = NULL;
+
+ /* Reset the globals. This is important in a non-reentrant scanner so the next time
+ * yylex() is called, initialization will occur. */
+ yy_init_globals( yyscanner);
+
+ /* Destroy the main struct (reentrant only). */
+ yyfree ( yyscanner , yyscanner );
+ yyscanner = NULL;
+ return 0;
+}
+
+/*
+ * Internal utility routines.
+ */
+
+#ifndef yytext_ptr
+static void yy_flex_strncpy (char* s1, const char * s2, int n , yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ (void)yyg;
+
+ int i;
+ for ( i = 0; i < n; ++i )
+ s1[i] = s2[i];
+}
+#endif
+
+#ifdef YY_NEED_STRLEN
+static int yy_flex_strlen (const char * s , yyscan_t yyscanner)
+{
+ int n;
+ for ( n = 0; s[n]; ++n )
+ ;
+
+ return n;
+}
+#endif
+
+void *yyalloc (yy_size_t size , yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ (void)yyg;
+ return malloc(size);
+}
+
+void *yyrealloc (void * ptr, yy_size_t size , yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ (void)yyg;
+
+ /* The cast to (char *) in the following accommodates both
+ * implementations that use char* generic pointers, and those
+ * that use void* generic pointers. It works with the latter
+ * because both ANSI C and C++ allow castless assignment from
+ * any pointer type to void*, and deal with argument conversions
+ * as though doing an assignment.
+ */
+ return realloc(ptr, size);
+}
+
+void yyfree (void * ptr , yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = (struct yyguts_t*)yyscanner;
+ (void)yyg;
+ free( (char *) ptr ); /* see yyrealloc() for (char *) cast */
+}
+
+#define YYTABLES_NAME "yytables"
+
+#line 1322 "parser.l"
+
+
+static int directive_tok(scanner_t *yyscanner, int tok, int state)
+{
+ struct yyguts_t *yyg = convert(struct yyguts_t *, yyscanner);
+ char *pstart = yytext + 1 + strspn(yytext + 1, " \t");
+ char *pcolon = strchr(pstart, ':');
+ char *pend = pstart + strspn(pstart, ":-abcdefghijklmnopqrstuvwxyz");
+
+ *pend = 0;
+
+ if (pcolon != 0) {
+ val pkgname = string_utf8((*pcolon = 0, pstart));
+ val package = if3(pstart[0], find_package(pkgname), keyword_package);
+ if (!package) {
+ yyerrprepf(yyg, lit("package ~a not found"), pkgname, nao);
+ tok = ERRTOK;
+ }
+ if (package != user_package && package != keyword_package) {
+ val sym = string_utf8(pcolon + 1);
+ yyerrprepf(yyg, lit("~a:~a: original usr package expected, not ~a"),
+ pkgname, sym, pkgname, nao);
+ tok = ERRTOK;
+ }
+ } else {
+ val symname = string_utf8(pstart);
+ val sym = intern_fallback(symname, cur_package);
+ val package = symbol_package(sym);
+
+ if (package != user_package && package != keyword_package) {
+ yyerrprepf(yyg, lit("~a: this is ~a:~a, not usr:~a"),
+ symname, package_name(package), symname, symname, nao);
+ tok = ERRTOK;
+ }
+ }
+
+ if (state != 0)
+ yy_push_state(state, yyscanner);
+ else
+ yy_pop_state(yyscanner);
+ yylval->lineno = yyextra->lineno;
+ return tok;
+}
+
+void end_of_regex(scanner_t *yyg)
+{
+ if (YYSTATE != REGEX && YYSTATE != SREGEX)
+ internal_error("end_of_regex called in wrong scanner state");
+
+ yy_pop_state(yyg);
+
+ if (YYSTATE != INITIAL) {
+ if (yy_top_state(yyg) == INITIAL
+ || yy_top_state(yyg) == QSILIT
+ || yy_top_state(yyg) == QWLIT)
+ yy_pop_state(yyg);
+ }
+}
+
+void end_of_char(scanner_t *yyg)
+{
+ if (YYSTATE != CHRLIT)
+ internal_error("end_of_char called in wrong scanner state");
+
+ yy_pop_state(yyg);
+}
+
+void end_of_buflit(scanner_t *yyg)
+{
+ if (YYSTATE != BUFLIT)
+ internal_error("end_of_buflit called in wrong scanner state");
+
+ yy_pop_state(yyg);
+}
+
+void end_of_json(scanner_t *yyg)
+{
+ if (YYSTATE == JLIT)
+ yy_pop_state(yyg);
+
+ if (YYSTATE != JSON)
+ internal_error("end_of_json called in wrong scanner state");
+
+ yy_pop_state(yyg);
+}
+
+/* The complexity here is necessary because TXR Lisp parsing looks ahead
+ * by one token. (The reason for *that* is the support of a.b.c referencing dot
+ * syntax in TXR Lisp.)
+ *
+ * Consider these two different cases:
+ *
+ * ^#J[,~(+ 2.0 2.0)]
+ * ^#J[,~(+ 2.0 2.0) #J42]
+ *
+ * This end_of_json_unquote function gets called when the (+ 2.0 2.0)
+ * has been parsed, but the Yacc-generated parser has shifted one tokan
+ * ahead. It has read the ] token in the one case or the #J token in
+ * the other. These tokens have totally different effects on the Lex
+ * start condition. When the lexer reads the ] token, it pops off a NESTED
+ * state, whereas the #J token wants to push on a new JSON state.
+ * By the time end_of_json_unquote has been called, this has already happened.
+ *
+ * To deal with this, we use the dummy JMARKER start state which serves as a
+ * kind of parenthesis inside the start condition stack. BHefore scanning Lisp
+ * unquote within JSON, we push JMARKER state first, then the NESTED state.
+ *
+ * If the lookahead token is like ], and pops off a state, it will pop off
+ * our NESTED state, so we are left at the JMARKER state. If the lookahead
+ * token is something else like #J (HASH_J), then it will push a new
+ * state like JSON on top, and we have JMARKER NESTED JSON.
+ *
+ * So what we are doing here is popping off everything until we get down
+ * to the JMARKER state, and putting it into our little save area.
+ *
+ * Then we lose the JMARKER state.
+ *
+ * If the save area is empty, it means that the lookahead token consumed
+ * our NESTED state, and so we are done.
+ *
+ * If the save area is not empty, it means the lookahead put something
+ * extra over our NESTED state. We drop that state from our save area,
+ * and restore the rest of the save area back into the stack.
+ * Effectively, we are deleting the unquote-related states from the
+ * interior of the start condition stack, not to disturb new material
+ * initiated by the lookahead token.
+ */
+void end_of_json_unquote(scanner_t *yyg)
+{
+ int stacksave[8];
+ int top = 0;
+
+ while (YYSTATE != JMARKER) {
+ stacksave[top++] = YYSTATE;
+ yy_pop_state(yyg);
+ }
+
+ yy_pop_state(yyg);
+
+ if (top-- > 0) {
+ while (top > 0)
+ yy_push_state(stacksave[--top], yyg);
+ }
+}
+
+val source_loc(val form)
+{
+ return gethash(form_to_ln_hash, form);
+}
+
+val source_loc_str(val form, val alt)
+{
+ cons_bind (line, file, gethash(form_to_ln_hash, form));
+ if (missingp(alt))
+ alt = lit("source location n/a");
+ return if3(line, format(nil, lit("~a:~d"), file, line, nao), alt);
+}
+
+int yylex(YYSTYPE *yylval_param, yyscan_t yyscanner)
+{
+ struct yyguts_t * yyg = convert(struct yyguts_t *, yyscanner);
+ int yy_char;
+
+ if (yyextra->tok_idx > 0) {
+ struct yy_token *tok = &yyextra->tok_pushback[--yyextra->tok_idx];
+ yyextra->recent_tok = *tok;
+ *yylval_param = tok->yy_lval;
+ if (tok->yy_lex_state && tok->yy_lex_state != YYSTATE)
+ yy_push_state(tok->yy_lex_state, yyg);
+ return tok->yy_char;
+ }
+
+ yy_char = yyextra->recent_tok.yy_char = yylex_impl(yylval_param, yyscanner);
+ yyextra->recent_tok.yy_lval = *yylval_param;
+ yyextra->recent_tok.yy_lex_state = YYSTATE;
+
+ return yy_char;
+}
+
+void prime_scanner(scanner_t *yyg, enum prime_parser prim)
+{
+ while (YYSTATE != INITIAL)
+ yy_pop_state(yyg);
+
+ switch (prim) {
+ case prime_lisp:
+ case prime_interactive:
+ yy_push_state(SPECIAL, yyg);
+ yy_push_state(NESTED, yyg);
+ yy_push_state(NESTED, yyg);
+ break;
+ case prime_regex:
+ yy_push_state(SREGEX, yyg);
+ break;
+ case prime_json:
+ yy_push_state(JSON, yyg);
+ break;
+ }
+}
+
+void scrub_scanner(scanner_t *yyg, int yy_char, wchar_t *lexeme)
+{
+ struct yy_token *rtok = &yyextra->recent_tok;
+
+ if (rtok->yy_char == yy_char && rtok->yy_lval.lexeme == lexeme) {
+ rtok->yy_char = 0;
+ rtok->yy_lval.lexeme = 0;
+ }
+}
+
+void parser_l_init(void)
+{
+ prot1(&form_to_ln_hash);
+ form_to_ln_hash = make_eq_hash(hash_weak_keys);
+ (void) &yy_fatal_error; /* suppress unused function warning */
+}
+
diff --git a/lib.c b/lib.c
index acf66f36..12f024cc 100644
--- a/lib.c
+++ b/lib.c
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stdio.h>
@@ -35,10 +36,9 @@
#include <errno.h>
#include <wchar.h>
#include <math.h>
-#include <time.h>
#include <signal.h>
-#include <sys/time.h>
#include <assert.h>
+#include <locale.h>
#include "config.h"
#include "alloca.h"
#if HAVE_GETENVIRONMENTSTRINGS
@@ -48,6 +48,9 @@
#if HAVE_MALLOC_H
#include <malloc.h>
#endif
+#if HAVE_MALLOC_NP_H
+#include <malloc_np.h>
+#endif
#include "lib.h"
#include "gc.h"
#include "arith.h"
@@ -64,6 +67,7 @@
#include "eval.h"
#include "vm.h"
#include "sysif.h"
+#include "time.h"
#include "regex.h"
#include "parser.h"
#include "syslog.h"
@@ -76,11 +80,13 @@
#include "buf.h"
#include "ffi.h"
#include "chksum.h"
+#include "socket.h"
#include "txr.h"
#include "debug.h"
#define max(a, b) ((a) > (b) ? (a) : (b))
#define min(a, b) ((a) < (b) ? (a) : (b))
+#define nelem(array) (sizeof (array) / sizeof (array)[0])
#if !HAVE_POSIX_SIGS
int async_sig_enabled = 0;
@@ -104,7 +110,7 @@ val zeroplus_s, optional_s, compl_s, compound_s;
val or_s, and_s, quasi_s, quasilist_s;
val skip_s, trailer_s, block_s, next_s, freeform_s, fail_s, accept_s;
val all_s, some_s, none_s, maybe_s, cases_s, collect_s, until_s, coll_s;
-val define_s, output_s, single_s, first_s, last_s, empty_s;
+val define_s, output_s, push_s, single_s, first_s, last_s, empty_s;
val repeat_s, rep_s, flatten_s, forget_s;
val local_s, merge_s, bind_s, rebind_s, cat_s;
val try_s, catch_s, finally_s, throw_s, defex_s, deffilter_s;
@@ -112,36 +118,45 @@ val eof_s, eol_s, assert_s, name_s;
val error_s, type_error_s, internal_error_s, panic_s;
val numeric_error_s, range_error_s;
val query_error_s, file_error_s, process_error_s, syntax_error_s;
-val timeout_error_s, system_error_s, alloc_error_s;
+val timeout_error_s, system_error_s, alloc_error_s, stack_overflow_s;
val path_not_found_s, path_exists_s, path_permission_s;
val warning_s, defr_warning_s, restart_s, continue_s;
-val gensym_counter_s, length_s;
+val gensym_counter_s, length_s, length_lt_s;
val rplaca_s, rplacd_s, seq_iter_s;
+val lazy_streams_s;
val nothrow_k, args_k, colon_k, auto_k, fun_k;
val wrap_k, reflect_k;
val null_string;
val nil_string;
-val null_list;
val identity_f, identity_star_f;
val equal_f, eql_f, eq_f, car_f, cdr_f, null_f;
-val list_f, less_f, greater_f;
+val list_f, less_f, greater_f, gt_f;
val prog_string;
-val time_s, time_local_s, time_utc_s, time_string_s, time_parse_s;
-val year_s, month_s, day_s, hour_s, min_s, sec_s, dst_s, gmtoff_s, zone_s;
+#if CONFIG_LOCALE_TOLERANCE
+char dec_point = '.';
+#endif
+
+static struct cobj_class cobj_class[64], *cobj_ptr = cobj_class;
+
+static val cobj_hash;
+
+struct cobj_class *seq_iter_cls;
-static val env_list;
static val recycled_conses;
+static val lazy_streams_binding;
+
const seq_kind_t seq_kind_tab[MAXTYPE+1] = {
SEQ_NIL, /* NIL */
SEQ_NOTSEQ, /* NUM */
SEQ_NOTSEQ, /* CHR */
SEQ_VECLIKE, /* LIT */
+ SEQ_NOTSEQ, /* FLNUM */
SEQ_LISTLIKE, /* CONS */
SEQ_VECLIKE, /* STR */
SEQ_NOTSEQ, /* SYM */
@@ -154,12 +169,14 @@ const seq_kind_t seq_kind_tab[MAXTYPE+1] = {
SEQ_NOTSEQ, /* CPTR */
SEQ_NOTSEQ, /* ENV */
SEQ_NOTSEQ, /* BGNUM */
- SEQ_NOTSEQ, /* FLNUM */
- SEQ_NOTSEQ, /* RNG */
+ SEQ_VECLIKE, /* RNG */
SEQ_VECLIKE, /* BUF */
SEQ_NOTSEQ, /* TNOD */
+ SEQ_NOTSEQ, /* DARG */
};
+static val hist_succ_f;
+
val identity(val obj)
{
return obj;
@@ -201,6 +218,22 @@ static val code2type(int code)
return nil;
}
+val built_in_type_p(val sym)
+{
+ int i;
+
+ for (i = NIL; i <= MAXTYPE; i++) {
+ val type = code2type(i);
+ if (subtypep(type, sym))
+ return t;
+ }
+
+ if (gethash(cobj_hash, sym))
+ return t;
+
+ return nil;
+}
+
val typeof(val obj)
{
switch (tag(obj)) {
@@ -215,7 +248,10 @@ val typeof(val obj)
int typecode = type(obj);
if (typecode == COBJ) {
- return obj->co.cls;
+ if (obj->co.cls == struct_cls)
+ return struct_type_name(obj);
+ else
+ return obj->co.cls->cls_sym;
} else {
val typesym = code2type(typecode);
if (!typesym)
@@ -228,11 +264,17 @@ val typeof(val obj)
}
}
+static struct cobj_class *class_from_sym(val cls_sym)
+{
+ val idx = gethash(cobj_hash, cls_sym);
+ return idx ? cobj_class + c_n(idx) : 0;
+}
+
val subtypep(val sub, val sup)
{
- if (sub == nil || sup == t) {
+ if (sub == sup) {
return t;
- } else if (sub == sup) {
+ } else if (sub == nil || sup == t) {
return t;
} else if (sup == atom_s) {
return tnil(sub != cons_s && sub != lcons_s);
@@ -248,7 +290,7 @@ val subtypep(val sub, val sup)
} else if (sup == list_s) {
return tnil(sub == null_s || sub == cons_s || sub == lcons_s);
} else if (sup == sequence_s) {
- val sub_struct = find_struct_type(sub);
+ val sub_struct = if3(struct_type_p(sub), sub, find_struct_type(sub));
if (sub_struct) {
if (get_special_slot_by_type(sub_struct, length_m) ||
get_special_slot_by_type(sub_struct, car_m))
@@ -260,16 +302,30 @@ val subtypep(val sub, val sup)
sub == lcons_s || sub == list_s || sub == string_s);
} else if (sup == string_s) {
return tnil(sub == str_s || sub == lit_s || sub == lstr_s);
- } else if (sup == stream_s) {
- return tnil(sub == stdio_stream_s);
} else if (sup == struct_s) {
- return tnil(find_struct_type(sub));
+ return tnil(struct_type_p(sub) || find_struct_type(sub));
} else {
- val sub_struct = find_struct_type(sub);
- val sup_struct = find_struct_type(sup);
+ {
+ val sub_struct = if3(struct_type_p(sub), sub, find_struct_type(sub));
+ val sup_struct = if3(struct_type_p(sup), sup, find_struct_type(sup));
- if (sub_struct && sup_struct)
- return struct_subtype_p(sub_struct, sup_struct);
+ if (sub_struct && sup_struct)
+ return struct_subtype_p(sub_struct, sup_struct);
+ }
+
+ {
+ struct cobj_class *sub_cls = class_from_sym(sub);
+ struct cobj_class *sup_cls = class_from_sym(sup);
+
+ if (sub_cls && sup_cls) {
+ struct cobj_class *pcls = sub_cls;
+ do {
+ if (pcls == sup_cls)
+ return t;
+ pcls = pcls->super;
+ } while (pcls);
+ }
+ }
return nil;
}
@@ -286,43 +342,82 @@ seq_info_t seq_info(val obj)
type_t to = type(obj);
ret.obj = obj;
+ ret.type = to;
+ ret.kind = SEQ_NOTSEQ;
if (to != COBJ) {
- ret.type = to;
ret.kind = seq_kind_tab[to];
return ret;
} else {
- val cls = obj->co.cls;
+ val cls = obj->co.cls->cls_sym;
if (cls == hash_s) {
ret.kind = SEQ_HASHLIKE;
} else if (cls == carray_s) {
ret.kind = SEQ_VECLIKE;
} else if (obj_struct_p(obj)) {
- val sub = nullify(obj);
+ val sub = obj;
+ val nullify_meth = get_special_slot(obj, nullify_m);
- if (!sub) {
- ret.kind = SEQ_NIL;
- ret.obj = nil;
- } else if (sub != obj) {
- return seq_info(sub);
- } else {
- if (get_special_slot(obj, length_m))
- ret.kind = SEQ_VECLIKE;
- else if (get_special_slot(obj, car_m))
- ret.kind = SEQ_LISTLIKE;
- else
- ret.kind = SEQ_NOTSEQ;
+ if (nullify_meth) {
+ sub = funcall1(nullify_meth, obj);
+
+ if (sub != obj) {
+ if (!sub)
+ ret.obj = nil;
+ return seq_info(sub);
+ }
}
- } else {
- ret.kind = SEQ_NOTSEQ;
+
+ if (get_special_slot(obj, length_m))
+ ret.kind = SEQ_VECLIKE;
+ else if (get_special_slot(obj, car_m))
+ ret.kind = SEQ_LISTLIKE;
+ } else if (cls == tree_s) {
+ ret.kind = SEQ_TREELIKE;
}
}
return ret;
}
-static void noreturn unsup_obj(val self, val obj)
+static val seq_iterable(seq_info_t si)
+{
+ if (si.kind != SEQ_NOTSEQ)
+ return t;
+
+ switch (si.type) {
+ case RNG:
+ {
+ val rf = from(si.obj);
+
+ switch (type(rf)) {
+ case NUM:
+ case CHR:
+ case BGNUM:
+ return t;
+ default:
+ break;
+ }
+ }
+ break;
+ case CHR:
+ case NUM:
+ case BGNUM:
+ case FLNUM:
+ return t;
+ case COBJ:
+ if (obj_struct_p(si.obj) && get_special_slot(si.obj, iter_begin_m))
+ return t;
+ break;
+ default:
+ break;
+ }
+
+ return nil;
+}
+
+static void NORETURN unsup_obj(val self, val obj)
{
uw_throwf(error_s, lit("~a: unsupported object ~s"), self, obj, nao);
abort();
@@ -330,11 +425,15 @@ static void noreturn unsup_obj(val self, val obj)
static int seq_iter_get_nil(seq_iter_t *it, val *pval)
{
+ (void) it;
+ (void) pval;
return 0;
}
static int seq_iter_peek_nil(seq_iter_t *it, val *pval)
{
+ (void) it;
+ (void) pval;
return 0;
}
@@ -357,7 +456,7 @@ static int seq_iter_peek_list(seq_iter_t *it, val *pval)
static int seq_iter_get_vec(seq_iter_t *it, val *pval)
{
- if (it->ui.index < it->len) {
+ if (it->ui.index < it->ul.len) {
*pval = ref(it->inf.obj, num(it->ui.index++));
return 1;
}
@@ -366,7 +465,7 @@ static int seq_iter_get_vec(seq_iter_t *it, val *pval)
static int seq_iter_peek_vec(seq_iter_t *it, val *pval)
{
- if (it->ui.index < it->len) {
+ if (it->ui.index < it->ul.len) {
*pval = ref(it->inf.obj, num(it->ui.index));
return 1;
}
@@ -385,64 +484,689 @@ static int seq_iter_peek_hash(seq_iter_t *it, val *pval)
return *pval != nil;
}
+static int seq_iter_get_tree(seq_iter_t *it, val *pval)
+{
+ val node = tree_next(it->ui.iter);
+ *pval = if2(node, key(node));
+ return node != nil;
+}
+
+static int seq_iter_peek_tree(seq_iter_t *it, val *pval)
+{
+ val node = tree_peek(it->ui.iter);
+ *pval = if2(node, key(node));
+ return node != nil;
+}
+
+static int seq_iter_get_range_cnum(seq_iter_t *it, val *pval)
+{
+ if (it->ui.cn < it->ul.cbound) {
+ *pval = num(it->ui.index++);
+ return 1;
+ }
+ return 0;
+}
+
+static int seq_iter_peek_range_cnum(seq_iter_t *it, val *pval)
+{
+ if (it->ui.cn < it->ul.cbound) {
+ *pval = num(it->ui.index);
+ return 1;
+ }
+ return 0;
+}
+
+static int seq_iter_get_range_chr(seq_iter_t *it, val *pval)
+{
+ if (it->ui.cn < it->ul.cbound) {
+ *pval = chr(it->ui.index++);
+ return 1;
+ }
+ return 0;
+}
+
+static int seq_iter_peek_range_chr(seq_iter_t *it, val *pval)
+{
+ if (it->ui.cn < it->ul.cbound) {
+ *pval = chr(it->ui.index);
+ return 1;
+ }
+ return 0;
+}
+
+static int seq_iter_get_range_number(seq_iter_t *it, val *pval)
+{
+ if (lt(it->ui.vn, it->ul.vbound)) {
+ *pval = it->ui.iter;
+ it->ui.iter = succ(it->ui.iter);
+ return 1;
+ }
+ return 0;
+}
+
+static int seq_iter_peek_range_number(seq_iter_t *it, val *pval)
+{
+ if (lt(it->ui.vn, it->ul.vbound)) {
+ *pval = it->ui.iter;
+ return 1;
+ }
+ return 0;
+}
+
+static int seq_iter_get_range_str(seq_iter_t *it, val *pval)
+{
+ if (it->ui.vn) {
+ val init = from(it->inf.obj);
+ val len = length_str(init);
+ val next = copy_str(it->ui.vn);
+ cnum l = c_num(len, nil);
+ wchar_t *nx = strip_qual(wchar_t *, c_str(next, nil));
+ const wchar_t *in = c_str(init, nil);
+ const wchar_t *bn = c_str(it->ul.vbound, nil);
+
+ *pval = it->ui.vn;
+
+ for (; l > 0; l--) {
+ if (++nx[l - 1] <= bn[l - 1])
+ break;
+ nx[l - 1] = in[l - 1];
+ }
+
+ it->ui.vn = if2(l > 0, next);
+
+ return 1;
+ }
+
+ return 0;
+}
+
+static int seq_iter_peek_range_str(seq_iter_t *it, val *pval)
+{
+ if (it->ui.vn) {
+ *pval = it->ui.vn;
+ return 1;
+ }
+ return 0;
+}
+
+static int seq_iter_get_rev_range_cnum(seq_iter_t *it, val *pval)
+{
+ if (it->ui.cn > it->ul.cbound) {
+ *pval = num(--it->ui.index);
+ return 1;
+ }
+ return 0;
+}
+
+static int seq_iter_peek_rev_range_cnum(seq_iter_t *it, val *pval)
+{
+ if (it->ui.cn > it->ul.cbound) {
+ *pval = num(it->ui.index - 1);
+ return 1;
+ }
+ return 0;
+}
+
+static int seq_iter_get_rev_range_chr(seq_iter_t *it, val *pval)
+{
+ if (it->ui.cn > it->ul.cbound) {
+ *pval = chr(--it->ui.index);
+ return 1;
+ }
+ return 0;
+}
+
+static int seq_iter_peek_rev_range_chr(seq_iter_t *it, val *pval)
+{
+ if (it->ui.cn > it->ul.cbound) {
+ *pval = chr(it->ui.index - 1);
+ return 1;
+ }
+ return 0;
+}
+
+static int seq_iter_get_rev_range_number(seq_iter_t *it, val *pval)
+{
+ if (gt(it->ui.vn, it->ul.vbound)) {
+ *pval = it->ui.iter = pred(it->ui.iter);
+ return 1;
+ }
+ return 0;
+}
+
+static int seq_iter_peek_rev_range_number(seq_iter_t *it, val *pval)
+{
+ if (gt(it->ui.vn, it->ul.vbound)) {
+ *pval = pred(it->ui.iter);
+ return 1;
+ }
+ return 0;
+}
+
+static int seq_iter_get_rev_range_str(seq_iter_t *it, val *pval)
+{
+ if (it->ui.vn) {
+ val init = from(it->inf.obj);
+ val len = length_str(init);
+ val next = copy_str(it->ui.vn);
+ cnum l = c_num(len, nil);
+ wchar_t *nx = strip_qual(wchar_t *, c_str(next, nil));
+ const wchar_t *in = c_str(init, nil);
+ const wchar_t *bn = c_str(it->ul.vbound, nil);
+
+ *pval = it->ui.vn;
+
+ for (; l > 0; l--) {
+ if (--nx[l - 1] >= bn[l - 1])
+ break;
+ nx[l - 1] = in[l - 1];
+ }
+
+ it->ui.vn = if2(l > 0, next);
+
+ return 1;
+ }
+
+ return 0;
+}
+
+static int seq_iter_get_chr(seq_iter_t *it, val *pval)
+{
+ if (it->ui.index <= 0x10FFFF) {
+ *pval = chr(it->ui.index++);
+ return 1;
+ }
+ return 0;
+}
+
+static int seq_iter_peek_chr(seq_iter_t *it, val *pval)
+{
+ if (it->ui.index <= 0x10FFFF) {
+ *pval = chr(it->ui.index);
+ return 1;
+ }
+ return 0;
+}
+
+static int seq_iter_get_num(seq_iter_t *it, val *pval)
+{
+ *pval = it->ui.iter;
+ it->ui.iter = succ(it->ui.iter);
+ return 1;
+}
+
+static int seq_iter_peek_num(seq_iter_t *it, val *pval)
+{
+ *pval = it->ui.iter;
+ return 1;
+}
+
+static int seq_iter_get_oop(seq_iter_t *it, val *pval)
+{
+ val iter = it->ui.iter;
+
+ /* The assignments to ui.iter and ui.next are wrong if the it structure is
+ * embedded inside a heap-allocated iterator object. The object could be a
+ * gen 1 object, whereas the value being assigned could be a gen 0.
+ *
+ * The only way this can happen is if the obsolescent seq-begin function is
+ * used on an object that supports the iter-begin method. The seq-begin
+ * constructor is the only function which creates a heap-allocated iterator
+ * which is initialized via seq_iter_init_with_info, which binds this
+ * seq_iter_get_oop function and its sisters.
+ *
+ * The other heap-allocated iterator type is iter-begin. iter-begin applies
+ * its own handling for OOP iterators; it doesn't set up seq_iter_t for
+ * objects of that type, and so these functions are not used.
+ */
+ if (it->ul.next != nao) {
+ val iter_step_meth = get_special_required_slot(iter, iter_step_m);
+ *pval = it->ul.next;
+ it->ui.iter = funcall1(iter_step_meth, iter);
+ it->ul.next = nao;
+ return 1;
+ } else {
+ val iter_more_meth = get_special_required_slot(iter, iter_more_m);
+
+ if (!funcall1(iter_more_meth, iter)) {
+ return 0;
+ } else {
+ val iter_item_meth = get_special_required_slot(iter, iter_item_m);
+ val iter_step_meth = get_special_required_slot(iter, iter_step_m);
+ *pval = funcall1(iter_item_meth, iter);
+ it->ui.iter = funcall1(iter_step_meth, iter);
+ it->ul.next = nao;
+ return 1;
+ }
+ }
+}
+
+static int seq_iter_peek_oop(seq_iter_t *it, val *pval)
+{
+ val iter = it->ui.iter;
+
+ /* See comment in seq_iter_get_oop */
+
+ if (it->ul.next != nao) {
+ *pval = it->ul.next;
+ return 1;
+ } else {
+ val iter_more_meth = get_special_required_slot(iter, iter_more_m);
+
+ if (funcall1(iter_more_meth, iter)) {
+ val iter_item_meth = get_special_required_slot(iter, iter_item_m);
+ it->ul.next = *pval = funcall1(iter_item_meth, iter);
+ }
+
+ return 1;
+ }
+
+ return 0;
+}
+
+static int seq_iter_get_fast_oop(seq_iter_t *it, val *pval)
+{
+ val iter = it->ui.iter;
+
+ if (iter) {
+ val item = it->ul.next;
+ val iter_step_meth = get_special_required_slot(iter, iter_step_m);
+
+ if (item == nao) {
+ val iter_item_meth = get_special_required_slot(iter, iter_item_m);
+ *pval = funcall1(iter_item_meth, iter);
+ } else {
+ *pval = item;
+ }
+
+ /* See comment in seq_iter_get_oop */
+
+ it->ui.iter = funcall1(iter_step_meth, iter);
+ it->ul.next = nao;
+ return 1;
+ }
+
+ return 0;
+}
+
+static int seq_iter_peek_fast_oop(seq_iter_t *it, val *pval)
+{
+ val iter = it->ui.iter;
+
+ if (it->ul.next != nao) {
+ *pval = it->ul.next;
+ return 1;
+ }
+
+ /* See comment in seq_iter_get_oop */
+
+ if (iter) {
+ val iter_item_meth = get_special_required_slot(iter, iter_item_m);
+ it->ul.next = *pval = funcall1(iter_item_meth, iter);
+ return 1;
+ }
+
+ return 0;
+}
+
val seq_geti(seq_iter_t *it)
{
val v = nil;
- (void) it->get(it, &v);
+ (void) it->ops->get(it, &v);
return v;
}
-void seq_iter_rewind(val self, seq_iter_t *it)
+static void seq_iter_rewind(seq_iter_t *it)
{
- switch (it->inf.kind) {
- case SEQ_NIL:
- it->ui.iter = nil;
- break;
- case SEQ_LISTLIKE:
- it->ui.iter = it->inf.obj;
+ switch (it->inf.type) {
+ case RNG:
+ {
+ val rf = from(it->inf.obj);
+
+ switch (type(rf)) {
+ case NUM:
+ it->ui.cn = c_n(rf);
+ break;
+ case CHR:
+ it->ui.cn = c_ch(rf);
+ break;
+ case BGNUM:
+ it->ui.vn = rf;
+ break;
+ default:
+ break;
+ }
+ }
break;
- case SEQ_VECLIKE:
- it->ui.index = 0;
+ case CHR:
+ it->ui.cn = c_chr(it->inf.obj);
break;
- case SEQ_HASHLIKE:
- it->ui.iter = hash_begin(it->inf.obj);
+ case NUM:
+ case BGNUM:
+ case FLNUM:
+ it->ui.vn = it->inf.obj;
break;
default:
+ switch (it->inf.kind) {
+ case SEQ_NIL:
+ it->ui.iter = nil;
+ break;
+ case SEQ_LISTLIKE:
+ it->ui.iter = it->inf.obj;
+ break;
+ case SEQ_VECLIKE:
+ it->ui.index = 0;
+ break;
+ case SEQ_HASHLIKE:
+ it->ui.iter = hash_reset(it->ui.iter, it->inf.obj);
+ break;
+ case SEQ_TREELIKE:
+ it->ui.iter = tree_reset(it->ui.iter, it->inf.obj, colon_k, colon_k);
+ break;
+ default:
+ break;
+ }
+ }
+}
+
+static void seq_iter_mark_op(struct seq_iter *it)
+{
+ gc_mark(it->ui.iter);
+}
+
+struct seq_iter_ops si_null_ops = seq_iter_ops_init_nomark(seq_iter_get_nil,
+ seq_iter_peek_nil);
+
+struct seq_iter_ops si_list_ops = seq_iter_ops_init(seq_iter_get_list,
+ seq_iter_peek_list);
+
+struct seq_iter_ops si_vec_ops = seq_iter_ops_init_nomark(seq_iter_get_vec,
+ seq_iter_peek_vec);
+
+struct seq_iter_ops si_hash_ops = seq_iter_ops_init(seq_iter_get_hash,
+ seq_iter_peek_hash);
+
+struct seq_iter_ops si_tree_ops = seq_iter_ops_init(seq_iter_get_tree,
+ seq_iter_peek_tree);
+
+struct seq_iter_ops si_range_cnum_ops =
+ seq_iter_ops_init_nomark(seq_iter_get_range_cnum,
+ seq_iter_peek_range_cnum);
+
+struct seq_iter_ops si_range_chr_ops =
+ seq_iter_ops_init_nomark(seq_iter_get_range_chr,
+ seq_iter_peek_range_chr);
+
+struct seq_iter_ops si_range_number_ops =
+ seq_iter_ops_init(seq_iter_get_range_number,
+ seq_iter_peek_range_number);
+
+struct seq_iter_ops si_range_str_ops =
+ seq_iter_ops_init(seq_iter_get_range_str,
+ seq_iter_peek_range_str);
+
+struct seq_iter_ops si_rev_range_cnum_ops =
+ seq_iter_ops_init_nomark(seq_iter_get_rev_range_cnum,
+ seq_iter_peek_rev_range_cnum);
+
+struct seq_iter_ops si_rev_range_chr_ops =
+ seq_iter_ops_init_nomark(seq_iter_get_rev_range_chr,
+ seq_iter_peek_rev_range_chr);
+
+struct seq_iter_ops si_rev_range_number_ops =
+ seq_iter_ops_init(seq_iter_get_rev_range_number,
+ seq_iter_peek_rev_range_number);
+
+struct seq_iter_ops si_rev_range_str_ops =
+ seq_iter_ops_init(seq_iter_get_rev_range_str,
+ seq_iter_peek_range_str);
+
+struct seq_iter_ops si_chr_ops = seq_iter_ops_init_nomark(seq_iter_get_chr,
+ seq_iter_peek_chr);
+
+struct seq_iter_ops si_num_ops = seq_iter_ops_init(seq_iter_get_num,
+ seq_iter_peek_num);
+
+struct seq_iter_ops si_oop_ops = seq_iter_ops_init(seq_iter_get_oop,
+ seq_iter_peek_oop);
+
+struct seq_iter_ops si_fast_oop_ops = seq_iter_ops_init(seq_iter_get_fast_oop,
+ seq_iter_peek_fast_oop);
+
+void seq_iter_init_with_info(val self, seq_iter_t *it,
+ seq_info_t si, int support_rewind)
+{
+ it->inf = si;
+
+ switch (it->inf.type) {
+ case RNG:
+ {
+ val rf = from(it->inf.obj);
+ val rt = to(it->inf.obj);
+
+ if (rt == colon_k || rt == t) {
+ seq_iter_init_with_info(self, it, seq_info(rf), support_rewind);
+ break;
+ }
+
+ if (less(rf, rt)) switch (type(rf)) {
+ case NUM:
+ num_range_fwd:
+ switch (type(rt)) {
+ case BGNUM:
+ if (mp_in_intptr_range(mp(rt))) {
+ case NUM:
+ it->ui.cn = c_num(rf, self);
+ it->ul.cbound = c_num(rt, self);
+ it->ops = &si_range_cnum_ops;
+ break;
+ }
+ /* fallthrough */
+ default:
+ it->ui.vn = rf;
+ it->ul.vbound = rt;
+ it->ops = &si_range_number_ops;
+ break;
+ }
+ break;
+ case CHR:
+ it->ui.cn = c_chr(rf);
+ it->ul.cbound = c_chr(rt);
+ it->ops = &si_range_chr_ops;
+ break;
+ case BGNUM:
+ if (mp_in_intptr_range(mp(rf)))
+ goto num_range_fwd;
+ /* fallthrough */
+ case FLNUM:
+ it->ui.vn = rf;
+ it->ul.vbound = rt;
+ it->ops = &si_range_number_ops;
+ break;
+ case LIT:
+ case STR:
+ case LSTR:
+ it->ui.vn = copy_str(rf);
+ it->ul.vbound = rt;
+ it->ops = &si_range_str_ops;
+ if (eql(length_str(rf), length_str(rt)))
+ break;
+ /* fallthrough */
+ default:
+ unsup_obj(self, it->inf.obj);
+ } else if (!equal(rf, rt)) switch (type(rf)) {
+ case NUM:
+ num_range_rev:
+ switch (type(rt)) {
+ case BGNUM:
+ if (mp_in_intptr_range(mp(rt))) {
+ case NUM:
+ it->ui.cn = c_num(rf, self);
+ it->ul.cbound = c_num(rt, self);
+ it->ops = &si_rev_range_cnum_ops;
+ break;
+ }
+ /* fallthrough */
+ default:
+ it->ui.vn = rf;
+ it->ul.vbound = rt;
+ it->ops = &si_rev_range_number_ops;
+ break;
+ }
+ break;
+ case CHR:
+ it->ui.cn = c_chr(rf);
+ it->ul.cbound = c_chr(rt);
+ it->ops = &si_rev_range_chr_ops;
+ break;
+ case BGNUM:
+ if (mp_in_intptr_range(mp(rf)))
+ goto num_range_rev;
+ /* fallthrough */
+ case FLNUM:
+ it->ui.vn = rf;
+ it->ul.vbound = rt;
+ it->ops = &si_rev_range_number_ops;
+ break;
+ case LIT:
+ case STR:
+ case LSTR:
+ it->ui.vn = copy_str(rf);
+ it->ul.vbound = rt;
+ it->ops = &si_rev_range_str_ops;
+ if (eql(length_str(rf), length_str(rt)))
+ break;
+ /* fallthrough */
+ default:
+ unsup_obj(self, it->inf.obj);
+ } else {
+ seq_iter_init_with_info(self, it, seq_info(nil), support_rewind);
+ break;
+ }
+ }
+ break;
+ case CHR:
+ it->ui.cn = c_chr(it->inf.obj);
+ it->ul.cbound = 0;
+ it->ops = &si_chr_ops;
break;
+ case NUM:
+ case BGNUM:
+ case FLNUM:
+ it->ui.vn = it->inf.obj;
+ it->ul.vbound = nil;
+ it->ops = &si_num_ops;
+ break;
+ case COBJ:
+ if (obj_struct_p(it->inf.obj)) {
+ val iter_begin_meth = get_special_slot(it->inf.obj, iter_begin_m);
+ if (iter_begin_meth) {
+ val iter = funcall1(iter_begin_meth, it->inf.obj);
+ if (iter == nil) {
+ it->ui.iter = nil;
+ it->ul.len = 0;
+ it->ops = &si_null_ops;
+ break;
+ } else {
+ val iter_more_meth = get_special_slot(iter, iter_more_m);
+ if (iter_more_meth) {
+ it->ui.iter = iter;
+ it->ul.next = nao;
+ it->ops = &si_oop_ops;
+ } else {
+ it->ui.iter = iter;
+ it->ul.next = nao;
+ it->ops = &si_fast_oop_ops;
+ }
+ break;
+ }
+ }
+ }
+ if (it->inf.obj->co.cls == seq_iter_cls)
+ {
+ *it = *coerce(struct seq_iter *, it->inf.obj->co.handle);
+ break;
+ }
+ if (it->inf.obj->co.cls == tree_iter_cls)
+ {
+ it->ui.iter = if3(support_rewind,
+ copy_tree_iter(it->inf.obj),
+ it->inf.obj);
+ it->ul.len = 0;
+ it->ops = &si_tree_ops;
+ break;
+ }
+ /* fallthrough */
+ default:
+ switch (it->inf.kind) {
+ case SEQ_NIL:
+ it->ui.iter = nil;
+ it->ul.len = 0;
+ it->ops = &si_null_ops;
+ break;
+ case SEQ_LISTLIKE:
+ it->ui.iter = it->inf.obj;
+ it->ul.len = 0;
+ it->ops = &si_list_ops;
+ if (!support_rewind)
+ it->inf.obj = nil;
+ break;
+ case SEQ_VECLIKE:
+ it->ui.index = 0;
+ it->ul.len = c_num(length(it->inf.obj), self);
+ it->ops = &si_vec_ops;
+ break;
+ case SEQ_HASHLIKE:
+ it->ui.iter = hash_begin(it->inf.obj);
+ it->ul.len = 0;
+ it->ops = &si_hash_ops;
+ break;
+ case SEQ_TREELIKE:
+ it->ui.iter = tree_begin(it->inf.obj, colon_k, colon_k);
+ it->ul.len = 0;
+ it->ops = &si_tree_ops;
+ break;
+ default:
+ unsup_obj(self, it->inf.obj);
+ }
}
}
void seq_iter_init(val self, seq_iter_t *it, val obj)
{
- it->inf = seq_info(obj);
+ seq_iter_init_with_info(self, it, seq_info(obj), 0);
+}
+
+static void seq_iter_init_with_rewind(val self, seq_iter_t *it, val obj)
+{
+ seq_iter_init_with_info(self, it, seq_info(obj), 1);
+}
+val seq_getpos(val self, seq_iter_t *it)
+{
switch (it->inf.kind) {
case SEQ_NIL:
- it->ui.iter = nil;
- it->len = 0;
- it->get = seq_iter_get_nil;
- it->peek = seq_iter_peek_nil;
- break;
case SEQ_LISTLIKE:
- it->ui.iter = it->inf.obj;
- it->len = 0;
- it->get = seq_iter_get_list;
- it->peek = seq_iter_peek_list;
- break;
+ return it->ui.iter;
case SEQ_VECLIKE:
- it->ui.index = 0;
- it->len = c_num(length(it->inf.obj));
- it->get = seq_iter_get_vec;
- it->peek = seq_iter_peek_vec;
+ return num(it->ui.index);
+ default:
+ unsup_obj(self, it->inf.obj);
+ }
+}
+
+void seq_setpos(val self, seq_iter_t *it, val pos)
+{
+ switch (it->inf.kind) {
+ case SEQ_NIL:
+ case SEQ_LISTLIKE:
+ it->ui.iter = pos;
break;
- case SEQ_HASHLIKE:
- it->ui.iter = hash_begin(it->inf.obj);
- it->len = 0;
- it->get = seq_iter_get_hash;
- it->peek = seq_iter_peek_hash;
+ case SEQ_VECLIKE:
+ it->ui.index = c_num(pos, self);
break;
default:
- unsup_obj(self, obj);
+ unsup_obj(self, it->inf.obj);
}
}
@@ -452,14 +1176,8 @@ static void seq_iter_mark(val seq_iter)
gc_mark(si->inf.obj);
- switch (si->inf.kind) {
- case SEQ_LISTLIKE:
- case SEQ_HASHLIKE:
- gc_mark(si->ui.iter);
- break;
- default:
- break;
- }
+ if (si->ops->mark)
+ si->ops->mark(si);
}
static struct cobj_ops seq_iter_ops = cobj_ops_init(eq,
@@ -471,10 +1189,13 @@ static struct cobj_ops seq_iter_ops = cobj_ops_init(eq,
val seq_begin(val obj)
{
val self = lit("seq-begin");
- val si_obj;
+ val si_obj, iter;
struct seq_iter *si = coerce(struct seq_iter *, chk_calloc(1, sizeof *si));
- si_obj = cobj(coerce(mem_t *, si), seq_iter_s, &seq_iter_ops);
seq_iter_init(self, si, obj);
+ iter = si->ui.iter;
+ si_obj = cobj(coerce(mem_t *, si), seq_iter_cls, &seq_iter_ops);
+ gc_hint(iter);
+ gc_hint(obj);
return si_obj;
}
@@ -482,29 +1203,533 @@ val seq_next(val iter, val end_val)
{
val self = lit("seq-next");
struct seq_iter *si = coerce(struct seq_iter *,
- cobj_handle(self, iter, seq_iter_s));
+ cobj_handle(self, iter, seq_iter_cls));
val item = nil;
- return if3(seq_get(si, &item), item, end_val);
+ val ret = if3(seq_get(si, &item), item, end_val);
+ mut(iter);
+ return ret;
}
val seq_reset(val iter, val obj)
{
val self = lit("seq-reset");
struct seq_iter *si = coerce(struct seq_iter *,
- cobj_handle(self, iter, seq_iter_s));
+ cobj_handle(self, iter, seq_iter_cls));
seq_iter_init(self, si, obj);
+ mut(iter);
return iter;
}
+val iter_begin(val obj)
+{
+ val self = lit("iter-begin");
+ seq_info_t sinf = seq_info(obj);
+
+ switch (sinf.type) {
+ case CHR:
+ case NUM:
+ case BGNUM:
+ return obj;
+ case COBJ:
+ if (obj_struct_p(obj)) {
+ val iter_begin_meth = get_special_slot(obj, iter_begin_m);
+ if (iter_begin_meth)
+ return funcall1(iter_begin_meth, obj);
+ }
+ /* fallthrough */
+ default:
+ switch (sinf.kind) {
+ case SEQ_NIL:
+ case SEQ_LISTLIKE:
+ return sinf.obj;
+ default:
+ {
+ val si_obj, iter;
+ struct seq_iter *si = coerce(struct seq_iter *,
+ chk_calloc(1, sizeof *si));
+ seq_iter_init_with_info(self, si, sinf, 0);
+ iter = si->ui.iter;
+ si_obj = cobj(coerce(mem_t *, si), seq_iter_cls, &seq_iter_ops);
+ gc_hint(iter);
+ gc_hint(obj);
+ return si_obj;
+ }
+ }
+ }
+}
+
+static val iter_dynamic(struct seq_iter *si_orig)
+{
+ struct seq_iter *si = coerce(struct seq_iter *,
+ chk_copy_obj(coerce(mem_t *, si_orig),
+ sizeof *si));
+ return cobj(coerce(mem_t *, si), seq_iter_cls, &seq_iter_ops);
+}
+
+val iter_more(val iter)
+{
+ switch (type(iter)) {
+ case NIL:
+ return nil;
+ case CHR:
+ return if2(c_ch(iter) <= 0x10FFFF, t);
+ case NUM:
+ case BGNUM:
+ return t;
+ case COBJ:
+ if (iter->co.cls == seq_iter_cls)
+ {
+ struct seq_iter *si = coerce(struct seq_iter *, iter->co.handle);
+ val item = nil;
+ return if2(seq_peek(si, &item), t);
+ }
+ if (obj_struct_p(iter)) {
+ val iter_more_meth = get_special_slot(iter, iter_more_m);
+ if (iter_more_meth)
+ return funcall1(iter_more_meth, iter);
+ }
+ /* fallthrough */
+ default:
+ return t;
+ }
+}
+
+val iter_item(val iter)
+{
+ switch (type(iter)) {
+ case NIL:
+ return nil;
+ case CHR:
+ case NUM:
+ case BGNUM:
+ return iter;
+ case COBJ:
+ if (iter->co.cls == seq_iter_cls)
+ {
+ struct seq_iter *si = coerce(struct seq_iter *, iter->co.handle);
+ val item = nil;
+ return if2(seq_peek(si, &item), item);
+ }
+ if (obj_struct_p(iter)) {
+ val iter_item_meth = get_special_slot(iter, iter_item_m);
+ if (iter_item_meth)
+ return funcall1(iter_item_meth, iter);
+ }
+ /* fallthrough */
+ default:
+ return car(iter);
+ }
+}
+
+val iter_step(val iter)
+{
+ val self = lit("iter-step");
+
+ switch (type(iter)) {
+ case NIL:
+ return nil;
+ case CHR:
+ case NUM:
+ case BGNUM:
+ return plus(iter, one);
+ case CONS:
+ case LCONS:
+ {
+ val next = cdr(iter);
+ if (next && !consp(next))
+ uw_throwf(error_s, lit("~a: ~s is not a cons"), self, next, nao);
+ return next;
+ }
+ case COBJ:
+ if (iter->co.cls == seq_iter_cls)
+ {
+ struct seq_iter *si = coerce(struct seq_iter *, iter->co.handle);
+ val item = nil;
+ (void) seq_get(si, &item);
+ if (si->ops->mark)
+ mut(iter);
+ return iter;
+ }
+ if (obj_struct_p(iter)) {
+ val iter_step_meth = get_special_slot(iter, iter_step_m);
+ if (iter_step_meth)
+ return funcall1(iter_step_meth, iter);
+ }
+ /* fallthrough */
+ default:
+ {
+ val next = cdr(iter);
+ if (next) {
+ seq_info_t sinf = seq_info(next);
+ if (sinf.kind != SEQ_LISTLIKE)
+ uw_throwf(error_s, lit("~a: ~s is improperly terminated"),
+ self, iter, nao);
+ }
+ return next;
+ }
+ }
+}
+
+val iter_reset(val iter, val obj)
+{
+ val self = lit("iter-reset");
+ seq_info_t sinf = seq_info(obj);
+
+ switch (type(iter)) {
+ case CHR:
+ case NUM:
+ case BGNUM:
+ return obj;
+ case COBJ:
+ if (iter->co.cls == seq_iter_cls)
+ {
+ struct seq_iter *si = coerce(struct seq_iter *, iter->co.handle);
+ seq_iter_init_with_info(self, si, sinf, 0);
+ if (si->ops->mark)
+ mut(iter);
+ return iter;
+ }
+ /* fallthrough */
+ default:
+ if (cobjp(obj) && obj_struct_p(obj)) {
+ val iter_reset_meth = get_special_slot(obj, iter_reset_m);
+ if (iter_reset_meth)
+ return funcall2(iter_reset_meth, obj, iter);
+ }
+ switch (sinf.kind) {
+ case SEQ_NIL:
+ case SEQ_LISTLIKE:
+ return sinf.obj;
+ default:
+ return iter_begin(obj);
+ }
+ }
+}
+
+static void seq_build_generic_pend(seq_build_t *bu, val seq)
+{
+ seq_iter_t it;
+ val elem;
+ seq_iter_init(bu->self, &it, seq);
+
+ while (seq_get(&it, &elem))
+ bu->ops->add(bu, elem);
+}
+
+static void seq_build_obj_mark(seq_build_t *bu)
+{
+ gc_mark(bu->obj);
+}
+
+static void seq_build_struct_mark(seq_build_t *bu)
+{
+ gc_mark(bu->obj);
+ gc_mark(bu->u.from_list_meth);
+}
+
+static void seq_build_carray_mark(seq_build_t *bu)
+{
+ gc_mark(bu->obj);
+ gc_mark(bu->u.carray_type);
+}
+
+static void seq_build_vec_add(seq_build_t *bu, val item)
+{
+ vec_push(bu->obj, item);
+}
+
+static void seq_build_convert_to_list(seq_build_t *bu, val list);
+
+static void seq_build_str_add(seq_build_t *bu, val item)
+{
+ if (chrp(item)) {
+ string_extend(bu->obj, item, nil);
+ } else {
+ seq_build_convert_to_list(bu, list_str(bu->obj));
+ bu->ops->add(bu, item);
+ }
+}
+
+static void seq_build_str_finish(seq_build_t *bu)
+{
+ string_finish(bu->obj);
+}
+
+static void seq_build_buf_add(seq_build_t *bu, val item)
+{
+ val buf = bu->obj;
+
+ if (integerp(item)) {
+ val len = length_buf(buf);
+ buf_put_uchar(buf, len, item);
+ } else {
+ seq_build_convert_to_list(bu, mapcar_listout(identity_f, buf));
+ bu->ops->add(bu, item);
+ }
+}
+
+static void seq_build_buf_finish(seq_build_t *bu)
+{
+ buf_trim(bu->obj);
+}
+
+static void seq_build_list_add(seq_build_t *bu, val item)
+{
+ bu->tail = list_collect(bu->tail, item);
+}
+
+static void seq_build_list_pend(seq_build_t *bu, val items)
+{
+ bu->tail = list_collect_append(bu->tail, items);
+}
+
+static void seq_build_list_nconc(seq_build_t *bu, val items)
+{
+ bu->tail = list_collect_nconc(bu->tail, items);
+}
+
+static void seq_build_convert_to_finished(seq_build_t *bu);
+
+static void seq_build_list_finish(seq_build_t *bu)
+{
+ seq_build_convert_to_finished(bu);
+}
+
+static void seq_build_struct_finish(seq_build_t *bu)
+{
+ seq_build_list_finish(bu);
+ bu->obj = funcall1(bu->u.from_list_meth, bu->obj);
+}
+
+static void seq_build_carray_finish(seq_build_t *bu)
+{
+ seq_build_list_finish(bu);
+ bu->obj = carray_list(bu->obj, bu->u.carray_type, nil);
+}
+
+static struct seq_build_ops
+ sb_vec_ops = seq_build_ops_init(seq_build_vec_add,
+ seq_build_generic_pend,
+ seq_build_generic_pend,
+ 0,
+ seq_build_obj_mark);
+
+static struct seq_build_ops
+ sb_str_ops = seq_build_ops_init(seq_build_str_add,
+ seq_build_generic_pend,
+ seq_build_generic_pend,
+ seq_build_str_finish,
+ seq_build_obj_mark);
+
+static struct seq_build_ops
+ sb_buf_ops = seq_build_ops_init(seq_build_buf_add,
+ seq_build_generic_pend,
+ seq_build_generic_pend,
+ seq_build_buf_finish,
+ seq_build_obj_mark);
+
+static struct seq_build_ops
+ sb_struct_ops = seq_build_ops_init(seq_build_list_add,
+ seq_build_generic_pend,
+ seq_build_generic_pend,
+ seq_build_struct_finish,
+ seq_build_struct_mark);
+
+static struct seq_build_ops
+ sb_carray_ops = seq_build_ops_init(seq_build_list_add,
+ seq_build_generic_pend,
+ seq_build_generic_pend,
+ seq_build_carray_finish,
+ seq_build_carray_mark);
+
+static struct seq_build_ops
+ sb_list_ops = seq_build_ops_init(seq_build_list_add,
+ seq_build_list_pend,
+ seq_build_list_nconc,
+ seq_build_list_finish,
+ seq_build_obj_mark);
+
+static struct seq_build_ops
+ sb_finished_ops = seq_build_ops_init(0, 0, 0, 0, seq_build_obj_mark);
+
+static void seq_build_convert_to_list(seq_build_t *bu, val list)
+{
+ if (list) {
+ bu->obj = list;
+ bu->tail = tail(list);
+ } else {
+ bu->obj = nil;
+ bu->tail = mkcloc(bu->obj);
+ }
+
+ bu->ops = &sb_list_ops;
+}
+
+static void seq_build_convert_to_finished(seq_build_t *bu)
+{
+ bu->ops = &sb_finished_ops;
+}
+
+void seq_build_init(val self, seq_build_t *bu, val likeobj)
+{
+ bu->self = self;
+
+ switch (type(likeobj)) {
+ case VEC:
+ bu->obj = vector(zero, nil);
+ bu->ops = &sb_vec_ops;
+ break;
+ case STR:
+ case LIT:
+ case LSTR:
+ bu->obj = string(L"");
+ bu->ops = &sb_str_ops;
+ break;
+ case BUF:
+ bu->obj = make_buf(zero, zero, num_fast(32));
+ bu->ops = &sb_buf_ops;
+ break;
+ case COBJ:
+ if (likeobj->co.cls == seq_iter_cls)
+ {
+ struct seq_iter *si = coerce(struct seq_iter *, likeobj->co.handle);
+ seq_build_init(self, bu, si->inf.obj);
+ break;
+ }
+ if (obj_struct_p(likeobj)) {
+ val from_list_meth = get_special_slot(likeobj, from_list_m);
+
+ if (from_list_meth) {
+ bu->obj = nil;
+ bu->tail = mkcloc(bu->obj);
+ bu->u.from_list_meth = from_list_meth;
+ bu->ops = &sb_struct_ops;
+ break;
+ }
+ }
+ if (likeobj->co.cls == carray_cls) {
+ bu->obj = nil;
+ bu->tail = mkcloc(bu->obj);
+ bu->u.carray_type = carray_type(likeobj);
+ bu->ops = &sb_carray_ops;
+ }
+ /* fallthrough */
+ case NIL:
+ case CONS:
+ case LCONS:
+ default:
+ bu->obj = nil;
+ bu->tail = mkcloc(bu->obj);
+ bu->ops = &sb_list_ops;
+ break;
+ }
+}
+
+void seq_add(seq_build_t *bu, val item)
+{
+ bu->ops->add(bu, item);
+}
+
+void seq_pend(seq_build_t *bu, val items)
+{
+ bu->ops->pend(bu, items);
+}
+
+void seq_nconc(seq_build_t *bu, val items)
+{
+ bu->ops->nconc(bu, items);
+}
+
+val seq_finish(seq_build_t *bu)
+{
+ if (bu->ops->finish)
+ bu->ops->finish(bu);
+ return bu->obj;
+}
+
+val seq_append2(val self, val seq0, val seq1)
+{
+ seq_build_t bu;
+
+ seq_build_init(self, &bu, seq0);
+
+ seq_pend(&bu, seq0);
+ seq_pend(&bu, seq1);
+
+ return seq_finish(&bu);
+}
+
+val seq_appendv(val self, varg seqs)
+{
+ cnum index = 0;
+ val seq0;
+ seq_build_t bu;
+
+ if (!args_more(seqs, index))
+ return nil;
+
+ seq0 = args_get(seqs, &index);
+
+ if (!args_more(seqs, index))
+ return seq0;
+
+ seq_build_init(self, &bu, seq0);
+
+ seq_pend(&bu, seq0);
+
+ do
+ seq_pend(&bu, args_get(seqs, &index));
+ while (args_more(seqs, index));
+
+ return seq_finish(&bu);
+}
+
+val seq_nconc2(val self, val seq0, val seq1)
+{
+ seq_build_t bu;
+
+ seq_build_init(self, &bu, seq0);
+
+ seq_nconc(&bu, seq0);
+ seq_nconc(&bu, seq1);
+
+ return seq_finish(&bu);
+}
+
+val seq_nconcv(val self, varg seqs)
+{
+ cnum index = 0;
+ val seq0;
+ seq_build_t bu;
+
+ if (!args_more(seqs, index))
+ return nil;
+
+ seq0 = args_get(seqs, &index);
+
+ if (!args_more(seqs, index))
+ return seq0;
+
+ seq_build_init(self, &bu, seq0);
+
+ seq_nconc(&bu, seq0);
+
+ do
+ seq_nconc(&bu, args_get(seqs, &index));
+ while (args_more(seqs, index));
+
+ return seq_finish(&bu);
+}
+
val throw_mismatch(val self, val obj, type_t t)
{
type_mismatch(lit("~a: ~s is not of type ~s"), self, obj, code2type(t), nao);
}
-val class_check(val self, val cobj, val class_sym)
+val class_check(val self, val cobj, struct cobj_class *cls)
{
- type_assert (cobjclassp(cobj, class_sym),
- (lit("~a: ~s is not of type ~s"), self, cobj, class_sym, nao));
+ type_assert (cobjclassp(cobj, cls),
+ (lit("~a: ~s is not of type ~s"), self, cobj, cls->cls_sym, nao));
return t;
}
@@ -597,6 +1822,7 @@ val cdr(val cons)
return funcall2(lambda_meth, cons, rcons(one, t));
}
}
+ /* fallthrough */
default:
type_mismatch(lit("cdr: ~s is not a cons"), cons, nao);
}
@@ -619,8 +1845,8 @@ val rplaca(val cons, val new_car)
case BUF:
buf_put_uchar(cons, zero, new_car);
return cons;
- default:
- if (structp(cons)) {
+ case COBJ:
+ if (obj_struct_p(cons)) {
{
val rplaca_meth = get_special_slot(cons, rplaca_m);
if (rplaca_meth) {
@@ -638,6 +1864,8 @@ val rplaca(val cons, val new_car)
type_mismatch(lit("rplaca: ~s lacks ~s or ~s method"),
cons, rplaca_s, lambda_set_s, nao);
}
+ /* fallthrough */
+ default:
type_mismatch(lit("rplaca: cannot modify ~s"), cons, nao);
}
}
@@ -657,8 +1885,8 @@ val rplacd(val cons, val new_cdr)
case BUF:
replace(cons, new_cdr, one, t);
return cons;
- default:
- if (structp(cons)) {
+ case COBJ:
+ if (obj_struct_p(cons)) {
{
val rplacd_meth = get_special_slot(cons, rplacd_m);
if (rplacd_meth) {
@@ -669,6 +1897,8 @@ val rplacd(val cons, val new_cdr)
replace(cons, new_cdr, one, t);
return cons;
}
+ /* fallthrough */
+ default:
type_mismatch(lit("rplacd: cannot modify ~s"), cons, nao);
}
}
@@ -691,10 +1921,10 @@ val sys_rplaca(val cons, val new_car)
return new_car;
}
-val sys_rplacd(val cons, val new_car)
+val sys_rplacd(val cons, val new_cdr)
{
- (void) rplacd(cons, new_car);
- return new_car;
+ (void) rplacd(cons, new_cdr);
+ return new_cdr;
}
loc car_l(val cons)
@@ -786,6 +2016,76 @@ val tenth(val obj)
return ref(obj, num_fast(9));
}
+val cxr(val addr, val obj)
+{
+ val self = lit("cxr");
+
+ switch (type(addr)) {
+ case NUM:
+ {
+ cnum a = c_num(addr, self);
+ if (a > 0) {
+ for (; a != 1; a >>= 1)
+ obj = if3((a & 1) != 0, car(obj), cdr(obj));
+ return obj;
+ }
+ }
+ break;
+ case BGNUM:
+ {
+ mp_int *a = mp(addr);
+ if (!mp_isneg(a)) {
+ mp_size i, n = mp_count_bits(a);
+ for (i = 0; i < n - 1; i++)
+ obj = if3(mp_bit(a, i) == MP_YES, car(obj), cdr(obj));
+ return obj;
+ }
+ }
+ break;
+ default:
+ break;
+ }
+
+ uw_throwf(error_s, lit("~a: ~s is an invalid address"), self, addr, nao);
+}
+
+val cyr(val addr, val obj)
+{
+ val self = lit("cyr");
+
+ switch (type(addr)) {
+ case NUM:
+ {
+ cnum a = c_num(addr, self);
+ if (a > 0) {
+ int h = highest_bit(a);
+ cnum m;
+ if (h > 1) {
+ for (m = convert(cnum, 1) << (h - 2); m != 0; m >>= 1)
+ obj = if3((a & m) != 0, car(obj), cdr(obj));
+ }
+ return obj;
+ }
+ }
+ break;
+ case BGNUM:
+ {
+ mp_int *a = mp(addr);
+ if (!mp_isneg(a)) {
+ mp_size i, n = mp_count_bits(a);
+ for (i = n - 2; i != convert(mp_size, -1); i--)
+ obj = if3(mp_bit(a, i) == MP_YES, car(obj), cdr(obj));
+ return obj;
+ }
+ }
+ break;
+ default:
+ break;
+ }
+
+ uw_throwf(error_s, lit("~a: ~s is an invalid address"), self, addr, nao);
+}
+
val conses(val list)
{
list_collect_decl (out, ptail);
@@ -876,10 +2176,11 @@ val last(val seq, val n)
val nthcdr(val pos, val list)
{
- cnum n = c_num(pos);
+ val self = lit("nthcdr");
+ cnum n = c_num(pos, self);
if (n < 0)
- uw_throwf(error_s, lit("nthcdr: negative index ~s given"), pos, nao);
+ uw_throwf(error_s, lit("~a: negative index ~s given"), self, pos, nao);
gc_hint(list);
@@ -992,12 +2293,17 @@ val make_like(val list, val thatobj)
return buf_list(list);
break;
case COBJ:
+ if (thatobj->co.cls == seq_iter_cls)
+ {
+ struct seq_iter *si = coerce(struct seq_iter *, thatobj->co.handle);
+ return make_like(list, si->inf.obj);
+ }
if (obj_struct_p(thatobj)) {
val from_list_meth = get_special_slot(thatobj, from_list_m);
if (from_list_meth)
return funcall1(from_list_meth, list);
}
- if (thatobj->co.cls == carray_s)
+ if (thatobj->co.cls == carray_cls)
return carray_list(list, carray_type(thatobj), nil);
break;
case NIL:
@@ -1030,36 +2336,30 @@ val tolist(val seq)
}
}
-val nullify(val seq)
+val nullify(val obj)
{
- switch (type(seq)) {
- case NIL:
- return nil;
- case CONS:
- case LCONS:
- return seq;
- case LIT:
- case STR:
- return c_str(seq)[0] ? seq : nil;
- case LSTR:
- return if3(length_str_gt(seq, zero), seq, nil);
- case VEC:
- return if3(length_vec(seq) != zero, seq, nil);
- case BUF:
- return if3(length_buf(seq) != zero, seq, nil);
- case COBJ:
- if (seq->co.cls == carray_s)
- return if3(length_carray(seq) != zero, seq, nil);
- if (seq->co.cls == hash_s)
- return if3(hash_count(seq) != zero, seq, nil);
- if (obj_struct_p(seq)) {
- val nullify_meth = get_special_slot(seq, nullify_m);
- if (nullify_meth)
- return funcall1(nullify_meth, seq);
- }
- default:
- return seq;
+ val self = lit("nullify");
+ seq_info_t si = seq_info(obj);
+
+ if (seq_iterable(si))
+ {
+ seq_iter_t iter;
+ val elem;
+ seq_iter_init_with_info(self, &iter, si, 0);
+ return if2(seq_peek(&iter, &elem), obj);
}
+
+ return si.obj;
+}
+
+val empty(val seq)
+{
+ val self = lit("empty");
+ val elem;
+ seq_iter_t iter;
+ seq_iter_init(self, &iter, seq);
+
+ return tnil(!seq_peek(&iter, &elem));
}
val seqp(val obj)
@@ -1068,6 +2368,68 @@ val seqp(val obj)
return tnil(si.kind != SEQ_NOTSEQ);
}
+val iterable(val obj)
+{
+ seq_info_t si = seq_info(obj);
+ return seq_iterable(si);
+}
+
+static val list_seq_func(val lcons)
+{
+ val iter = us_car(lcons);
+ val item = iter_item(iter);
+ val new_iter = iter_step(iter);
+
+ us_rplaca(lcons, item);
+
+ if (iter_more(new_iter))
+ us_rplacd(lcons, make_lazy_cons_car(us_lcons_fun(lcons), new_iter));
+
+ return nil;
+}
+
+val list_seq(val seq)
+{
+ val iter = iter_begin(seq);
+
+ if (iter_more(iter))
+ return make_lazy_cons_car(func_n1(list_seq_func), iter);
+
+ return nil;
+}
+
+val vec_seq(val seq)
+{
+ val self = lit("vec-seq");
+ seq_iter_t iter;
+ val elem;
+ val vec = vector(zero, nil);
+ seq_iter_init(self, &iter, seq);
+
+ while (seq_get(&iter, &elem))
+ vec_push(vec, elem);
+
+ return vec;
+}
+
+val str_seq(val seq)
+{
+ val self = lit("str-seq");
+ seq_iter_t iter;
+ val elem;
+ val str = mkustring(zero);
+ seq_iter_init(self, &iter, seq);
+
+ while (seq_get(&iter, &elem)) {
+ if (chrp(elem) || stringp(elem))
+ string_extend(str, elem, nil);
+ else
+ unsup_obj(self, elem);
+ }
+
+ return str;
+}
+
loc list_collect(loc ptail, val obj)
{
val items = cons(obj, nil);
@@ -1095,7 +2457,7 @@ again:
replace_buf(tailobj, items, t, t);
return ptail;
case COBJ:
- if (tailobj->co.cls == carray_s) {
+ if (tailobj->co.cls == carray_cls) {
carray_replace(tailobj, items, t, t);
return ptail;
}
@@ -1103,6 +2465,7 @@ again:
replace_obj(tailobj, items, t, t);
return ptail;
}
+ /* fallthrough */
default:
uw_throwf(error_s, lit("cannot append ~s"), deref(ptail), nao);
}
@@ -1242,9 +2605,10 @@ static val revlist(val in, val *tail)
loc list_collect_revappend(loc ptail, val obj)
{
val last;
- obj = nullify(obj);
val tailobj = deref(ptail);
+ obj = nullify(obj);
+
again:
switch (type(tailobj)) {
case CONS:
@@ -1324,7 +2688,7 @@ val nreverse(val in)
return in;
}
default:
- uw_throwf(error_s, lit("nreverse: cannot reverse ~s"), in, nao);
+ uw_throwf(error_s, lit("~a: cannot reverse ~s"), self, in, nao);
}
}
@@ -1367,7 +2731,7 @@ val reverse(val seq_in)
return obj;
}
default:
- uw_throwf(error_s, lit("reverse: cannot reverse ~s"), seq_in, nao);
+ uw_throwf(error_s, lit("~a: cannot reverse ~s"), self, seq_in, nao);
}
}
@@ -1387,35 +2751,23 @@ val us_nreverse(val in)
val append2(val list1, val list2)
{
- list_collect_decl (out, ptail);
-
- ptail = list_collect_append (ptail, list1);
- ptail = list_collect_append (ptail, list2);
-
- return out;
+ return seq_append2(lit("append"), list1, list2);
}
-val appendv(struct args *lists)
+val appendv(varg lists)
{
- cnum index = 0;
- list_collect_decl (out, ptail);
-
- while (args_more(lists, index)) {
- val item = args_get(lists, &index);
- ptail = list_collect_append(ptail, item);
- }
+ return seq_appendv(lit("append"), lists);
+}
- return out;
+static val appendl(val lists)
+{
+ args_decl_list(args, ARGS_MIN, lists);
+ return appendv(args);
}
val nappend2(val list1, val list2)
{
- list_collect_decl (out, ptail);
-
- ptail = list_collect_nconc (ptail, list1);
- ptail = list_collect_nconc (ptail, list2);
-
- return out;
+ return seq_nconc2(lit("nconc"), list1, list2);
}
val revappend(val list1, val list2)
@@ -1438,28 +2790,20 @@ val nreconc(val list1, val list2)
return out;
}
-val nconcv(struct args *lists)
+val nconcv(varg lists)
{
- cnum index = 0;
- list_collect_decl (out, ptail);
-
- while (args_more(lists, index))
- ptail = list_collect_nconc(ptail, args_get(lists, &index));
-
- return out;
+ return seq_nconcv(lit("nconc"), lists);
}
val sub_list(val list, val from, val to)
{
val len = nil;
- if (!list)
+ if (!list || from == t)
return nil;
if (null_or_missing_p(from))
from = zero;
- else if (from == t)
- from = nil;
else if (minusp(from)) {
from = plus(from, len = length(list));
if (to == zero)
@@ -1479,7 +2823,7 @@ val sub_list(val list, val from, val to)
val i;
for (i = zero; list; list = cdr(list), i = plus(i, one)) {
- if (from && ge(i, from))
+ if (ge(i, from))
break;
}
return list;
@@ -1498,6 +2842,48 @@ val sub_list(val list, val from, val to)
}
}
+static val sub_iter(val obj, val from, val to)
+{
+ val self = lit("sub");
+ seq_iter_t iter;
+ val idx = zero, elem;
+ list_collect_decl (out, ptail);
+
+ seq_iter_init(self, &iter, obj);
+
+ if (from == t)
+ return nil;
+
+ if (null_or_missing_p(from))
+ from = zero;
+ else if (minusp(from))
+ goto list;
+
+ if (to == t || null_or_missing_p(to))
+ to = nil;
+ else if (!null_or_missing_p(to) && minusp(to))
+ goto list;
+
+ if (!to) {
+ do {
+ if (ge(idx, from))
+ return iter_dynamic(&iter);
+ idx = succ(idx);
+ } while (seq_get(&iter, &elem));
+ } else {
+ for (; seq_get(&iter, &elem) && lt(idx, to); idx = succ(idx))
+ if (ge(idx, from))
+ ptail = list_collect(ptail, elem);
+ }
+
+ return out;
+
+list:
+ while (seq_get(&iter, &elem))
+ ptail = list_collect(ptail, elem);
+ return sub_list(out, from, to);
+}
+
val replace_list(val list, val items, val from, val to)
{
val self = lit("replace-list");
@@ -1512,8 +2898,11 @@ val replace_list(val list, val items, val from, val to)
from = nil;
} else if (!integerp(from)) {
seq_iter_t wh_iter;
- val iter = list, idx = zero, item, wh;
+ cnum ndel = 0;
+ loc iter = mkcloc(list);
+ val cons, idx = zero, item, wh;
seq_iter_t item_iter;
+ int compat = opt_compat && opt_compat <= 289;
seq_iter_init(self, &item_iter, items);
seq_iter_init(self, &wh_iter, from);
@@ -1522,20 +2911,30 @@ val replace_list(val list, val items, val from, val to)
lit("~a: to-arg not applicable when from-arg is a list"),
self, nao);
- while (iter && seq_peek(&item_iter, &item) && seq_peek(&wh_iter, &wh)) {
+ while ((cons = deref(iter)) && seq_peek(&wh_iter, &wh)) {
+ int have_item = seq_peek(&item_iter, &item);
+ if (!have_item && compat)
+ break;
if (minusp(wh))
- wh = plus(wh, len ? len : (len = length(list)));
+ wh = plus(wh, len ? len : (len = plus(length(list), num_fast(ndel))));
if (lt(wh, idx)) {
seq_geti(&wh_iter);
seq_geti(&item_iter);
continue;
} else if (eql(wh, idx)) {
- rplaca(iter, item);
seq_geti(&wh_iter);
- seq_geti(&item_iter);
+ if (have_item) {
+ rplaca(cons, item);
+ seq_geti(&item_iter);
+ } else {
+ deref(iter) = cdr(cons);
+ idx = plus(idx, one);
+ ndel++;
+ continue;
+ }
}
- iter = cdr(iter);
+ iter = cdr_l(cons);
idx = plus(idx, one);
}
@@ -1622,7 +3021,7 @@ static val lazy_appendv_func(val rl, val lcons)
return nil;
}
-val lazy_appendv(struct args *args)
+val lazy_appendv(varg args)
{
val nonempty = nil;
cnum index = 0;
@@ -1670,11 +3069,13 @@ loop:
case SEQ_KIND_PAIR(SEQ_NIL, SEQ_LISTLIKE):
case SEQ_KIND_PAIR(SEQ_NIL, SEQ_VECLIKE):
case SEQ_KIND_PAIR(SEQ_NIL, SEQ_HASHLIKE):
+ case SEQ_KIND_PAIR(SEQ_NIL, SEQ_TREELIKE):
case SEQ_KIND_PAIR(SEQ_NIL, SEQ_NOTSEQ):
break;
case SEQ_KIND_PAIR(SEQ_LISTLIKE, SEQ_NIL):
case SEQ_KIND_PAIR(SEQ_VECLIKE, SEQ_NIL):
case SEQ_KIND_PAIR(SEQ_HASHLIKE, SEQ_NIL):
+ case SEQ_KIND_PAIR(SEQ_TREELIKE, SEQ_NIL):
case SEQ_KIND_PAIR(SEQ_NOTSEQ, SEQ_NIL):
return seq1;
case SEQ_KIND_PAIR(SEQ_LISTLIKE, SEQ_LISTLIKE):
@@ -1683,6 +3084,7 @@ loop:
goto loop;
case SEQ_KIND_PAIR(SEQ_LISTLIKE, SEQ_VECLIKE):
case SEQ_KIND_PAIR(SEQ_LISTLIKE, SEQ_HASHLIKE):
+ case SEQ_KIND_PAIR(SEQ_LISTLIKE, SEQ_TREELIKE):
case SEQ_KIND_PAIR(SEQ_LISTLIKE, SEQ_NOTSEQ):
ptail = list_collect(ptail, car(si1.obj));
seq1 = cdr(si1.obj);
@@ -1694,6 +3096,7 @@ loop:
seq1 = sub(seq1, one, t);
goto loop;
case SEQ_KIND_PAIR(SEQ_HASHLIKE, SEQ_HASHLIKE):
+ case SEQ_KIND_PAIR(SEQ_HASHLIKE, SEQ_TREELIKE):
case SEQ_KIND_PAIR(SEQ_NOTSEQ, SEQ_NOTSEQ):
if (!equal(seq1, seq2))
ptail = list_collect_append(ptail, seq1);
@@ -1745,6 +3148,28 @@ val tailp(val obj, val list)
return t;
}
+val delcons(val cons, val list)
+{
+ val iter = list;
+
+ if (!consp(cons))
+ return list;
+
+ if (cons == iter)
+ return cdr(iter);
+
+ while (consp(iter)) {
+ val d = us_cdr(iter);
+ if (cons == d) {
+ us_rplacd(iter, us_cdr(cons));
+ break;
+ }
+ iter = d;
+ }
+
+ return list;
+}
+
val memq(val obj, val list)
{
val list_orig = list;
@@ -1886,144 +3311,44 @@ val rmember_if(val pred, val list, val key)
return found;
}
-static val rem_impl(val (*eqfun)(val, val), val name,
- val obj, val seq_in, val keyfun_in)
+static val rem_impl(val (*eqfun)(val, val), val self,
+ val obj, val seq, val keyfun_in)
{
val keyfun = default_null_arg(keyfun_in);
+ seq_iter_t it;
+ seq_build_t bu;
+ val elem;
- switch (type(seq_in)) {
- case NIL:
- return nil;
- case CONS:
- case LCONS:
- case COBJ:
- {
- list_collect_decl (out, ptail);
- val list = seq_in;
- val lastmatch = cons(nil, list);
-
- gc_hint(list);
-
- for (; list; list = cdr(list)) {
- val elem = car(list);
- val key = keyfun ? funcall1(keyfun, elem) : elem;
-
- if (eqfun(key, obj)) {
- ptail = list_collect_nconc(ptail, ldiff(cdr(lastmatch), list));
- lastmatch = list;
- }
- }
- ptail = list_collect_nconc(ptail, cdr(lastmatch));
- return out;
- }
- case LIT:
- case STR:
- case LSTR:
- {
- val out = mkustring(zero);
- val str = seq_in;
- cnum len = c_fixnum(length_str(str), name), i;
-
- for (i = 0; i < len; i++) {
- val elem = chr_str(str, num_fast(i));
- val key = keyfun ? funcall1(keyfun, elem) : elem;
+ seq_iter_init(self, &it, seq);
+ seq_build_init(self, &bu, seq);
- if (!eqfun(key, obj))
- string_extend(out, elem);
- }
-
- return out;
- }
- case VEC:
- {
- val out = vector(zero, nil);
- val vec = seq_in;
- cnum len = c_fixnum(length_vec(vec), name), i;
-
- for (i = 0; i < len; i++) {
- val elem = vecref(vec, num_fast(i));
- val key = keyfun ? funcall1(keyfun, elem) : elem;
-
- if (!eqfun(key, obj))
- vec_push(out, elem);
- }
-
- return out;
- }
- default:
- uw_throwf(error_s, lit("~a: ~s isn't a sequence"), name, seq_in, nao);
+ while (seq_get(&it, &elem)) {
+ val key = keyfun ? funcall1(keyfun, elem) : elem;
+ if (!eqfun(key, obj))
+ seq_add(&bu, elem);
}
+
+ return seq_finish(&bu);
}
-val remove_if(val pred, val seq_in, val keyfun_in)
+static val rem_if_impl(val pred, val seq, val keyfun_in, val self)
{
- val self = lit("remove-if");
val keyfun = default_null_arg(keyfun_in);
+ seq_iter_t it;
+ seq_build_t bu;
+ val elem;
- switch (type(seq_in)) {
- case NIL:
- return nil;
- case CONS:
- case LCONS:
- case COBJ:
- {
- list_collect_decl (out, ptail);
- val list = seq_in;
- val lastmatch = cons(nil, list);
-
- gc_hint(list);
+ seq_iter_init(self, &it, seq);
+ seq_build_init(self, &bu, seq);
- for (; list; list = cdr(list)) {
- val elem = car(list);
- val key = keyfun ? funcall1(keyfun, elem) : elem;
-
- if (funcall1(pred, key)) {
- ptail = list_collect_nconc(ptail, ldiff(cdr(lastmatch), list));
- lastmatch = list;
- }
- }
- ptail = list_collect_nconc(ptail, cdr(lastmatch));
- return out;
- }
- case LIT:
- case STR:
- case LSTR:
- {
- val out = mkustring(zero);
- val str = seq_in;
- cnum len = c_fixnum(length_str(str), self), i;
-
- for (i = 0; i < len; i++) {
- val elem = chr_str(str, num_fast(i));
- val key = keyfun ? funcall1(keyfun, elem) : elem;
-
- if (!funcall1(pred, key))
- string_extend(out, elem);
- }
-
- return out;
- }
- case VEC:
- {
- val out = vector(zero, nil);
- val vec = seq_in;
- cnum len = c_fixnum(length_vec(vec), self), i;
-
- for (i = 0; i < len; i++) {
- val elem = vecref(vec, num_fast(i));
- val key = keyfun ? funcall1(keyfun, elem) : elem;
-
- if (!funcall1(pred, key))
- vec_push(out, elem);
- }
-
- return out;
- }
- default:
- uw_throwf(error_s, lit("remove-if: ~s isn't a sequence"), seq_in, nao);
+ while (seq_get(&it, &elem)) {
+ val key = keyfun ? funcall1(keyfun, elem) : elem;
+ if (!funcall1(pred, key))
+ seq_add(&bu, elem);
}
-}
+ return seq_finish(&bu);
+}
val remq(val obj, val seq, val keyfun)
{
@@ -2032,7 +3357,7 @@ val remq(val obj, val seq, val keyfun)
val remql(val obj, val seq, val keyfun)
{
- return rem_impl(eql, lit("remq"), obj, seq, keyfun);
+ return rem_impl(eql, lit("remql"), obj, seq, keyfun);
}
val remqual(val obj, val seq, val keyfun)
@@ -2055,9 +3380,77 @@ val keepqual(val obj, val seq, val keyfun)
return rem_impl(nequal, lit("keepqual"), obj, seq, keyfun);
}
+val remove_if(val pred, val seq, val keyfun)
+{
+ return rem_if_impl(pred, seq, keyfun, lit("remove-if"));
+}
+
val keep_if(val pred, val seq, val keyfun)
{
- return remove_if(notf(pred), seq, keyfun);
+ return rem_if_impl(notf(pred), seq, keyfun, lit("keep-if"));
+}
+
+val keep_keys_if(val pred, val seq, val keyfun_in)
+{
+ val self = lit("keep-keys-if");
+ val keyfun = default_null_arg(keyfun_in);
+ seq_iter_t it;
+ seq_build_t bu;
+ val elem;
+
+ seq_iter_init(self, &it, seq);
+ seq_build_init(self, &bu, seq);
+
+ while (seq_get(&it, &elem)) {
+ val key = keyfun ? funcall1(keyfun, elem) : elem;
+
+ if (funcall1(pred, key))
+ seq_add(&bu, key);
+ }
+
+ return seq_finish(&bu);
+}
+
+val separate(val pred, val seq, val keyfun_in)
+{
+ val self = lit("separate");
+ val keyfun = default_null_arg(keyfun_in);
+ seq_iter_t it;
+ seq_build_t yea;
+ seq_build_t nay;
+ val elem;
+
+ seq_iter_init(self, &it, seq);
+ seq_build_init(self, &yea, seq);
+ seq_build_init(self, &nay, seq);
+
+ while (seq_get(&it, &elem)) {
+ val key = keyfun ? funcall1(keyfun, elem) : elem;
+ seq_add(funcall1(pred, key) ? &yea : &nay, elem);
+ }
+
+ return cons(seq_finish(&yea), cons(seq_finish(&nay), nil));
+}
+
+val separate_keys(val pred, val seq, val keyfun_in)
+{
+ val self = lit("separate-keys");
+ val keyfun = default_null_arg(keyfun_in);
+ seq_iter_t it;
+ seq_build_t yea;
+ seq_build_t nay;
+ val elem;
+
+ seq_iter_init(self, &it, seq);
+ seq_build_init(self, &yea, seq);
+ seq_build_init(self, &nay, seq);
+
+ while (seq_get(&it, &elem)) {
+ val key = keyfun ? funcall1(keyfun, elem) : elem;
+ seq_add(funcall1(pred, key) ? &yea : &nay, key);
+ }
+
+ return cons(seq_finish(&yea), cons(seq_finish(&nay), nil));
}
static val rem_lazy_rec(val obj, val list, val env, val func);
@@ -2120,123 +3513,207 @@ val tree_find(val obj, val tree, val testfun)
return nil;
}
-val countqual(val obj, val list)
+static val cons_find_rec(val obj, val tree, val testfun)
+{
+ uses_or2;
+ if (funcall2(testfun, obj, tree))
+ return t;
+ else if (consp(tree))
+ return or2(cons_find_rec(obj, us_car(tree), testfun),
+ cons_find_rec(obj, us_cdr(tree), testfun));
+ else
+ return nil;
+}
+
+val cons_find(val obj, val tree, val testfun)
{
- val count = zero;
+ return cons_find_rec(obj, tree, default_arg(testfun, equal_f));
+}
- list = nullify(list);
+val countqual(val obj, val seq)
+{
+ val self = lit("countqual");
+ seq_iter_t iter;
+ ucnum count = 0;
+ val ocount = zero;
+ val elem;
- gc_hint(list);
+ seq_iter_init(self, &iter, z(seq));
- for (; list; list = cdr(list))
- if (equal(car(list), obj))
- count = plus(count, one);
+ while (seq_get(&iter, &elem))
+ if (equal(elem, obj))
+ if (++count == 0)
+ ocount = plus(ocount, one);
- return count;
+ return if3(ocount == zero,
+ unum(count),
+ plus(unum(count), ash(ocount, num_fast(CHAR_BIT * sizeof count))));
}
-val countql(val obj, val list)
+val countql(val obj, val seq)
{
- val count = zero;
+ val self = lit("countql");
+ seq_iter_t iter;
+ ucnum count = 0;
+ val ocount = zero;
+ val elem;
- list = nullify(list);
+ seq_iter_init(self, &iter, z(seq));
- gc_hint(list);
+ while (seq_get(&iter, &elem))
+ if (eql(elem, obj))
+ if (++count == 0)
+ ocount = plus(ocount, one);
- for (; list; list = cdr(list))
- if (eql(car(list), obj))
- count = plus(count, one);
-
- return count;
+ return if3(ocount == zero,
+ unum(count),
+ plus(unum(count), ash(ocount, num_fast(CHAR_BIT * sizeof count))));
}
-val countq(val obj, val list)
+val countq(val obj, val seq)
{
- val count = zero;
+ val self = lit("countq");
+ seq_iter_t iter;
+ ucnum count = 0;
+ val ocount = zero;
+ val elem;
- list = nullify(list);
+ seq_iter_init(self, &iter, z(seq));
- gc_hint(list);
+ while (seq_get(&iter, &elem))
+ if (elem == obj)
+ if (++count == 0)
+ ocount = plus(ocount, one);
- for (; list; list = cdr(list))
- if (car(list) == obj)
- count = plus(count, one);
+ return if3(ocount == zero,
+ unum(count),
+ plus(unum(count), ash(ocount, num_fast(CHAR_BIT * sizeof count))));
+}
+
+val count_if(val pred, val seq, val key_in)
+{
+ val self = lit("count-if");
+ seq_iter_t iter;
+ ucnum count = 0;
+ val ocount = zero;
+ val key = default_arg(key_in, identity_f);
+ val elem;
+
+ seq_iter_init(self, &iter, z(seq));
+
+ while (seq_get(&iter, &elem)) {
+ val subj = funcall1(key, elem);
+ if (funcall1(pred, subj))
+ if (++count == 0)
+ ocount = plus(ocount, one);
+ }
- return count;
+ return if3(ocount == zero,
+ unum(count),
+ plus(unum(count), ash(ocount, num_fast(CHAR_BIT * sizeof count))));
}
-val count_if(val pred, val list, val key)
+val count(val item, val seq, val testfun_in, val keyfun_in)
{
- val count = zero;
+ val self = lit("count");
+ val testfun = default_arg(testfun_in, equal_f);
+ val keyfun = default_arg(keyfun_in, identity_f);
+ seq_iter_t iter;
+ ucnum count = 0;
+ val ocount = zero;
+ val elem;
- key = default_arg(key, identity_f);
- list = nullify(list);
+ seq_iter_init(self, &iter, z(seq));
- gc_hint(list);
+ while (seq_get(&iter, &elem)) {
+ val subj = funcall1(keyfun, elem);
+ if (funcall2(testfun, item, subj))
+ if (++count == 0)
+ ocount = plus(ocount, one);
+ }
- for (; list; list = cdr(list)) {
- val subj = funcall1(key, car(list));
- val satisfies = funcall1(pred, subj);
+ return if3(ocount == zero,
+ unum(count),
+ plus(unum(count), ash(ocount, num_fast(CHAR_BIT * sizeof count))));
+
+}
+
+static val cons_count_rec(val item, val tree, val testfun)
+{
+ val hc = if3(funcall2(testfun, item, tree), one, zero);
+
+ if (consp(tree)) {
+ val ac = cons_count_rec(item, us_car(tree), testfun);
+ val dc = cons_count_rec(item, us_cdr(tree), testfun);
- if (satisfies)
- count = plus(count, one);
+ return plus(plus(hc, ac), dc);
}
- return count;
+ return hc;
}
-val some_satisfy(val list, val pred, val key)
+val cons_count(val item, val tree, val testfun_in)
{
- pred = default_arg(pred, identity_f);
- key = default_arg(key, identity_f);
- list = nullify(list);
+ return cons_count_rec(item, tree, default_arg(testfun_in, equal_f));
+}
- gc_hint(list);
+val some_satisfy(val seq, val pred_in, val key_in)
+{
+ val pred = default_arg(pred_in, identity_f);
+ val key = default_arg(key_in, identity_f);
+ val self = lit("some");
+ seq_iter_t iter;
+ val elem;
- for (; list; list = cdr(list)) {
- val item;
- if ((item = funcall1(pred, funcall1(key, car(list)))) != nil)
+ seq_iter_init(self, &iter, z(seq));
+
+ while (seq_get(&iter, &elem)) {
+ val item = funcall1(pred, funcall1(key, elem));
+ if (item != nil)
return item;
}
return nil;
}
-val all_satisfy(val list, val pred, val key)
+val all_satisfy(val seq, val pred_in, val key_in)
{
- val item = t;
-
- pred = default_arg(pred, identity_f);
- key = default_arg(key, identity_f);
- list = nullify(list);
+ val pred = default_arg(pred_in, identity_f);
+ val key = default_arg(key_in, identity_f);
+ val self = lit("all");
+ seq_iter_t iter;
+ val elem;
+ val ret = t;
- gc_hint(list);
+ seq_iter_init(self, &iter, z(seq));
- for (; list; list = cdr(list)) {
- if ((item = funcall1(pred, funcall1(key, car(list)))) == nil)
+ while (seq_get(&iter, &elem)) {
+ if ((ret = funcall1(pred, funcall1(key, elem))) == nil)
return nil;
}
- return item;
+ return ret;
}
-val none_satisfy(val list, val pred, val key)
+val none_satisfy(val seq, val pred_in, val key_in)
{
- pred = default_arg(pred, identity_f);
- key = default_arg(key, identity_f);
- list = nullify(list);
+ val pred = default_arg(pred_in, identity_f);
+ val key = default_arg(key_in, identity_f);
+ val self = lit("none");
+ seq_iter_t iter;
+ val elem;
- gc_hint(list);
+ seq_iter_init(self, &iter, z(seq));
- for (; list; list = cdr(list)) {
- if (funcall1(pred, funcall1(key, car(list))))
+ while (seq_get(&iter, &elem)) {
+ if (funcall1(pred, funcall1(key, elem)))
return nil;
}
return t;
}
-val multi(val func, struct args *lists)
+val multi(val func, varg lists)
{
val transposed = mapcarv(list_f, lists);
val processed = funcall1(func, transposed);
@@ -2269,12 +3746,11 @@ static val lazy_flatten_scan(val list, val *escape)
list = cdr(list);
} else if (atom(a)) {
return list;
- } else do {
+ } else {
push(cdr(list), escape); /* safe mutation: *escape is a local var */
list = a;
a = car(list);
- } while (consp(a));
- return list;
+ }
} else if (*escape) {
list = pop(escape);
} else {
@@ -2283,7 +3759,7 @@ static val lazy_flatten_scan(val list, val *escape)
}
}
-static val lazy_flatten_func(val env, val lcons)
+static val lazy_flatten_func(val lcons)
{
us_cons_bind (list, escape, lcons);
val atom = car(list);
@@ -2301,7 +3777,9 @@ static val lazy_flatten_func(val env, val lcons)
val lazy_flatten(val list)
{
- if (atom(list)) {
+ if (list == nil) {
+ return nil;
+ } if (atom(list)) {
return cons(list, nil);
} else {
val escape = nil;
@@ -2310,7 +3788,7 @@ val lazy_flatten(val list)
if (!next)
return nil;
- return make_lazy_cons_car_cdr(func_f1(nil, lazy_flatten_func),
+ return make_lazy_cons_car_cdr(func_n1(lazy_flatten_func),
next, escape);
}
}
@@ -2373,75 +3851,200 @@ val lazy_flatcar(val tree)
static val tuples_func(val n, val lcons)
{
- list_collect_decl (out, ptail);
- us_cons_bind (seq_in, fill, lcons);
- val seq = seq_in;
+ seq_build_t bu;
+ us_cons_bind (iter_in, fill, lcons);
+ val iter = iter_in;
val count;
- for (count = n; count != zero && seq; count = minus(count, one))
- ptail = list_collect(ptail, pop(&seq));
+ seq_build_init(lit("tuples"), &bu, iter);
+
+ for (count = n; count != zero && iter_more(iter);
+ count = minus(count, one), iter = iter_step(iter))
+ seq_add(&bu, iter_item(iter));
if (!missingp(fill))
for (; gt(count, zero); count = minus(count, one))
- ptail = list_collect(ptail, fill);
+ seq_add(&bu, fill);
- if (seq)
- us_rplacd(lcons, make_lazy_cons_car_cdr(us_lcons_fun(lcons), seq, fill));
+ if (iter_more(iter))
+ us_rplacd(lcons, make_lazy_cons_car_cdr(us_lcons_fun(lcons), iter, fill));
else
us_rplacd(lcons, nil);
- us_rplaca(lcons, make_like(out, seq_in));
+
+ us_rplaca(lcons, seq_finish(&bu));
return nil;
}
val tuples(val n, val seq, val fill)
{
- seq = nullify(seq);
+ val self = lit("tuples");
+ val iter = iter_begin(seq);
- if (!seq)
+ if (!plusp(n) || !integerp(n))
+ uw_throwf(error_s, lit("~a: positive integer required, not ~s"), self, n, nao);
+
+ if (!iter_more(iter))
return nil;
- return make_lazy_cons_car_cdr(func_f1(n, tuples_func), seq, fill);
+ return make_lazy_cons_car_cdr(func_f1(n, tuples_func), iter, fill);
+}
+
+static val tuples_star_func(val tail, val lcons)
+{
+ us_cons_bind (tuple, iter, lcons);
+ val item = make_like(tuple, iter);
+
+ if (iter_more(iter)) {
+ val itemcopy = if3(tuple == item, copy_list(tuple), item);
+ us_rplaca(lcons, itemcopy);
+ us_rplacd(tail, cons(iter_item(iter), nil));
+
+ {
+ val nxtuple = us_cdr(tuple);
+ val fun = us_lcons_fun(lcons);
+ tail = us_cdr(tail);
+ iter = iter_step(iter);
+ rcyc_cons(tuple);
+ us_func_set_env(fun, tail);
+ us_rplacd(lcons, make_lazy_cons_car_cdr(fun, nxtuple, iter));
+ }
+ } else {
+ val item = make_like(tuple, iter);
+ us_rplaca(lcons, item);
+ us_rplacd(lcons, nil);
+ }
+
+ return nil;
+}
+
+val tuples_star(val n, val seq, val fill)
+{
+ val self = lit("tuples*");
+ val iter = iter_begin(seq);
+ cnum i, cn = c_num(n, self);
+ list_collect_decl (tuple, ptail);
+
+ if (!plusp(n) || !integerp(n))
+ uw_throwf(error_s, lit("~a: positive integer required, not ~s"), self, n, nao);
+
+ for (i = 0; i < cn; i++, iter = iter_step(iter))
+ {
+ if (!iter_more(iter)) {
+ if (missingp(fill))
+ return nil;
+ for (; i < cn; i++)
+ ptail = list_collect(ptail, fill);
+ break;
+ }
+
+ ptail = list_collect(ptail, iter_item(iter));
+ }
+
+ return make_lazy_cons_car_cdr(func_f1(lastcons(tuple), tuples_star_func), tuple, iter);
}
static val partition_by_func(val func, val lcons)
{
- list_collect_decl (out, ptail);
- us_cons_bind (flast, seq_in, lcons);
- val seq = seq_in;
+ seq_build_t bu;
+ us_cons_bind (flast, iter, lcons);
val fnext = nil;
- ptail = list_collect(ptail, pop(&seq));
+ seq_build_init(lit("partition-by"), &bu, iter);
+
+ seq_add(&bu, iter_item(iter));
+ iter = iter_step(iter);
+
+ while (iter_more(iter)) {
+ val next = iter_item(iter);
- while (seq) {
- val next = car(seq);
fnext = funcall1(func, next);
if (!equal(flast, fnext))
break;
- ptail = list_collect(ptail, next);
+ seq_add(&bu, next);
- seq = cdr(seq);
+ iter = iter_step(iter);
flast = fnext;
}
- us_rplacd(lcons, if2(seq,
+ us_rplacd(lcons, if2(iter_more(iter),
make_lazy_cons_car_cdr(us_lcons_fun(lcons),
- fnext, seq)));
- us_rplaca(lcons, make_like(out, seq_in));
+ fnext, iter)));
+ us_rplaca(lcons, seq_finish(&bu));
return nil;
}
val partition_by(val func, val seq)
{
+ val iter = iter_begin(seq);
seq = nullify(seq);
- if (!seq)
+ if (!iter_more(iter))
return nil;
return make_lazy_cons_car_cdr(func_f1(func, partition_by_func),
- funcall1(func, car(seq)), seq);
+ funcall1(func, iter_item(iter)), iter);
+}
+
+static val partition_if_countdown_funv(val envcons, varg args)
+{
+ cons_bind(count, targetfun, envcons);
+ val ret;
+ if (zerop(count))
+ return nil;
+ if ((ret = generic_funcall(targetfun, args)))
+ rplaca(envcons, pred(count));
+ return ret;
+}
+
+static val partition_if_func(val func, val lcons)
+{
+ seq_build_t bu;
+ us_cons_bind (prev_item, iter, lcons);
+
+ seq_build_init(lit("partition-if"), &bu, iter);
+
+ seq_add(&bu, prev_item);
+
+ while (iter_more(iter)) {
+ val next_item = iter_item(iter);
+ val different = funcall2(func, prev_item, next_item);
+ prev_item = next_item;
+ if (different)
+ break;
+ seq_add(&bu, next_item);
+ iter = iter_step(iter);
+ }
+
+ us_rplacd(lcons, if2(iter_more(iter),
+ make_lazy_cons_car_cdr(us_lcons_fun(lcons),
+ prev_item, iter_step(iter))));
+ us_rplaca(lcons, seq_finish(&bu));
+ return nil;
+}
+
+val partition_if(val func, val seq, val count_in)
+{
+ val self = lit("partition-if");
+ val iter = iter_begin(seq);
+
+ if (count_in == zero) {
+ return cons(seq, nil);
+ } else if (iter_more(iter)) {
+ val item = iter_item(iter);
+ if (!missingp(count_in)) {
+ if (!integerp(count_in) && !plusp(count_in))
+ uw_throwf(type_error_s, lit("~a: count ~s isn't a nonnegative integer"),
+ self, count_in, nao);
+ func = func_f0v(cons(count_in, func), partition_if_countdown_funv);
+ }
+ return make_lazy_cons_car_cdr(func_f1(func, partition_if_func),
+ item, iter_step(iter));
+ } else {
+ return nil;
+ }
}
static val partition_func(val base, val lcons)
@@ -2450,8 +4053,8 @@ static val partition_func(val base, val lcons)
val len = nil;
for (;;) {
- if (indices) {
- val raw_index = pop(&indices);
+ if (iter_more(indices)) {
+ val raw_index = iter_item(indices);
val index = if3((!opt_compat || opt_compat > 170) && minusp(raw_index),
plus(raw_index, if3(len, len, len = length(seq))),
raw_index);
@@ -2466,7 +4069,8 @@ static val partition_func(val base, val lcons)
if (rest) {
val fun = us_lcons_fun(lcons);
us_func_set_env(fun, index);
- us_rplacd(lcons, make_lazy_cons_car_cdr(fun, rest, indices));
+ us_rplacd(lcons, make_lazy_cons_car_cdr(fun, rest,
+ iter_step(indices)));
} else {
us_rplacd(lcons, nil);
}
@@ -2489,8 +4093,8 @@ static val split_func(val base, val lcons)
val len = nil;
for (;;) {
- if (indices) {
- val raw_index = pop(&indices);
+ if (iter_more(indices)) {
+ val raw_index = iter_item(indices);
val index = if3((!opt_compat || opt_compat > 170) && minusp(raw_index),
plus(raw_index, if3(len, len, len = length(seq))),
raw_index);
@@ -2506,7 +4110,8 @@ static val split_func(val base, val lcons)
if (rest) {
val fun = us_lcons_fun(lcons);
us_func_set_env(fun, index);
- us_rplacd(lcons, make_lazy_cons_car_cdr(fun, rest, indices));
+ us_rplacd(lcons, make_lazy_cons_car_cdr(fun, rest,
+ iter_step(indices)));
} else {
us_rplacd(lcons, cons(rsub, nil));
}
@@ -2529,8 +4134,8 @@ static val split_star_func(val base, val lcons)
val len = nil;
for (;;) {
- if (indices) {
- val raw_index = pop(&indices);
+ if (iter_more(indices)) {
+ val raw_index = iter_item(indices);
val index = if3((!opt_compat || opt_compat > 170) && minusp(raw_index),
plus(raw_index, if3(len, len, len = length(seq))),
raw_index);
@@ -2546,7 +4151,8 @@ static val split_star_func(val base, val lcons)
if (rest) {
val fun = us_lcons_fun(lcons);
us_func_set_env(fun, succ(index));
- us_rplacd(lcons, make_lazy_cons_car_cdr(fun, rest, indices));
+ us_rplacd(lcons, make_lazy_cons_car_cdr(fun, rest,
+ iter_step(indices)));
} else {
us_rplacd(lcons, cons(rsub, nil));
}
@@ -2582,7 +4188,8 @@ static val partition_split_common(val seq, val indices,
if (!seqp(indices))
indices = cons(indices, nil);
- return make_lazy_cons_car_cdr(func_f1(zero, split_fptr), seq, indices);
+ return make_lazy_cons_car_cdr(func_f1(zero, split_fptr), seq,
+ iter_begin(indices));
}
val partition(val seq, val indices)
@@ -2679,7 +4286,7 @@ val partition_star(val seq, val indices)
}
}
-cnum c_num(val num);
+cnum c_num(val num, val self);
val eql(val left, val right)
{
@@ -2710,6 +4317,8 @@ val eql(val left, val right)
val equal(val left, val right)
{
+ val self = lit("equal");
+
if (left == right)
return t;
@@ -2731,7 +4340,7 @@ val equal(val left, val right)
default:
break;
}
- return nil;
+ break;
case LCONS:
switch (type(right)) {
case CONS:
@@ -2811,7 +4420,7 @@ val equal(val left, val right)
cnum i, length;
if (!equal(left->v.vec[vec_length], right->v.vec[vec_length]))
return nil;
- length = c_num(left->v.vec[vec_length]);
+ length = c_num(left->v.vec[vec_length], self);
for (i = 0; i < length; i++) {
if (!equal(left->v.vec[i], right->v.vec[i]))
return nil;
@@ -2831,7 +4440,7 @@ val equal(val left, val right)
default:
return nil;
}
- return nil;
+ break;
case BGNUM:
if (type(right) == BGNUM) {
if (mp_cmp(mp(left), mp(right)) == MP_EQ)
@@ -2841,7 +4450,7 @@ val equal(val left, val right)
break;
case FLNUM:
if (type(right) == FLNUM) {
- if (left->fl.n == right->fl.n)
+ if (c_f(left) == c_f(right))
return t;
return nil;
}
@@ -2856,8 +4465,8 @@ val equal(val left, val right)
break;
case BUF:
if (type(right) == BUF) {
- cnum ll = c_num(left->b.len);
- cnum rl = c_num(right->b.len);
+ cnum ll = c_num(left->b.len, self);
+ cnum rl = c_num(right->b.len, self);
if (ll == rl && memcmp(left->b.data, right->b.data, ll) == 0)
return t;
}
@@ -2881,7 +4490,7 @@ val equal(val left, val right)
if (type(right) == COBJ && left->co.ops == right->co.ops)
return left->co.ops->equal(left, right);
- return nil;
+ break;
case CPTR:
if (type(right) == CPTR && left->co.ops == right->co.ops)
return left->co.ops->equal(left, right);
@@ -2991,12 +4600,22 @@ mem_t *chk_calloc(size_t n, size_t size)
mem_t *chk_realloc(mem_t *old, size_t size)
{
- mem_t *newptr = convert(mem_t *, realloc(old, size));
+ mem_t *newptr = 0;
assert (!async_sig_enabled);
- if (size != 0 && newptr == 0)
- oom();
+ /* We avoid calling realloc with size == 0.
+ * It was okay in C99; 2023 draft of ISO C says this is undefined.
+ */
+ if (size == 0) {
+ free(old);
+ newptr = convert(mem_t *, malloc(0));
+ } else {
+ newptr = convert(mem_t *, realloc(old, size));
+ if (newptr == 0)
+ oom();
+ }
+
malloc_bytes += size;
return newptr;
}
@@ -3089,6 +4708,21 @@ wchar_t *chk_strdup(const wchar_t *str)
return copy;
}
+wchar_t *chk_substrdup(const wchar_t *str, size_t off, size_t len)
+{
+ size_t size = wcslen(str) + 1, nchar;
+ wchar_t *copy;
+ if (off >= size - 1)
+ return chk_strdup(L"");
+ if (off + len < off)
+ uw_throw(error_s, lit("string size overflow"));
+ nchar = min(size - off, len + 1);
+ copy = chk_wmalloc(nchar);
+ wmemcpy(copy, str, nchar - 1);
+ copy[nchar - 1] = 0;
+ return copy;
+}
+
char *chk_strdup_utf8(const char *str)
{
size_t nchar = strlen(str) + 1;
@@ -3097,6 +4731,21 @@ char *chk_strdup_utf8(const char *str)
return copy;
}
+char *chk_substrdup_utf8(const char *str, size_t off, size_t len)
+{
+ size_t size = strlen(str) + 1, nchar;
+ char *copy;
+ if (off >= size - 1)
+ return chk_strdup_utf8("");
+ if (off + len < off)
+ uw_throw(error_s, lit("string size overflow"));
+ nchar = min(size - off, len + 1);
+ copy = coerce(char *, chk_malloc(nchar));
+ memcpy(copy, str, nchar - 1);
+ copy[nchar - 1] = 0;
+ return copy;
+}
+
unsigned char *chk_strdup_8bit(const wchar_t *str)
{
size_t nchar = wcslen(str) + 1, i;
@@ -3124,7 +4773,7 @@ mem_t *chk_xalloc(ucnum m, ucnum n, val self)
ucnum mn = m * n;
size_t size = mn;
- if ((m > 0 && mn / m != n) || (ucnum) size != mn)
+ if ((m > 0 && mn / m != n) || convert(ucnum, size) != mn)
uw_throwf(error_s, lit("~a: memory allocation size overflow"),
self, nao);
@@ -3203,19 +4852,6 @@ void rcyc_cons(val cons)
recycled_conses = cons;
}
-void rcyc_list(val list)
-{
- if (list) {
- val rl_orig = recycled_conses;
- recycled_conses = list;
-
- while (list->c.cdr)
- list = list->c.cdr;
-
- list->c.cdr = rl_orig;
- }
-}
-
void rcyc_empty(void)
{
recycled_conses = nil;
@@ -3254,7 +4890,7 @@ val list(val first, ...)
return list;
}
-val listv(struct args *args)
+val listv(varg args)
{
return args_get_list(args);
}
@@ -3324,6 +4960,19 @@ val length_list(val list)
return bn_len;
}
+val length_list_lt(val list, val len)
+{
+ val self = lit("length-list-lt");
+ cnum le = c_num(len, self);
+
+ while (consp(list) && le > 0) {
+ list = cdr(list);
+ le--;
+ }
+
+ return tnil(le > 0);
+}
+
static val length_proper_list(val list)
{
cnum len = 0;
@@ -3430,14 +5079,14 @@ val min2(val a, val b)
return if3(less(a, b), a, b);
}
-val maxv(val first, struct args *rest)
+val maxv(val first, varg rest)
{
- return nary_simple_op(lit("max"), max2, rest, first);
+ return nary_simple_op(max2, rest, first);
}
-val minv(val first, struct args *rest)
+val minv(val first, varg rest)
{
- return nary_simple_op(lit("min"), min2, rest, first);
+ return nary_simple_op(min2, rest, first);
}
val maxl(val first, val rest)
@@ -3457,7 +5106,7 @@ val clamp(val low, val high, val num)
return max2(low, min2(high, num));
}
-val bracket(val larg, struct args *args)
+val bracket(val larg, varg args)
{
cnum index = 0, i = 0;
@@ -3476,7 +5125,9 @@ val string_own(wchar_t *str)
obj->st.type = STR;
obj->st.str = str;
obj->st.len = nil;
- obj->st.alloc = nil;
+#if !HAVE_MALLOC_USABLE_SIZE
+ obj->st.alloc = 0;
+#endif
return obj;
}
@@ -3484,9 +5135,11 @@ val string(const wchar_t *str)
{
val obj = make_obj();
obj->st.type = STR;
- obj->st.str = coerce(wchar_t *, chk_strdup(str));
+ obj->st.str = chk_strdup(str);
obj->st.len = nil;
- obj->st.alloc = nil;
+#if !HAVE_MALLOC_USABLE_SIZE
+ obj->st.alloc = 0;
+#endif
return obj;
}
@@ -3496,7 +5149,9 @@ val string_utf8(const char *str)
obj->st.type = STR;
obj->st.str = utf8_dup_from(str);
obj->st.len = nil;
- obj->st.alloc = nil;
+#if !HAVE_MALLOC_USABLE_SIZE
+ obj->st.alloc = 0;
+#endif
return obj;
}
@@ -3521,54 +5176,95 @@ val string_8bit_size(const unsigned char *str, size_t sz)
val mkstring(val len, val ch_in)
{
+ val self = lit("mkstring");
size_t l = if3(minusp(len),
- (uw_throwf(error_s, lit("mkstring: negative size ~s specified"),
- len, nao), 0),
- c_num(len));
+ (uw_throwf(error_s, lit("~a: negative size ~s specified"),
+ self, len, nao), 0),
+ c_num(len, self));
wchar_t *str = chk_wmalloc(l + 1);
val s = string_own(str);
val ch = default_arg_strict(ch_in, chr(' '));
wmemset(str, c_chr(ch), l);
str[l] = 0;
s->st.len = len;
- s->st.alloc = plus(len, one);
+#if !HAVE_MALLOC_USABLE_SIZE
+ s->st.alloc = c_num(len, self) + 1;
+#endif
return s;
}
val mkustring(val len)
{
+ val self = lit("mkustring");
cnum l = if3(minusp(len),
- (uw_throwf(error_s, lit("mkustring: negative size ~s specified"),
+ (uw_throwf(error_s, lit("~a: negative size ~s specified"),
len, nao), 0),
- c_num(len));
+ c_num(len, self));
wchar_t *str = chk_wmalloc(l + 1);
val s = string_own(str);
str[l] = 0;
s->st.len = len;
- s->st.alloc = plus(len, one);
+#if !HAVE_MALLOC_USABLE_SIZE
+ s->st.alloc = c_num(len, self) + 1;
+#endif
return s;
}
-val init_str(val str, const wchar_t *data)
+val init_str(val str, const wchar_t *data, val self)
{
- wmemcpy(str->st.str, data, c_num(str->st.len));
+ wmemcpy(str->st.str, data, c_num(str->st.len, self));
return str;
}
+val str(val len, val pattern)
+{
+ if (chrp(pattern) || null_or_missing_p(pattern)) {
+ return mkstring(len, pattern);
+ } else {
+ val self = lit("str");
+ const wchar_t *pat = c_str(pattern, self);
+ ucnum pl = c_unum(length(pattern), self);
+
+ if (pl <= 1) {
+ val ch = if3(pl == 0, chr(' '), chr(pat[0]));
+ return mkstring(len, ch);
+ } else {
+ ucnum l = c_unum(len, self);
+ val str = mkustring(len);
+ ucnum offs = 0;
+
+ str->st.str[l] = 0;
+
+ for (;;) {
+ wmemcpy(str->st.str + offs, pat, min(l, pl));
+ if (pl < l) {
+ l -= pl;
+ offs += pl;
+ continue;
+ }
+ break;
+ }
+ return str;
+ }
+ }
+}
+
static val copy_lazy_str(val lstr);
val copy_str(val str)
{
+ val self = lit("copy-str");
return if3(lazy_stringp(str),
copy_lazy_str(str),
- string(c_str(str)));
+ string(c_str(str, self)));
}
val upcase_str(val str)
{
+ val self = lit("upcase-str");
val len = length_str(str);
- wchar_t *dst = chk_wmalloc(c_num(len) + 1);
- const wchar_t *src = c_str(str);
+ wchar_t *dst = chk_wmalloc(c_unum(len, self) + 1);
+ const wchar_t *src = c_str(str, self);
val out = string_own(dst);
while ((*dst++ = towupper(*src++)))
@@ -3579,9 +5275,10 @@ val upcase_str(val str)
val downcase_str(val str)
{
+ val self = lit("downcase-str");
val len = length_str(str);
- wchar_t *dst = chk_wmalloc(c_num(len) + 1);
- const wchar_t *src = c_str(str);
+ wchar_t *dst = chk_wmalloc(c_unum(len, self) + 1);
+ const wchar_t *src = c_str(str, self);
val out = string_own(dst);
while ((*dst++ = towlower(*src++)))
@@ -3590,15 +5287,20 @@ val downcase_str(val str)
return out;
}
-val string_extend(val str, val tail)
+val string_extend(val str, val tail, val finish_in)
{
val self = lit("string-extend");
type_check(self, str, STR);
{
+ val finish = default_null_arg(finish_in);
cnum len = c_fixnum(length_str(str), self);
- cnum oalloc = c_fixnum(str->st.alloc, self), alloc = oalloc;
- cnum delta, needed;
+#if HAVE_MALLOC_USABLE_SIZE
+ cnum oalloc = malloc_usable_size(str->st.str) / sizeof str->st.str[0];
+#else
+ cnum oalloc = str->st.alloc;
+#endif
+ cnum alloc = oalloc, delta, needed;
if (stringp(tail))
delta = c_fixnum(length_str(tail), self);
@@ -3614,25 +5316,26 @@ val string_extend(val str, val tail)
needed = len + delta + 1;
- if (needed > alloc) {
- if (alloc >= (NUM_MAX - NUM_MAX / 5))
+ if (needed > alloc || finish) {
+ if (finish)
+ alloc = needed;
+ else if (alloc >= (NUM_MAX - NUM_MAX / 5))
alloc = NUM_MAX;
else
alloc = max(alloc + alloc / 4, needed);
if (alloc != oalloc) {
- str->st.str = coerce(wchar_t *,
- chk_grow_vec(coerce(mem_t *, str->st.str),
- oalloc, alloc,
- sizeof *str->st.str));
- set(mkloc(str->st.alloc, str), num_fast(alloc));
+ str->st.str = chk_wrealloc(str->st.str, alloc);
+#if !HAVE_MALLOC_USABLE_SIZE
+ str->st.alloc = alloc;
+#endif
}
}
- set(mkloc(str->st.len, str), num_fast(len + delta));
+ set(mkloc(str->st.len, str), num(len + delta));
if (stringp(tail)) {
- wmemcpy(str->st.str + len, c_str(tail), delta + 1);
+ wmemcpy(str->st.str + len, c_str(tail, self), delta + 1);
} else if (chrp(tail)) {
str->st.str[len] = c_chr(tail);
str->st.str[len + 1] = 0;
@@ -3642,16 +5345,95 @@ val string_extend(val str, val tail)
return str;
}
+val string_finish(val str)
+{
+ val self = lit("string-finish");
+ type_check(self, str, STR);
+
+ {
+ cnum len = c_fixnum(length_str(str), self);
+#if HAVE_MALLOC_USABLE_SIZE
+ cnum alloc = malloc_usable_size(str->st.str) / sizeof str->st.str[0];
+#else
+ cnum alloc = str->st.alloc;
+#endif
+
+ if (alloc > len + 1) {
+ alloc = len + 1;
+ str->st.str = chk_wrealloc(str->st.str, alloc);
+#if !HAVE_MALLOC_USABLE_SIZE
+ str->st.alloc = alloc;
+#endif
+ }
+ }
+
+ return str;
+}
+
+val string_set_code(val str, val code)
+{
+ val self = lit("string-set-code");
+ type_check(self, str, STR);
+
+ {
+ cnum len = c_fixnum(length_str(str), self);
+#if HAVE_MALLOC_USABLE_SIZE
+ cnum alloc = malloc_usable_size(str->st.str) / sizeof str->st.str[0];
+#else
+ cnum alloc = str->st.alloc;
+#endif
+
+ if (alloc < len + 2) {
+ string_extend(str, one, t);
+ set(mkloc(str->st.len, str), num(len));
+ }
+
+ {
+ str->st.str[len + 1] = c_int(code, self);
+ }
+ }
+
+ return str;
+}
+
+val string_get_code(val str)
+{
+ val self = lit("string-get-code");
+ type_check(self, str, STR);
+
+ {
+ cnum len = c_fixnum(length_str(str), self);
+#if HAVE_MALLOC_USABLE_SIZE
+ cnum alloc = malloc_usable_size(str->st.str) / sizeof str->st.str[0];
+#else
+ cnum alloc = str->st.alloc;
+#endif
+
+ if (alloc >= len + 2)
+ return num(str->st.str[len + 1]);
+ }
+
+ return nil;
+}
+
val stringp(val str)
{
- switch (type(str)) {
- case LIT:
- case STR:
- case LSTR:
+ if (str) switch (tag_ex(str)) {
+ case TAG_LIT:
return t;
+ case TAG_PTR:
+ switch (str->t.type) {
+ case STR:
+ case LSTR:
+ return t;
+ default:
+ break;
+ }
+ /* fallthrough */
default:
- return nil;
+ break;
}
+ return nil;
}
val lazy_stringp(val str)
@@ -3661,16 +5443,19 @@ val lazy_stringp(val str)
val length_str(val str)
{
+ val self = lit("length-str");
switch (type(str)) {
case LIT:
- return num(wcslen(c_str(str)));
+ return num(wcslen(c_str(str, self)));
case LSTR:
lazy_str_force(str);
return length_str(str->ls.prefix);
case STR:
if (!str->st.len) {
set(mkloc(str->st.len, str), num(wcslen(str->st.str)));
- set(mkloc(str->st.alloc, str), plus(str->st.len, one));
+#if !HAVE_MALLOC_USABLE_SIZE
+ str->st.alloc = c_num(str->st.len, self) + 1;
+#endif
}
return str->st.len;
default:
@@ -3680,10 +5465,11 @@ val length_str(val str)
val coded_length(val str)
{
- return unum(utf8_to_buf(0, c_str(str), 0));
+ val self = lit("coded-length");
+ return unum(utf8_to_buf(0, c_str(str, self), 0));
}
-const wchar_t *c_str(val obj)
+const wchar_t *c_str(val obj, val self)
{
switch (type(obj)) {
case LIT:
@@ -3692,18 +5478,20 @@ const wchar_t *c_str(val obj)
return obj->st.str;
case LSTR:
lazy_str_force(obj);
- return c_str(obj->ls.prefix);
+ return c_str(obj->ls.prefix, self);
case SYM:
if (opt_compat && opt_compat <= 231)
- return c_str(symbol_name(obj));
+ return c_str(symbol_name(obj), self);
/* fallthrough */
default:
- type_mismatch(lit("~s is not a string"), obj, nao);
+ self = default_arg(self, lit("internal error"));
+ type_mismatch(lit("~a: ~s is not a string"), self, obj, nao);
}
}
val search_str(val haystack, val needle, val start_num, val from_end)
{
+ val self = lit("search-str");
from_end = default_null_arg(from_end);
start_num = default_arg(start_num, zero);
@@ -3711,12 +5499,12 @@ val search_str(val haystack, val needle, val start_num, val from_end)
return nil;
} else {
val h_is_lazy = lazy_stringp(haystack);
- cnum start = c_num(start_num);
+ cnum start = c_num(start_num, self);
cnum good = -1, pos = -1;
- const wchar_t *n = c_str(needle), *h;
+ const wchar_t *n = c_str(needle, self), *h;
if (!h_is_lazy) {
- h = c_str(haystack);
+ h = c_str(haystack, self);
if (start < 0)
start += wcslen(h);
@@ -3731,18 +5519,18 @@ val search_str(val haystack, val needle, val start_num, val from_end)
pos = -1;
} while (pos != -1 && (good = pos) != -1 && from_end && h[start++]);
} else {
- size_t ln = c_num(length_str(needle));
+ size_t ln = c_num(length_str(needle), self);
if (start < 0) {
lazy_str_force(haystack);
- h = c_str(haystack->ls.prefix);
+ h = c_str(haystack->ls.prefix, self);
start += wcslen(h);
goto nonlazy;
}
do {
lazy_str_force_upto(haystack, plus(num(start + 1), length_str(needle)));
- h = c_str(haystack->ls.prefix);
+ h = c_str(haystack->ls.prefix, self);
if (!wcsncmp(h + start, n, ln))
good = start;
@@ -3779,38 +5567,120 @@ val search_str_tree(val haystack, val tree, val start_num, val from_end)
return nil;
}
-val match_str(val bigstr, val str, val pos)
+static val do_match_str(val bigstr, val str, cnum pos, val self)
{
- val i, p;
+ switch (TYPE_PAIR(type(bigstr), type(str))) {
+ case TYPE_PAIR(LIT, LIT):
+ case TYPE_PAIR(LIT, STR):
+ case TYPE_PAIR(STR, LIT):
+ case TYPE_PAIR(STR, STR):
+ {
+ cnum bl = c_num(length_str(bigstr), self);
+ cnum sl = c_num(length_str(str), self);
- pos = default_arg(pos, zero);
+ if (sl == 0 && pos <= bl)
+ return num(pos);
- if (ge(pos, zero)) {
- for (i = zero;
- length_str_gt(bigstr, p = plus(pos, i)) && length_str_gt(str, i);
- i = plus(i, one))
- {
- if (chr_str(bigstr, p) != chr_str(str, i))
+ if (pos > bl || sl > bl)
return nil;
- }
- return length_str_le(str, i) ? t : nil;
- } else {
- pos = plus(pos, length(bigstr));
- pos = plus(minus(pos, length(str)), one);
+ if (pos > INT_PTR_MAX - sl)
+ return nil;
+
+ if (pos + sl > bl)
+ return nil;
- for (i = minus(length(str), one);
- ge(i, zero) && ge(p = plus(pos, i), zero);
- i = minus(i, one))
+ {
+ const wchar_t *bs = c_str(bigstr, self);
+ const wchar_t *ss = c_str(str, self);
+
+ return if3(wmemcmp(bs + pos, ss, sl) == 0, num(pos + sl), nil);
+ }
+ }
+ case TYPE_PAIR(LSTR, LIT):
+ case TYPE_PAIR(LSTR, STR):
+ {
+ lazy_str_force_upto(bigstr, num(pos + c_num(length_str(str), self)));
+ return do_match_str(bigstr->ls.prefix, str, pos, self);
+ }
+ case TYPE_PAIR(LIT, LSTR):
+ case TYPE_PAIR(STR, LSTR):
{
- if (chr_str(bigstr, p) != chr_str(str, i))
+ if (length_str_gt(str, length_str(bigstr)))
return nil;
+
+ lazy_str_force(str);
+ return do_match_str(bigstr, str->ls.prefix, pos, self);
}
+ case TYPE_PAIR(LSTR, LSTR):
+ {
+ cnum i, p;
+
+ for (i = 0;
+ length_str_gt(bigstr, num((p = pos + i))) &&
+ length_str_gt(str, num(i));
+ i++)
+ {
+ if (chr_str(bigstr, num(p)) != chr_str(str, num(i)))
+ return nil;
+ }
- return minusp(i);
+ return length_str_le(str, num(i)) ? num(p) : nil;
+ }
+ default:
+ invalid_ops(self, bigstr, str);
}
}
+static val do_rmatch_str(val bigstr, val str, cnum pos, val self)
+{
+ if (type(bigstr) == LSTR) {
+ lazy_str_force(bigstr);
+ return do_rmatch_str(bigstr->ls.prefix, str, pos, self);
+ }
+
+ if (type(str) == LSTR) {
+ lazy_str_force(str);
+ return do_rmatch_str(bigstr, str->ls.prefix, pos, self);
+ }
+
+ {
+ cnum bl = c_num(length_str(bigstr), self);
+ cnum sl = c_num(length_str(str), self);
+
+ pos += bl;
+
+ if (pos < 0)
+ return nil;
+
+ if (sl == 0)
+ return num(pos + 1);
+
+ if (sl > pos + 1)
+ return nil;
+
+ if (pos > INT_PTR_MAX - sl)
+ return nil;
+
+ {
+ const wchar_t *bs = c_str(bigstr, self);
+ const wchar_t *ss = c_str(str, self);
+ cnum start = pos + 1 - sl;
+ return if3(wmemcmp(bs + start, ss, sl) == 0, num(start), nil);
+ }
+ }
+}
+
+val match_str(val bigstr, val str, val pos)
+{
+ val self = lit("match-str");
+ cnum p = c_num(default_arg(pos, zero), self);
+
+ return if3(p >= 0,
+ do_match_str(bigstr, str, p, self),
+ do_rmatch_str(bigstr, str, p, self));
+}
+
val match_str_tree(val bigstr, val tree, val pos)
{
pos = default_arg(pos, zero);
@@ -3876,13 +5746,15 @@ static val lazy_sub_str(val lstr, val from, val to)
if (to != t) {
return pfxsub;
} else {
+ val pfxcopy = copy_str(pfxsub);
val lsub = make_obj();
lsub->ls.type = LSTR;
- lsub->ls.prefix = pfxsub;
+ lsub->ls.prefix = pfxcopy;
lsub->ls.list = lstr->ls.list;
lsub->ls.props = coerce(struct lazy_string_props *,
chk_copy_obj(coerce(mem_t *, lstr->ls.props),
sizeof *lstr->ls.props));
+ gc_hint(pfxcopy);
return lsub;
}
}
@@ -3890,6 +5762,7 @@ static val lazy_sub_str(val lstr, val from, val to)
val sub_str(val str_in, val from, val to)
{
+ val self = lit("sub-str");
val len = nil;
if (lazy_stringp(str_in))
@@ -3917,13 +5790,15 @@ val sub_str(val str_in, val from, val to)
if (ge(from, to)) {
return null_string;
- } else if (from == zero && eql(to, len)) {
+ } else if (from == zero && eql(to, len) &&
+ (opt_compat == 0 || opt_compat > 215))
+ {
return str_in;
} else {
- size_t nchar = c_num(to) - c_num(from) + 1;
+ size_t nchar = c_num(to, self) - c_num(from, self) + 1;
wchar_t *sub = chk_wmalloc(nchar);
- const wchar_t *str = c_str(str_in);
- wcsncpy(sub, str + c_num(from), nchar);
+ const wchar_t *str = c_str(str_in, self);
+ wcsncpy(sub, str + c_num(from, self), nchar);
sub[nchar-1] = 0;
return string_own(sub);
}
@@ -3946,6 +5821,8 @@ val replace_str(val str_in, val items, val from, val to)
from = len;
} else if (!integerp(from)) {
val wh, item;
+ cnum offs = 0;
+ cnum l = c_num(len, self), ol = l;
seq_iter_t wh_iter, item_iter;
seq_iter_init(self, &item_iter, items);
seq_iter_init(self, &wh_iter, from);
@@ -3955,12 +5832,37 @@ val replace_str(val str_in, val items, val from, val to)
lit("~a: to-arg not applicable when from-arg is a list"),
self, nao);
- while (seq_get(&wh_iter, &wh) && seq_get(&item_iter, &item)) {
+ while (seq_get(&item_iter, &item) && seq_get(&wh_iter, &wh)) {
if (ge(wh, len))
break;
chr_str_set(str_in, wh, item);
}
+ if (!opt_compat || opt_compat > 289) {
+ while (seq_get(&wh_iter, &wh)) {
+ cnum w = c_num(wh, self);
+
+ if (w < 0)
+ w += ol;
+
+ if (w < 0)
+ break;
+
+ w -= offs;
+
+ if (w >= l)
+ break;
+
+ wmemmove(str_in->st.str + w,
+ str_in->st.str + w + 1,
+ l - w);
+ l--;
+ offs++;
+
+ }
+ if (offs > 0)
+ set(mkloc(str_in->st.len, str_in), num_fast(l));
+ }
return str_in;
} else if (minusp(from)) {
from = plus(from, len);
@@ -3976,27 +5878,26 @@ val replace_str(val str_in, val items, val from, val to)
from = max2(zero, min2(from, len));
to = max2(zero, min2(to, len));
-
{
val len_rep = minus(to, from);
val len_it = length(items);
if (gt(len_rep, len_it)) {
val len_diff = minus(len_rep, len_it);
- cnum t = c_num(to);
- cnum l = c_num(len);
+ cnum t = c_num(to, self);
+ cnum l = c_num(len, self);
- wmemmove(str_in->st.str + t - c_num(len_diff),
+ wmemmove(str_in->st.str + t - c_num(len_diff, self),
str_in->st.str + t, (l - t) + 1);
set(mkloc(str_in->st.len, str_in), minus(len, len_diff));
to = plus(from, len_it);
} else if (lt(len_rep, len_it)) {
val len_diff = minus(len_it, len_rep);
- cnum t = c_num(to);
- cnum l = c_num(len);
+ cnum t = c_num(to, self);
+ cnum l = c_num(len, self);
- string_extend(str_in, len_diff);
- wmemmove(str_in->st.str + t + c_num(len_diff),
+ string_extend(str_in, len_diff, one);
+ wmemmove(str_in->st.str + t + c_num(len_diff, self),
str_in->st.str + t, (l - t) + 1);
to = plus(from, len_it);
}
@@ -4004,12 +5905,14 @@ val replace_str(val str_in, val items, val from, val to)
if (zerop(len_it))
return str_in;
if (stringp(items)) {
- wmemmove(str_in->st.str + c_num(from), c_str(items), c_num(len_it));
+ wmemmove(str_in->st.str + c_num(from, self),
+ c_str(items, self), c_num(len_it, self));
} else {
seq_iter_t item_iter;
+ cnum f = c_num(from, self);
+ cnum t = c_num(to, self);
+
seq_iter_init(self, &item_iter, items);
- cnum f = c_num(from);
- cnum t = c_num(to);
for (; f != t; f++)
str_in->st.str[f] = c_chr(seq_geti(&item_iter));
@@ -4019,169 +5922,257 @@ val replace_str(val str_in, val items, val from, val to)
return str_in;
}
-val cat_str(val list, val sep)
-{
- size_t total = 1;
- val iter;
- wchar_t *str, *ptr;
- wchar_t onech[] = wini(" ");
+struct cat_str {
+ val sep;
cnum len_sep;
+ size_t total;
+ int seen_one;
+ wchar_t *str, *ptr;
+};
+
+static void cat_str_init(struct cat_str *cs, val sep, wchar_t *onech, val self)
+{
+ cs->sep = sep;
+ cs->seen_one = 0;
+ cs->total = 1;
+ cs->str = cs->ptr = 0;
if (null_or_missing_p(sep)) {
- len_sep = 0;
+ cs->len_sep = 0;
} else if (chrp(sep)) {
onech[0] = c_chr(sep);
- len_sep = 1;
- sep = auto_str(coerce(const wchli_t *, wref(onech)));
+ cs->len_sep = 1;
+ cs->sep = auto_str(coerce(const wchli_t *, wref(onech)));
} else {
- len_sep = c_num(length_str(sep));
+ cs->len_sep = c_num(length_str(cs->sep), self);
}
+}
- for (iter = list; iter != nil; iter = cdr(iter)) {
- val item = car(iter);
- if (!item)
- continue;
- if (stringp(item)) {
- size_t ntotal = total + c_num(length_str(item));
-
- if (len_sep && cdr(iter))
- ntotal += len_sep;
-
- if (ntotal < total)
- goto oflow;
+static void cat_str_measure(struct cat_str *cs, val item, val self)
+{
+ if (!item)
+ return;
- total = ntotal;
+ if (stringp(item)) {
+ size_t ntotal = cs->total + c_num(length_str(item), self);
- continue;
+ if (cs->len_sep) {
+ if (cs->seen_one)
+ ntotal += cs->len_sep;
+ else
+ cs->seen_one = 1;
}
- if (chrp(item)) {
- size_t ntotal = total + 1;
- if (len_sep && cdr(iter))
- ntotal += len_sep;
+ if (ntotal < cs->total)
+ goto oflow;
- if (ntotal < total)
- goto oflow;
+ cs->total = ntotal;
+ return;
+ }
- total = ntotal;
+ if (chrp(item)) {
+ size_t ntotal = cs->total + 1;
- continue;
+ if (cs->len_sep) {
+ if (cs->seen_one)
+ ntotal += cs->len_sep;
+ else
+ cs->seen_one = 1;
}
- uw_throwf(error_s, lit("cat-str: ~s is not a character or string"),
- item, nao);
- }
- str = chk_wmalloc(total);
+ if (ntotal < cs->total)
+ goto oflow;
- for (ptr = str, iter = list; iter != nil; iter = cdr(iter)) {
- val item = car(iter);
+ cs->total = ntotal;
+ return;
+ }
- if (!item)
- continue;
- if (stringp(item)) {
- cnum len = c_num(length_str(item));
- wmemcpy(ptr, c_str(item), len);
- ptr += len;
- } else {
- *ptr++ = c_chr(item);
- }
+ if (seqp(item)) {
+ seq_iter_t item_iter;
+ seq_iter_init(self, &item_iter, item);
- if (len_sep && cdr(iter)) {
- wmemcpy(ptr, c_str(sep), len_sep);
- ptr += len_sep;
- }
- }
- *ptr = 0;
+ while (seq_get(&item_iter, &item))
+ cat_str_measure(cs, item, self);
- return string_own(str);
+ return;
+ }
+ uw_throwf(error_s, lit("~a: ~s neither character, string nor sequence"),
+ self, item, nao);
oflow:
- uw_throwf(error_s, lit("cat-str: string length overflow"), nao);
+ uw_throwf(error_s, lit("~a: string length overflow"), self, nao);
}
-static val vscat(val sep, va_list vl1, va_list vl2)
+static void cat_str_alloc(struct cat_str *cs)
{
- size_t total = 1;
- val item, next;
- wchar_t *str, *ptr;
- cnum len_sep = (!null_or_missing_p(sep)) ? c_num(length_str(sep)) : 0;
-
- for (item = va_arg(vl1, val); item != nao; item = next)
- {
- next = va_arg(vl1, val);
+ cs->seen_one = 0;
+ cs->ptr = cs->str = chk_wmalloc(cs->total);
+}
- if (stringp(item)) {
- size_t ntotal = total + c_num(length_str(item));
+static void cat_str_append(struct cat_str *cs, val item, val self)
+{
+ if (!item)
+ return;
+ if (stringp(item) || chrp(item)) {
+ if (cs->len_sep) {
+ if (cs->seen_one) {
+ wmemcpy(cs->ptr, c_str(cs->sep, self), cs->len_sep);
+ cs->ptr += cs->len_sep;
+ } else {
+ cs->seen_one = 1;
+ }
+ }
+ if (chrp(item)) {
+ *cs->ptr++ = c_chr(item);
+ } else {
+ cnum len = c_num(length_str(item), self);
+ wmemcpy(cs->ptr, c_str(item, self), len);
+ cs->ptr += len;
+ }
+ } else {
+ seq_iter_t item_iter;
+ seq_iter_init(self, &item_iter, item);
- if (len_sep && next != nao)
- ntotal += len_sep;
+ while (seq_get(&item_iter, &item))
+ cat_str_append(cs, item, self);
+ }
+}
- if (ntotal < total)
- goto oflow;
+static val cat_str_get(struct cat_str *cs)
+{
+ *cs->ptr = 0;
+ return string_own(cs->str);
+}
- total = ntotal;
+val cat_str(val items, val sep)
+{
+ val self = lit("cat-str");
+ struct cat_str cs;
+ wchar_t onech[] = wini(" ");
- continue;
- }
- if (chrp(item)) {
- size_t ntotal = total + 1;
+ cat_str_init(&cs, sep, onech, self);
+ cat_str_measure(&cs, items, self);
+ cat_str_alloc(&cs);
+ cat_str_append(&cs, items, self);
- if (len_sep && next != nao)
- ntotal += len_sep;
+ return cat_str_get(&cs);
+}
- if (ntotal < total)
- goto oflow;
+static val vscat(val sep, va_list vl1, va_list vl2, val self)
+{
+ val item;
+ struct cat_str cs;
+ wchar_t onech[] = wini(" ");
- total = ntotal;
+ cat_str_init(&cs, sep, onech, self);
- continue;
- }
- uw_throwf(error_s, lit("scat: ~s is not a character or string"),
- item, nao);
- }
+ while ((item = va_arg(vl1, val)) != nao)
+ cat_str_measure(&cs, item, self);
- str = chk_wmalloc(total);
+ cat_str_alloc(&cs);
- for (ptr = str, item = va_arg(vl2, val); item != nao; item = next)
+ while ((item = va_arg(vl2, val)) != nao)
{
- next = va_arg(vl2, val);
-
- if (stringp(item)) {
- cnum len = c_num(length_str(item));
- wmemcpy(ptr, c_str(item), len);
- ptr += len;
- } else {
- *ptr++ = c_chr(item);
- }
-
- if (len_sep && next != nao) {
- wmemcpy(ptr, c_str(sep), len_sep);
- ptr += len_sep;
- }
+ cat_str_append(&cs, item, self);
}
- *ptr = 0;
-
- return string_own(str);
-oflow:
- uw_throwf(error_s, lit("scat: string length overflow"), nao);
+ return cat_str_get(&cs);
}
val scat(val sep, ...)
{
+ val self = lit("scat");
va_list vl1, vl2;
val ret;
va_start (vl1, sep);
va_start (vl2, sep);
- ret = vscat(sep, vl1, vl2);
+ ret = vscat(sep, vl1, vl2, self);
va_end (vl1);
va_end (vl2);
return ret;
}
-val split_str_keep(val str, val sep, val keep_sep)
+val scat2(val s1, val s2)
+{
+ val self = lit("scat2");
+ struct cat_str cs;
+
+ cat_str_init(&cs, nil, NULL, self);
+
+ cat_str_measure(&cs, s1, self);
+ cat_str_measure(&cs, s2, self);
+
+ cat_str_alloc(&cs);
+
+ cat_str_append(&cs, s1, self);
+ cat_str_append(&cs, s2, self);
+
+ return cat_str_get(&cs);
+}
+
+val scat3(val s1, val sep, val s2)
+{
+ val self = lit("scat3");
+ struct cat_str cs;
+ wchar_t onech[] = wini(" ");
+
+ cat_str_init(&cs, sep, onech, self);
+
+ cat_str_measure(&cs, s1, self);
+ cat_str_measure(&cs, s2, self);
+
+ cat_str_alloc(&cs);
+
+ cat_str_append(&cs, s1, self);
+ cat_str_append(&cs, s2, self);
+
+ return cat_str_get(&cs);
+}
+
+val join_with(val sep, varg args)
+{
+ val self = lit("join-with");
+ cnum index;
+ val iter;
+ struct cat_str cs;
+ wchar_t onech[] = wini(" ");
+
+ cat_str_init(&cs, sep, onech, self);
+
+ for (index = 0, iter = args->list; args_more_nozap(args, index, iter);)
+ {
+ val item = args_get_nozap(args, &index, &iter);
+ cat_str_measure(&cs, item, self);
+ }
+
+ cat_str_alloc(&cs);
+
+ for (index = 0, iter = args->list; args_more_nozap(args, index, iter);)
+ {
+ val item = args_get_nozap(args, &index, &iter);
+ cat_str_append(&cs, item, self);
+ }
+
+ return cat_str_get(&cs);
+}
+
+val fmt_join(varg args)
+{
+ return join_with(nil, args);
+}
+
+val split_str_keep(val str, val sep, val keep_sep_opt, val count_opt)
{
- keep_sep = default_null_arg(keep_sep);
+ val self = lit("split-str");
+ val keep_sep = default_null_arg(keep_sep_opt);
+ val count = default_null_arg(count_opt);
+ cnum cnt = c_num(if3(count, count, negone), self);
+
+ if (count && cnt < 0)
+ uw_throwf(error_s, lit("~a: count must be nonnegative"), self, nao);
+
+ if (count == zero)
+ return cons(str, nil);
if (regexp(sep)) {
list_collect_decl (out, iter);
@@ -4201,6 +6192,10 @@ val split_str_keep(val str, val sep, val keep_sep)
pos = plus(pos, len);
if (keep_sep)
iter = list_collect(iter, sub_str(str, new_pos, pos));
+ if (cnt > 0 && --cnt == 0) {
+ iter = list_collect(iter, sub_str(str, pos, t));
+ break;
+ }
continue;
}
break;
@@ -4212,28 +6207,34 @@ val split_str_keep(val str, val sep, val keep_sep)
wchar_t onech[] = wini(" ");
if (chrp(sep)) {
- onech[0] = c_chr(sep);
+ wref(onech)[0] = c_chr(sep);
len_sep = 1;
sep = auto_str(coerce(const wchli_t *, wref(onech)));
} else {
- len_sep = c_num(length_str(sep));
+ len_sep = c_num(length_str(sep), self);
}
if (len_sep == 0) {
if (opt_compat && opt_compat <= 100) {
return list_str(str);
} else {
- const wchar_t *cstr = c_str(str);
+ const wchar_t *cstr = c_str(str, self);
if (*cstr) {
list_collect_decl (out, iter);
for (; *cstr; cstr++) {
val piece = mkustring(one);
- init_str(piece, cstr);
+ init_str(piece, cstr, self);
iter = list_collect(iter, piece);
- if (keep_sep && *(cstr+1))
- iter = list_collect(iter, null_string);
+ if (*(cstr + 1)) {
+ if (keep_sep)
+ iter = list_collect(iter, null_string);
+ if (cnt > 0 && --cnt == 0) {
+ iter = list_collect(iter, string(cstr + 1));
+ break;
+ }
+ }
}
gc_hint(str);
@@ -4244,22 +6245,26 @@ val split_str_keep(val str, val sep, val keep_sep)
}
}
} else {
- const wchar_t *cstr = c_str(str);
- const wchar_t *csep = c_str(sep);
+ const wchar_t *cstr = c_str(str, self);
+ const wchar_t *csep = c_str(sep, self);
list_collect_decl (out, iter);
for (;;) {
const wchar_t *psep = wcsstr(cstr, csep);
- size_t span = (psep != 0) ? psep - cstr : wcslen(cstr);
+ size_t span = (psep != 0) ? convert(size_t, psep - cstr) : wcslen(cstr);
val piece = mkustring(num(span));
- init_str(piece, cstr);
+ init_str(piece, cstr, self);
iter = list_collect(iter, piece);
cstr += span;
if (psep != 0) {
cstr += len_sep;
if (keep_sep)
iter = list_collect(iter, sep);
+ if (cnt > 0 && --cnt == 0) {
+ iter = list_collect(iter, string(cstr));
+ break;
+ }
continue;
}
break;
@@ -4276,25 +6281,38 @@ val split_str_keep(val str, val sep, val keep_sep)
val spl(val sep, val arg1, val arg2)
{
return if3(missingp(arg2),
- split_str_keep(arg1, sep, arg2),
- split_str_keep(arg2, sep, arg1));
+ split_str_keep(arg1, sep, arg2, nil),
+ split_str_keep(arg2, sep, arg1, nil));
+}
+
+val spln(val count, val sep, val arg1, val arg2)
+{
+ val self = lit("spln");
+
+ if (null_or_missing_p(count))
+ uw_throwf(error_s, lit("~a: count ~s isn't an integer"), self, count, nao);
+
+ return if3(missingp(arg2),
+ split_str_keep(arg1, sep, arg2, count),
+ split_str_keep(arg2, sep, arg1, count));
}
val split_str(val str, val sep)
{
- return split_str_keep(str, sep, nil);
+ return split_str_keep(str, sep, nil, nil);
}
val split_str_set(val str, val set)
{
- const wchar_t *cstr = c_str(str);
- const wchar_t *cset = c_str(set);
+ val self = lit("split-str-set");
+ const wchar_t *cstr = c_str(str, self);
+ const wchar_t *cset = c_str(set, self);
list_collect_decl (out, iter);
for (;;) {
size_t span = wcscspn(cstr, cset);
val piece = mkustring(num(span));
- init_str(piece, cstr);
+ init_str(piece, cstr, self);
iter = list_collect(iter, piece);
cstr += span;
if (*cstr) {
@@ -4310,15 +6328,28 @@ val split_str_set(val str, val set)
return out;
}
-val tok_str(val str, val tok_regex, val keep_sep)
+val sspl(val set, val str)
+{
+ return split_str_set(str, set);
+}
+
+val tok_str(val str, val tok_regex, val keep_sep_opt, val count_opt)
{
+ val self = lit("tok-str");
list_collect_decl (out, iter);
val pos = zero;
val last_end = zero;
val slen = length(str);
int prev_empty = 1;
+ val keep_sep = default_null_arg(keep_sep_opt);
+ val count = default_null_arg(count_opt);
+ cnum cnt = c_num(if3(count, count, negone), self);
- keep_sep = default_null_arg(keep_sep);
+ if (count && cnt < 0)
+ uw_throwf(error_s, lit("~a: count must be nonnegative"), self, nao);
+
+ if (count == zero)
+ return if2(keep_sep || slen != zero, cons(str, nil));
if (opt_compat && opt_compat <= 155) for (;;) {
cons_bind (new_pos, len, search_regex(str, tok_regex, pos, nil));
@@ -4337,6 +6368,12 @@ val tok_str(val str, val tok_regex, val keep_sep)
pos = plus(new_pos, len);
iter = list_collect(iter, sub_str(str, new_pos, pos));
+
+ if (cnt > 0 && --cnt == 0) {
+ if (pos != slen || keep_sep)
+ iter = list_collect(iter, sub_str(str, pos, t));
+ break;
+ }
} else for (;;) {
cons_bind (new_pos, len, search_regex(str, tok_regex, pos, nil));
@@ -4360,6 +6397,12 @@ val tok_str(val str, val tok_regex, val keep_sep)
if (len == zero)
pos = succ(pos);
+
+ if (cnt > 0 && --cnt == 0) {
+ if (pos != slen || keep_sep)
+ iter = list_collect(iter, sub_str(str, pos, t));
+ break;
+ }
}
return out;
@@ -4368,8 +6411,20 @@ val tok_str(val str, val tok_regex, val keep_sep)
val tok(val tok_regex, val arg1, val arg2)
{
return if3(missingp(arg2),
- tok_str(arg1, tok_regex, arg2),
- tok_str(arg2, tok_regex, arg1));
+ tok_str(arg1, tok_regex, arg2, nil),
+ tok_str(arg2, tok_regex, arg1, nil));
+}
+
+val tokn(val count, val tok_regex, val arg1, val arg2)
+{
+ val self = lit("tokn");
+
+ if (null_or_missing_p(count))
+ uw_throwf(error_s, lit("~a: count ~s isn't an integer"), self, count, nao);
+
+ return if3(missingp(arg2),
+ tok_str(arg1, tok_regex, arg2, count),
+ tok_str(arg2, tok_regex, arg1, count));
}
val tok_where(val str, val tok_regex)
@@ -4422,7 +6477,8 @@ val tok_where(val str, val tok_regex)
val list_str(val str)
{
- const wchar_t *cstr = c_str(str);
+ val self = lit("list-str");
+ const wchar_t *cstr = c_str(str, self);
list_collect_decl (out, iter);
while (*cstr)
@@ -4435,8 +6491,9 @@ val list_str(val str)
val trim_str(val str)
{
- const wchar_t *start = c_str(str);
- const wchar_t *end = start + c_num(length_str(str));
+ val self = lit("trim-str");
+ const wchar_t *start = c_str(str, self);
+ const wchar_t *end = start + c_num(length_str(str), self);
if (opt_compat && opt_compat <= 148) {
while (start[0] && iswspace(start[0]))
@@ -4463,45 +6520,67 @@ val trim_str(val str)
}
}
+val str_esc(val escset, val escchr, val str)
+{
+ val self = lit("shell-escape");
+ val out = mkstring(zero, chr(' '));
+ const wchar_t *s = c_str(str, self);
+ const wchar_t *es = c_str(escset, self);
+ wchar_t ch;
+
+ while ((ch = *s++)) {
+ if (wcschr(es, ch)) {
+ string_extend(out, escchr, nil);
+ string_extend(out, chr(ch), nil);
+ } else {
+ string_extend(out, chr(ch), nil);
+ }
+ }
+
+ return string_finish(out);
+}
+
val cmp_str(val astr, val bstr)
{
- switch (TYPE_PAIR(type(astr), type(bstr))) {
- case TYPE_PAIR(LIT, LIT):
- case TYPE_PAIR(STR, STR):
- case TYPE_PAIR(LIT, STR):
- case TYPE_PAIR(STR, LIT):
- {
- int cmp = wcscmp(c_str(astr), c_str(bstr));
- return if3(cmp < 0, negone, if3(cmp > 0, one, zero));
- }
- case TYPE_PAIR(LSTR, LIT):
- case TYPE_PAIR(LSTR, STR):
- case TYPE_PAIR(LIT, LSTR):
- case TYPE_PAIR(STR, LSTR):
- case TYPE_PAIR(LSTR, LSTR):
- {
- val i;
- for (i = zero;
- length_str_lt(astr, i) && length_str_lt(bstr, i);
- i = plus(i, one))
- {
- val ach = chr_str(astr, i);
- val bch = chr_str(bstr, i);
-
- if (ach < bch)
- return one;
- else if (ach < bch)
- return one;
- }
- if (length_str_lt(bstr, i))
- return negone;
- if (length_str_lt(astr, i))
- return negone;
- return zero;
- }
- default:
- uw_throwf(error_s, lit("cmp-str: invalid operands ~s ~s"),
- astr, bstr, nao);
+ val self = lit("cmp-str");
+
+ switch (TYPE_PAIR(type(astr), type(bstr))) {
+ case TYPE_PAIR(LIT, LIT):
+ case TYPE_PAIR(STR, STR):
+ case TYPE_PAIR(LIT, STR):
+ case TYPE_PAIR(STR, LIT):
+ {
+ int cmp = wcscmp(c_str(astr, self), c_str(bstr, self));
+ return if3(cmp < 0, negone, if3(cmp > 0, one, zero));
+ }
+ case TYPE_PAIR(LSTR, LIT):
+ case TYPE_PAIR(LSTR, STR):
+ case TYPE_PAIR(LIT, LSTR):
+ case TYPE_PAIR(STR, LSTR):
+ case TYPE_PAIR(LSTR, LSTR):
+ {
+ val i;
+ for (i = zero;
+ length_str_lt(astr, i) && length_str_lt(bstr, i);
+ i = plus(i, one))
+ {
+ val ach = chr_str(astr, i);
+ val bch = chr_str(bstr, i);
+
+ if (ach < bch)
+ return one;
+ else if (ach < bch)
+ return one;
+ }
+ if (length_str_lt(bstr, i))
+ return negone;
+ if (length_str_lt(astr, i))
+ return negone;
+ return zero;
+ }
+ default:
+ uw_throwf(error_s, lit("~a: invalid operands ~s ~s"),
+ self, astr, bstr, nao);
}
}
@@ -4534,10 +6613,11 @@ val str_ge(val astr, val bstr)
val int_str(val str, val base)
{
- const wchar_t *wcs = c_str(str);
+ val self = lit("int-str");
+ const wchar_t *wcs = c_str(str, self);
wchar_t *ptr;
long value;
- cnum b = c_num(default_arg(base, num_fast(10)));
+ cnum b = c_num(default_arg(base, num_fast(10)), self);
int zerox = 0, octzero = 0, minus = 0, flip = 0;
switch (wcs[0]) {
@@ -4564,23 +6644,26 @@ val int_str(val str, val base)
case 'x': case 'X':
zerox = 1;
wcs += 2;
+ break;
default:
octzero = 1;
+ break;
}
break;
}
if (base == chr('c')) {
b = (zerox ? 16 : (octzero ? 8 : 10));
- } else if (b == 16) {
- /* If base is 16, strtoul and its siblings
- still recognize the 0x prefix. We don't want that;
- except if base is the character #\c. Otherwise,
- it is a zero with trailing junk. */
+ } else if (b < 2 || b > 36) {
+ uw_throwf(error_s, lit("~a: invalid base ~s"), self, base, nao);
+ } else if (zerox) {
+ /* If we have a 0x prefix, and base is not #\c
+ * then that is just a zero followed by junk.
+ * We do this check here because wcstol recognizes
+ * these prefixes even when base isn't zero.
+ */
if (zerox)
return zero;
- } else if (b < 2 || b > 36) {
- uw_throwf(error_s, lit("int-str: invalid base ~s"), base, nao);
}
/* TODO: detect if we have wcstoll */
@@ -4617,13 +6700,51 @@ val int_str(val str, val base)
return bignum_from_long(value);
}
+val flo_str_utf8(const char *str)
+{
+ char *ptr;
+ double value;
+
+#if CONFIG_LOCALE_TOLERANCE
+ if (dec_point != '.') {
+ size_t size = strlen(str) + 1;
+ char *scopy = alloca(size), *dot = scopy;
+ wmemcpy(scopy, str, size);
+ str = scopy;
+ while ((dot = strchr(dot, '.')) != 0)
+ *dot++ = dec_point;
+ }
+#endif
+
+ value = strtod(str, &ptr);
+
+ if (value == 0 && ptr == str)
+ return nil;
+ if ((value == HUGE_VAL || value == -HUGE_VAL) && errno == ERANGE)
+ return nil;
+ return flo(value);
+}
+
val flo_str(val str)
{
- const wchar_t *wcs = c_str(str);
+ val self = lit("flo-str");
+ const wchar_t *wcs = c_str(str, self);
wchar_t *ptr;
+ double value;
+
+#if CONFIG_LOCALE_TOLERANCE
+ if (dec_point != '.') {
+ size_t size = c_unum(length_str(str), self) + 1;
+ wchar_t *wcopy = alloca(sizeof *wcopy * size), *dot = wcopy;
+ wmemcpy(wcopy, wcs, size);
+ wcs = wcopy;
+ while ((dot = wcschr(dot, '.')) != 0)
+ *dot++ = dec_point;
+ }
+#endif
+
+ value = wcstod(wcs, &ptr);
- /* TODO: detect if we have wcstod */
- double value = wcstod(wcs, &ptr);
if (value == 0 && ptr == wcs)
return nil;
if ((value == HUGE_VAL || value == -HUGE_VAL) && errno == ERANGE)
@@ -4633,7 +6754,8 @@ val flo_str(val str)
val num_str(val str)
{
- const wchar_t *wcs = c_str(str);
+ val self = lit("num-str");
+ const wchar_t *wcs = c_str(str, self);
const wchar_t *nws = wcs + wcsspn(wcs, L"\f\n\r\t\v");
const wchar_t *dig = nws + wcsspn(wcs, L"+-");
@@ -4664,11 +6786,12 @@ static void less_tab_init(void)
type_prec[STR] = 3;
type_prec[SYM] = 4;
type_prec[LCONS] = 5;
+ type_prec[VEC] = 6;
type_prec[LSTR] = 3;
type_prec[BGNUM] = 1;
type_prec[FLNUM] = 1;
type_prec[RNG] = 2;
- type_prec[BUF] = 6;
+ type_prec[BUF] = 7;
for (l = 0; l <= MAXTYPE; l++)
for (r = 0; r <= MAXTYPE; r++) {
@@ -4720,8 +6843,8 @@ tail:
case less_compare:
break;
case less_cannot:
- uw_throwf(type_error_s, lit("less: cannot compare ~s and ~s"),
- left, right, nao);
+ uw_throwf(type_error_s, lit("~a: cannot compare ~s and ~s"),
+ self, left, right, nao);
}
switch (l_type) {
@@ -4735,17 +6858,16 @@ tail:
case LSTR:
return str_lt(left, right);
case NIL:
- return str_lt(nil_string, symbol_name(right));
case SYM:
{
- val cmp = cmp_str(left->s.name, symbol_name(right));
+ val cmp = cmp_str(symbol_name(left), symbol_name(right));
if (cmp == negone) {
return t;
} else if (cmp == one) {
return nil;
} else {
- val lpkg = left->s.package;
- val rpkg = right->s.package;
+ val lpkg = symbol_package(left);
+ val rpkg = symbol_package(right);
if (lpkg == nil && rpkg == nil)
return tnil(left < right);
@@ -4816,8 +6938,8 @@ tail:
}
case BUF:
{
- cnum ll = c_num(left->b.len);
- cnum rl = c_num(right->b.len);
+ cnum ll = c_num(left->b.len, self);
+ cnum rl = c_num(right->b.len, self);
cnum len = min(ll, rl);
int cmp = memcmp(left->b.data, right->b.data, len);
@@ -4843,13 +6965,7 @@ val lequal(val left, val right)
return or2(equal(left, right), less(left, right));
}
-val gequal(val left, val right)
-{
- uses_or2;
- return or2(equal(left, right), less(right, left));
-}
-
-val lessv(val first, struct args *rest)
+val lessv(val first, varg rest)
{
cnum index = 0;
@@ -4863,7 +6979,7 @@ val lessv(val first, struct args *rest)
return t;
}
-val greaterv(val first, struct args *rest)
+val greaterv(val first, varg rest)
{
cnum index = 0;
@@ -4877,7 +6993,7 @@ val greaterv(val first, struct args *rest)
return t;
}
-val lequalv(val first, struct args *rest)
+val lequalv(val first, varg rest)
{
cnum index = 0;
@@ -4891,7 +7007,7 @@ val lequalv(val first, struct args *rest)
return t;
}
-val gequalv(val first, struct args *rest)
+val gequalv(val first, varg rest)
{
cnum index = 0;
@@ -4915,7 +7031,7 @@ wchar_t c_chr(val chr)
{
if (!is_chr(chr))
type_mismatch(lit("~s is not a character"), chr, nao);
- return convert(wchar_t, coerce(cnum, chr) >> TAG_SHIFT);
+ return convert(wchar_t, c_n(chr));
}
val chr_isalnum(val ch)
@@ -4935,7 +7051,13 @@ val chr_isascii(val ch)
val chr_iscntrl(val ch)
{
- return tnil(iswcntrl(c_chr(ch)));
+ wchar_t c = c_chr(ch);
+ switch ((c >> 5)) {
+ case 0: case 4:
+ return t;
+ default:
+ return tnil(c == 0x7F);
+ }
}
val chr_isdigit(val ch)
@@ -5026,7 +7148,8 @@ val int_chr(val ch)
val chr_int(val num)
{
- cnum n = c_num(num);
+ val self = lit("chr-int");
+ cnum n = c_num(num, self);
if (n < 0 || n > 0x10FFFF)
uw_throwf(numeric_error_s,
lit("chr-num: ~s is out of character range"), num, nao);
@@ -5035,42 +7158,44 @@ val chr_int(val num)
val chr_str(val str, val ind)
{
- cnum index = c_num(ind);
+ val self = lit("chr-str");
+ cnum index = c_num(ind, self);
if (index < 0) {
ind = plus(length_str(str), ind);
- index = c_num(ind);
+ index = c_num(ind, self);
}
if (index < 0 || !length_str_gt(str, ind))
- uw_throwf(error_s, lit("chr-str: ~s is out of range for string ~s"),
- ind, str, nao);
+ uw_throwf(error_s, lit("~a: ~s is out of range for string ~s"),
+ self, ind, str, nao);
if (lazy_stringp(str)) {
lazy_str_force_upto(str, ind);
- return chr(c_str(str->ls.prefix)[index]);
+ return chr(c_str(str->ls.prefix, self)[index]);
} else {
- return chr(c_str(str)[index]);
+ return chr(c_str(str, self)[index]);
}
}
val chr_str_set(val str, val ind, val chr)
{
- cnum index = c_num(ind);
+ val self = lit("chr-str-set");
+ cnum index = c_num(ind, self);
if (is_lit(str)) {
- uw_throwf(error_s, lit("chr-str-set: cannot modify literal string ~s"),
- str, nao);
+ uw_throwf(error_s, lit("~a: cannot modify literal string ~s"),
+ self, str, nao);
}
if (index < 0) {
ind = plus(length_str(str), ind);
- index = c_num(ind);
+ index = c_num(ind, self);
}
if (index < 0 || !length_str_gt(str, ind))
- uw_throwf(error_s, lit("chr-str-set: ~s is out of range for string ~s"),
- ind, str, nao);
+ uw_throwf(error_s, lit("~a: ~s is out of range for string ~s"),
+ self, ind, str, nao);
if (lazy_stringp(str)) {
@@ -5085,24 +7210,27 @@ val chr_str_set(val str, val ind, val chr)
val span_str(val str, val set)
{
- const wchar_t *cstr = c_str(str);
- const wchar_t *cset = c_str(set);
+ val self = lit("span-str");
+ const wchar_t *cstr = c_str(str, self);
+ const wchar_t *cset = c_str(set, self);
size_t span = wcsspn(cstr, cset);
return num(span);
}
val compl_span_str(val str, val set)
{
- const wchar_t *cstr = c_str(str);
- const wchar_t *cset = c_str(set);
+ val self = lit("compl-span-str");
+ const wchar_t *cstr = c_str(str, self);
+ const wchar_t *cset = c_str(set, self);
size_t span = wcscspn(cstr, cset);
return num(span);
}
val break_str(val str, val set)
{
- const wchar_t *cstr = c_str(str);
- const wchar_t *cset = c_str(set);
+ val self = lit("break-str");
+ const wchar_t *cstr = c_str(str, self);
+ const wchar_t *cset = c_str(set, self);
const wchar_t *brk = wcspbrk(cstr, cset);
if (!brk)
return nil;
@@ -5132,7 +7260,7 @@ val symbol_package(val sym)
val make_sym(val name)
{
- if (t && !stringp(name)) {
+ if (!stringp(name)) {
uw_throwf(error_s, lit("make-sym: name ~s isn't a string"), name, nao);
} else {
val obj = make_obj();
@@ -5144,19 +7272,21 @@ val make_sym(val name)
}
}
-val gensym(val prefix)
+val gensym(val prefix_in)
{
- prefix = default_arg(prefix, lit("g"));
+ val prefix = default_arg(prefix_in, lit("g"));
loc gs_loc = lookup_var_l(nil, gensym_counter_s);
val name = format(nil, lit("~a~,04d"), prefix,
set(gs_loc, plus(deref(gs_loc), one)), nao);
return make_sym(name);
}
-static val make_package_common(val name)
+static val make_package_common(val name, val weak)
{
- val sh = make_hash(nil, nil, lit("t")); /* don't have t yet! */
- val hh = make_hash(nil, nil, lit("t"));
+ hash_weak_opt_t wkopt = if3(default_null_arg(weak),
+ hash_weak_vals, hash_weak_none);
+ val sh = make_hash(wkopt, t);
+ val hh = make_hash(wkopt, t);
val obj = make_obj();
obj->pk.type = PKG;
obj->pk.name = name;
@@ -5165,25 +7295,25 @@ static val make_package_common(val name)
return obj;
}
-val make_package(val name)
+val make_package(val name, val weak)
{
if (find_package(name)) {
uw_throwf(error_s, lit("make-package: ~s exists already"), name, nao);
- } else if (t && !stringp(name)) {
+ } else if (!stringp(name)) {
uw_throwf(error_s, lit("make-package: name ~s isn't a string"), name, nao);
} else if (length(name) == zero) {
uw_throwf(error_s, lit("make-package: package name can't be empty string"),
nao);
} else {
- val obj = make_package_common(name);
+ val obj = make_package_common(name, weak);
mpush(cons(name, obj), cur_package_alist_loc);
return obj;
}
}
-val make_anon_package(void)
+val make_anon_package(val weak)
{
- return make_package_common(lit("#<anon-package>"));
+ return make_package_common(lit("#<anon-package>"), weak);
}
val packagep(val obj)
@@ -5225,7 +7355,7 @@ val delete_package(val package_in)
val package = get_package(lit("delete-package"), package_in, nil);
val iter;
loc cpll = cur_package_alist_loc;
- set(cpll, alist_remove1(deref(cpll), package->pk.name));
+ set(cpll, remqual(package->pk.name, deref(cpll), car_f));
for (iter = deref(cpll); iter; iter = cdr(iter))
unuse_package(package, cdar(iter));
return nil;
@@ -5324,13 +7454,19 @@ static void prot_sym_check(val func, val symname, val package)
}
}
-val use_sym(val symbol, val package_in)
+val use_sym_as(val symbol, val name, val package_in)
{
- val self = lit("use-sym");
+ val self = lit("use-sym-as");
val package = get_package(self, package_in, t);
+ if (symbolp(name))
+ name = symbol_name(name);
+ else if (!stringp(name))
+ uw_throwf(error_s,
+ lit("~a: ~s: name must be specified as string or symbol"),
+ self, name, nao);
+
if (symbol_package(symbol) != package) {
- val name = symbol_name(symbol);
val found = gethash_e(self, package->pk.symhash, name);
val existing = cdr(found);
@@ -5348,6 +7484,11 @@ val use_sym(val symbol, val package_in)
return symbol;
}
+val use_sym(val sym, val package_in)
+{
+ return use_sym_as(sym, symbol_name(sym), package_in);
+}
+
val unuse_sym(val symbol, val package_in)
{
val self = lit("unuse-sym");
@@ -5358,6 +7499,16 @@ val unuse_sym(val symbol, val package_in)
val visible = cdr(found_visible);
val hidden = cdr(found_hidden);
+ if (!found_visible || visible != symbol) {
+ name = hash_revget(package->pk.symhash, symbol, eq_f, identity_f);
+ if (name) {
+ found_visible = gethash_e(self, package->pk.symhash, name);
+ found_hidden = gethash_e(self, package->pk.hidhash, name);
+ visible = cdr(found_visible);
+ hidden = cdr(found_hidden);
+ }
+ }
+
if (!found_visible || visible != symbol)
return nil;
@@ -5488,6 +7639,9 @@ val symbol_needs_prefix(val self, val package, val sym)
if (sym_pkg == keyword_package)
return null_string;
+ if (length_str(name) == zero)
+ return sym_pkg->pk.name;
+
if (sym_pkg == package) {
if (us_hash_count(package->pk.hidhash) != zero) {
val here_cell = gethash_e(self, package->pk.symhash, name);
@@ -5506,6 +7660,7 @@ val symbol_needs_prefix(val self, val package, val sym)
{
val fallback = get_hash_userdata(package->pk.symhash);
+ val rescanfb = fallback;
for (; fallback; fallback = cdr(fallback)) {
val fb_pkg = car(fallback);
@@ -5515,11 +7670,17 @@ val symbol_needs_prefix(val self, val package, val sym)
val cell = gethash_e(self, fb_pkg->pk.symhash, name);
if (cell) {
int found_in_fallback = (eq(cdr(cell), sym) != nil);
- if (found_in_fallback)
- return nil;
- break;
+ if (!found_in_fallback)
+ break;
}
}
+ if (gethash_e(self, package->pk.symhash, name))
+ return sym_pkg->pk.name;
+ for (; rescanfb != fallback && rescanfb; rescanfb = cdr(rescanfb)) {
+ val fb_pkg = car(rescanfb);
+ if (gethash_e(self, fb_pkg->pk.symhash, name))
+ return sym_pkg->pk.name;
+ }
return nil;
} else {
if (gethash_e(self, fb_pkg->pk.symhash, name))
@@ -5557,17 +7718,6 @@ val find_symbol(val name, val package_in, val notfound_val_in)
return cdr(cell);
}
- {
- val fallback = get_hash_userdata(package->pk.symhash);
-
- for (; fallback; fallback = cdr(fallback)) {
- val fb_pkg = car(fallback);
- val cell = gethash_e(self, fb_pkg->pk.symhash, name);
- if (cell)
- return cdr(cell);
- }
- }
-
return default_null_arg(notfound_val_in);
}
@@ -5655,8 +7805,8 @@ val unintern(val symbol, val package_in)
if (symbol_package(symbol) == package) {
if (symbol == nil)
- uw_throwf(error_s, lit("unintern: cannot unintern ~s from ~s"),
- symbol, package, nao);
+ uw_throwf(error_s, lit("~a: cannot unintern ~s from ~s"),
+ self, symbol, package, nao);
symbol->s.package = nil;
}
@@ -5672,7 +7822,7 @@ val rehome_sym(val sym, val package_in)
val name = symbol_name(sym);
if (!sym)
- uw_throwf(error_s, lit("rehome-sym: cannot rehome ~s"), sym, nao);
+ uw_throwf(error_s, lit("~a: cannot rehome ~s"), self, sym, nao);
prot_sym_check(self, name, sym->s.package);
prot_sym_check(self, name, package);
@@ -6114,45 +8264,6 @@ val func_n5v(val (*fun)(val, val, val, val, val, varg))
return obj;
}
-val func_n6v(val (*fun)(val, val, val, val, val, val, varg))
-{
- val obj = make_obj();
- obj->f.type = FUN;
- obj->f.functype = N6;
- obj->f.env = nil;
- obj->f.f.n6v = fun;
- obj->f.variadic = 1;
- obj->f.fixparam = 6;
- obj->f.optargs = 0;
- return obj;
-}
-
-val func_n7v(val (*fun)(val, val, val, val, val, val, val, varg))
-{
- val obj = make_obj();
- obj->f.type = FUN;
- obj->f.functype = N7;
- obj->f.env = nil;
- obj->f.f.n7v = fun;
- obj->f.variadic = 1;
- obj->f.fixparam = 7;
- obj->f.optargs = 0;
- return obj;
-}
-
-val func_n8v(val (*fun)(val, val, val, val, val, val, val, val, varg))
-{
- val obj = make_obj();
- obj->f.type = FUN;
- obj->f.functype = N8;
- obj->f.env = nil;
- obj->f.f.n8v = fun;
- obj->f.variadic = 1;
- obj->f.fixparam = 8;
- obj->f.optargs = 0;
- return obj;
-}
-
val func_n1o(val (*fun)(val), int reqargs)
{
val obj = func_n1(fun);
@@ -6230,6 +8341,13 @@ val func_n3ov(val (*fun)(val, val, val, varg), int reqargs)
return obj;
}
+val func_n4ov(val (*fun)(val, val, val, val, varg), int reqargs)
+{
+ val obj = func_n4v(fun);
+ obj->f.optargs = 4 - reqargs;
+ return obj;
+}
+
val func_interp(val env, val form)
{
val obj = make_obj();
@@ -6269,8 +8387,7 @@ val copy_fun(val ofun)
val self = lit("copy-fun");
type_check(self, ofun, FUN);
{
- val nfun = make_obj();
- nfun->f = ofun->f;
+ val nfun = copy_obj(ofun);
if (nfun->f.env)
nfun->f.env = if3(nfun->f.functype == FVM,
@@ -6338,7 +8455,7 @@ static val get_param_counts(val params, cnum *fixparam, cnum *optparam)
}
*fixparam = fx;
- *optparam = oa;
+ *optparam = (oa > 0) ? oa : 0;
return params;
}
@@ -6386,7 +8503,7 @@ val fun_variadic(val fun)
}
}
-static noreturn void callerror(val fun, val msg)
+static NORETURN void callerror(val fun, val msg)
{
uses_or2;
@@ -6399,10 +8516,10 @@ static noreturn void callerror(val fun, val msg)
abort();
}
-INLINE val do_generic_funcall(val fun, struct args *args_in)
+INLINE val do_generic_funcall(val fun, varg args_in)
{
int variadic, fixparam, reqargs;
- struct args *args = args_in;
+ varg args = args_in;
switch (type(fun)) {
case FUN:
@@ -6416,6 +8533,8 @@ INLINE val do_generic_funcall(val fun, struct args *args_in)
case LSTR:
case BUF:
carray:
+ default:
+ dfl:
bug_unless (args->argc >= ARGS_MIN);
args_normalize_least(args, 3);
@@ -6447,8 +8566,33 @@ INLINE val do_generic_funcall(val fun, struct args *args_in)
fun = cdr(binding);
}
break;
+ case NUM:
+ case BGNUM:
+ args_normalize_least(args, 1);
+
+ switch (args->fill) {
+ case 0:
+ callerror(fun, lit("missing required arguments"));
+ case 1:
+ return ref(args->arg[0], fun);
+ default:
+ callerror(fun, lit("too many arguments"));
+ }
+ case RNG:
+ if (opt_compat && opt_compat <= 288)
+ goto dfl;
+ args_normalize_least(args, 1);
+
+ switch (args->fill) {
+ case 0:
+ callerror(fun, lit("missing required arguments"));
+ case 1:
+ return rangeref(fun, args->arg[0]);
+ default:
+ callerror(fun, lit("too many arguments"));
+ }
case COBJ:
- if (fun->co.cls == hash_s) {
+ if (fun->co.cls == hash_cls) {
bug_unless (args->argc >= ARGS_MIN);
args_normalize_least(args, 3);
@@ -6462,7 +8606,7 @@ INLINE val do_generic_funcall(val fun, struct args *args_in)
default:
callerror(fun, lit("too many arguments"));
}
- } else if (fun->co.cls == regex_s) {
+ } else if (fun->co.cls == regex_cls) {
bug_unless (args->argc >= ARGS_MIN);
args_normalize_least(args, 3);
@@ -6478,19 +8622,32 @@ INLINE val do_generic_funcall(val fun, struct args *args_in)
default:
callerror(fun, lit("too many arguments"));
}
- } else if (fun->co.cls == vm_desc_s) {
+ } else if (fun->co.cls == vm_desc_cls) {
if (args->fill || args->list)
callerror(fun, lit("too many arguments"));
return vm_execute_toplevel(fun);
- } else if (fun->co.cls == carray_s) {
+ } else if (fun->co.cls == carray_cls) {
goto carray;
+ } else if (fun->co.cls == tree_cls) {
+ switch (args->fill) {
+ case 0:
+ callerror(fun, lit("missing required arguments"));
+ case 1:
+ switch (type(args->arg[0])) {
+ case RNG:
+ return sub(fun, args->arg[0]->rn.from, args->arg[0]->rn.to);
+ default:
+ return ref(fun, args->arg[0]);
+ }
+ case 2:
+ return sub(fun, args->arg[0], args->arg[1]);
+ default:
+ callerror(fun, lit("too many arguments"));
+ }
} else if (obj_struct_p(fun)) {
fun = method(fun, lambda_s);
break;
}
- /* fallthrough */
- default:
- callerror(fun, lit("object is not callable"));
}
variadic = fun->f.variadic;
@@ -6612,7 +8769,7 @@ INLINE val do_generic_funcall(val fun, struct args *args_in)
internal_error("corrupt function type field");
}
-val generic_funcall(val fun, struct args *args)
+val generic_funcall(val fun, varg args)
{
if (dbg_backtrace) {
val ret;
@@ -6624,72 +8781,128 @@ val generic_funcall(val fun, struct args *args)
return do_generic_funcall(fun, args);
}
-static noreturn void wrongargs(val fun)
+static NORETURN void wrongargs(val fun)
{
callerror(fun, lit("wrong number of arguments"));
}
val funcall(val fun)
{
- if (type(fun) != FUN || fun->f.optargs || dbg_backtrace) {
- args_decl(args, ARGS_MIN);
+ if (type(fun) != FUN || dbg_backtrace) generic: {
+ args_decl_constsize(args, ARGS_MIN);
return generic_funcall(fun, args);
}
+ if (fun->f.fixparam - fun->f.optargs > 0)
+ wrongargs(fun);
+
+ if (fun->f.functype == FVM) {
+ switch (fun->f.fixparam) {
+ case 0:
+ return vm_funcall(fun);
+ case 1:
+ return vm_funcall1(fun, colon_k);
+ case 2:
+ return vm_funcall2(fun, colon_k, colon_k);
+ case 3:
+ return vm_funcall3(fun, colon_k, colon_k, colon_k);
+ case 4:
+ return vm_funcall4(fun, colon_k, colon_k, colon_k, colon_k);
+ default:
+ {
+ args_decl_constsize(args, ARGS_MIN);
+ return vm_execute_closure(fun, args);
+ }
+ }
+ }
+
if (fun->f.variadic) {
- args_decl(args, ARGS_MIN);
+ args_decl_constsize(args, ARGS_MIN);
switch (fun->f.functype) {
case FINTERP:
return funcall_interp(fun, args);
- case FVM:
- return vm_execute_closure(fun, args);
case F0:
return fun->f.f.f0v(fun->f.env, args);
case N0:
return fun->f.f.n0v(args);
+ case N1:
+ return fun->f.f.n1v(colon_k, args);
+ case N2:
+ return fun->f.f.n2v(colon_k, colon_k, args);
+ case N3:
+ return fun->f.f.n3v(colon_k, colon_k, colon_k, args);
+ case N4:
+ return fun->f.f.n4v(colon_k, colon_k, colon_k, colon_k, args);
default:
break;
}
} else {
switch (fun->f.functype) {
- case FVM:
- {
- if (fun->f.fixparam != 0)
- break;
- return vm_funcall(fun);
- }
case F0:
return fun->f.f.f0(fun->f.env);
case N0:
return fun->f.f.n0();
+ case N1:
+ return fun->f.f.n1(colon_k);
+ case N2:
+ return fun->f.f.n2(colon_k, colon_k);
+ case N3:
+ return fun->f.f.n3(colon_k, colon_k, colon_k);
+ case N4:
+ return fun->f.f.n4(colon_k, colon_k, colon_k, colon_k);
+ case N5:
+ return fun->f.f.n5(colon_k, colon_k, colon_k, colon_k, colon_k);
default:
break;
}
}
+
+ if (fun->f.optargs)
+ goto generic;
+
wrongargs(fun);
}
val funcall1(val fun, val arg)
{
- if (type(fun) != FUN || fun->f.optargs || dbg_backtrace) {
- args_decl(args, ARGS_MIN);
- args_add(args, arg);
+ if (type(fun) != FUN || dbg_backtrace) generic: {
+ args_decl_constsize(args, ARGS_MIN);
+ args_add(args, z(arg));
return generic_funcall(fun, args);
}
+ if (fun->f.fixparam - fun->f.optargs > 1)
+ wrongargs(fun);
+
+ if (fun->f.functype == FVM) {
+ switch (fun->f.fixparam) {
+ case 1:
+ return vm_funcall1(fun, z(arg));
+ case 2:
+ return vm_funcall2(fun, z(arg), colon_k);
+ case 3:
+ return vm_funcall3(fun, z(arg), colon_k, colon_k);
+ case 4:
+ return vm_funcall4(fun, z(arg), colon_k, colon_k, colon_k);
+ default:
+ if (!fun->f.variadic && fun->f.fixparam == 0) {
+ wrongargs(fun);
+ } else {
+ args_decl_constsize(args, ARGS_MIN);
+ args_add(args, arg);
+ return vm_execute_closure(fun, args);
+ }
+ }
+ }
+
if (fun->f.variadic) {
- args_decl(args, ARGS_MIN);
+ args_decl_constsize(args, ARGS_MIN);
switch (fun->f.functype) {
case FINTERP:
args_add(args, arg);
return funcall_interp(fun, args);
- case FVM:
- if (fun->f.fixparam > 1)
- break;
- args_add(args, arg);
- return vm_execute_closure(fun, args);
case F0:
args_add(args, arg);
return fun->f.f.f0v(fun->f.env, args);
@@ -6700,48 +8913,77 @@ val funcall1(val fun, val arg)
return fun->f.f.f1v(fun->f.env, z(arg), args);
case N1:
return fun->f.f.n1v(z(arg), args);
+ case N2:
+ return fun->f.f.n2v(z(arg), colon_k, args);
+ case N3:
+ return fun->f.f.n3v(z(arg), colon_k, colon_k, args);
+ case N4:
+ return fun->f.f.n4v(z(arg), colon_k, colon_k, colon_k, args);
default:
break;
}
} else {
switch (fun->f.functype) {
- case FVM:
- {
- if (fun->f.fixparam != 1)
- break;
- return vm_funcall1(fun, z(arg));
- }
case F1:
return fun->f.f.f1(fun->f.env, z(arg));
case N1:
return fun->f.f.n1(z(arg));
+ case N2:
+ return fun->f.f.n2(z(arg), colon_k);
+ case N3:
+ return fun->f.f.n3(z(arg), colon_k, colon_k);
+ case N4:
+ return fun->f.f.n4(z(arg), colon_k, colon_k, colon_k);
+ case N5:
+ return fun->f.f.n5(z(arg), colon_k, colon_k, colon_k, colon_k);
default:
break;
}
}
+
+ if (fun->f.optargs)
+ goto generic;
+
wrongargs(fun);
}
val funcall2(val fun, val arg1, val arg2)
{
- if (type(fun) != FUN || fun->f.optargs || dbg_backtrace) {
- args_decl(args, ARGS_MIN);
- args_add2(args, arg1, arg2);
+ if (type(fun) != FUN || dbg_backtrace) generic: {
+ args_decl_constsize(args, ARGS_MIN);
+ args_add2(args, z(arg1), z(arg2));
return generic_funcall(fun, args);
}
+ if (fun->f.fixparam - fun->f.optargs > 2)
+ wrongargs(fun);
+
+ if (fun->f.functype == FVM) {
+ switch (fun->f.fixparam) {
+ case 2:
+ return vm_funcall2(fun, z(arg1), z(arg2));
+ case 3:
+ return vm_funcall3(fun, z(arg1), z(arg2), colon_k);
+ case 4:
+ return vm_funcall4(fun, z(arg1), z(arg2), colon_k, colon_k);
+ default:
+ if (!fun->f.variadic && fun->f.fixparam < 2) {
+ wrongargs(fun);
+ } else {
+ args_decl_constsize(args, ARGS_MIN);
+ args_add2(args, arg1, arg2);
+ return vm_execute_closure(fun, args);
+ }
+ }
+ }
+
if (fun->f.variadic) {
- args_decl(args, ARGS_MIN);
+ args_decl_constsize(args, ARGS_MIN);
switch (fun->f.functype) {
case FINTERP:
args_add2(args, arg1, arg2);
return funcall_interp(fun, args);
- case FVM:
- if (fun->f.fixparam > 2)
- break;
- args_add2(args, arg1, arg2);
- return vm_execute_closure(fun, args);
case F0:
args_add2(args, arg1, arg2);
return fun->f.f.f0v(fun->f.env, args);
@@ -6758,48 +9000,72 @@ val funcall2(val fun, val arg1, val arg2)
return fun->f.f.f2v(fun->f.env, z(arg1), z(arg2), args);
case N2:
return fun->f.f.n2v(z(arg1), z(arg2), args);
+ case N3:
+ return fun->f.f.n3v(z(arg1), z(arg2), colon_k, args);
+ case N4:
+ return fun->f.f.n4v(z(arg1), z(arg2), colon_k, colon_k, args);
default:
break;
}
} else {
switch (fun->f.functype) {
- case FVM:
- {
- if (fun->f.fixparam != 2)
- break;
- return vm_funcall2(fun, z(arg1), z(arg2));
- }
case F2:
return fun->f.f.f2(fun->f.env, z(arg1), z(arg2));
case N2:
return fun->f.f.n2(z(arg1), z(arg2));
+ case N3:
+ return fun->f.f.n3(z(arg1), z(arg2), colon_k);
+ case N4:
+ return fun->f.f.n4(z(arg1), z(arg2), colon_k, colon_k);
+ case N5:
+ return fun->f.f.n5(z(arg1), z(arg2), colon_k, colon_k, colon_k);
+ case N6:
+ return fun->f.f.n6(z(arg1), z(arg2), colon_k, colon_k, colon_k, colon_k);
default:
break;
}
}
+
+ if (fun->f.optargs)
+ goto generic;
+
wrongargs(fun);
}
val funcall3(val fun, val arg1, val arg2, val arg3)
{
- if (type(fun) != FUN || fun->f.optargs || dbg_backtrace) {
- args_decl(args, ARGS_MIN);
- args_add3(args, arg1, arg2, arg3);
+ if (type(fun) != FUN || dbg_backtrace) generic: {
+ args_decl_constsize(args, ARGS_MIN);
+ args_add3(args, z(arg1), z(arg2), z(arg3));
return generic_funcall(fun, args);
}
+ if (fun->f.fixparam - fun->f.optargs > 3)
+ wrongargs(fun);
+
+ if (fun->f.functype == FVM) {
+ switch (fun->f.fixparam) {
+ case 3:
+ return vm_funcall3(fun, z(arg1), z(arg2), z(arg3));
+ case 4:
+ return vm_funcall4(fun, z(arg1), z(arg2), z(arg3), colon_k);
+ default:
+ if (!fun->f.variadic && fun->f.fixparam < 3) {
+ wrongargs(fun);
+ } else {
+ args_decl_constsize(args, ARGS_MIN);
+ args_add3(args, arg1, arg2, arg3);
+ return vm_execute_closure(fun, args);
+ }
+ }
+ }
if (fun->f.variadic) {
- args_decl(args, ARGS_MIN);
+ args_decl_constsize(args, ARGS_MIN);
switch (fun->f.functype) {
case FINTERP:
args_add3(args, arg1, arg2, arg3);
return funcall_interp(fun, args);
- case FVM:
- if (fun->f.fixparam > 3)
- break;
- args_add3(args, arg1, arg2, arg3);
- return vm_execute_closure(fun, args);
case F0:
args_add3(args, arg1, arg2, arg3);
return fun->f.f.f0v(fun->f.env, args);
@@ -6822,48 +9088,64 @@ val funcall3(val fun, val arg1, val arg2, val arg3)
return fun->f.f.f3v(fun->f.env, z(arg1), z(arg2), z(arg3), args);
case N3:
return fun->f.f.n3v(z(arg1), z(arg2), z(arg3), args);
+ case N4:
+ return fun->f.f.n4v(z(arg1), z(arg2), z(arg3), colon_k, args);
default:
break;
}
} else {
switch (fun->f.functype) {
- case FVM:
- {
- if (fun->f.fixparam != 3)
- break;
- return vm_funcall3(fun, z(arg1), z(arg2), z(arg3));
- }
case F3:
return fun->f.f.f3(fun->f.env, z(arg1), z(arg2), z(arg3));
case N3:
return fun->f.f.n3(z(arg1), z(arg2), z(arg3));
+ case N4:
+ return fun->f.f.n4(z(arg1), z(arg2), z(arg3), colon_k);
+ case N5:
+ return fun->f.f.n5(z(arg1), z(arg2), z(arg3), colon_k, colon_k);
+ case N6:
+ return fun->f.f.n6(z(arg1), z(arg2), z(arg3), colon_k, colon_k, colon_k);
+ case N7:
+ return fun->f.f.n7(z(arg1), z(arg2), z(arg3), colon_k, colon_k, colon_k, colon_k);
default:
break;
}
}
+ if (fun->f.optargs)
+ goto generic;
wrongargs(fun);
}
val funcall4(val fun, val arg1, val arg2, val arg3, val arg4)
{
- if (type(fun) != FUN || fun->f.optargs || dbg_backtrace) {
- args_decl(args, ARGS_MIN);
- args_add4(args, arg1, arg2, arg3, arg4);
+ if (type(fun) != FUN || dbg_backtrace) generic: {
+ args_decl_constsize(args, ARGS_MIN);
+ args_add4(args, z(arg1), z(arg2), z(arg3), z(arg4));
return generic_funcall(fun, args);
}
+ if (fun->f.fixparam - fun->f.optargs > 4)
+ wrongargs(fun);
+
+ if (fun->f.functype == FVM) {
+ if (fun->f.fixparam == 4) {
+ return vm_funcall4(fun, z(arg1), z(arg2), z(arg3), z(arg4));
+ } else if (fun->f.variadic || fun->f.fixparam > 4) {
+ args_decl(args, ARGS_MIN);
+ args_add4(args, arg1, arg2, arg3, arg4);
+ return vm_execute_closure(fun, args);
+ } else {
+ wrongargs(fun);
+ }
+ }
+
if (fun->f.variadic) {
- args_decl(args, ARGS_MIN);
+ args_decl_constsize(args, ARGS_MIN);
switch (fun->f.functype) {
case FINTERP:
args_add4(args, arg1, arg2, arg3, arg4);
return funcall_interp(fun, args);
- case FVM:
- if (fun->f.fixparam > 4)
- break;
- args_add4(args, arg1, arg2, arg3, arg4);
- return vm_execute_closure(fun, args);
case F0:
args_add4(args, arg1, arg2, arg3, arg4);
return fun->f.f.f0v(fun->f.env, args);
@@ -6897,39 +9179,49 @@ val funcall4(val fun, val arg1, val arg2, val arg3, val arg4)
}
} else {
switch (fun->f.functype) {
- case FVM:
- {
- if (fun->f.fixparam != 4)
- break;
- return vm_funcall4(fun, z(arg1), z(arg2), z(arg3), z(arg4));
- }
case F4:
return fun->f.f.f4(fun->f.env, z(arg1), z(arg2), z(arg3), z(arg4));
case N4:
return fun->f.f.n4(z(arg1), z(arg2), z(arg3), z(arg4));
+ case N5:
+ return fun->f.f.n5(z(arg1), z(arg2), z(arg3), z(arg4), colon_k);
+ case N6:
+ return fun->f.f.n6(z(arg1), z(arg2), z(arg3), z(arg4), colon_k, colon_k);
+ case N7:
+ return fun->f.f.n7(z(arg1), z(arg2), z(arg3), z(arg4), colon_k, colon_k, colon_k);
+ case N8:
+ return fun->f.f.n8(z(arg1), z(arg2), z(arg3), z(arg4), colon_k, colon_k, colon_k, colon_k);
default:
break;
}
}
+
+ if (fun->f.optargs)
+ goto generic;
+
wrongargs(fun);
}
-val reduce_left(val fun, val list, val init, val key)
+val reduce_left(val fun, val seq, val init, val key)
{
+ val self = lit("reduce-left");
+ seq_iter_t item_iter;
+ val item;
+
if (null_or_missing_p(key))
key = identity_f;
- list = nullify(list);
+ seq_iter_init(self, &item_iter, seq);
if (missingp(init)) {
- if (list)
- init = funcall1(key, pop(&list));
+ if (seq_get(&item_iter, &item))
+ init = funcall1(key, item);
else
return funcall(fun);
}
- for (; list; list = cdr(list))
- init = funcall2(fun, init, funcall1(key, car(list)));
+ while (seq_get(&item_iter, &item))
+ init = funcall2(fun, init, funcall1(key, item));
return init;
}
@@ -6985,16 +9277,6 @@ val pa_12_1(val fun2, val arg2)
return func_f1(cons(fun2, arg2), do_pa_12_1);
}
-static val do_pa_12_1_v(val fcons, struct args *args)
-{
- return funcall2(car(fcons), args_get_list(args), cdr(fcons));
-}
-
-static val pa_12_1_v(val fun2, val arg2)
-{
- return func_f0v(cons(fun2, arg2), do_pa_12_1_v);
-}
-
static val do_pa_123_3(val fcons, val arg3)
{
return funcall3(car(fcons), car(cdr(fcons)), cdr(cdr(fcons)), arg3);
@@ -7025,16 +9307,6 @@ val pa_123_1(val fun3, val arg2, val arg3)
return func_f1(cons(fun3, cons(arg2, arg3)), do_pa_123_1);
}
-static val do_pa_123_23(val fcons, val arg2, val arg3)
-{
- return funcall3(car(fcons), cdr(fcons), arg2, arg3);
-}
-
-val pa_123_23(val fun3, val arg1)
-{
- return func_f2(cons(fun3, arg1), do_pa_123_23);
-}
-
static val do_pa_1234_1(val fcons, val arg1)
{
cons_bind (fun, dr, fcons);
@@ -7060,36 +9332,7 @@ val pa_1234_34(val fun4, val arg1, val arg2)
return func_f2(cons(fun4, cons(arg1, arg2)), do_pa_1234_34);
}
-val transposev(struct args *list)
-{
- val func = list_f;
-
- if (!args_more(list, 0))
- return nil;
-
- switch (type(args_at(list, 0))) {
- case STR:
- case LSTR:
- case LIT:
- func = pa_12_1_v(func_n2(cat_str), nil);
- break;
- case VEC:
- func = func_n0v(vectorv);
- break;
- default:
- break;
- }
-
- return mapcarv(func, list);
-}
-
-val transpose(val list)
-{
- args_decl_list(args, ARGS_MIN, copy(list));
- return make_like(transposev(args), list);
-}
-
-static val do_chain(val fun1_list, struct args *args)
+static val do_chain(val fun1_list, varg args)
{
val arg = nil;
@@ -7125,12 +9368,12 @@ val chain(val first_fun, ...)
return func_f0v(out, do_chain);
}
-val chainv(struct args *funlist)
+val chainv(varg funlist)
{
return func_f0v(args_get_list(funlist), do_chain);
}
-static val do_chand(val fun1_list, struct args *args)
+static val do_chand(val fun1_list, varg args)
{
val arg = nil;
@@ -7148,22 +9391,22 @@ static val do_chand(val fun1_list, struct args *args)
}
-val chandv(struct args *funlist)
+val chandv(varg funlist)
{
return func_f0v(args_get_list(funlist), do_chand);
}
-static val do_juxt(val funcs, struct args *args)
+static val do_juxt(val funcs, varg args)
{
return mapcar(pa_12_1(func_n2(apply), args_get_list(args)), funcs);
}
-val juxtv(struct args *funlist)
+val juxtv(varg funlist)
{
return func_f0v(args_get_list(funlist), do_juxt);
}
-static val do_and(val fun1_list, struct args *args_in)
+static val do_and(val fun1_list, varg args_in)
{
cnum argc = args_in->argc;
args_decl(args, argc);
@@ -7201,7 +9444,7 @@ val andf(val first_fun, ...)
return func_f0v(out, do_and);
}
-val andv(struct args *funlist)
+val andv(varg funlist)
{
return func_f0v(args_get_list(funlist), do_and);
}
@@ -7216,7 +9459,7 @@ val swap_12_21(val fun)
return func_f2(fun, do_swap_12_21);
}
-static val do_or(val fun1_list, struct args *args_in)
+static val do_or(val fun1_list, varg args_in)
{
cnum argc = args_in->argc;
args_decl(args, argc);
@@ -7235,31 +9478,12 @@ static val do_or(val fun1_list, struct args *args_in)
return ret;
}
-val orf(val first_fun, ...)
-{
- va_list vl;
- list_collect_decl (out, iter);
-
- if (first_fun != nao) {
- val next_fun;
- va_start (vl, first_fun);
- iter = list_collect(iter, first_fun);
-
- while ((next_fun = va_arg(vl, val)) != nao)
- iter = list_collect(iter, next_fun);
-
- va_end (vl);
- }
-
- return func_f0v(out, do_or);
-}
-
-val orv(struct args *funlist)
+val orv(varg funlist)
{
return func_f0v(args_get_list(funlist), do_or);
}
-static val do_not(val fun, struct args *args)
+static val do_not(val fun, varg args)
{
return null(apply(fun, args_get_list(args)));
}
@@ -7269,7 +9493,17 @@ val notf(val fun)
return func_f0v(fun, do_not);
}
-static val do_iff(val env, struct args *args_in)
+val nandv(varg funlist)
+{
+ return notf(andv(funlist));
+}
+
+val norv(varg funlist)
+{
+ return notf(orv(funlist));
+}
+
+static val do_iff(val env, varg args_in)
{
cons_bind (condfun, choices, env);
cons_bind (thenfun, elsefun, choices);
@@ -7307,16 +9541,18 @@ val dupl(val fun)
return func_f1(fun, do_dup);
}
-val vector(val length, val initval)
+static val *vec_allocate(ucnum len, val self)
{
- unsigned i;
- ucnum len = c_unum(length);
ucnum alloc_plus = len + 2;
- ucnum size = if3(alloc_plus > len, alloc_plus, -1);
- val *v = coerce(val *, chk_xalloc(size, sizeof *v, lit("vector")));
+ ucnum size = if3(alloc_plus > len, alloc_plus, convert(ucnum, -1));
+ return coerce(val *, chk_xalloc(size, sizeof (val), self));
+}
+
+static val vec_own(val *v, val length)
+{
val vec = make_obj();
+
vec->v.type = VEC;
- initval = default_null_arg(initval);
#if HAVE_VALGRIND
vec->v.vec_true_start = v;
#endif
@@ -7324,8 +9560,27 @@ val vector(val length, val initval)
vec->v.vec = v;
v[vec_alloc] = length;
v[vec_length] = length;
- for (i = 0; i < alloc_plus - 2; i++)
- vec->v.vec[i] = initval;
+
+ return vec;
+}
+
+static void vec_init(val *v, ucnum len, val initval_in)
+{
+ ucnum i;
+ val initval = default_null_arg(initval_in);
+ v += 2;
+ for (i = 0; i < len; i++)
+ v[i] = initval;
+}
+
+val vector(val length, val initval)
+{
+ val self = lit("vector");
+
+ ucnum len = c_unum(length, self);
+ val *v = vec_allocate(len, self);
+ val vec = vec_own(v, length);
+ vec_init(v, len, initval);
return vec;
}
@@ -7340,9 +9595,9 @@ val vec_set_length(val vec, val length)
type_check(self, vec, VEC);
{
- cnum new_length = c_num(length);
- cnum old_length = c_num(vec->v.vec[vec_length]);
- cnum old_alloc = c_num(vec->v.vec[vec_alloc]);
+ cnum new_length = c_num(length, self);
+ cnum old_length = c_num(vec->v.vec[vec_length], self);
+ cnum old_alloc = c_num(vec->v.vec[vec_alloc], self);
if (new_length < 0)
uw_throwf(error_s, lit("~a: negative length ~s specified"),
@@ -7386,25 +9641,27 @@ val vec_set_length(val vec, val length)
val vecref(val vec, val ind)
{
- cnum index = c_num(ind);
- cnum len = c_num(length_vec(vec));
+ val self = lit("vecref");
+ cnum index = c_num(ind, self);
+ cnum len = c_num(length_vec(vec), self);
if (index < 0)
index = len + index;
if (index < 0 || index >= len)
- uw_throwf(error_s, lit("vecref: ~s is out of range for vector ~s"),
- ind, vec, nao);
+ uw_throwf(error_s, lit("~a: ~s is out of range for vector ~s"),
+ self, ind, vec, nao);
return vec->v.vec[index];
}
loc vecref_l(val vec, val ind)
{
- cnum index = c_num(ind);
- cnum len = c_num(length_vec(vec));
+ val self = lit("vecref");
+ cnum index = c_num(ind, self);
+ cnum len = c_num(length_vec(vec), self);
if (index < 0)
index = len + index;
if (index < 0 || index >= len)
- uw_throwf(error_s, lit("vecref: ~s is out of range for vector ~s"),
- ind, vec, nao);
+ uw_throwf(error_s, lit("~a: ~s is out of range for vector ~s"),
+ self, ind, vec, nao);
return mkloc(vec->v.vec[index], vec);
}
@@ -7428,7 +9685,7 @@ val size_vec(val vec)
return vec->v.vec[vec_alloc];
}
-val vectorv(struct args *args)
+val vectorv(varg args)
{
cnum index = 0;
val vec = vector(zero, nil);
@@ -7473,12 +9730,13 @@ val vec_list(val list)
val list_vec(val vec)
{
+ val self = lit("list-vec");
list_collect_decl (list, ptail);
- int i, len;
+ ucnum i, len;
- type_check(lit("list-vec"), vec, VEC);
+ type_check(self, vec, VEC);
- len = c_num(vec->v.vec[vec_length]);
+ len = c_unum(vec->v.vec[vec_length], self);
for (i = 0; i < len; i++)
ptail = list_collect(ptail, vec->v.vec[i]);
@@ -7488,24 +9746,18 @@ val list_vec(val vec)
val copy_vec(val vec_in)
{
+ val self = lit("copy-vec");
val length = length_vec(vec_in);
- ucnum alloc_plus = c_unum(length) + 2;
- val *v = coerce(val *, chk_xalloc(alloc_plus, sizeof *v, lit("copy-vec")));
- val vec = make_obj();
- vec->v.type = VEC;
-#if HAVE_VALGRIND
- vec->v.vec_true_start = v;
-#endif
- v += 2;
- vec->v.vec = v;
- v[vec_alloc] = length;
- v[vec_length] = length;
- memcpy(vec->v.vec, vec_in->v.vec, (alloc_plus - 2) * sizeof *vec->v.vec);
+ ucnum len = c_unum(length, self);
+ val *v = vec_allocate(len, self);
+ val vec = vec_own(v, length);
+ memcpy(v + 2, vec_in->v.vec, len * sizeof *v);
return vec;
}
val sub_vec(val vec_in, val from, val to)
{
+ val self = lit("sub-vec");
val len = length_vec(vec_in);
if (null_or_missing_p(from))
@@ -7531,9 +9783,9 @@ val sub_vec(val vec_in, val from, val to)
} else if (from == zero && eql(to, len)) {
return vec_in;
} else {
- cnum cfrom = c_num(from);
- size_t nelem = c_num(to) - cfrom;
- val *v = coerce(val *, chk_xalloc((nelem + 2), sizeof *v, lit("sub-vec")));
+ cnum cfrom = c_num(from, self);
+ size_t nelem = c_num(to, self) - cfrom;
+ val *v = coerce(val *, chk_xalloc((nelem + 2), sizeof *v, self));
val vec = make_obj();
vec->v.type = VEC;
#if HAVE_VALGRIND
@@ -7541,7 +9793,7 @@ val sub_vec(val vec_in, val from, val to)
#endif
v += 2;
vec->v.vec = v;
- v[vec_length] = v[vec_alloc] = num(nelem);
+ v[vec_length] = v[vec_alloc] = unum(nelem);
memcpy(vec->v.vec, vec_in->v.vec + cfrom, nelem * sizeof *vec->v.vec);
return vec;
}
@@ -7558,6 +9810,8 @@ val replace_vec(val vec_in, val items, val from, val to)
from = len;
} else if (!integerp(from)) {
seq_iter_t wh_iter, item_iter;
+ cnum offs = 0;
+ cnum l = c_num(len, self), ol = l;
val wh, item;
seq_iter_init(self, &wh_iter, from);
seq_iter_init(self, &item_iter, items);
@@ -7567,12 +9821,38 @@ val replace_vec(val vec_in, val items, val from, val to)
lit("~a: to-arg not applicable when from-arg is a list"),
self, nao);
- while (seq_get(&wh_iter, &wh) && seq_get(&item_iter, &item)) {
+ while (seq_get(&item_iter, &item) && seq_get(&wh_iter, &wh)) {
if (ge(wh, len))
break;
set(vecref_l(vec_in, wh), item);
}
+ if (!opt_compat || opt_compat > 289) {
+ while (seq_get(&wh_iter, &wh)) {
+ cnum w = c_num(wh, self);
+
+ if (w < 0)
+ w += ol;
+
+ if (w < 0)
+ break;
+
+ w -= offs;
+
+ if (w >= l)
+ break;
+
+ memmove(vec_in->v.vec + w,
+ vec_in->v.vec + w + 1,
+ (l - w - 1) * sizeof vec_in->v.vec);
+ l--;
+ offs++;
+ }
+
+ if (offs > 0)
+ vec_set_length(vec_in, num_fast(l));
+ }
+
return vec_in;
} else if (minusp(from)) {
from = plus(from, len);
@@ -7594,10 +9874,10 @@ val replace_vec(val vec_in, val items, val from, val to)
if (gt(len_rep, len_it)) {
val len_diff = minus(len_rep, len_it);
- cnum t = c_num(to);
- cnum l = c_num(len);
+ cnum t = c_num(to, self);
+ cnum l = c_num(len, self);
- memmove(vec_in->v.vec + t - c_num(len_diff),
+ memmove(vec_in->v.vec + t - c_num(len_diff, self),
vec_in->v.vec + t,
(l - t) * sizeof vec_in->v.vec);
@@ -7605,12 +9885,12 @@ val replace_vec(val vec_in, val items, val from, val to)
to = plus(from, len_it);
} else if (lt(len_rep, len_it)) {
val len_diff = minus(len_it, len_rep);
- cnum t = c_num(to);
- cnum l = c_num(len);
+ cnum t = c_num(to, self);
+ cnum l = c_num(len, self);
vec_set_length(vec_in, plus(len, len_diff));
- memmove(vec_in->v.vec + t + c_num(len_diff),
+ memmove(vec_in->v.vec + t + c_num(len_diff, self),
vec_in->v.vec + t,
(l - t) * sizeof vec_in->v.vec);
to = plus(from, len_it);
@@ -7619,15 +9899,16 @@ val replace_vec(val vec_in, val items, val from, val to)
if (zerop(len_it))
return vec_in;
if (vectorp(items)) {
- memmove(vec_in->v.vec + c_num(from), items->v.vec,
- sizeof *vec_in->v.vec * c_num(len_it));
+ memmove(vec_in->v.vec + c_num(from, self), items->v.vec,
+ sizeof *vec_in->v.vec * c_num(len_it, self));
mut(vec_in);
} else {
seq_iter_t item_iter;
- seq_iter_init(self, &item_iter, items);
int mut_needed = 0;
- cnum f = c_num(from);
- cnum t = c_num(to);
+ cnum f = c_num(from, self);
+ cnum t = c_num(to, self);
+
+ seq_iter_init(self, &item_iter, items);
for (; f != t; f++) {
val item = seq_geti(&item_iter);
@@ -7667,8 +9948,43 @@ val replace_obj(val obj, val items, val from, val to)
return obj;
}
+val fill_vec(val vec, val item, val from_in, val to_in)
+{
+ val self = lit("fill-vec");
+ val len = length_vec(vec);
+ cnum from = c_num(default_arg(from_in, zero), self);
+ cnum to = c_num(default_arg(to_in, len), self);
+ cnum l = c_num(len, self);
+ cnum i;
+
+ if (from < 0)
+ from += l;
+
+ if (to < 0)
+ to += l;
+
+ if (from < 0 || from > l)
+ uw_throwf(error_s, lit("~a: from index ~s is out of range for vector ~s"),
+ self, num(from), vec, nao);
+
+ if (to < 0 || to > l)
+ uw_throwf(error_s, lit("~a: to index ~s is out of range for vector ~s"),
+ self, num(to), vec, nao);
+
+ if (from >= to)
+ return vec;
+
+ for (i = from; i < to - 1; i++)
+ vec->v.vec[i] = item;
+
+ set(mkloc(vec->v.vec[i], vec), item);
+
+ return vec;
+}
+
val cat_vec(val list)
{
+ val self = lit("cat-vec");
ucnum total = 0;
val iter;
val vec, *v;
@@ -7676,7 +9992,7 @@ val cat_vec(val list)
list = nullify(list);
for (iter = list; iter != nil; iter = cdr(iter)) {
- ucnum newtot = total + c_unum(length_vec(car(iter)));
+ ucnum newtot = total + c_unum(length_vec(car(iter)), self);
if (newtot < total)
goto toobig;
total = newtot;
@@ -7685,7 +10001,7 @@ val cat_vec(val list)
if (total + 2 < total)
goto toobig;
- v = coerce(val *, chk_xalloc(total + 2, sizeof *v, lit("cat-vec")));
+ v = coerce(val *, chk_xalloc(total + 2, sizeof *v, self));
vec = make_obj();
vec->v.type = VEC;
@@ -7698,14 +10014,51 @@ val cat_vec(val list)
for (iter = list; iter != nil; iter = cdr(iter)) {
val item = car(iter);
- cnum len = c_num(item->v.vec[vec_length]);
+ cnum len = c_num(item->v.vec[vec_length], self);
memcpy(v, item->v.vec, len * sizeof *v);
v += len;
}
return vec;
toobig:
- uw_throwf(error_s, lit("cat-vec: resulting vector too large"), nao);
+ uw_throwf(error_s, lit("~a: resulting vector too large"), self, nao);
+}
+
+val nested_vec_of_v(val initval, struct args *args)
+{
+ val self = lit("nested-vec-of");
+ cnum index = 0;
+
+ if (!args_more(args, index))
+ return nil;
+
+ {
+ val dim = args_get(args, &index);
+
+ if (args_more(args, index)) {
+ ucnum i, n = c_num(dim, self);
+ val *rawvec = vec_allocate(n, self);
+ args_decl(args_copy, max(args->fill, ARGS_MIN));
+ int gc_save = gc_state(0);
+ val vec;
+
+ args_cat_from(args_copy, args, index);
+
+ for (i = 0; i < n; i++)
+ rawvec[i + 2] = nested_vec_of_v(initval, args_copy);
+
+ vec = vec_own(rawvec, dim);
+ gc_state(gc_save);
+ return vec;
+ } else {
+ return vector(dim, initval);
+ }
+ }
+}
+
+val nested_vec_v(struct args *args)
+{
+ return nested_vec_of_v(nil, args);
}
static val simple_lazy_stream_func(val stream, val lcons)
@@ -7720,12 +10073,24 @@ static val simple_lazy_stream_func(val stream, val lcons)
return nil;
}
-static val lazy_stream_cont(val stream, val func, val env)
+static val simple_lazy_stream_func_nt(val stream, val lcons)
+{
+ if (set(mkloc(lcons->lc.car, lcons), get_line(stream)) != nil) {
+ set(mkloc(lcons->lc.cdr, lcons), make_lazy_cons(us_lcons_fun(lcons)));
+ } else {
+ close_stream(stream, nil);
+ lcons->lc.cdr = nil;
+ }
+
+ return nil;
+}
+
+static val lazy_stream_cont(val stream, val func, val env, val throw_p)
{
val next = get_line(stream);
if (!next) {
- close_stream(stream, t);
+ close_stream(stream, throw_p);
return nil;
}
@@ -7740,27 +10105,61 @@ static val lazy_stream_func(val env, val lcons)
set(mkloc(lcons->lc.car, lcons), prefetched_line);
set(mkloc(lcons->lc.cdr, lcons), lazy_stream_cont(stream,
- us_lcons_fun(lcons), env));
+ us_lcons_fun(lcons), env, t));
+
+ return prefetched_line;
+}
+
+static val lazy_stream_func_nt(val env, val lcons)
+{
+ val stream = car(env);
+ val prefetched_line = cdr(env);
+
+ set(mkloc(lcons->lc.car, lcons), prefetched_line);
+ set(mkloc(lcons->lc.cdr, lcons), lazy_stream_cont(stream,
+ us_lcons_fun(lcons), env, nil));
return prefetched_line;
}
-val lazy_stream_cons(val stream)
+static void lazy_stream_register(val stream)
{
- stream = default_arg(stream, std_input);
+ val lazy_streams_dyn_binding = lookup_var(nil, lazy_streams_s);
+
+ if (lazy_streams_dyn_binding) {
+ if (!lazy_streams_binding)
+ lazy_streams_binding = lookup_global_var(lazy_streams_s);
+
+ if (lazy_streams_dyn_binding != lazy_streams_binding) {
+ val list = us_cdr(lazy_streams_dyn_binding);
+ us_rplacd(lazy_streams_dyn_binding, cons(stream, list));
+ }
+ }
+}
+
+val lazy_stream_cons(val stream, val no_throw_close)
+{
+ stream = default_arg_strict(stream, std_input);
+ no_throw_close = default_null_arg(no_throw_close);
if (real_time_stream_p(stream)) {
- return make_lazy_cons(func_f1(stream, simple_lazy_stream_func));
+ lazy_stream_register(stream);
+ return make_lazy_cons(func_f1(stream, if3(no_throw_close,
+ simple_lazy_stream_func_nt,
+ simple_lazy_stream_func)));
} else {
val first = get_line(stream);
if (!first) {
- close_stream(stream, t);
+ close_stream(stream, null(no_throw_close));
return nil;
}
+ lazy_stream_register(stream);
return make_lazy_cons(func_f1(cons(stream, first),
- lazy_stream_func));
+ if3(no_throw_close,
+ lazy_stream_func_nt,
+ lazy_stream_func)));
}
}
@@ -7818,8 +10217,8 @@ val lazy_str_force(val lstr)
val next = pop(&lstr->ls.list);
if (!next)
break;
- string_extend(pfx, next);
- string_extend(pfx, term);
+ string_extend(pfx, next, nil);
+ string_extend(pfx, term, nil);
if (lim)
lim = minus(lim, one);
}
@@ -7830,13 +10229,19 @@ val lazy_str_force(val lstr)
return lstr->ls.prefix;
}
+INLINE cnum max_str_chars(cnum max_len)
+{
+ return max_len < INT_PTR_MAX / 8 ? 8 * max(3, max_len) : INT_PTR_MAX;
+}
+
val lazy_str_put(val lstr, val stream, struct strm_base *s)
{
+ val self = lit("lazy-str-put");
val lim = lstr->ls.props->limit;
val term = lstr->ls.props->term;
val iter;
cnum max_len = s->max_length;
- cnum max_chr = if3(max_len, max(max_len, 15), 0);
+ cnum max_chr = max_len ? max_str_chars(max_len) : 0;
put_string(lstr->ls.prefix, stream);
@@ -7851,9 +10256,9 @@ val lazy_str_put(val lstr, val stream, struct strm_base *s)
put_string(sub_str(str, zero, num(max_chr)), stream);
goto max_reached;
}
- if (--max_len == 0)
+ if (--max_chr == 0)
goto max_reached;
- max_chr -= c_num(length_str(str));
+ max_chr -= c_num(length_str(str), self);
}
if (lim)
lim = pred(lim);
@@ -7886,8 +10291,8 @@ val lazy_str_force_upto(val lstr, val index)
val next = pop(&lstr->ls.list);
if (!next)
break;
- string_extend(pfx, next);
- string_extend(pfx, term);
+ string_extend(pfx, next, nil);
+ string_extend(pfx, term, nil);
if (lim)
lim = minus(lim, one);
len = plus(len, length_str(next));
@@ -7902,11 +10307,12 @@ val lazy_str_force_upto(val lstr, val index)
val length_str_gt(val str, val len)
{
+ val self = lit("length-str-gt");
switch (type(str)) {
case LIT:
{
- const wchar_t *cstr = c_str(str);
- size_t clen = c_num(len);
+ const wchar_t *cstr = c_str(str, self);
+ size_t clen = c_num(len, self);
const wchar_t *nult = wmemchr(cstr, 0, clen + 1);
return nult == 0 ? t : nil;
}
@@ -7916,17 +10322,18 @@ val length_str_gt(val str, val len)
lazy_str_force_upto(str, len);
return gt(length_str(str->ls.prefix), len);
default:
- type_mismatch(lit("length-str-gt: ~s is not a string"), str, nao);
+ type_mismatch(lit("~a: ~s is not a string"), self, str, nao);
}
}
val length_str_ge(val str, val len)
{
+ val self = lit("length-str-ge");
switch (type(str)) {
case LIT:
{
- const wchar_t *cstr = c_str(str);
- size_t clen = c_num(len);
+ const wchar_t *cstr = c_str(str, self);
+ size_t clen = c_num(len, self);
const wchar_t *nult = wmemchr(cstr, 0, clen);
return nult == 0 ? t : nil;
}
@@ -7936,17 +10343,18 @@ val length_str_ge(val str, val len)
lazy_str_force_upto(str, len);
return ge(length_str(str->ls.prefix), len);
default:
- type_mismatch(lit("length-str-ge: ~s is not a string"), str, nao);
+ type_mismatch(lit("~a: ~s is not a string"), self, str, nao);
}
}
val length_str_lt(val str, val len)
{
+ val self = lit("length-str-lt");
switch (type(str)) {
case LIT:
{
- const wchar_t *cstr = c_str(str);
- size_t clen = c_num(len);
+ const wchar_t *cstr = c_str(str, self);
+ size_t clen = c_num(len, self);
const wchar_t *nult = wmemchr(cstr, 0, clen);
return nult != 0 ? t : nil;
}
@@ -7956,17 +10364,18 @@ val length_str_lt(val str, val len)
lazy_str_force_upto(str, len);
return lt(length_str(str->ls.prefix), len);
default:
- type_mismatch(lit("length-str-lt: ~s is not a string"), str, nao);
+ type_mismatch(lit("~a: ~s is not a string"), self, str, nao);
}
}
val length_str_le(val str, val len)
{
+ val self = lit("length-str-le");
switch (type(str)) {
case LIT:
{
- const wchar_t *cstr = c_str(str);
- size_t clen = c_num(len);
+ const wchar_t *cstr = c_str(str, self);
+ size_t clen = c_num(len, self);
const wchar_t *nult = wmemchr(cstr, 0, clen + 1);
return nult != 0 ? t : nil;
}
@@ -7976,7 +10385,7 @@ val length_str_le(val str, val len)
lazy_str_force_upto(str, len);
return le(length_str(str->ls.prefix), len);
default:
- type_mismatch(lit("length-str-lt: ~s is not a string"), str, nao);
+ type_mismatch(lit("~a: ~s is not a string"), self, str, nao);
}
}
@@ -7996,18 +10405,49 @@ val lazy_str_get_trailing_list(val lstr, val index)
if (!cdr(split_suffix) && equal(car(split_suffix), null_string))
return lstr->ls.list;
+ if (!opt_compat || opt_compat > 273) {
+ val penult = nthlast(two, split_suffix);
+ if (equal(cadr(penult), null_string))
+ rplacd(penult, nil);
+ }
+
return nappend2(split_suffix, lstr->ls.list);
}
}
-val cobj(mem_t *handle, val cls_sym, struct cobj_ops *ops)
+struct cobj_class *cobj_register(val cls_sym)
{
- val obj = make_obj();
- obj->co.type = COBJ;
- obj->co.handle = handle;
- obj->co.ops = ops;
- obj->co.cls = cls_sym;
- return obj;
+ if (convert(size_t, cobj_ptr - cobj_class) >= nelem(cobj_class))
+ internal_error("cobj array too small");
+ cobj_ptr->cls_sym = cls_sym;
+ return cobj_ptr++;
+}
+
+struct cobj_class *cobj_register_super(val cls_sym, struct cobj_class *super)
+{
+ struct cobj_class *cls = cobj_register(cls_sym);
+ cls->super = super;
+ return cls;
+}
+
+static void cobj_populate_hash(void)
+{
+ struct cobj_class *ptr;
+ for (ptr = cobj_class; ptr < cobj_ptr; ptr++)
+ sethash(cobj_hash, ptr->cls_sym, num_fast(ptr - cobj_class));
+}
+
+val cobj(mem_t *handle, struct cobj_class *cls, struct cobj_ops *ops)
+{
+ if (cls != 0) {
+ val obj = make_obj();
+ obj->co.type = COBJ;
+ obj->co.handle = handle;
+ obj->co.ops = ops;
+ obj->co.cls = cls;
+ return obj;
+ }
+ internal_error("cobj creation with null class pointer");
}
val cobjp(val obj)
@@ -8015,29 +10455,33 @@ val cobjp(val obj)
return type(obj) == COBJ ? t : nil;
}
-val cobjclassp(val obj, val cls_sym)
+val cobjclassp(val obj, struct cobj_class *cls)
{
- return if2(is_ptr(obj) && obj->t.type == COBJ &&
- (obj->co.cls == cls_sym || subtypep(obj->co.cls, cls_sym)),
- one);
+ if (is_ptr(obj) && obj->t.type == COBJ) {
+ struct cobj_class *pcls;
+ for (pcls = obj->co.cls; pcls != 0; pcls = pcls->super)
+ if (pcls == cls)
+ return t;
+ }
+ return nil;
}
-mem_t *cobj_handle(val self, val cobj, val cls_sym)
+mem_t *cobj_handle(val self, val cobj, struct cobj_class *cls)
{
- class_check(self, cobj, cls_sym);
+ class_check(self, cobj, cls);
return cobj->co.handle;
}
-struct cobj_ops *cobj_ops(val self, val cobj, val cls_sym)
+struct cobj_ops *cobj_ops(val self, val cobj, struct cobj_class *cls)
{
- class_check(self, cobj, cls_sym);
+ class_check(self, cobj, cls);
return cobj->co.ops;
}
void cobj_print_op(val obj, val out, val pretty, struct strm_ctx *ctx)
{
put_string(lit("#<"), out);
- obj_print_impl(obj->co.cls, out, pretty, ctx);
+ obj_print_impl(obj->co.cls->cls_sym, out, pretty, ctx);
format(out, lit(": ~p>"), coerce(val, obj->co.handle), nao);
}
@@ -8046,7 +10490,7 @@ void cptr_print_op(val obj, val out, val pretty, struct strm_ctx *ctx)
put_string(lit("#<cptr"), out);
if (obj->co.cls) {
put_char(chr(' '), out);
- obj_print_impl(obj->co.cls, out, pretty, ctx);
+ obj_print_impl(obj->cp.cls, out, pretty, ctx);
}
format(out, lit(": ~p>"), coerce(val, obj->co.handle), nao);
}
@@ -8063,21 +10507,19 @@ ucnum cobj_handle_hash_op(val obj, int *count, ucnum seed)
return cobj_eq_hash_op(coerce(val, handle), count, seed);
}
-static struct cobj_ops cptr_ops = {
- cobj_equal_handle_op,
- cptr_print_op,
- cobj_destroy_stub_op,
- cobj_mark_op,
- cobj_handle_hash_op
-};
+static struct cobj_ops cptr_ops = cobj_ops_init(cobj_equal_handle_op,
+ cptr_print_op,
+ cobj_destroy_stub_op,
+ cobj_mark_op,
+ cobj_handle_hash_op);
val cptr_typed(mem_t *handle, val type_sym, struct cobj_ops *ops)
{
val obj = make_obj();
- obj->co.type = CPTR;
- obj->co.handle = handle;
- obj->co.ops = (ops != 0 ? ops : &cptr_ops);
- obj->co.cls = type_sym;
+ obj->cp.type = CPTR;
+ obj->cp.handle = handle;
+ obj->cp.ops = (ops != 0 ? ops : &cptr_ops);
+ obj->cp.cls = type_sym;
return obj;
}
@@ -8094,20 +10536,25 @@ val cptrp(val obj)
val cptr_type(val cptr)
{
(void) cptr_handle(cptr, nil, lit("cptr-type"));
- return cptr->co.cls;
+ return cptr->cp.cls;
}
val cptr_size_hint(val cptr, val size)
{
+ val self = lit("cptr-size-hint");
(void) cptr;
- malloc_bytes += c_unum(size);
+ malloc_bytes += c_unum(size, self);
return nil;
}
val cptr_int(val n, val type_sym_in)
{
+ val self = lit("cptr-int");
val type_sym = default_null_arg(type_sym_in);
- return cptr_typed(coerce(mem_t *, c_num(n)), type_sym, 0);
+ return cptr_typed(if3(plusp(n),
+ coerce(mem_t *, c_unum(n, self)),
+ coerce(mem_t *, c_num(n, self))),
+ type_sym, 0);
}
val cptr_obj(val obj, val type_sym_in)
@@ -8144,6 +10591,12 @@ val cptr_cast(val to_type, val cptr)
return cptr_typed(ptr, to_type, 0);
}
+val copy_cptr(val cptr)
+{
+ mem_t *ptr = cptr_handle(cptr, nil, lit("cptr-copy"));
+ return cptr_typed(ptr, cptr->cp.cls, 0);
+}
+
val int_cptr(val cptr)
{
return num(coerce(cnum, cptr_handle(cptr, nil, lit("int-cptr"))));
@@ -8154,9 +10607,9 @@ mem_t *cptr_handle(val cptr, val type_sym, val self)
if (type(cptr) != CPTR) {
uw_throwf(error_s, lit("~a: ~s isn't a cptr"), self, cptr, nao);
} else {
- mem_t *ptr = cptr->co.handle;
+ mem_t *ptr = cptr->cp.handle;
- if (type_sym && cptr->co.cls != type_sym && (ptr != 0 || cptr->co.cls))
+ if (type_sym && cptr->cp.cls != type_sym && (ptr != 0 || cptr->cp.cls))
uw_throwf(error_s, lit("~a: cptr ~s isn't of type ~s"), self, cptr,
type_sym, nao);
@@ -8172,7 +10625,7 @@ mem_t *cptr_get(val cptr)
mem_t **cptr_addr_of(val cptr, val type_sym, val self)
{
(void) cptr_handle(cptr, type_sym, self);
- return &cptr->co.handle;
+ return &cptr->cp.handle;
}
val assoc(val key, val list)
@@ -8305,24 +10758,6 @@ val aconsql_new(val key, val value, val list)
}
}
-val aconsql_new_c(val key, loc new_p, loc list)
-{
- val existing = assql(key, deref(list));
-
- if (existing) {
- if (!nullocp(new_p))
- deref(new_p) = nil;
- return existing;
- } else {
- val nc = cons(key, nil);
- set(list, cons(nc, deref(list)));
- if (!nullocp(new_p))
- deref(new_p) = t;
- return nc;
- }
-}
-
-
static val alist_remove_test(val item, val key)
{
return equal(car(item), key);
@@ -8333,16 +10768,11 @@ val alist_remove(val list, val keys)
return set_diff(list, keys, func_n2(alist_remove_test), nil);
}
-val alist_removev(val list, struct args *keys)
+val alist_removev(val list, varg keys)
{
return alist_remove(list, args_get_list(keys));
}
-val alist_remove1(val list, val key)
-{
- return alist_remove(list, cons(key, nil));
-}
-
val alist_nremove(val list, val keys)
{
loc plist = mkcloc(list);
@@ -8357,7 +10787,7 @@ val alist_nremove(val list, val keys)
return list;
}
-val alist_nremovev(val list, struct args *keys)
+val alist_nremovev(val list, varg keys)
{
return alist_nremove(list, args_get_list(keys));
}
@@ -8382,9 +10812,7 @@ val copy_cons(val cell)
case CONS:
case LCONS:
{
- val obj = make_obj();
- *obj = *cell;
- return obj;
+ return copy_obj(cell);
}
default:
type_mismatch(lit("copy-cons: ~s is not a cons"), cell, nao);
@@ -8398,11 +10826,7 @@ val copy_tree(val tree)
} else {
val car = copy_tree(tree->c.car);
val cdr = copy_tree(tree->c.cdr);
- val copy = make_obj();
- *copy = *tree;
- copy->c.car = car;
- copy->c.cdr = cdr;
- return copy;
+ return cons(car, cdr);
}
}
@@ -8414,38 +10838,54 @@ val copy_alist(val list)
return out;
}
+val pairlis(val keys, val values, val alist_in)
+{
+ val self = lit("pairlis");
+ val alist = default_null_arg(alist_in);
+ seq_iter_t sik, siv;
+ val key, value;
+ list_collect_decl (out, ptail);
+
+ seq_iter_init(self, &sik, keys);
+ seq_iter_init(self, &siv, values);
+
+ while (seq_get(&sik, &key) && seq_get(&siv, &value))
+ ptail = list_collect(ptail, cons(key, value));
+
+ list_collect_nconc(ptail, alist);
+
+ return out;
+}
+
val mapcar_listout(val fun, val seq)
{
val self = lit("mapcar");
- seq_info_t si = seq_info(seq);
- list_collect_decl (out, iter);
+ seq_iter_t iter;
+ val elem;
+ list_collect_decl (out, ptail);
- switch (si.kind) {
- case SEQ_NIL:
- return nil;
- case SEQ_VECLIKE:
- {
- val v = si.obj;
- cnum i, len = c_fixnum(length(v), self);
+ seq_iter_init(self, &iter, seq);
- for (i = 0; i < len; i++)
- iter = list_collect(iter, funcall1(fun, ref(v, num_fast(i))));
- }
- break;
- case SEQ_LISTLIKE:
- for (seq = z(si.obj); seq; seq = cdr(seq))
- iter = list_collect(iter, funcall1(fun, car(seq)));
- break;
- default:
- unsup_obj(self, seq);
- }
+ while (seq_get(&iter, &elem))
+ ptail = list_collect(ptail, funcall1(fun, elem));
return out;
}
-val mapcar(val fun, val list)
+val mapcar(val fun, val seq)
{
- return make_like(mapcar_listout(fun, list), list);
+ val self = lit("mapcar");
+ seq_iter_t iter;
+ seq_build_t build;
+ val elem;
+
+ seq_iter_init(self, &iter, seq);
+ seq_build_init(self, &build, seq);
+
+ while (seq_get(&iter, &elem))
+ seq_add(&build, funcall1(fun, elem));
+
+ return seq_finish(&build);
}
val mapcon(val fun, val list)
@@ -8461,29 +10901,32 @@ val mapcon(val fun, val list)
return make_like(out, list_orig);
}
-val mappend(val fun, val list)
+val mappend(val fun, val seq)
{
- list_collect_decl (out, iter);
- val list_orig = list;
-
- list = nullify(list);
+ val self = lit("mappend");
+ seq_iter_t iter;
+ seq_build_t build;
+ val elem;
- gc_hint(list);
+ seq_iter_init(self, &iter, seq);
+ seq_build_init(self, &build, seq);
- for (; list; list = cdr(list))
- iter = list_collect_append(iter, funcall1(fun, car(list)));
+ while (seq_get(&iter, &elem))
+ seq_pend(&build, funcall1(fun, elem));
- return make_like(out, list_orig);
+ return seq_finish(&build);
}
-val mapdo(val fun, val list)
+val mapdo(val fun, val seq)
{
- list = nullify(list);
+ val self = lit("mapdo");
+ seq_iter_t iter;
+ val elem;
- gc_hint(list);
+ seq_iter_init(self, &iter, seq);
- for (; list; list = cdr(list))
- funcall1(fun, car(list));
+ while (seq_get(&iter, &elem))
+ funcall1(fun, elem);
return nil;
}
@@ -8502,129 +10945,113 @@ enum wmap_op {
WMAP_MAP, WMAP_MAPPEND, WMAP_MAPDO
};
-static val window_map_list(val range, val boundary, val fun, val list,
- enum wmap_op op)
+static val window_map_common(val range, val boundary, val fun,
+ val seq, enum wmap_op op,
+ val self, seq_build_t *bu)
{
- val self = lit("window-map");
cnum i, j, ra = c_fixnum(range, self), ws = calc_win_size(ra);
- val iter;
args_decl (args, ws);
- list_collect_decl (out, ptail);
+ val elem;
+ seq_iter_t it0, it1;
+
+ seq_iter_init(self, &it0, seq);
+
+ if (!seq_get(&it0, &elem))
+ return nil;
args_set_fill(args, ws);
- if (boundary == wrap_k) {
- val lcopy = take(range, list);
- while (lt(length(lcopy), range))
- lcopy = append2(lcopy, lcopy);
- boundary = append2(sub(lcopy, num_fast(-ra), t), sub(lcopy, zero, range));
- } else if (boundary == reflect_k) {
- val lcopy = take(range, list);
- while (lt(length(lcopy), range))
- lcopy = append2(lcopy, lcopy);
- boundary = nappend2(nreverse(sub(lcopy, zero, range)),
- nreverse(sub(lcopy, num_fast(-ra), t)));
+ if (boundary == wrap_k || boundary == reflect_k) {
+ val lw = sub(seq, num_fast(-ra), t), lwing = lw;
+ val rw = sub(seq, zero, range), rwing = rw;
+ cnum i, len = c_fixnum(length(seq), self);
+
+ if (boundary == reflect_k) {
+ lwing = reverse(rw);
+ rwing = reverse(lw);
+ lw = lwing;
+ rw = rwing;
+ }
+
+ for (i = len; i < ra; i += len) {
+ lwing = append2(lwing, lw);
+ rwing = append2(rwing, rw);
+ }
+
+ if (len < ra)
+ boundary = append2(sub(lwing, num_fast(-ra), t), sub(rwing, zero, range));
+ else
+ boundary = append2(lwing, rwing);
}
+ seq_iter_init(self, &it1, seq);
+
for (i = 0; i < ra; i++)
args->arg[i] = ref(boundary, num_fast(i));
- for (iter = list; iter && i < ws; iter = cdr(iter), i++)
- args->arg[i] = car(iter);
+ for (; i < ws && seq_get(&it1, &elem); i++)
+ args->arg[i] = elem;
for (j = ra; i < ws; i++)
args->arg[i] = ref(boundary, num(j++));
for (;;) {
+ val item;
args_decl (args_cp, ws);
args_copy(args_cp, args);
- val item = generic_funcall(fun, args_cp);
+
+ item = generic_funcall(fun, args_cp);
switch (op) {
- case WMAP_MAP: ptail = list_collect(ptail, item); break;
- case WMAP_MAPPEND: ptail = list_collect_append(ptail, item); break;
+ case WMAP_MAP: seq_add(bu, item); break;
+ case WMAP_MAPPEND: seq_pend(bu, item); break;
case WMAP_MAPDO: (void) item; break;
}
- if (nilp(list = cdr(list)))
- break;
-
for (i = 0; i < ws - 1; i++)
args->arg[i] = args->arg[i + 1];
- if (iter) {
- args->arg[i] = car(iter);
- iter = cdr(iter);
- } else {
+ if (!seq_get(&it0, &elem))
+ break;
+
+ if (seq_get(&it1, &elem))
+ args->arg[i] = elem;
+ else
args->arg[i] = ref(boundary, num(j++));
- }
}
- return out;
-}
-
-static val window_map_vec(val range, val boundary, val fun, val seq,
- enum wmap_op op)
-{
- val list = tolist(seq);
- val out = window_map_list(range, boundary, fun, list, op);
- return make_like(out, seq);
+ return seq_finish(bu);
}
val window_map(val range, val boundary, val fun, val seq)
{
- switch (type(seq)) {
- case NIL:
- return nil;
- case CONS:
- case LCONS:
- return window_map_list(range, boundary, fun, seq, WMAP_MAP);
- case VEC:
- case LIT:
- case STR:
- case LSTR:
- return window_map_vec(range, boundary, fun, seq, WMAP_MAP);
- default:
- type_mismatch(lit("window-map: ~s is not a sequence"), seq, nao);
- }
+ val self = lit("window-map");
+ seq_build_t bu;
+ seq_build_init(self, &bu, seq);
+
+ return window_map_common(range, boundary, fun, seq,
+ WMAP_MAP, self, &bu);
}
val window_mappend(val range, val boundary, val fun, val seq)
{
- switch (type(seq)) {
- case NIL:
- return nil;
- case CONS:
- case LCONS:
- return window_map_list(range, boundary, fun, seq, WMAP_MAPPEND);
- case VEC:
- case LIT:
- case STR:
- case LSTR:
- return window_map_vec(range, boundary, fun, seq, WMAP_MAPPEND);
- default:
- type_mismatch(lit("window-mappend: ~s is not a sequence"), seq, nao);
- }
+ val self = lit("window-mappend");
+ seq_build_t bu;
+ seq_build_init(self, &bu, seq);
+
+ return window_map_common(range, boundary, fun, seq,
+ WMAP_MAPPEND, self, &bu);
}
val window_mapdo(val range, val boundary, val fun, val seq)
{
- switch (type(seq)) {
- case NIL:
- return nil;
- case CONS:
- case LCONS:
- (void) window_map_list(range, boundary, fun, seq, WMAP_MAPDO);
- return nil;
- case VEC:
- case LIT:
- case STR:
- case LSTR:
- (void) window_map_vec(range, boundary, fun, seq, WMAP_MAPDO);
- return nil;
- default:
- type_mismatch(lit("window-mapdo: ~s is not a sequence"), seq, nao);
- }
+ val self = lit("window-mapdo");
+ seq_build_t bu;
+ seq_build_init(self, &bu, seq);
+
+ (void) window_map_common(range, boundary, fun, seq,
+ WMAP_MAPDO, self, &bu);
+ return nil;
}
static val lazy_interpose_func(val sep, val lcons)
@@ -8755,7 +11182,7 @@ static void swap(val vec, val i, val j)
}
}
-static cnum med_of_three(val vec, val lessfun, val keyfun, cnum from, cnum to,
+static void med_of_three(val vec, val lessfun, val keyfun, cnum from, cnum to,
val *pkval)
{
cnum mid = from + (to - from) / 2;
@@ -8767,114 +11194,286 @@ static cnum med_of_three(val vec, val lessfun, val keyfun, cnum from, cnum to,
val tkval = funcall1(keyfun, tval);
if (funcall2(lessfun, fkval, mkval)) {
- if (funcall2(lessfun, mkval, tval)) {
+ if (funcall2(lessfun, mkval, tval))
*pkval = mkval;
- return mid;
- } else if (funcall2(lessfun, fkval, tkval)) {
+ else if (funcall2(lessfun, fkval, tkval))
*pkval = tkval;
- return to - 1;
- } else {
+ else
*pkval = fkval;
- return from;
- }
} else {
- if (funcall2(lessfun, fkval, tval)) {
+ if (funcall2(lessfun, fkval, tval))
*pkval = fkval;
- return from;
- } else if (funcall2(lessfun, mkval, tkval)) {
+ else if (funcall2(lessfun, mkval, tkval))
*pkval = tkval;
- return to - 1;
- } else {
+ else
*pkval = mkval;
- return mid;
- }
}
}
-static cnum middle_pivot(val vec, val lessfun, val keyfun, cnum from, cnum to,
+static void middle_pivot(val vec, val keyfun, cnum from, cnum to,
val *pkval)
{
cnum pivot = from + (to - from) / 2;
val pval = ref(vec, num_fast(pivot));
*pkval = funcall1(keyfun, pval);
- return pivot;
}
static void quicksort(val vec, val lessfun, val keyfun, cnum from, cnum to)
{
+ int is_identity = keyfun == identity_f;
+
while (to - from >= 2) {
+ cnum i = from - 1;
+ cnum j = to;
val pkval;
- cnum i, j;
- cnum pivot = if3(to - from > 15,
- med_of_three(vec, lessfun, keyfun, from, to, &pkval),
- middle_pivot(vec, lessfun, keyfun, from, to, &pkval));
- swap(vec, num_fast(pivot), num_fast(to - 1));
+ if (to - from > 15)
+ med_of_three(vec, lessfun, keyfun, from, to, &pkval);
+ else
+ middle_pivot(vec, keyfun, from, to, &pkval);
+
+ for (;;) {
+ val elem;
+
+ do {
+ i++;
+ elem = ref(vec, num_fast(i));
+ if (!is_identity)
+ elem = funcall1(keyfun, elem);
+ } while (funcall2(lessfun, elem, pkval));
+
+ do {
+ j--;
+ if (i < j) {
+ elem = ref(vec, num_fast(j));
+ if (!is_identity)
+ elem = funcall1(keyfun, elem);
+ }
+ } while (i < j && funcall2(lessfun, pkval, elem));
- for (j = from, i = from; i < to - 1; i++)
- if (funcall2(lessfun, funcall1(keyfun, ref(vec, num_fast(i))), pkval))
- swap(vec, num_fast(i), num_fast(j++));
+ if (i >= j)
+ break;
- swap(vec, num_fast(j), num_fast(to - 1));
+ swap(vec, num_fast(i), num_fast(j));
+ }
if (j - from > to - j) {
- quicksort(vec, lessfun, keyfun, j + 1, to);
- to = j;
+ quicksort(vec, lessfun, keyfun, i, to);
+ to = i;
} else {
- quicksort(vec, lessfun, keyfun, from, j);
- from = j + 1;
+ quicksort(vec, lessfun, keyfun, from, i);
+ from = i;
}
}
}
-static void sort_vec(val vec, val lessfun, val keyfun)
+static void sort_vec(val vec, val lessfun, val keyfun, val self)
{
- val self = lit("sort");
cnum len = c_fixnum(length(vec), self);
quicksort(vec, lessfun, keyfun, 0, len);
}
-val sort(val seq_in, val lessfun, val keyfun)
+static void mergesort(val vec, val lessfun, val keyfun, cnum from, cnum to,
+ val *aux)
{
- val seq_orig = seq_in;
- val seq = nullify(seq_in);
+ int is_identity = keyfun == identity_f;
- if (!seq)
- return make_like(nil, seq_orig);
+ switch (to - from) {
+ case 0:
+ case 1:
+ break;
+ case 2:
+ {
+ val el0 = ref(vec, num_fast(from));
+ val el1 = ref(vec, num_fast(from + 1));
+
+ if (is_identity) {
+ el0 = funcall1(keyfun, el0);
+ el1 = funcall1(keyfun, el1);
+ }
+ if (funcall2(lessfun, el1, el0))
+ swap(vec, num_fast(from), num_fast(from + 1));
+ }
+ break;
+ default:
+ {
+ cnum mid = from + (to - from) / 2;
+ cnum i, j, k;
+ val iel, jel;
+
+ mergesort(vec, lessfun, keyfun, from, mid, aux);
+ mergesort(vec, lessfun, keyfun, mid, to, aux);
+
+ for (i = from, j = mid, k = 0, iel = nao, jel = nao; i < mid && j < to; )
+ {
+ if (iel == nao) {
+ iel = ref(vec, num_fast(i));
+ if (!is_identity)
+ iel = funcall1(keyfun, iel);
+ }
+
+
+ if (jel == nao) {
+ jel = ref(vec, num_fast(j));
+ if (!is_identity)
+ jel = funcall1(keyfun, jel);
+ }
+
+ if (funcall2(lessfun, iel, jel)) {
+ aux[k++] = ref(vec, num_fast(i++));
+ iel = nao;
+ } else {
+ aux[k++] = ref(vec, num_fast(j++));
+ jel = nao;
+ }
+ }
+
+ while (i < mid)
+ aux[k++] = ref(vec, num_fast(i++));
+ while (j < to)
+ aux[k++] = ref(vec, num_fast(j++));
+
+ for (i = from, k = 0; i < to; i++, k++)
+ refset(vec, num_fast(i), aux[k]);
+ }
+ break;
+ }
+}
+
+static void ssort_vec(val vec, val lessfun, val keyfun, val self)
+{
+ cnum len = c_fixnum(length(vec), self);
+ val auxobj;
+ val *aux = gc_prot_array_alloc(len, &auxobj);
+ mergesort(vec, lessfun, keyfun, 0, len, aux);
+ gc_prot_array_free(aux);
+ gc_hint(auxobj);
+}
+
+
+val nsort(val seq, val lessfun, val keyfun)
+{
+ val self = lit("nsort");
+ seq_info_t si = seq_info(seq);
keyfun = default_arg(keyfun, identity_f);
lessfun = default_arg(lessfun, less_f);
- if (consp(seq))
+ switch (si.kind) {
+ case SEQ_NIL:
+ return nil;
+ case SEQ_VECLIKE:
+ case SEQ_HASHLIKE:
+ sort_vec(seq, lessfun, keyfun, self);
+ return seq;
+ case SEQ_LISTLIKE:
return sort_list(seq, lessfun, keyfun);
+ case SEQ_TREELIKE:
+ case SEQ_NOTSEQ:
+ unsup_obj(self, seq);
+ }
- sort_vec(seq, lessfun, keyfun);
- return seq;
+ abort();
}
-val shuffle(val seq)
+val sort(val seq, val lessfun, val keyfun)
{
- switch (type(seq)) {
- case NIL:
+ val self = lit("sort");
+ seq_info_t si = seq_info(seq);
+
+ keyfun = default_arg(keyfun, identity_f);
+ lessfun = default_arg(lessfun, less_f);
+
+ switch (si.kind) {
+ case SEQ_NIL:
return nil;
- case CONS:
- case LCONS:
+ case SEQ_VECLIKE:
+ case SEQ_HASHLIKE:
+ seq = copy(seq);
+ sort_vec(seq, lessfun, keyfun, self);
+ return seq;
+ case SEQ_LISTLIKE:
+ return sort_list(copy_list(seq), lessfun, keyfun);
+ case SEQ_TREELIKE:
+ case SEQ_NOTSEQ:
+ unsup_obj(self, seq);
+ }
+
+ abort();
+}
+
+val snsort(val seq, val lessfun, val keyfun)
+{
+ val self = lit("snsort");
+ seq_info_t si = seq_info(seq);
+
+ keyfun = default_arg(keyfun, identity_f);
+ lessfun = default_arg(lessfun, less_f);
+
+ switch (si.kind) {
+ case SEQ_NIL:
+ return nil;
+ case SEQ_VECLIKE:
+ case SEQ_HASHLIKE:
+ ssort_vec(seq, lessfun, keyfun, self);
+ return seq;
+ case SEQ_LISTLIKE:
+ return sort_list(seq, lessfun, keyfun);
+ case SEQ_TREELIKE:
+ case SEQ_NOTSEQ:
+ unsup_obj(self, seq);
+ }
+
+ abort();
+}
+
+val ssort(val seq, val lessfun, val keyfun)
+{
+ val self = lit("ssort");
+ seq_info_t si = seq_info(seq);
+
+ keyfun = default_arg(keyfun, identity_f);
+ lessfun = default_arg(lessfun, less_f);
+
+ switch (si.kind) {
+ case SEQ_NIL:
+ return nil;
+ case SEQ_VECLIKE:
+ case SEQ_HASHLIKE:
+ seq = copy(seq);
+ ssort_vec(seq, lessfun, keyfun, self);
+ return seq;
+ case SEQ_LISTLIKE:
+ return sort_list(copy_list(seq), lessfun, keyfun);
+ case SEQ_TREELIKE:
+ case SEQ_NOTSEQ:
+ unsup_obj(self, seq);
+ }
+
+ abort();
+}
+
+val nshuffle(val seq, val randstate)
+{
+ seq_info_t si = seq_info(seq);
+
+ switch (si.kind) {
+ case SEQ_NIL:
+ return nil;
+ case SEQ_LISTLIKE:
if (cdr(seq))
{
- val v = shuffle(vec_list(seq));
+ val v = nshuffle(vec_list(seq), randstate);
val i, l;
for (l = seq, i = zero; l; i = succ(i), l = cdr(l))
rplaca(l, ref(v, i));
}
return seq;
- case LIT:
- uw_throwf(error_s, lit("shuffle: ~s is a literal"), seq, nao);
- case STR:
- case LSTR:
- case VEC:
+ case SEQ_VECLIKE:
+ case SEQ_HASHLIKE:
{
- val rs = random_state;
+ val rs = default_arg(randstate, random_state);
val n = length(seq);
val i;
@@ -8890,9 +11489,19 @@ val shuffle(val seq)
return seq;
}
- default:
- type_mismatch(lit("shuffle: ~s is not a sequence"), seq, nao);
+ case SEQ_NOTSEQ:
+ case SEQ_TREELIKE:
+ unsup_obj(lit("nshuffle"), seq);
}
+
+ abort();
+}
+
+val shuffle(val seq, val randstate)
+{
+ if (seqp(seq))
+ return nshuffle(copy(seq), randstate);
+ type_mismatch(lit("nshuffle: ~s is not a sequence"), seq, nao);
}
static val multi_sort_less(val funcs_cons, val llist, val rlist)
@@ -8922,64 +11531,59 @@ val multi_sort(val lists, val funcs, val key_funcs)
{
val tuples = mapcarl(list_f, nullify(lists));
- key_funcs = default_null_arg(key_funcs);
+ if (tuples) {
+ key_funcs = default_null_arg(key_funcs);
- if (functionp(funcs))
- funcs = cons(funcs, nil);
+ if (functionp(funcs))
+ funcs = cons(funcs, nil);
- tuples = sort_list(tuples, func_f2(cons(funcs, key_funcs),
- multi_sort_less), identity_f);
+ tuples = sort_list(tuples, func_f2(cons(funcs, key_funcs),
+ multi_sort_less), identity_f);
- return mapcarl(list_f, tuples);
+ return mapcarl(list_f, tuples);
+ } else {
+ list_collect_decl (out, ptail);
+ for (; !endp(lists); lists = us_cdr(lists))
+ ptail = list_collect(ptail, nil);
+ return out;
+ }
}
val sort_group(val seq, val keyfun, val lessfun)
{
val kf = default_arg(keyfun, identity_f);
val lf = default_arg(lessfun, less_f);
- val seq_copy = copy(seq);
- val sorted = sort(seq_copy, lf, kf);
+ val sorted = sort(seq, lf, kf);
return partition_by(kf, sorted);
}
-val unique(val seq, val keyfun, struct args *hashv_args)
+val unique(val seq, val keyfun, varg hashv_args)
{
val self = lit("unique");
val hash = hashv(hashv_args);
val kf = default_arg(keyfun, identity_f);
+ seq_iter_t iter;
+ seq_build_t build;
+ val elem;
- list_collect_decl (out, ptail);
-
- if (vectorp(seq) || stringp(seq)) {
- cnum i, len;
+ seq_iter_init(self, &iter, seq);
+ seq_build_init(self, &build, seq);
- for (i = 0, len = c_fixnum(length(seq), self); i < len; i++) {
- val new_p;
- val v = ref(seq, num_fast(i));
-
- (void) gethash_c(self, hash, funcall1(kf, v), mkcloc(new_p));
-
- if (new_p)
- ptail = list_collect(ptail, v);
- }
- } else {
- for (; seq; seq = cdr(seq)) {
- val new_p;
- val v = car(seq);
+ while (seq_get(&iter, &elem)) {
+ val new_p;
- (void) gethash_c(self, hash, funcall1(kf, v), mkcloc(new_p));
+ (void) gethash_c(self, hash, funcall1(kf, elem), mkcloc(new_p));
- if (new_p)
- ptail = list_collect(ptail, v);
- }
+ if (new_p)
+ seq_add(&build, elem);
}
- return make_like(out, seq);
+ return seq_finish(&build);
}
val uniq(val seq)
{
- args_decl(hashv_args, ARGS_MIN);
+ args_decl_constsize(hashv_args, ARGS_MIN);
args_add(hashv_args, equal_based_k);
return unique(seq, identity_f, hashv_args);
}
@@ -9015,7 +11619,7 @@ val grade(val seq, val lessfun, val keyfun_in)
{
list_collect_decl (out, ptail);
- sort(v, lessfun, keyfun);
+ nsort(v, lessfun, keyfun);
for (i = 0; i < len; i++)
ptail = list_collect(ptail, cdr(v->v.vec[i]));
@@ -9027,83 +11631,126 @@ val grade(val seq, val lessfun, val keyfun_in)
return nil;
}
-val find(val item, val seq, val testfun, val keyfun)
+static val hist_succ(val left, val right)
+{
+ (void) right;
+ return succ(left);
+}
+
+val hist_sort_by(val fun, val seq, varg hashv_args)
+{
+ val hash = group_reduce(hashv(hashv_args),
+ fun, hist_succ_f,
+ seq, zero, nil);
+ return nsort(hash_alist(hash), gt_f, cdr_f);
+}
+
+val hist_sort(val seq, varg hashv_args)
+{
+ return hist_sort_by(identity_f, seq, hashv_args);
+}
+
+val nrot(val seq, val n_in)
+{
+ val len = length(seq);
+
+ if (len != zero && len != one) {
+ val n = mod(default_arg(n_in, one), len);
+
+ if (n == one) {
+ val head = ref(seq, zero);
+ seq = replace(seq, cons(head, nil), len, len);
+ seq = replace(seq, nil, zero, one);
+ } else if (n != zero) {
+ val head = sub(seq, zero, n);
+ seq = replace(seq, head, len, len);
+ seq = replace(seq, nil, zero, n);
+ }
+ }
+
+ return seq;
+}
+
+val rot(val seq, val n_in)
+{
+ val seq_orig = seq;
+ val len = length(seq);
+
+ if (len != zero && len != one) {
+ val n = mod(default_arg(n_in, one), len);
+
+ if (n != zero) {
+ val head = sub(seq, zero, n);
+ seq = sub(seq, n, t);
+ seq = replace(seq, head, t, t);
+ }
+ }
+
+ if (seq == seq_orig)
+ seq = copy(seq);
+
+ return seq;
+}
+
+val find(val item, val seq, val testfun_in, val keyfun_in)
{
val self = lit("find");
- testfun = default_arg(testfun, equal_f);
- keyfun = default_arg(keyfun, identity_f);
+ val testfun = default_arg(testfun_in, equal_f);
+ val keyfun = default_arg(keyfun_in, identity_f);
seq_info_t si = seq_info(seq);
- switch (si.kind) {
- case SEQ_NIL:
- return nil;
- case SEQ_LISTLIKE:
+ switch (si.type) {
+ case STR:
+ case LIT:
+ if (keyfun == identity_f &&
+ (testfun == equal_f || testfun == eql_f || testfun == eq_f))
{
- gc_hint(seq);
+ const wchar_t ch = c_chr(item);
+ const wchar_t *cstr = c_str(seq, self);
+ if (wcschr(cstr, ch))
+ return item;
+ return nil;
+ }
+ /* fallthrough */
+ default:
+ {
+ val elem;
+ seq_iter_t it;
- for (seq = z(si.obj); seq; seq = cdr(seq)) {
- val elem = car(seq);
- val key = funcall1(keyfun, elem);
+ seq_iter_init_with_info(self, &it, si, 0);
+ while (seq_get(&it, &elem)) {
+ val key = funcall1(keyfun, elem);
if (funcall2(testfun, item, key))
return elem;
}
}
- return nil;
- case SEQ_VECLIKE:
- switch (si.type) {
- case STR:
- case LIT:
- if (keyfun == identity_f &&
- (testfun == equal_f || testfun == eql_f || testfun == eq_f))
- {
- const wchar_t ch = c_chr(item);
- const wchar_t *cstr = c_str(seq);
- if (wcschr(cstr, ch))
- return item;
- return nil;
- }
- /* fallthrough */
- default:
- {
- val vec = si.obj;
- cnum len = c_fixnum(length(vec), self);
- cnum i;
-
- for (i = 0; i < len; i++) {
- val elem = ref(vec, num_fast(i));
- val key = funcall1(keyfun, elem);
- if (funcall2(testfun, item, key))
- return elem;
- }
- }
- break;
- }
- return nil;
- default:
- unsup_obj(self, seq);
+ break;
}
+ return nil;
}
-val rfind(val item, val seq, val testfun, val keyfun)
+val rfind(val item, val seq, val testfun_in, val keyfun_in)
{
val self = lit("rfind");
- testfun = default_arg(testfun, equal_f);
- keyfun = default_arg(keyfun, identity_f);
+ val testfun = default_arg(testfun_in, equal_f);
+ val keyfun = default_arg(keyfun_in, identity_f);
seq_info_t si = seq_info(seq);
switch (si.kind) {
case SEQ_NIL:
return nil;
case SEQ_LISTLIKE:
+ default:
{
val found = nil;
- gc_hint(seq);
+ val elem;
+ seq_iter_t it;
- for (seq = z(si.obj); seq; seq = cdr(seq)) {
- val elem = car(seq);
- val key = funcall1(keyfun, elem);
+ seq_iter_init_with_info(self, &it, si, 0);
+ while (seq_get(&it, &elem)) {
+ val key = funcall1(keyfun, elem);
if (funcall2(testfun, item, key))
found = elem;
}
@@ -9117,7 +11764,7 @@ val rfind(val item, val seq, val testfun, val keyfun)
(testfun == equal_f || testfun == eql_f || testfun == eq_f))
{
const wchar_t ch = c_chr(item);
- const wchar_t *cstr = c_str(seq);
+ const wchar_t *cstr = c_str(seq, self);
if (wcschr(cstr, ch))
return item;
return nil;
@@ -9138,90 +11785,135 @@ val rfind(val item, val seq, val testfun, val keyfun)
}
break;
}
- return nil;
- default:
- unsup_obj(self, seq);
+ break;
}
+ return nil;
}
-val find_max(val seq, val testfun, val keyfun)
+val find_max(val seq, val testfun_in, val keyfun_in)
{
val self = lit("find-max");
+ val testfun = default_arg(testfun_in, greater_f);
+ val keyfun = default_arg(keyfun_in, identity_f);
+ seq_iter_t iter;
+ val elem;
+
+ seq_iter_init(self, &iter, seq);
+
+ if (seq_get(&iter, &elem)) {
+ val maxkey = funcall1(keyfun, elem);
+ val maxelem = elem;
+
+ while (seq_get(&iter, &elem)) {
+ val key = funcall1(keyfun, elem);
+ if (funcall2(testfun, key, maxkey)) {
+ maxkey = key;
+ maxelem = elem;
+ }
+ }
+
+ return maxelem;
+ }
+
+ return nil;
+}
+
+val find_max_key(val seq, val testfun_in, val keyfun_in)
+{
+ val self = lit("find-max-key");
+ val testfun = default_arg(testfun_in, greater_f);
+ val keyfun = default_arg(keyfun_in, identity_f);
+ seq_iter_t iter;
+ val elem;
+
+ seq_iter_init(self, &iter, seq);
+
+ if (seq_get(&iter, &elem)) {
+ val maxkey = funcall1(keyfun, elem);
+
+ while (seq_get(&iter, &elem)) {
+ val key = funcall1(keyfun, elem);
+ if (funcall2(testfun, key, maxkey))
+ maxkey = key;
+ }
+
+ return maxkey;
+ }
+
+ return nil;
+}
+
+val find_min(val seq, val testfun, val keyfun)
+{
+ return find_max(seq, default_arg(testfun, less_f), keyfun);
+}
+
+val find_min_key(val seq, val testfun, val keyfun)
+{
+ return find_max_key(seq, default_arg(testfun, less_f), keyfun);
+}
+
+val find_true(val pred, val seq, val key)
+{
+ val self = lit("find-true");
+ val keyfun = default_arg(key, identity_f);
seq_info_t si = seq_info(seq);
- testfun = default_arg(testfun, greater_f);
- keyfun = default_arg(keyfun, identity_f);
switch (si.kind) {
case SEQ_NIL:
- return nil;
+ break;
case SEQ_HASHLIKE:
{
struct hash_iter hi;
- val cell = (hash_iter_init(&hi, si.obj, self), hash_iter_next(&hi));
- val maxelt = cell;
- val maxkey = if2(cell, funcall1(keyfun, cell));
+ val cell;
- while (cell && (cell = hash_iter_next(&hi))) {
+ hash_iter_init(&hi, si.obj, self);
+
+ while ((cell = hash_iter_next(&hi))) {
val key = funcall1(keyfun, cell);
- if (funcall2(testfun, key, maxkey)) {
- maxkey = key;
- maxelt = cell;
- }
+ val res = funcall1(pred, key);
+ if (res)
+ return res;
}
- return maxelt;
+ break;
}
case SEQ_LISTLIKE:
{
- val maxelt = car(z(si.obj));
- val maxkey = funcall1(keyfun, maxelt);
-
gc_hint(seq);
- for (seq = cdr(seq); seq; seq = cdr(seq)) {
+ for (seq = z(si.obj); seq; seq = cdr(seq)) {
val elt = car(seq);
val key = funcall1(keyfun, elt);
- if (funcall2(testfun, key, maxkey)) {
- maxkey = key;
- maxelt = elt;
- }
+ val res = funcall1(pred, key);
+ if (res)
+ return res;
}
- return maxelt;
+ break;
}
case SEQ_VECLIKE:
{
val vec = si.obj;
cnum len = c_fixnum(length(vec), self);
+ cnum i;
- if (len > 0) {
- val maxelt = ref(vec, zero);
- val maxkey = funcall1(keyfun, maxelt);
- cnum i;
-
- for (i = 1; i < len; i++) {
- val elt = ref(vec, num_fast(i));
- val key = funcall1(keyfun, elt);
- if (funcall2(testfun, key, maxkey)) {
- maxkey = key;
- maxelt = elt;
- }
- }
-
- return maxelt;
+ for (i = 0; i < len; i++) {
+ val elt = ref(vec, num_fast(i));
+ val key = funcall1(keyfun, elt);
+ val res = funcall1(pred, key);
+ if (res)
+ return res;
}
- return nil;
+ break;
}
case SEQ_NOTSEQ:
default:
unsup_obj(self, seq);
}
-}
-val find_min(val seq, val testfun, val keyfun)
-{
- return find_max(seq, default_arg(testfun, less_f), keyfun);
+ return nil;
}
val find_if(val pred, val seq, val key)
@@ -9344,11 +12036,11 @@ val rfind_if(val predi, val seq, val key)
return found;
}
-val pos(val item, val seq, val testfun, val keyfun)
+val pos(val item, val seq, val testfun_in, val keyfun_in)
{
val self = lit("pos");
- testfun = default_arg(testfun, equal_f);
- keyfun = default_arg(keyfun, identity_f);
+ val testfun = default_arg(testfun_in, equal_f);
+ val keyfun = default_arg(keyfun_in, identity_f);
seq_info_t si = seq_info(seq);
switch (si.kind) {
@@ -9376,7 +12068,7 @@ val pos(val item, val seq, val testfun, val keyfun)
(testfun == equal_f || testfun == eql_f || testfun == eq_f))
{
const wchar_t ch = c_chr(item);
- const wchar_t *cstr = c_str(seq);
+ const wchar_t *cstr = c_str(seq, self);
const wchar_t *cpos = wcschr(cstr, ch);
if (cpos != 0)
return num(cpos - cstr);
@@ -9405,11 +12097,11 @@ val pos(val item, val seq, val testfun, val keyfun)
}
}
-val rpos(val item, val seq, val testfun, val keyfun)
+val rpos(val item, val seq, val testfun_in, val keyfun_in)
{
val self = lit("rpos");
- testfun = default_arg(testfun, equal_f);
- keyfun = default_arg(keyfun, identity_f);
+ val testfun = default_arg(testfun_in, equal_f);
+ val keyfun = default_arg(keyfun_in, identity_f);
seq_info_t si = seq_info(seq);
switch (si.kind) {
@@ -9437,7 +12129,7 @@ val rpos(val item, val seq, val testfun, val keyfun)
(testfun == equal_f || testfun == eql_f || testfun == eq_f))
{
const wchar_t ch = c_chr(item);
- const wchar_t *cstr = c_str(seq);
+ const wchar_t *cstr = c_str(seq, self);
const wchar_t *cpos = wcsrchr(cstr, ch);
if (cpos != 0)
return num(cpos - cstr);
@@ -9651,6 +12343,40 @@ val pos_min(val seq, val testfun, val keyfun)
return pos_max(seq, default_arg(testfun, less_f), keyfun);
}
+val subq(val oldv, val newv, val seq)
+{
+ return subst(oldv, newv, seq, eq_f, identity_f);
+}
+
+val subql(val oldv, val newv, val seq)
+{
+ return subst(oldv, newv, seq, eql_f, identity_f);
+}
+
+val subqual(val oldv, val newv, val seq)
+{
+ return subst(oldv, newv, seq, equal_f, identity_f);
+}
+
+val subst(val oldv, val newv, val seq, val testfun_in, val keyfun_in)
+{
+ val self = lit("subst");
+ seq_iter_t iter;
+ val elem;
+ val testfun = default_arg(testfun_in, equal_f);
+ val keyfun = default_arg(keyfun_in, identity_f);
+ list_collect_decl (out, ptail);
+
+ seq_iter_init(self, &iter, seq);
+
+ while (seq_get(&iter, &elem)) {
+ val key = funcall1(keyfun, elem);
+ ptail = list_collect(ptail, if3(funcall2(testfun, oldv, key), newv, elem));
+ }
+
+ return make_like(out, seq);
+}
+
val mismatch(val left, val right, val testfun_in, val keyfun_in)
{
val testfun = default_arg(testfun_in, equal_f);
@@ -9734,10 +12460,29 @@ val mismatch(val left, val right, val testfun_in, val keyfun_in)
case CONS:
case LCONS:
return mismatch(right, left, testfun, keyfun);
- case VEC:
- case LIT:
case STR:
+ case LIT:
+ switch (type(left)) {
+ case STR:
+ case LIT:
+ if (keyfun == identity_f && (testfun == equal_f ||
+ testfun == eql_f ||
+ testfun == eq_f))
+ {
+ const wchar_t *lft = c_str(left, nil), *le = lft;
+ const wchar_t *rgt = c_str(right, nil), *ri = rgt;
+
+ while (*le && *ri && *le == *ri)
+ le++, ri++;
+
+ return if3(*le || *ri, num(le - lft), nil);
+ }
+ default:
+ break;
+ }
+ /* fallthrough */
case LSTR:
+ case VEC:
{
val llen = length(left);
val rlen = length(right);
@@ -9765,6 +12510,7 @@ val mismatch(val left, val right, val testfun_in, val keyfun_in)
val rmismatch(val left, val right, val testfun_in, val keyfun_in)
{
+ val self = lit("rmismatch");
val testfun = default_arg(testfun_in, equal_f);
val keyfun = default_arg(keyfun_in, identity_f);
@@ -9828,13 +12574,36 @@ val rmismatch(val left, val right, val testfun_in, val keyfun_in)
case VEC:
switch (type(right)) {
case NIL:
- return if3(length(left) == zero, nil, zero);
+ return if3(length(left) == zero, nil, negone);
case CONS:
case LCONS:
return rmismatch(right, left, testfun, keyfun);
- case VEC:
case LIT:
case STR:
+ switch (type(left)) {
+ case STR:
+ case LIT:
+ if (keyfun == identity_f && (testfun == equal_f ||
+ testfun == eql_f ||
+ testfun == eq_f))
+ {
+ cnum ll = c_num(length(left), self), li = ll - 1;
+ cnum rl = c_num(length(right), self), ri = rl - 1;
+ const wchar_t *lft = c_str(left, self);
+ const wchar_t *rgt = c_str(right, self);
+
+ for (; li >= 0 && ri >= 0; li--, ri--) {
+ if (lft[li] != rgt[ri])
+ break;
+ }
+
+ return if2(li >= 0 || ri >= 0, num(li - ll));
+ }
+ default:
+ break;
+ }
+ /* fallthrough */
+ case VEC:
case LSTR:
{
val llen = length(left);
@@ -9908,6 +12677,8 @@ val take(val count, val seq)
return sub(seq, zero, count);
case SEQ_HASHLIKE:
type_mismatch(lit("~a: hashes not supported"), self, nao);
+ case SEQ_TREELIKE:
+ type_mismatch(lit("~a: trees not supported"), self, nao);
default:
type_mismatch(lit("~a: ~s is not a sequence"), self, seq, nao);
}
@@ -9950,6 +12721,8 @@ val take_while(val pred, val seq, val keyfun)
}
case SEQ_HASHLIKE:
type_mismatch(lit("~a: hashes not supported"), self, nao);
+ case SEQ_TREELIKE:
+ type_mismatch(lit("~a: trees not supported"), self, nao);
default:
type_mismatch(lit("~a: ~s is not a sequence"), self, seq, nao);
}
@@ -9990,6 +12763,8 @@ val take_until(val pred, val seq, val keyfun)
}
case SEQ_HASHLIKE:
type_mismatch(lit("~a: hashes not supported"), self, nao);
+ case SEQ_TREELIKE:
+ type_mismatch(lit("~a: trees not supported"), self, nao);
default:
type_mismatch(lit("~a: ~s is not a sequence"), self, seq, nao);
}
@@ -10024,6 +12799,8 @@ val drop_while(val pred, val seq, val keyfun)
}
case SEQ_HASHLIKE:
type_mismatch(lit("~a: hashes not supported"), self, nao);
+ case SEQ_TREELIKE:
+ type_mismatch(lit("~a: trees not supported"), self, nao);
default:
type_mismatch(lit("~a: ~s is not a sequence"), self, seq, nao);
}
@@ -10057,12 +12834,14 @@ val drop_until(val pred, val seq, val keyfun)
}
case SEQ_HASHLIKE:
type_mismatch(lit("~a: hashes not supported"), self, nao);
+ case SEQ_TREELIKE:
+ type_mismatch(lit("~a: trees not supported"), self, nao);
default:
type_mismatch(lit("~a: ~s is not a sequence"), self, seq, nao);
}
}
-val in(val seq, val item, val testfun, val keyfun)
+val in(val seq, val item, val testfun_in, val keyfun_in)
{
val self = lit("in");
seq_info_t si = seq_info(seq);
@@ -10074,8 +12853,8 @@ val in(val seq, val item, val testfun, val keyfun)
case STR:
case LSTR:
{
- testfun = default_arg(testfun, equal_f);
- keyfun = default_arg(keyfun, identity_f);
+ val testfun = default_arg(testfun_in, equal_f);
+ val keyfun = default_arg(keyfun_in, identity_f);
val len = length_str(seq);
val ind;
@@ -10091,8 +12870,8 @@ val in(val seq, val item, val testfun, val keyfun)
}
case VEC:
{
- testfun = default_arg(testfun, equal_f);
- keyfun = default_arg(keyfun, identity_f);
+ val testfun = default_arg(testfun_in, equal_f);
+ val keyfun = default_arg(keyfun_in, identity_f);
val len = length_vec(seq);
val ind;
@@ -10109,7 +12888,7 @@ val in(val seq, val item, val testfun, val keyfun)
default:
switch (si.kind) {
case SEQ_HASHLIKE:
- if (null_or_missing_p(testfun) && null_or_missing_p(keyfun))
+ if (null_or_missing_p(testfun_in) && null_or_missing_p(keyfun_in))
return tnil(gethash_e(self, si.obj, item));
/* fallthrough */
case SEQ_LISTLIKE:
@@ -10117,12 +12896,11 @@ val in(val seq, val item, val testfun, val keyfun)
{
seq_iter_t iter;
val elem;
+ val testfun = default_arg(testfun_in, equal_f);
+ val keyfun = default_arg(keyfun_in, identity_f);
seq_iter_init(self, &iter, seq);
- testfun = default_arg(testfun, equal_f);
- keyfun = default_arg(keyfun, identity_f);
-
while (seq_get(&iter, &elem)) {
val key = funcall1(keyfun, elem);
if (funcall2(testfun, item, key))
@@ -10132,7 +12910,7 @@ val in(val seq, val item, val testfun, val keyfun)
return nil;
}
default:
- type_mismatch(lit("in: ~s is not a sequence"), seq, nao);
+ type_mismatch(lit("~a: ~s is not a sequence"), self, seq, nao);
}
}
}
@@ -10148,14 +12926,14 @@ val diff(val seq1, val seq2, val testfun, val keyfun)
keyfun = default_arg(keyfun, identity_f);
seq_iter_init(self, &si1, seq1);
- seq_iter_init(self, &si2, seq2);
+ seq_iter_init_with_rewind(self, &si2, seq2);
while (seq_get(&si1, &el1)) {
val el1_key = funcall1(keyfun, el1);
val el2;
int found = 0;
- seq_iter_rewind(self, &si2);
+ seq_iter_rewind(&si2);
while (seq_get(&si2, &el2)) {
val el2_key = funcall1(keyfun, el2);
@@ -10255,13 +13033,13 @@ val isec(val seq1, val seq2, val testfun, val keyfun)
keyfun = default_arg(keyfun, identity_f);
seq_iter_init(self, &si1, seq1);
- seq_iter_init(self, &si2, seq2);
+ seq_iter_init_with_rewind(self, &si2, seq2);
while (seq_get(&si1, &el1)) {
val el1_key = funcall1(keyfun, el1);
val el2;
- seq_iter_rewind(self, &si2);
+ seq_iter_rewind(&si2);
while (seq_get(&si2, &el2)) {
val el2_key = funcall1(keyfun, el2);
@@ -10276,6 +13054,38 @@ val isec(val seq1, val seq2, val testfun, val keyfun)
return make_like(out, seq1);
}
+val isecp(val seq1, val seq2, val testfun, val keyfun)
+{
+ val self = lit("isecp");
+ val out = nil;
+ seq_iter_t si1, si2;
+ val el1;
+
+ testfun = default_arg(testfun, equal_f);
+ keyfun = default_arg(keyfun, identity_f);
+
+ seq_iter_init(self, &si1, seq1);
+ seq_iter_init_with_rewind(self, &si2, seq2);
+
+ while (seq_get(&si1, &el1)) {
+ val el1_key = funcall1(keyfun, el1);
+ val el2;
+
+ seq_iter_rewind(&si2);
+
+ while (seq_get(&si2, &el2)) {
+ val el2_key = funcall1(keyfun, el2);
+
+ if (funcall2(testfun, el1_key, el2_key)) {
+ out = t;
+ break;
+ }
+ }
+ }
+
+ return out;
+}
+
val uni(val seq1, val seq2, val testfun, val keyfun)
{
val self = lit("uni");
@@ -10322,15 +13132,19 @@ val copy(val seq)
return copy_fun(seq);
case TNOD:
return copy_tnode(seq);
+ case CPTR:
+ return copy_cptr(seq);
case COBJ:
- if (seq->co.cls == hash_s)
+ if (seq->co.cls == hash_cls)
return copy_hash(seq);
- if (seq->co.cls == random_state_s)
+ if (seq->co.cls == random_state_cls)
return make_random_state(seq, nil);
- if (seq->co.cls == carray_s)
+ if (seq->co.cls == carray_cls)
return copy_carray(seq);
- if (seq->co.cls == tree_s)
+ if (seq->co.cls == tree_cls)
return copy_search_tree(seq);
+ if (seq->co.cls == tree_iter_cls)
+ return copy_tree_iter(seq);
if (obj_struct_p(seq))
return copy_struct(seq);
/* fallthrough */
@@ -10340,8 +13154,6 @@ val copy(val seq)
}
}
-static val length_proper_list(val list);
-
val length(val seq)
{
switch (type(seq)) {
@@ -10361,10 +13173,12 @@ val length(val seq)
case BUF:
return length_buf(seq);
case COBJ:
- if (seq->co.cls == hash_s)
+ if (seq->co.cls == hash_cls)
return hash_count(seq);
- if (seq->co.cls == carray_s)
+ if (seq->co.cls == carray_cls)
return length_carray(seq);
+ if (seq->co.cls == tree_cls)
+ return tree_count(seq);
if (obj_struct_p(seq)) {
val length_meth = get_special_slot(seq, length_m);
@@ -10382,39 +13196,35 @@ val length(val seq)
}
}
-val empty(val seq)
+val length_lt(val seq, val len)
{
switch (type(seq)) {
case NIL:
- return t;
+ return if3(plusp(len), t, nil);
case CONS:
case LCONS:
- return nil;
- case LIT:
- case STR:
- return if2(c_str(seq)[0] == 0, t);
+ return length_list_lt(seq, len);
case LSTR:
- return length_str_le(seq, zero);
- case VEC:
- return eq(length_vec(seq), zero);
- case RNG:
- return eql(from(seq), to(seq));
- case BUF:
- return eq(length_buf(seq), zero);
+ return length_str_lt(seq, len);
case COBJ:
- if (seq->co.cls == hash_s)
- return eq(hash_count(seq), zero);
- if (seq->co.cls == carray_s)
- return eq(length_carray(seq), zero);
if (obj_struct_p(seq)) {
- val length_meth = get_special_slot(seq, length_m);
- val nullify_meth = if2(nilp(length_meth), get_special_slot(seq, nullify_m));
- if (length_meth)
- return eq(funcall1(length_meth, seq), zero);
- return if3(nullify_meth && funcall1(nullify_meth, seq), nil, seq);
+ val length_lt_meth = get_special_slot(seq, length_lt_m);
+
+ if (length_lt_meth) {
+ return funcall2(length_lt_meth, seq, len);
+ } else {
+ val length_meth = get_special_slot(seq, length_m);
+
+ if (length_meth)
+ return lt(funcall1(length_meth, seq), len);
+ }
+
+ type_mismatch(lit("~a: ~s has no ~a or ~a method"), length_lt_s,
+ seq, length_lt_s, length_s, nao);
}
+ /* fallthrough */
default:
- type_mismatch(lit("empty: ~s is not a sequence"), seq, nao);
+ return lt(length(seq), len);
}
}
@@ -10435,9 +13245,11 @@ val sub(val seq, val from, val to)
case BUF:
return sub_buf(seq, from, to);
case COBJ:
- if (seq->co.cls == carray_s)
+ if (seq->co.cls == carray_cls)
return carray_sub(seq, from, to);
- if (structp(seq)) {
+ if (seq->co.cls == tree_cls)
+ return sub_tree(seq, from, to);
+ if (obj_struct_p(seq)) {
val lambda_meth = get_special_slot(seq, lambda_m);
if (lambda_meth)
return funcall2(lambda_meth, seq, rcons(from, to));
@@ -10446,7 +13258,7 @@ val sub(val seq, val from, val to)
}
/* fallthrough */
default:
- type_mismatch(lit("sub: ~s is not a sequence"), seq, nao);
+ return sub_iter(seq, from, to);
}
}
@@ -10456,10 +13268,12 @@ val ref(val seq, val ind)
case NIL:
return nil;
case COBJ:
- if (seq->co.cls == hash_s)
+ if (seq->co.cls == hash_cls)
return gethash(seq, ind);
- if (seq->co.cls == carray_s)
+ if (seq->co.cls == carray_cls)
return carray_ref(seq, ind);
+ if (seq->co.cls == tree_cls)
+ return tree_lookup(seq, ind);
if (obj_struct_p(seq)) {
val lambda_meth = get_special_slot(seq, lambda_m);
if (lambda_meth)
@@ -10477,6 +13291,8 @@ val ref(val seq, val ind)
return vecref(seq, ind);
case BUF:
return buf_get_uchar(seq, ind);
+ case RNG:
+ return rangeref(seq, ind);
default:
type_mismatch(lit("ref: ~s is not a sequence"), seq, nao);
}
@@ -10506,9 +13322,9 @@ val refset(val seq, val ind, val newval)
case BUF:
return buf_put_uchar(seq, ind, newval);
case COBJ:
- if (seq->co.cls == hash_s)
+ if (seq->co.cls == hash_cls)
return sethash(seq, ind, newval);
- if (seq->co.cls == carray_s)
+ if (seq->co.cls == carray_cls)
return carray_refset(seq, ind, newval);
if (obj_struct_p(seq)) {
{
@@ -10551,7 +13367,7 @@ val replace(val seq, val items, val from, val to)
case BUF:
return replace_buf(seq, items, from, to);
case COBJ:
- if (seq->co.cls == carray_s)
+ if (seq->co.cls == carray_cls)
return carray_replace(seq, items, from, to);
if (obj_struct_p(seq))
return replace_obj(seq, items, from, to);
@@ -10564,42 +13380,78 @@ val replace(val seq, val items, val from, val to)
val dwim_set(val place_p, val seq, varg vargs)
{
val self = lit("index/range assignment");
+ type_t st = type(seq);
- switch (type(seq)) {
- case COBJ:
- if (type(seq) == COBJ) {
- if (seq->co.cls == hash_s) {
- args_normalize_least(vargs, 3);
-
- switch (vargs->fill) {
- case 2:
- (void) sethash(seq, vargs->arg[0], vargs->arg[1]);
- break;
- case 3:
- if (vargs->list)
- goto excargs;
- (void) sethash(seq, vargs->arg[0], vargs->arg[2]);
- break;
- default:
- goto fewargs;
+ switch (st) {
+ case NUM:
+ case BGNUM:
+ case RNG:
+ {
+ args_normalize_least(vargs, 3);
+ switch (vargs->fill) {
+ case 2:
+ {
+ val arg = vargs->arg[0];
+ val newval = vargs->arg[1];
+ switch (type(arg)) {
+ case NUM:
+ case BGNUM:
+ case RNG:
+ goto notplace;
+ default:
+ if (st == RNG) {
+ range_bind (x, y, seq);
+ if (!place_p && listp(arg))
+ goto notplace;
+ return replace(arg, newval, x, y);
+ } else {
+ (void) refset(arg, seq, newval);
+ return seq;
+ }
+ }
}
+ case 1:
+ case 0:
+ goto fewargs;
+ default:
+ goto excargs;
+ }
+ }
+ case COBJ:
+ if (seq->co.cls == hash_cls) {
+ args_normalize_least(vargs, 3);
- return seq;
+ switch (vargs->fill) {
+ case 2:
+ (void) sethash(seq, vargs->arg[0], vargs->arg[1]);
+ break;
+ case 3:
+ if (vargs->list)
+ goto excargs;
+ (void) sethash(seq, vargs->arg[0], vargs->arg[2]);
+ break;
+ case 1:
+ case 0:
+ goto fewargs;
+ default:
+ goto excargs;
}
- if (obj_struct_p(seq)) {
- {
- val lambda_set_meth = get_special_slot(seq, lambda_set_m);
- if (lambda_set_meth) {
- (void) funcall(method_args(seq, lambda_set_s, vargs));
- return seq;
- }
+
+ return seq;
+ }
+ if (obj_struct_p(seq)) {
+ {
+ val lambda_set_meth = get_special_slot(seq, lambda_set_m);
+ if (lambda_set_meth) {
+ (void) funcall(method_args(seq, lambda_set_s, vargs));
+ return seq;
}
- if (get_special_slot(seq, car_m))
- goto list;
- type_mismatch(lit("~a: object ~s lacks "
- "~s or ~s method"),
- self, seq, lambda_set_s, car_s, nao);
}
+ if (get_special_slot(seq, car_m))
+ goto list;
+ type_mismatch(lit("~a: object ~s lacks "
+ "~s or ~s method"),
+ self, seq, lambda_set_s, car_s, nao);
}
/* fallthrough */
default:
@@ -10634,7 +13486,7 @@ val dwim_set(val place_p, val seq, varg vargs)
}
}
notplace:
- uw_throwf(error_s, lit("~a: list form must be place"), self, nao);
+ uw_throwf(error_s, lit("~a: mutated object must be place"), self, nao);
fewargs:
uw_throwf(error_s, lit("~a: missing required arguments"), self, nao);
excargs:
@@ -10652,24 +13504,42 @@ val dwim_del(val place_p, val seq, val ind_range)
nao);
break;
case COBJ:
- if (seq->co.cls == hash_s) {
+ if (seq->co.cls == hash_cls) {
(void) remhash(seq, ind_range);
return seq;
}
- if (obj_struct_p(seq))
- uw_throwf(error_s, lit("index/range delete: not supported for structs"),
- nao);
default:
break;
}
- if (rangep(ind_range)) {
- return replace(seq, nil, from(ind_range), to(ind_range));
- } else {
+ switch (type(ind_range)) {
+ case NIL:
+ case CONS:
+ case LCONS:
+ case VEC:
+ return replace(seq, nil, ind_range, colon_k);
+ case RNG:
+ {
+ range_bind (x, y, ind_range);
+ return replace(seq, nil, x, y);
+ }
+ default:
return replace(seq, nil, ind_range, succ(ind_range));
}
}
+val mref(val obj, varg args)
+{
+ cnum index = 0;
+
+ while (args_more(args, index)) {
+ val idx = args_get(args, &index);
+ obj = funcall1(obj, idx);
+ }
+
+ return obj;
+}
+
val butlast(val seq, val idx)
{
if (listp(seq)) {
@@ -10682,11 +13552,13 @@ val butlast(val seq, val idx)
val update(val seq, val fun)
{
- switch (type(seq)) {
- case NIL:
- break;
- case CONS:
- case LCONS:
+ val self = lit("update");
+ seq_info_t si = seq_info(seq);
+
+ switch (si.kind) {
+ case SEQ_NIL:
+ return nil;
+ case SEQ_LISTLIKE:
{
val iter = seq;
@@ -10696,10 +13568,7 @@ val update(val seq, val fun)
}
}
break;
- case LIT:
- case STR:
- case LSTR:
- case VEC:
+ case SEQ_VECLIKE:
{
val len = length(seq);
val i;
@@ -10707,177 +13576,142 @@ val update(val seq, val fun)
refset(seq, i, funcall1(fun, ref(seq, i)));
}
break;
- case COBJ:
- if (hashp(seq))
- return hash_update(seq, fun);
- /* fallthrough */
+ case SEQ_HASHLIKE:
+ return hash_update(seq, fun);
+ case SEQ_TREELIKE:
+ type_mismatch(lit("~a: trees not supported"), self, nao);
default:
- type_mismatch(lit("update: ~s is not a sequence"), seq, nao);
+ type_mismatch(lit("~a: ~s is not a sequence"), self, seq, nao);
}
return seq;
}
-static val search_list(val seq, val key, val testfun, val keyfun)
+static val search_common(val self, int all, int from_right,
+ val seq, val key, val testfun_in, val keyfun_in)
{
- val siter, kiter;
- val pos = zero;
+ val testfun = default_arg(testfun_in, equal_f);
+ val keyfun = default_arg(keyfun_in, identity_f);
+ seq_iter_t si, ki;
- switch (type(key)) {
- case NIL:
- return pos;
- case CONS:
- case LCONS:
- case LIT:
- case STR:
- case LSTR:
- case VEC:
- /* TODO: optimize me */
- gc_hint(seq);
+ seq_iter_init(self, &si, seq);
+ seq_iter_init(self, &ki, key);
- for (; seq; seq = cdr(seq)) {
- for (siter = seq, kiter = key;
- siter && kiter;
- siter = cdr(siter), kiter = cdr(kiter))
- {
- if (!funcall2(testfun,
- funcall1(keyfun, car(siter)),
- funcall1(keyfun, car(kiter))))
- {
+ if (si.inf.kind == SEQ_NIL) {
+ val kelem;
+ return if2(!seq_peek(&ki, &kelem),
+ if3(all, cons(zero, nil), zero));
+ } else if (ki.inf.kind == SEQ_HASHLIKE || si.inf.kind == SEQ_HASHLIKE) {
+ type_mismatch(lit("~a: hashes not supported"), self, nao);
+ } else if (!all && ki.inf.kind == SEQ_NIL) {
+ return if3(from_right, length(seq), zero);
+ } else {
+ val selem, kelem;
+ val pos = zero;
+ list_collect_decl (found, ptail);
+
+ if (!seq_peek(&ki, &kelem)) {
+ if (all) {
+ while (seq_get(&si, &selem)) {
+ ptail = list_collect(ptail, pos);
pos = plus(pos, one);
- break;
}
+ list_collect(ptail, pos);
+ return found;
}
-
- if (!kiter)
- return pos;
-
- if (!siter)
- break;
+ return if3(from_right, length(seq), zero);
}
- break;
- default:
- type_mismatch(lit("search: ~s is not a sequence"), seq, nao);
- }
-
- return nil;
-}
-
-val search(val seq, val key, val testfun, val keyfun)
-{
- testfun = default_arg(testfun, equal_f);
- keyfun = default_arg(keyfun, identity_f);
- seq = nullify(seq);
-
- switch (type(seq)) {
- case NIL:
- return if3(length(key) == zero, zero, nil);
- case CONS:
- case LCONS:
- case LIT:
- case STR:
- case LSTR:
- case VEC:
- case COBJ:
- /* TODO: optimize me */
- return search_list(seq, key, testfun, keyfun);
- default:
- type_mismatch(lit("search: ~s is not a sequence"), seq, nao);
- }
-}
-val contains(val key, val seq, val testfun, val keyfun)
-{
- return search(seq, key, testfun, keyfun);
-}
+ for (;;) {
+ val did_save = nil;
+ val saved_seq_pos = nil;
+ val saved_key_pos = nil;
+ int more_seq, more_key;
+
+ while ((more_seq = seq_peek(&si, &selem),
+ more_key = seq_peek(&ki, &kelem),
+ more_key && more_seq))
+ {
+ if (!did_save)
+ saved_key_pos = seq_getpos(self, &ki);
-static val rsearch_list(val seq, val key, val testfun, val keyfun)
-{
- val siter, kiter;
- val pos = zero;
- val found = nil;
+ seq_geti(&si);
+ seq_geti(&ki);
- switch (type(key)) {
- case NIL:
- return pos;
- case CONS:
- case LCONS:
- case LIT:
- case STR:
- case LSTR:
- case VEC:
- /* TODO: optimize me */
- gc_hint(seq);
+ if (!did_save) {
+ saved_seq_pos = seq_getpos(self, &si);
+ did_save = t;
+ }
- for (; seq; seq = cdr(seq)) {
- for (siter = seq, kiter = key;
- siter && kiter;
- siter = cdr(siter), kiter = cdr(kiter))
- {
if (!funcall2(testfun,
- funcall1(keyfun, car(siter)),
- funcall1(keyfun, car(kiter))))
+ funcall1(keyfun, selem),
+ funcall1(keyfun, kelem)))
{
- pos = plus(pos, one);
break;
}
}
- if (!kiter)
- found = pos;
+ if (!more_key) {
+ if (all)
+ ptail = list_collect(ptail, pos);
+ else if (from_right)
+ found = pos;
+ else
+ return pos;
+ }
- if (!siter)
- break;
+ if (!more_seq)
+ return found;
+
+ pos = plus(pos, one);
+ seq_setpos(self, &si, saved_seq_pos);
+ seq_setpos(self, &ki, saved_key_pos);
}
- break;
- default:
- type_mismatch(lit("rsearch: ~s is not a sequence"), seq, nao);
}
+}
- return found;
+val search(val seq, val key, val testfun, val keyfun)
+{
+ return search_common(lit("search"), 0, 0, seq, key, testfun, keyfun);
}
val rsearch(val seq, val key, val testfun, val keyfun)
{
- testfun = default_arg(testfun, equal_f);
- keyfun = default_arg(keyfun, identity_f);
- seq = nullify(seq);
+ return search_common(lit("rsearch"), 0, 1, seq, key, testfun, keyfun);
+}
- switch (type(seq)) {
- case NIL:
- return if3(length(key) == zero, zero, nil);
- case CONS:
- case LCONS:
- case LIT:
- case STR:
- case LSTR:
- case VEC:
- case COBJ:
- /* TODO: optimize me */
- return rsearch_list(seq, key, testfun, keyfun);
- default:
- type_mismatch(lit("rsearch: ~s is not a sequence"), seq, nao);
- }
+val contains(val key, val seq, val testfun, val keyfun)
+{
+ return search_common(lit("contains"), 0, 0, seq, key, testfun, keyfun);
}
-static val lazy_where_func(val seq_iter, val lcons)
+val search_all(val seq, val key, val testfun, val keyfun)
{
- struct seq_iter *si = coerce(struct seq_iter *, seq_iter->co.handle);
+ return search_common(lit("search-all"), 1, 0, seq, key, testfun, keyfun);
+}
+
+static val lazy_where_func(val iter, val lcons)
+{
+ val iter_orig = iter;
us_cons_bind (index, func, lcons);
for (;;) {
- val item;
- if (!si->get(si, &item)) {
+ if (!iter_more(iter)) {
us_rplacd(lcons, nil);
return nil;
}
index = succ(index);
- if (funcall1(func, item))
+ if (funcall1(func, iter_item(iter)))
break;
+ iter = iter_step(iter);
}
+ iter = iter_step(iter);
{
- us_rplacd(lcons, make_lazy_cons_car_cdr(lcons_fun(lcons), index, func));
+ val fun = us_lcons_fun(lcons);
+ if (iter != iter_orig)
+ us_func_set_env(fun, iter);
+ us_rplacd(lcons, make_lazy_cons_car_cdr(fun, index, func));
return nil;
}
}
@@ -10905,25 +13739,29 @@ static val lazy_where_hash_func(val hash_iter, val lcons)
}
}
-val where(val func, val seq)
+static val lazy_where_tree_func(val tree_iter, val lcons)
{
- if (!hashp(seq)) {
- val seq_iter = seq_begin(seq);
- val index = zero;
- struct seq_iter *si = coerce(struct seq_iter *, seq_iter->co.handle);
+ val func = us_cdr(lcons);
- for (;;) {
- val item;
- if (!si->get(si, &item))
+ for (;;) {
+ val node = tree_next(tree_iter);
+ if (!node) {
+ us_rplacd(lcons, nil);
+ return nil;
+ } else {
+ val ky = key(node);
+ if (funcall1(func, ky)) {
+ val fun = us_lcons_fun(lcons);
+ us_rplacd(lcons, make_lazy_cons_car_cdr(fun, ky, func));
return nil;
- if (funcall1(func, item))
- break;
- index = succ(index);
+ }
}
+ }
+}
- return make_lazy_cons_car_cdr(func_f1(seq_iter, lazy_where_func),
- index, func);
- } else {
+val where(val func, val seq)
+{
+ if (hashp(seq)) {
val hash_iter = hash_begin(seq);
val key;
@@ -10939,6 +13777,36 @@ val where(val func, val seq)
return make_lazy_cons_car_cdr(func_f1(hash_iter, lazy_where_hash_func),
key, func);
+ } else if (treep(seq)) {
+ val tree_iter = tree_begin(seq, colon_k, colon_k);
+
+ for (;;) {
+ val node = tree_next(tree_iter);
+ if (!node) {
+ return nil;
+ } else {
+ val ky = key(node);
+ if (funcall1(func, ky))
+ return make_lazy_cons_car_cdr(func_f1(tree_iter, lazy_where_tree_func),
+ ky, func);
+ }
+ }
+ } else {
+ val iter = iter_begin(seq);
+ val index = zero;
+
+ for (;;) {
+ if (!iter_more(iter))
+ return nil;
+ if (funcall1(func, iter_item(iter)))
+ break;
+ iter = iter_step(iter);
+ index = succ(index);
+ }
+
+ iter = iter_step(iter);
+ return make_lazy_cons_car_cdr(func_f1(iter, lazy_where_func),
+ index, func);
}
}
@@ -10970,6 +13838,18 @@ val sel(val seq, val where_in)
return newhash;
}
+ case SEQ_TREELIKE:
+ {
+ val newtree = make_similar_tree(si.obj);
+
+ while (seq_get(&wh_iter, &wh)) {
+ val node = tree_lookup_node(seq, wh);
+ if (node)
+ tree_insert(newtree, key(node), t);
+ }
+
+ return newtree;
+ }
case SEQ_LISTLIKE:
{
val idx = zero;
@@ -11010,6 +13890,51 @@ val sel(val seq, val where_in)
return make_like(out, seq);
}
+val reject(val seq, val where_in)
+{
+ val self = lit("reject");
+ seq_info_t si = seq_info(seq);
+ val (*appendfn)(val) = lazy_appendl;
+
+ switch (si.kind) {
+ case SEQ_NIL:
+ return nil;
+ case SEQ_HASHLIKE:
+ case SEQ_TREELIKE:
+ {
+ seq_iter_t wh_iter;
+ val wh;
+ val newobj = copy(si.obj);
+ val where = if3(functionp(where_in),
+ funcall1(where_in, seq),
+ where_in);
+ seq_iter_init(self, &wh_iter, where);
+
+ if (si.kind == SEQ_HASHLIKE)
+ while (seq_get(&wh_iter, &wh))
+ remhash(newobj, wh);
+ else
+ while (seq_get(&wh_iter, &wh))
+ tree_delete(newobj, wh);
+
+ return newobj;
+ }
+ case SEQ_VECLIKE:
+ appendfn = appendl;
+ /* fallthrough */
+ case SEQ_LISTLIKE:
+ {
+ val list = appendfn(split_star(seq, where_in));
+ return make_like(list, seq);
+ }
+ break;
+ case SEQ_NOTSEQ:
+ type_mismatch(lit("~a: ~s is not a sequence"), self, seq, nao);
+ }
+
+ abort();
+}
+
static val do_relate(val env, val arg)
{
cons_bind (dom, rng, env);
@@ -11044,7 +13969,7 @@ val relate(val domain_seq, val range_seq, val dfl_val)
val lds = length(domain_seq);
val use_hash = and2(gt(lds, num_fast(10)),
le(lds, length(range_seq)));
- args_decl(args, ARGS_MIN);
+ args_decl_constsize(args, ARGS_MIN);
val hash = if2(use_hash, hash_zip(domain_seq, range_seq, args));
return if3(missingp(dfl_val),
@@ -11119,43 +14044,49 @@ val in_range_star(val range, val num)
}
}
-val env(void)
+val rangeref(val range, val ind)
{
- if (env_list) {
- return env_list;
- } else {
- list_collect_decl (out, ptail);
-#if HAVE_ENVIRON
- extern char **environ;
- char **iter = environ;
+ val self = lit("rangeref");
- for (; *iter != 0; iter++)
- ptail = list_collect(ptail, string_utf8(*iter));
-
- return env_list = out;
-#elif HAVE_GETENVIRONMENTSTRINGS
- wchar_t *env = GetEnvironmentStringsW();
- wchar_t *iter = env;
+ if (integerp(ind))
+ {
+ val fr = range->rn.from;
+ val to = range->rn.to;
+ val eind = ind;
- if (iter == 0)
- oom();
+ if (to != t && to != colon_k) {
+ val len = minus(to, fr);
- for (; *iter; iter += wcslen(iter) + 1)
- ptail = list_collect(ptail, string(iter));
+ if (minusp(eind))
+ eind = plus(eind, len);
- FreeEnvironmentStringsW(env);
+ if (minusp(eind) || ge(eind, len))
+ goto err;
+ } else if (minusp(eind)) {
+ goto err;
+ }
- return env_list = out;
-#else
- uw_throwf(error_s, lit("environment strings not available"), nao);
-#endif
+ return plus(fr, eind);
+ err:
+ uw_throwf(error_s, lit("~a: ~s is out of range for ~s"),
+ self, ind, range, nao);
}
+
+ return sub(ind, range->rn.from, range->rn.to);
}
-static void obj_init(void)
+#if CONFIG_LOCALE_TOLERANCE
+
+static void locale_init(void)
{
- val self = lit("internal init");
+ struct lconv *lc = localeconv();
+ dec_point = *lc->decimal_point;
+}
+
+#endif
+static void obj_init(void)
+{
/*
* No need to GC-protect the convenience variables which hold the interned
* symbols, because the interned_syms list holds a reference to all the
@@ -11164,21 +14095,20 @@ static void obj_init(void)
protect(&packages, &system_package, &keyword_package,
&user_package, &public_package,
- &null_list, &equal_f, &eq_f, &eql_f,
+ &equal_f, &eq_f, &eql_f,
&car_f, &cdr_f, &null_f, &list_f,
- &identity_f, &identity_star_f, &less_f, &greater_f,
- &prog_string, &env_list,
+ &identity_f, &identity_star_f, &less_f, &greater_f, &gt_f,
+ &prog_string, &cobj_hash, &lazy_streams_binding, &hist_succ_f,
convert(val *, 0));
nil_string = lit("nil");
null_string = lit("");
- null_list = cons(nil, nil);
hash_s = make_sym(lit("hash"));
- system_package = make_package(lit("sys"));
- keyword_package = make_package(lit("keyword"));
- user_package = make_package(lit("usr"));
- public_package = make_package(lit("pub"));
+ system_package = make_package(lit("sys"), nil);
+ keyword_package = make_package(lit("keyword"), nil);
+ user_package = make_package(lit("usr"), nil);
+ public_package = make_package(lit("pub"), nil);
rehome_sym(hash_s, user_package);
@@ -11187,10 +14117,8 @@ static void obj_init(void)
symbol-manipulating function. */
sethash(user_package->pk.symhash, nil_string, nil);
- /* t can't be interned, because intern needs t in order to do its job. */
- t = cdr(rplacd(gethash_c(self, user_package->pk.symhash,
- lit("t"), nulloc), make_sym(lit("t"))));
- set(mkloc(t->s.package, t), user_package);
+ /* Replace fake t (value 1 set in init) with real symbol. */
+ t = intern(lit("t"), user_package);
set_package_fallback_list(system_package, cons(user_package, nil));
set_package_fallback_list(public_package, cons(user_package, nil));
@@ -11266,6 +14194,7 @@ static void obj_init(void)
coll_s = intern(lit("coll"), user_package);
define_s = intern(lit("define"), user_package);
output_s = intern(lit("output"), user_package);
+ push_s = intern(lit("push"), user_package);
single_s = intern(lit("single"), user_package);
first_s = intern(lit("first"), user_package);
last_s = intern(lit("last"), user_package);
@@ -11300,6 +14229,7 @@ static void obj_init(void)
system_error_s = intern(lit("system-error"), user_package);
timeout_error_s = intern(lit("timeout-error"), user_package);
alloc_error_s = intern(lit("alloc-error"), user_package);
+ stack_overflow_s = intern(lit("stack-overflow"), user_package);
path_not_found_s = intern(lit("path-not-found"), user_package);
path_exists_s = intern(lit("path-exists"), user_package);
path_permission_s = intern(lit("path-permission"), user_package);
@@ -11310,18 +14240,22 @@ static void obj_init(void)
continue_s = intern(lit("continue"), user_package);
name_s = intern(lit("name"), user_package);
length_s = intern(lit("length"), user_package);
+ length_lt_s = intern(lit("length-<"), user_package);
rplaca_s = intern(lit("rplaca"), user_package);
rplacd_s = intern(lit("rplacd"), user_package);
seq_iter_s = intern(lit("seq-iter"), user_package);
+ lazy_streams_s = intern(lit("*lazy-streams*"), system_package);
args_k = intern(lit("args"), keyword_package);
nothrow_k = intern(lit("nothrow"), keyword_package);
- colon_k = intern(lit(""), keyword_package);
+ colon_k = intern(null_string, keyword_package);
auto_k = intern(lit("auto"), keyword_package);
fun_k = intern(lit("fun"), keyword_package);
wrap_k = intern(lit("wrap"), keyword_package);
reflect_k = intern(lit("reflect"), keyword_package);
+ seq_iter_cls = cobj_register(seq_iter_s);
+
equal_f = func_n2(equal);
eq_f = func_n2(eq);
eql_f = func_n2(eql);
@@ -11333,7 +14267,12 @@ static void obj_init(void)
list_f = func_n0v(listv);
less_f = func_n2(less);
greater_f = func_n2(greater);
+ gt_f = func_n2(gt);
prog_string = string(progname);
+
+ cobj_hash = make_hash(hash_weak_none, nil);
+
+ hist_succ_f = func_n2(hist_succ);
}
static val simple_qref_args_p(val args, val pos)
@@ -11344,10 +14283,18 @@ static val simple_qref_args_p(val args, val pos)
return nil;
} else {
val arg = car(args);
- if (symbolp(arg) || (consp(arg) &&
- car(arg) != qref_s &&
- car(arg) != uref_s))
- {
+
+ if (symbolp(arg)) {
+ val name = symbol_name(arg);
+ if (length(name) == zero)
+ return nil;
+ if (!zerop(pos) && chr_isdigit(chr_str(name, zero)))
+ {
+ return nil;
+ }
+ return simple_qref_args_p(cdr(args), succ(pos));
+ }
+ if (consp(arg) && car(arg) != qref_s && car(arg) != uref_s) {
return simple_qref_args_p(cdr(args), succ(pos));
}
return nil;
@@ -11406,19 +14353,20 @@ static void out_str_readable(const wchar_t *ptr, val out, int *semi_flag)
static void out_lazy_str(val lstr, val out, struct strm_base *strm)
{
+ val self = lit("print");
int semi_flag = 0;
val lim = lstr->ls.props->limit;
val term = lstr->ls.props->term;
val iter;
const wchar_t *wcterm;
cnum max_len = strm->max_length;
- cnum max_chr = if3(max_len, max(max_len, 15), 0);
+ cnum max_chr = max_len ? max_str_chars(max_len) : 0;
- wcterm = c_str(term);
+ wcterm = c_str(term, self);
put_char(chr('"'), out);
- out_str_readable(c_str(lstr->ls.prefix), out, &semi_flag);
+ out_str_readable(c_str(lstr->ls.prefix, self), out, &semi_flag);
for (iter = lstr->ls.list; (!lim || gt(lim, zero)) && iter;
iter = cdr(iter))
@@ -11428,14 +14376,15 @@ static void out_lazy_str(val lstr, val out, struct strm_base *strm)
break;
if (max_len) {
if (length_str_gt(str, num(max_chr))) {
- out_str_readable(c_str(sub_str(str, zero, num(max_chr))), out, &semi_flag);
+ out_str_readable(c_str(sub_str(str, zero, num(max_chr)), self),
+ out, &semi_flag);
goto max_reached;
}
- if (--max_len == 0)
+ if (--max_chr == 0)
goto max_reached;
- max_chr -= c_num(length_str(str));
+ max_chr -= c_num(length_str(str), self);
}
- out_str_readable(c_str(str), out, &semi_flag);
+ out_str_readable(c_str(str, self), out, &semi_flag);
out_str_readable(wcterm, out, &semi_flag);
if (lim)
lim = pred(lim);
@@ -11481,11 +14430,10 @@ static void out_quasi_str_sym(val name, val mods, val rem_args,
static void out_quasi_str(val args, val out, struct strm_ctx *ctx)
{
+ val self = lit("print");
val iter, next;
cnum max_len = ctx->strm->max_length, max_count = max_len;
-
- if (max_len)
- max_len = max(15, max_len);
+ cnum max_chr = max_len ? max_str_chars(max_len) : 0;
for (iter = cdr(args); iter; iter = next) {
val elem = car(iter);
@@ -11493,14 +14441,15 @@ static void out_quasi_str(val args, val out, struct strm_ctx *ctx)
if (stringp(elem)) {
int semi_flag = 0;
- if (max_len && length_str_gt(elem, num(max_len))) {
- out_str_readable(c_str(sub_str(elem, zero, num(max_len))), out, &semi_flag);
+ if (max_len && length_str_gt(elem, num(max_chr))) {
+ out_str_readable(c_str(sub_str(elem, zero, num(max_chr)), self),
+ out, &semi_flag);
goto max_exceeded;
} else {
- out_str_readable(c_str(elem), out, &semi_flag);
+ out_str_readable(c_str(elem, self), out, &semi_flag);
if (max_len) {
- max_len -= c_num(length(elem));
- if (max_len == 0) {
+ max_chr -= c_num(length(elem), self);
+ if (max_chr == 0) {
goto max_reached;
}
}
@@ -11533,26 +14482,87 @@ max_exceeded:
put_string(lit("\\..."), out);
}
-INLINE int circle_print_eligible(val obj)
+static void out_json_str(val str, val out)
{
- return is_ptr(obj) && (!symbolp(obj) || !symbol_package(obj));
+ val self = lit("print");
+ const wchar_t *cstr = c_str(str, self);
+ wchar_t ch;
+
+ put_char(chr('"'), out);
+
+ while ((ch = *cstr++)) {
+ switch (ch) {
+ case '\\':
+ case '"':
+ put_char(chr('\\'), out);
+ put_char(chr(ch), out);
+ break;
+ case '\b':
+ put_string(lit("\\b"), out);
+ break;
+ case '\f':
+ put_string(lit("\\f"), out);
+ break;
+ case '\n':
+ put_string(lit("\\n"), out);
+ break;
+ case '\r':
+ put_string(lit("\\r"), out);
+ break;
+ case '\t':
+ put_string(lit("\\t"), out);
+ break;
+ case '<':
+ put_char(chr(ch), out);
+ if (wcsncmp(cstr, L"/script", 7) == 0) {
+ put_char(chr('\\'), out);
+ } else if (wcsncmp(cstr, L"!--", 3) == 0) {
+ put_string(lit("\\u0021"), out);
+ cstr++;
+ }
+ break;
+ case '-':
+ put_char(chr(ch), out);
+ if (wcsncmp(cstr, L"->", 2) == 0) {
+ put_string(lit("\\u002D"), out);
+ cstr++;
+ }
+ break;
+ case 0xDC00:
+ put_string(lit("\\u0000"), out);
+ break;
+ default:
+ {
+
+ if ((ch < 0x20) || (ch >= 0x7F && ch < 0xA0) ||
+ (ch >= 0xD800 && ch < 0xDC00) ||
+ (ch >= 0xDD00 && ch < 0xE000) ||
+ ch == 0xFFFE || ch == 0xFFFF)
+ {
+ format(out, lit("\\u~,04X"), chr(ch), nao);
+ } else if (ch >= 0xFFFF) {
+ wchar_t c20 = ch - 0x10000;
+ wchar_t sg0 = 0xD800 + ((c20 >> 10) & 0x3FF);
+ wchar_t sg1 = 0xDC00 + (c20 & 0x3FF);
+ format(out, lit("\\u~,04X\\u~,04X"), chr(sg0), chr(sg1), nao);
+ } else {
+ put_char(chr(ch), out);
+ }
+ }
+ break;
+ }
+ }
+
+ put_char(chr('"'), out);
}
-static int unquote_star_check(val obj, val pretty)
+INLINE int circle_print_eligible(val obj)
{
- if (!obj || !symbolp(obj))
- return 0;
- if (car(obj->s.name) != chr('*'))
- return 0;
- return pretty || !symbol_needs_prefix(lit("print"), cur_package, obj);
+ return is_ptr(obj) && (!symbolp(obj) || !symbol_package(obj));
}
-val obj_print_impl(val obj, val out, val pretty, struct strm_ctx *ctx)
+static int check_emit_circle(val obj, val out, struct strm_ctx *ctx, val self)
{
- val self = lit("print");
- val ret = obj;
- cnum save_depth = ctx->depth;
-
if (ctx->obj_hash && circle_print_eligible(obj)) {
loc pcdr = gethash_l(self, ctx->obj_hash, obj, nulloc);
val label = deref(pcdr);
@@ -11564,12 +14574,274 @@ val obj_print_impl(val obj, val out, val pretty, struct strm_ctx *ctx)
format(out, lit("#~s="), counter, nao);
} else if (integerp(label)) {
format(out, lit("#~s#"), label, nao);
- return ret;
+ return 1;
} else if (!label) {
set(pcdr, colon_k);
}
}
+ return 0;
+}
+
+static void out_json_rec(val obj, val out, enum json_fmt jf,
+ struct strm_ctx *ctx)
+{
+ val self = lit("print");
+
+ if (ctx && check_emit_circle(obj, out, ctx, self))
+ return;
+
+ switch (type(obj)) {
+ case NIL:
+ put_string(lit("false"), out);
+ return;
+ case SYM:
+ if (obj == t) {
+ put_string(lit("true"), out);
+ return;
+ }
+ if (obj == null_s) {
+ put_string(lit("null"), out);
+ return;
+ }
+ break;
+ case LCONS:
+ case CONS:
+ if (ctx != 0) {
+ val sym = car(obj);
+ if (sym == hash_lit_s) {
+ val save_indent;
+ int force_br = 0;
+ val iter, next;
+
+ if (jf == json_fmt_standard) {
+ put_string(lit("{\n"), out);
+ save_indent = inc_indent_abs(out, two);
+ } else {
+ put_char(chr('{'), out);
+ save_indent = inc_indent(out, zero);
+ }
+
+ for (iter = cddr(obj), next = nil; iter; iter = next) {
+ val pair = car(iter);
+ val k = car(pair), v = cadr(pair);
+ if (jf == json_fmt_standard || consp(k) || consp(v)) {
+ if (jf != json_fmt_standard && next)
+ put_char(chr(' '), out);
+ out_json_rec(k, out, jf, ctx);
+ put_string(lit(" : "), out);
+ } else {
+ out_json_rec(k, out, jf, ctx);
+ put_char(chr(':'), out);
+ }
+ out_json_rec(v, out, jf, ctx);
+
+ if (jf == json_fmt_standard) {
+ if ((next = cdr(iter)) != 0)
+ put_string(lit(",\n"), out);
+ else
+ put_char(chr('\n'), out);
+ } else if ((next = cdr(iter)) != 0) {
+ put_char(chr(','), out);
+ if (width_check(out, nil))
+ force_br = 1;
+ }
+ }
+ set_indent(out, save_indent);
+ put_char(chr('}'), out);
+ if (force_br)
+ force_break(out);
+ return;
+ }
+ if (sym == vector_lit_s) {
+ val save_indent;
+ int force_br = 0;
+ val iter, next;
+
+ if (jf == json_fmt_standard) {
+ put_string(lit("[\n"), out);
+ save_indent = inc_indent_abs(out, two);
+ } else {
+ put_char(chr('['), out);
+ save_indent = inc_indent(out, zero);
+ }
+
+ for (iter = cadr(obj), next = nil; iter; iter = next) {
+ val elem = car(iter);
+ next = cdr(iter);
+ out_json_rec(elem, out, jf, ctx);
+ if (jf == json_fmt_standard) {
+ if (next)
+ put_string(lit(",\n"), out);
+ else
+ put_char(chr('\n'), out);
+ } else if (next) {
+ put_char(chr(','), out);
+ if (width_check(out, nil))
+ force_br = 1;
+ }
+ }
+ set_indent(out, save_indent);
+ put_char(chr(']'), out);
+ if (force_br)
+ force_break(out);
+ return;
+ }
+ if (sym == sys_unquote_s) {
+ put_char(chr('~'), out);
+ obj_print_impl(cadr(obj), out, nil, ctx);
+ return;
+ }
+ if (sym == sys_splice_s) {
+ put_string(lit("~*"), out);
+ obj_print_impl(cadr(obj), out, nil, ctx);
+ return;
+ }
+ }
+ /* fallthrough */
+ case VEC:
+ {
+ val save_indent;
+ int force_br = 0;
+ seq_iter_t si;
+ val elem;
+ seq_iter_init(self, &si, obj);
+
+ if (jf == json_fmt_standard) {
+ put_string(lit("[\n"), out);
+ save_indent = inc_indent_abs(out, two);
+ } else {
+ put_char(chr('['), out);
+ save_indent = inc_indent(out, zero);
+ }
+
+ if (seq_get(&si, &elem)) for (;;) {
+ val nxelem;
+ int more = seq_get(&si, &nxelem);
+ out_json_rec(elem, out, jf, ctx);
+ if (jf == json_fmt_standard) {
+ if (more)
+ put_string(lit(",\n"), out);
+ else
+ put_char(chr('\n'), out);
+ } else if (more) {
+ put_char(chr(','), out);
+ if (width_check(out, nil))
+ force_br = 1;
+ }
+ if (!more)
+ break;
+ elem = nxelem;
+ }
+ set_indent(out, save_indent);
+ put_char(chr(']'), out);
+ if (force_br)
+ force_break(out);
+ return;
+ }
+ break;
+ case COBJ:
+ if (hashp(obj)) {
+ val save_indent;
+ int force_br = 0;
+ val cell, next;
+ struct hash_iter hi;
+
+ us_hash_iter_init(&hi, obj);
+
+ if (jf == json_fmt_standard) {
+ put_string(lit("{\n"), out);
+ save_indent = inc_indent_abs(out, two);
+ } else {
+ put_char(chr('{'), out);
+ save_indent = inc_indent(out, zero);
+ }
+
+ for (next = nil, cell = hash_iter_next(&hi); cell; cell = next) {
+ val k = car(cell), v = cdr(cell);
+
+ if (jf == json_fmt_standard || consp(k) || consp(v)) {
+ if (jf != json_fmt_standard && next)
+ put_char(chr(' '), out);
+ out_json_rec(k, out, jf, ctx);
+ put_string(lit(" : "), out);
+ } else {
+ out_json_rec(k, out, jf, ctx);
+ put_char(chr(':'), out);
+ }
+ out_json_rec(v, out, jf, ctx);
+ if (jf == json_fmt_standard) {
+ if ((next = hash_iter_next(&hi)) != 0)
+ put_string(lit(",\n"), out);
+ else
+ put_char(chr('\n'), out);
+ } else if ((next = hash_iter_next(&hi)) != 0) {
+ put_char(chr(','), out);
+ if (jf == json_fmt_standard)
+ put_char(chr('\n'), out);
+ else if (width_check(out, nil))
+ force_br = 1;
+ }
+ }
+ set_indent(out, save_indent);
+ put_char(chr('}'), out);
+ if (force_br)
+ force_break(out);
+ return;
+ }
+ break;
+ case FLNUM:
+ case NUM:
+ case BGNUM:
+ format(out, lit("~a"), obj, nao);
+ return;
+ case LIT:
+ case STR:
+ case LSTR:
+ out_json_str(obj, out);
+ return;
+ default:
+ break;
+ }
+
+ uw_throwf(type_error_s, lit("~a: invalid object ~s in JSON"),
+ self, obj, nao);
+}
+
+static void out_json(val op, val obj, val out, struct strm_ctx *ctx)
+{
+ val save_mode = test_set_indent_mode(out, num_fast(indent_off),
+ num_fast(indent_data));
+ val jfsym = cdr(lookup_var(nil, print_json_format_s));
+ enum json_fmt jf = if3(jfsym == standard_k,
+ json_fmt_standard,
+ json_fmt_default);
+ if (op == sys_qquote_s)
+ put_char(chr('^'), out);
+ out_json_rec(obj, out, jf, ctx);
+ set_indent_mode(out, save_mode);
+}
+
+static int unquote_star_check(val obj, val pretty)
+{
+ if (!obj || !symbolp(obj))
+ return 0;
+ if (car(obj->s.name) != chr('*'))
+ return 0;
+ return pretty || !symbol_needs_prefix(lit("print"), cur_package, obj);
+}
+
+val obj_print_impl(val obj, val out, val pretty, struct strm_ctx *ctx)
+{
+ val self = lit("print");
+ val ret = obj;
+ cnum save_depth = ctx->depth;
+
+ gc_stack_check();
+
+ if (check_emit_circle(obj, out, ctx, self))
+ return ret;
+
if (ctx->strm->max_depth) {
if (ctx->depth > ctx->strm->max_depth) {
put_string(lit("..."), out);
@@ -11592,6 +14864,9 @@ val obj_print_impl(val obj, val out, val pretty, struct strm_ctx *ctx)
} else if (structp(obj)) {
put_string(lit("#S(...)"), out);
return obj;
+ } else if (treep(obj)) {
+ put_string(lit("#T(...)"), out);
+ return obj;
}
default:
break;
@@ -11613,47 +14888,74 @@ val obj_print_impl(val obj, val out, val pretty, struct strm_ctx *ctx)
val save_mode = test_set_indent_mode(out, num_fast(indent_off),
num_fast(indent_data));
val save_indent = nil;
- int two_elem = consp(cdr(obj)) && !cddr(obj);
+ val args = cdr(obj);
+ int have_args = consp(args) != nil;
+ int two_elem = have_args && cdr(args) == nil;
+ val arg = if2(have_args, car(args));
if (sym == quote_s && two_elem) {
put_char(chr('\''), out);
- obj_print_impl(second(obj), out, pretty, ctx);
+ obj_print_impl(arg, out, pretty, ctx);
} else if (sym == sys_qquote_s && two_elem) {
put_char(chr('^'), out);
- obj_print_impl(second(obj), out, pretty, ctx);
+ obj_print_impl(arg, out, pretty, ctx);
} else if (sym == sys_unquote_s && two_elem) {
- val arg = second(obj);
+ val arg = car(args);
put_char(chr(','), out);
if (unquote_star_check(arg, pretty))
put_char(chr(' '), out);
- obj_print_impl(second(obj), out, pretty, ctx);
+ obj_print_impl(arg, out, pretty, ctx);
} else if (sym == sys_splice_s && two_elem) {
put_string(lit(",*"), out);
- obj_print_impl(second(obj), out, pretty, ctx);
+ obj_print_impl(arg, out, pretty, ctx);
} else if (sym == vector_lit_s && two_elem) {
put_char(chr('#'), out);
- obj_print_impl(second(obj), out, pretty, ctx);
+ if (!arg)
+ put_string(lit("()"), out);
+ else
+ obj_print_impl(arg, out, pretty, ctx);
} else if (sym == hash_lit_s) {
put_string(lit("#H"), out);
- obj_print_impl(rest(obj), out, pretty, ctx);
+ if (!args)
+ put_string(lit("()"), out);
+ else
+ obj_print_impl(args, out, pretty, ctx);
+ } else if (sym == struct_lit_s) {
+ put_string(lit("#S"), out);
+ obj_print_impl(args, out, pretty, ctx);
+ } else if (sym == json_s && have_args &&
+ consp(cdr(args)) && nilp(cddr(args)))
+ {
+ put_string(lit("#J"), out);
+ out_json(arg, cadr(args), out, ctx);
} else if (sym == var_s && two_elem &&
- (symbolp(second(obj)) || integerp(second(obj))))
+ (symbolp(arg) || integerp(arg)))
{
put_char(chr('@'), out);
- obj_print_impl(second(obj), out, pretty, ctx);
- } else if (sym == expr_s && two_elem && consp(second(obj))) {
+ obj_print_impl(arg, out, pretty, ctx);
+ } else if (sym == expr_s && two_elem && consp(arg)) {
+ val inarg = car(arg);
put_char(chr('@'), out);
- obj_print_impl(second(obj), out, pretty, ctx);
- } else if (sym == rcons_s && consp(cdr(obj))
- && consp(cddr(obj)) && !(cdddr(obj)))
+ if (inarg != rcons_s) {
+ obj_print_impl(arg, out, pretty, ctx);
+ } else {
+ obj = arg;
+ sym = inarg;
+ args = cdr(obj);
+ arg = car(obj);
+ goto list;
+ }
+ } else if (sym == rcons_s && have_args
+ && consp(cdr(args)) && !(cddr(args)) &&
+ (!consp(arg) || car(arg) != rcons_s))
{
- obj_print_impl(second(obj), out, pretty, ctx);
+ obj_print_impl(arg, out, pretty, ctx);
put_string(lit(".."), out);
- obj_print_impl(third(obj), out, pretty, ctx);
+ obj_print_impl(cadr(args), out, pretty, ctx);
} else if ((sym == uref_s || sym == qref_s) &&
- simple_qref_args_p(cdr(obj), if3(sym == uref_s, zero, one)))
+ simple_qref_args_p(args, if3(sym == uref_s, one, zero)))
{
- val iter = cdr(obj), next;
+ val iter = args, next;
if (sym == uref_s) {
if (car(iter) == t) {
@@ -11679,18 +14981,16 @@ val obj_print_impl(val obj, val out, val pretty, struct strm_ctx *ctx)
put_char(chr('?'), out);
}
}
- } else if (sym == quasi_s && consp(cdr(obj))) {
+ } else if (sym == quasi_s && have_args) {
put_char(chr('`'), out);
out_quasi_str(obj, out, ctx);
put_char(chr('`'), out);
- } else if (sym == quasilist_s && consp(cdr(obj))) {
+ } else if (sym == quasilist_s && have_args) {
cnum max_length = ctx->strm->max_length;
- val args = cdr(obj);
put_string(lit("#`"), out);
- if (args) {
- out_quasi_str(car(args), out, ctx);
- args = cdr(args);
- }
+ out_quasi_str(arg, out, ctx);
+ args = cdr(args);
+
while (args) {
put_char(chr(' '), out);
if (max_length && --max_length == 0) {
@@ -11701,7 +15001,7 @@ val obj_print_impl(val obj, val out, val pretty, struct strm_ctx *ctx)
args = cdr(args);
}
put_char(chr('`'), out);
- } else {
+ } else list: {
val iter;
val closepar = chr(')');
val indent = zero;
@@ -11709,9 +15009,17 @@ val obj_print_impl(val obj, val out, val pretty, struct strm_ctx *ctx)
cnum max_len = ctx->strm->max_length;
cnum max_count = max_len;
- if (sym == dwim_s && consp(cdr(obj))) {
+ if (sym == dwim_s) {
put_char(chr('['), out);
- obj = cdr(obj);
+ if (!have_args) {
+ if (args) {
+ put_string(lit(". "), out);
+ obj_print_impl(args, out, pretty, ctx);
+ }
+ put_char(chr(']'), out);
+ break;
+ }
+ obj = args;
closepar = chr(']');
} else {
put_char(chr('('), out);
@@ -11734,7 +15042,7 @@ val obj_print_impl(val obj, val out, val pretty, struct strm_ctx *ctx)
} else if (special_operator_p(sym) || macro_form_p(obj, nil)) {
indent = one;
test_neq_set_indent_mode(out, num_fast(indent_foff), num_fast(indent_code));
- } else if (fboundp(sym)) {
+ } else if (symbolp(sym) && fboundp(sym)) {
obj_print_impl(sym, out, pretty, ctx);
indent = one;
save_indent = inc_indent(out, indent);
@@ -11751,10 +15059,19 @@ val obj_print_impl(val obj, val out, val pretty, struct strm_ctx *ctx)
val a = car(iter);
val unq = nil;
- if (a == sys_unquote_s)
+ if (a == sys_unquote_s) {
unq = lit(". ,");
- else if (a == sys_splice_s)
+ } else if (a == sys_splice_s) {
unq = lit(". ,*");
+ } else if (a == var_s && consp(cdr(iter))) {
+ val ad = cadr(iter);
+ if (symbolp(ad) || integerp(ad))
+ unq = lit(". @");
+ } else if (a == expr_s && consp(cdr(iter))) {
+ val ad = cadr(iter);
+ if (consp(ad))
+ unq = lit(". @");
+ }
if (unq) {
val d = cdr(iter);
@@ -11808,23 +15125,23 @@ dot:
case STR:
{
cnum max_length = ctx->strm->max_length;
- cnum eff_max_length = max(15, max_length);
+ cnum max_chr = max_str_chars(max_length);
if (pretty) {
- if (!max_length || le(length_str(obj), num(eff_max_length))) {
+ if (!max_length || le(length_str(obj), num(max_chr))) {
put_string(obj, out);
} else {
- put_string(sub_str(obj, zero, num(eff_max_length)), out);
+ put_string(sub_str(obj, zero, num(max_chr)), out);
put_string(lit("..."), out);
}
} else {
int semi_flag = 0;
put_char(chr('"'), out);
- if (!max_length || le(length_str(obj), num(eff_max_length))) {
- out_str_readable(c_str(obj), out, &semi_flag);
+ if (!max_length || le(length_str(obj), num(max_chr))) {
+ out_str_readable(c_str(obj, self), out, &semi_flag);
} else {
- out_str_readable(c_str(sub_str(obj, zero, num(eff_max_length))),
+ out_str_readable(c_str(sub_str(obj, zero, num(max_chr)), self),
out, &semi_flag);
put_string(lit("\\..."), out);
}
@@ -11838,7 +15155,6 @@ dot:
put_char(obj, out);
} else {
wchar_t ch = c_chr(obj);
- val fmt = nil;
put_string(lit("#\\"), out);
switch (ch) {
@@ -11854,20 +15170,18 @@ dot:
case ' ': put_string(lit("space"), out); break;
case 0xDC00: put_string(lit("pnul"), out); break;
case 0xFEFF: case 0xFFFE: case 0xFFFF:
- goto fourhex;
+ hex:
+ format(out, lit("x~X"), num(ch), nao);
+ break;
default:
if ((ch < 0x20) || (ch >= 0x7F && ch < 0xA0))
- fmt = lit("x~,02X");
+ goto hex;
else if (ch >= 0xD800 && ch < 0xE000)
- fourhex:
- fmt = lit("x~,04X");
+ goto hex;
else if (ch >= 0xFFFF)
- fmt = lit("x~,06X");
+ goto hex;
else
put_char(chr(ch), out);
-
- if (fmt)
- format(out, fmt, num(ch), nao);
}
}
break;
@@ -11889,7 +15203,7 @@ dot:
if (obj->s.package == keyword_package)
put_char(chr(':'), out);
} else {
- val prefix = symbol_needs_prefix(lit("print"), cur_package, obj);
+ val prefix = symbol_needs_prefix(self, cur_package, obj);
if (prefix) {
put_string(prefix, out);
@@ -11924,7 +15238,7 @@ dot:
break;
case VEC:
{
- cnum i, length = c_num(obj->v.vec[vec_length]);
+ cnum i, length = c_num(obj->v.vec[vec_length], self);
cnum max_length = ctx->strm->max_length;
val save_mode = test_set_indent_mode(out, num_fast(indent_off),
num_fast(indent_data));
@@ -12005,8 +15319,8 @@ tail:
val label = cdr(prev_cell);
if (label == colon_k)
- uw_throwf(error_s, lit("print: unexpected duplicate object "
- "(misbehaving print method?)"), nao);
+ uw_throwf(error_s, lit("~a: unexpected duplicate object "
+ "(misbehaving print method?)"), self, nao);
if (prev_cell)
return;
} else {
@@ -12033,7 +15347,7 @@ tail:
case VEC:
{
cnum i;
- cnum l = c_num(length_vec(obj));
+ cnum l = c_num(length_vec(obj), self);
for (i = 0; i < l; i++) {
val in = num(i);
@@ -12075,7 +15389,7 @@ tail:
populate_obj_hash(slot(obj, sn), ctx);
}
} else if (treep(obj)) {
- val iter = tree_begin(obj);
+ val iter = tree_begin(obj, colon_k, colon_k);
val node;
while ((node = tree_next(iter)))
populate_obj_hash(key(node), ctx);
@@ -12128,7 +15442,7 @@ val obj_print(val obj, val out, val pretty)
if (ctx) {
if (cdr(lookup_var(nil, print_circle_s))) {
ctx->obj_hash_prev = ctx->obj_hash;
- ctx->obj_hash = make_eq_hash(nil, nil);
+ ctx->obj_hash = make_eq_hash(hash_weak_none);
populate_obj_hash(obj, ctx);
obj_hash_merge(ctx->obj_hash_prev, ctx->obj_hash);
ctx->obj_hash = ctx->obj_hash_prev;
@@ -12136,14 +15450,14 @@ val obj_print(val obj, val out, val pretty)
}
} else {
struct strm_base *s = coerce(struct strm_base *,
- cobj_handle(self, out, stream_s));
+ cobj_handle(self, out, stream_cls));
ctx = &ctx_struct;
ctx->strm = s;
ctx->counter = zero;
ctx->obj_hash_prev = nil;
ctx->obj_hash = if2(print_circle_s &&
cdr(lookup_var(nil, print_circle_s)),
- make_eq_hash(nil, nil));
+ make_eq_hash(hash_weak_none));
ctx->depth = 0;
get_set_ctx(out, ctx);
if (ctx->obj_hash)
@@ -12169,13 +15483,13 @@ val obj_print(val obj, val out, val pretty)
val print(val obj, val stream, val pretty)
{
- return obj_print(obj, default_arg(stream, std_output),
+ return obj_print(obj, default_arg_strict(stream, std_output),
default_null_arg(pretty));
}
val pprint(val obj, val stream)
{
- return obj_print(obj, default_arg(stream, std_output), t);
+ return obj_print(obj, default_arg_strict(stream, std_output), t);
}
val tostring(val obj)
@@ -12192,10 +15506,48 @@ val tostringp(val obj)
return get_string_from_stream(ss);
}
+val put_json(val obj, val stream_in, val flat)
+{
+ val stream = default_arg_strict(stream_in, std_output);
+ val imode = if3(default_null_arg(flat),
+ set_indent_mode(stream, num_fast(indent_foff)),
+ test_set_indent_mode(stream, num_fast(indent_off),
+ num_fast(indent_data)));
+ val isave = get_indent(stream);
+ val jfsym = cdr(lookup_var(nil, print_json_format_s));
+ enum json_fmt jf = if3(jfsym == standard_k,
+ json_fmt_standard,
+ json_fmt_default);
+ uw_simple_catch_begin;
+ out_json_rec(obj, stream, jf, 0);
+ uw_unwind {
+ set_indent_mode(stream, imode);
+ set_indent(stream, isave);
+ }
+ uw_catch_end;
+ return t;
+}
+
+val put_jsonl(val obj, val stream, val flat)
+{
+ put_json(obj, stream, flat);
+ put_char(chr('\n'), stream);
+ return t;
+}
+
+val tojson(val obj, val flat)
+{
+ val ss = make_string_output_stream();
+ put_json(obj, ss, flat);
+ return get_string_from_stream(ss);
+}
+
val display_width(val obj)
{
+ val self = lit("display-width");
+
if (stringp(obj)) {
- const wchar_t *s = c_str(obj);
+ const wchar_t *s = c_str(obj, self);
cnum width = 0;
for (; *s; s++) {
if (iswcntrl(*s))
@@ -12210,443 +15562,8 @@ val display_width(val obj)
return num_fast(1 + wide_display_char_p(ch));
}
- uw_throwf(type_error_s, lit("display-width: ~s isn't a character or string"),
- obj, nao);
-}
-
-val time_sec(void)
-{
- struct timeval tv;
- if (gettimeofday(&tv, 0) == -1)
- return nil;
- return num(tv.tv_sec);
-}
-
-val time_sec_usec(void)
-{
- struct timeval tv;
- if (gettimeofday(&tv, 0) == -1)
- return nil;
- return cons(num_time(tv.tv_sec), num(tv.tv_usec));
-}
-
-#if !HAVE_GMTIME_R
-struct tm *gmtime_r(const time_t *timep, struct tm *result);
-struct tm *localtime_r(const time_t *timep, struct tm *result);
-
-struct tm *gmtime_r(const time_t *timep, struct tm *result)
-{
- struct tm *hack = gmtime(timep);
- *result = *hack;
- return hack;
-}
-
-struct tm *localtime_r(const time_t *timep, struct tm *result)
-{
- struct tm *hack = localtime(timep);
- *result = *hack;
- return hack;
-}
-#endif
-
-static val string_time(struct tm *(*break_time_fn)(const time_t *, struct tm *),
- char *format, time_t time)
-{
- char buffer[512] = "";
- struct tm broken_out_time;
-
- if (break_time_fn(&time, &broken_out_time) == 0)
- return nil;
-
-#if HAVE_TM_ZONE
- if (strcmp(broken_out_time.TM_ZONE, "GMT") == 0)
- broken_out_time.TM_ZONE = "UTC";
-#endif
-
- if (strftime(buffer, sizeof buffer, format, &broken_out_time) == 0)
- buffer[0] = 0;
-
- {
- wchar_t *wctime = utf8_dup_from(buffer);
- return string_own(wctime);
- }
-}
-
-val time_string_local(val time, val format)
-{
- time_t secs = c_time(time);
- const wchar_t *wcfmt = c_str(format);
- char *u8fmt = utf8_dup_to(wcfmt);
- val timestr = string_time(localtime_r, u8fmt, secs);
- free(u8fmt);
- return timestr;
-}
-
-val time_string_utc(val time, val format)
-{
- time_t secs = c_time(time);
- const wchar_t *wcfmt = c_str(format);
- char *u8fmt = utf8_dup_to(wcfmt);
- val timestr = string_time(gmtime_r, u8fmt, secs);
- free(u8fmt);
- return timestr;
-}
-
-static val broken_time_list(struct tm *tms)
-{
- return list(num(tms->tm_year + 1900),
- num_fast(tms->tm_mon + 1),
- num_fast(tms->tm_mday),
- num_fast(tms->tm_hour),
- num_fast(tms->tm_min),
- num_fast(tms->tm_sec),
- tms->tm_isdst ? t : nil,
- nao);
-}
-
-static void tm_to_time_struct(val time_struct, struct tm *ptm)
-{
- slotset(time_struct, year_s, num(ptm->tm_year + 1900));
- slotset(time_struct, month_s, num_fast(ptm->tm_mon + 1));
- slotset(time_struct, day_s, num_fast(ptm->tm_mday));
- slotset(time_struct, hour_s, num_fast(ptm->tm_hour));
- slotset(time_struct, min_s, num_fast(ptm->tm_min));
- slotset(time_struct, sec_s, num_fast(ptm->tm_sec));
- slotset(time_struct, dst_s, tnil(ptm->tm_isdst));
-#if HAVE_TM_GMTOFF
- slotset(time_struct, gmtoff_s, num_fast(ptm->TM_GMTOFF));
-#endif
-#if HAVE_TM_ZONE
- slotset(time_struct, zone_s, if2(ptm->TM_ZONE, string_utf8(ptm->TM_ZONE)));
-#endif
-}
-
-static val broken_time_struct(struct tm *tms)
-{
- args_decl(args, ARGS_MIN);
- val ts = make_struct(time_s, nil, args);
-
- tm_to_time_struct(ts, tms);
-
- return ts;
-}
-
-val time_fields_local(val time)
-{
- struct tm tms;
- time_t secs = c_time(time);
-
- if (localtime_r(&secs, &tms) == 0)
- return nil;
-
- return broken_time_list(&tms);
-}
-
-val time_fields_utc(val time)
-{
- struct tm tms;
- time_t secs = c_time(time);
-
- if (gmtime_r(&secs, &tms) == 0)
- return nil;
-
- return broken_time_list(&tms);
-}
-
-val time_struct_local(val time)
-{
- struct tm tms;
- time_t secs = c_time(time);
-
- if (localtime_r(&secs, &tms) == 0)
- return nil;
-
- return broken_time_struct(&tms);
-}
-
-val time_struct_utc(val time)
-{
- struct tm tms;
- time_t secs = c_time(time);
-
- if (gmtime_r(&secs, &tms) == 0)
- return nil;
-
- return broken_time_struct(&tms);
-}
-
-static void time_fields_to_tm(struct tm *ptm,
- val year, val month, val day,
- val hour, val min, val sec, val dst)
-{
- uses_or2;
- ptm->tm_year = c_num(or2(year, zero)) - 1900;
- ptm->tm_mon = c_num(or2(month, zero)) - 1;
- ptm->tm_mday = c_num(or2(day, zero));
- ptm->tm_hour = c_num(or2(hour, zero));
- ptm->tm_min = c_num(or2(min, zero));
- ptm->tm_sec = c_num(or2(sec, zero));
-
- if (!dst)
- ptm->tm_isdst = 0;
- else if (dst == auto_k)
- ptm->tm_isdst = -1;
- else
- ptm->tm_isdst = 1;
-
-#if HAVE_TM_GMTOFF
- ptm->TM_GMTOFF = 0;
-#endif
-#if HAVE_TM_ZONE
- ptm->TM_ZONE = 0;
-#endif
-}
-
-static void time_struct_to_tm(struct tm *ptm, val time_struct, val strict)
-{
- val year = slot(time_struct, year_s);
- val month = slot(time_struct, month_s);
- val day = slot(time_struct, day_s);
- val hour = slot(time_struct, hour_s);
- val min = slot(time_struct, min_s);
- val sec = slot(time_struct, sec_s);
- val dst = slot(time_struct, dst_s);
-
- if (!strict) {
- year = (year ? year : zero);
- month = (month ? month : zero);
- day = (day ? day : zero);
- hour = (hour ? hour : zero);
- min = (min ? min : zero);
- sec = (sec ? sec : zero);
- }
-
- time_fields_to_tm(ptm, year, month, day, hour, min, sec, dst);
-}
-
-static val make_time_impl(time_t (*pmktime)(struct tm *),
- val year, val month, val day,
- val hour, val minute, val second,
- val isdst)
-{
- struct tm local = { 0 };
- time_t time;
-
- time_fields_to_tm(&local, year, month, day,
- hour, minute, second, isdst);
- time = pmktime(&local);
-
- return time == -1 ? nil : num_time(time);
-}
-
-val make_time(val year, val month, val day,
- val hour, val minute, val second,
- val isdst)
-{
- return make_time_impl(mktime, year, month, day, hour, minute, second, isdst);
-}
-
-#if HAVE_STRPTIME
-
-static struct tm epoch_tm(void)
-{
- struct tm ep = { 0 };
- ep.tm_year = 70;
- ep.tm_mday = 1;
- return ep;
-}
-
-static int strptime_wrap(val string, val format, struct tm *ptms)
-{
- const wchar_t *w_str = c_str(string);
- const wchar_t *w_fmt = c_str(format);
- char *str = utf8_dup_to(w_str);
- char *fmt = utf8_dup_to(w_fmt);
- char *ptr = strptime(str, fmt, ptms);
- int ret = ptr != 0;
- free(fmt);
- free(str);
- return ret;
-}
-
-val time_parse(val format, val string)
-{
- struct tm tms = epoch_tm();
- int ret = strptime_wrap(string, format, &tms);
- return ret ? broken_time_struct(&tms) : nil;
-}
-
-#endif
-
-#if !HAVE_SETENV
-
-void setenv(const char *name, const char *value, int overwrite)
-{
- int len = strlen(name)+1+strlen(value)+1;
- char *str = (char *) chk_malloc(len);
- (void) overwrite;
- sprintf(str, "%s=%s", name, value);
- putenv(str);
-}
-
-void unsetenv(const char *name)
-{
- setenv(name, "", 1);
-}
-
-#endif
-
-
-#if !HAVE_TIMEGM
-
-static time_t timegm_hack(struct tm *tm)
-{
- time_t ret;
- char *tz;
-
- tz = getenv("TZ");
- setenv("TZ", "UTC", 1);
-#if HAVE_TZSET
- tzset();
-#endif
- ret = mktime(tm);
- if (tz)
- setenv("TZ", tz, 1);
- else
- unsetenv("TZ");
-#if HAVE_TZSET
- tzset();
-#endif
-
- env_list = nil;
- return ret;
-}
-#endif
-
-val make_time_utc(val year, val month, val day,
- val hour, val minute, val second,
- val isdst)
-{
-#if HAVE_TIMEGM
- time_t (*pmktime)(struct tm *) = timegm;
-#else
- time_t (*pmktime)(struct tm *) = timegm_hack;
-#endif
-
- return make_time_impl(pmktime, year, month, day, hour, minute, second, isdst);
-}
-
-static val time_meth(val utc_p, val time_struct)
-{
- val year = slot(time_struct, year_s);
- val month = slot(time_struct, month_s);
- val day = slot(time_struct, day_s);
- val hour = slot(time_struct, hour_s);
- val min = slot(time_struct, min_s);
- val sec = slot(time_struct, sec_s);
- val dst = slot(time_struct, dst_s);
-
- return (utc_p ? make_time_utc : make_time)(year, month, day,
- hour, min, sec, dst);
-}
-
-static val time_string_meth(val time_struct, val format)
-{
- struct tm tms = { 0 };
- time_struct_to_tm(&tms, time_struct, t);
- char buffer[512] = "";
- char *fmt = utf8_dup_to(c_str(format));
-
- if (strftime(buffer, sizeof buffer, fmt, &tms) == 0)
- buffer[0] = 0;
-
- free(fmt);
-
- return string_own(utf8_dup_from(buffer));
-}
-
-#if HAVE_STRPTIME
-
-static val time_parse_meth(val time_struct, val format, val string)
-{
- struct tm tms = { 0 };
- time_struct_to_tm(&tms, time_struct, nil);
- val ret = nil;
-
- {
- const wchar_t *w_str = c_str(string);
- const wchar_t *w_fmt = c_str(format);
- char *str = utf8_dup_to(w_str);
- char *fmt = utf8_dup_to(w_fmt);
- char *ptr = strptime(str, fmt, &tms);
-
- if (ptr != 0) {
- tm_to_time_struct(time_struct, &tms);
- ret = string_utf8(ptr);
- }
-
- free(fmt);
- free(str);
- }
-
- return ret;
-}
-
-val time_parse_local(val format, val string)
-{
- struct tm tms = epoch_tm();
- if (!strptime_wrap(string, format, &tms))
- return nil;
- return num(mktime(&tms));
-}
-
-val time_parse_utc(val format, val string)
-{
- struct tm tms = epoch_tm();
- if (!strptime_wrap(string, format, &tms))
- return nil;
-#if HAVE_TIMEGM
- return num_time(timegm(&tms));
-#else
- return num_time(timegm_hack(&tms));
-#endif
-}
-
-#endif
-
-static void time_init(void)
-{
- val time_st;
-
- time_s = intern(lit("time"), user_package);
- time_local_s = intern(lit("time-local"), user_package);
- time_utc_s = intern(lit("time-utc"), user_package);
- time_string_s = intern(lit("time-string"), user_package);
- time_parse_s = intern(lit("time-parse"), user_package);
- year_s = intern(lit("year"), user_package);
- month_s = intern(lit("month"), user_package);
- day_s = intern(lit("day"), user_package);
- hour_s = intern(lit("hour"), user_package);
- min_s = intern(lit("min"), user_package);
- sec_s = intern(lit("sec"), user_package);
- dst_s = intern(lit("dst"), user_package);
- gmtoff_s = intern(lit("gmtoff"), user_package);
- zone_s = intern(lit("zone"), user_package);
-
- time_st = make_struct_type(time_s, nil,
- list(time_local_s, time_utc_s,
- time_string_s, time_parse_s, nao),
- list(year_s, month_s, day_s,
- hour_s, min_s, sec_s, dst_s,
- gmtoff_s, zone_s, nao),
- nil, nil, nil, nil);
-
- static_slot_set(time_st, time_local_s, func_f1(nil, time_meth));
- static_slot_set(time_st, time_utc_s, func_f1(t, time_meth));
- static_slot_set(time_st, time_string_s, func_n2(time_string_meth));
-#if HAVE_STRPTIME
- static_slot_set(time_st, time_parse_s, func_n3(time_parse_meth));
-#endif
+ uw_throwf(type_error_s, lit("~a: ~s isn't a character or string"),
+ self, obj, nao);
}
void init(val *stack_bottom)
@@ -12654,14 +15571,18 @@ void init(val *stack_bottom)
int gc_save;
gc_save = gc_state(0);
+ t = one;
gc_init(stack_bottom);
+ hash_early_init();
+#if CONFIG_LOCALE_TOLERANCE
+ locale_init();
+#endif
obj_init();
uw_init();
eval_init();
hash_init();
struct_init();
tree_init();
- itypes_init();
buf_init();
ffi_init();
sysif_init();
@@ -12679,6 +15600,7 @@ void init(val *stack_bottom)
parse_init();
uw_late_init();
less_tab_init();
+ eval_late_init();
#if HAVE_SYSLOG
syslog_init();
#endif
@@ -12694,6 +15616,11 @@ void init(val *stack_bottom)
cadr_init();
time_init();
chksum_init();
+#if HAVE_SOCKETS
+ sock_init();
+#endif
+
+ cobj_populate_hash();
gc_state(gc_save);
}
@@ -12715,6 +15642,12 @@ int compat_fixup(int compat_ver)
eval_compat_fixup(compat_ver);
rand_compat_fixup(compat_ver);
+ arith_compat_fixup(compat_ver);
+ ffi_compat_fixup(compat_ver);
+ regex_compat_fixup(compat_ver);
+ stream_compat_fixup(compat_ver);
+ struct_compat_fixup(compat_ver);
+
return 0;
}
@@ -12745,3 +15678,16 @@ void d(val obj)
void breakpt(void)
{
}
+
+/*
+ * Function for dissembling VM functions
+ * when debugging in gdb.
+ */
+
+void dis(val obj)
+{
+ val sym = intern(lit("disassemble"), user_package);
+ val fun = cdr(if2(sym, lookup_fun(nil, sym)));
+ if (fun)
+ funcall1(fun, obj);
+}
diff --git a/lib.h b/lib.h
index 115b11d2..b4b1df87 100644
--- a/lib.h
+++ b/lib.h
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include "mpi/mpi.h"
@@ -45,29 +46,66 @@ typedef double_uintptr_t dbl_ucnum;
#define coerce(TYPE, EXPR) ((TYPE) (EXPR))
#endif
-#define TAG_SHIFT 2
-#define TAG_MASK ((convert(cnum, 1) << TAG_SHIFT) - 1)
+#define container(PTR, TYPE, MEMB) \
+ coerce(TYPE *, \
+ coerce(mem_t *, (PTR)) - offsetof(TYPE, MEMB))
+
+#if __STDC_VERSION__ >= 199901L
+#define FLEX_ARRAY
+#else
+#define FLEX_ARRAY 1
+#endif
+
+#define PTR_BIT (SIZEOF_PTR * CHAR_BIT)
+
#define TAG_PTR 0
#define TAG_NUM 1
#define TAG_CHR 2
#define TAG_LIT 3
-#define NUM_MAX (INT_PTR_MAX/4)
-#define NUM_MIN (INT_PTR_MIN/4)
-#define PTR_BIT (SIZEOF_PTR * CHAR_BIT)
+#if CONFIG_NAN_BOXING
+
+#define TAG_FLNUM 4 /* pseudo-tag */
+#define TAG_WIDTH 2
+#define TAG_PAIR(A, B) ((A) << TAG_WIDTH | (B))
+
+#define NAN_TAG_BIT 14
+#define NAN_TAG_MASK 0xFFFC000000000000U
+#define TAG_BIGMASK 0xFFFF000000000000U
+#define TAG_BIGSHIFT 48
+
+#define NAN_FLNUM_DELTA 0x0004000000000000U
+
+#define NUM_MAX (INT_PTR_MAX >> NAN_TAG_BIT)
+#define NUM_MIN (INT_PTR_MIN >> NAN_TAG_BIT)
+#define NUM_BIT (PTR_BIT - NAN_TAG_BIT)
+
+#else
+
+#define TAG_SHIFT 2
+#define TAG_MASK ((convert(cnum, 1) << TAG_SHIFT) - 1)
+#define TAG_PAIR(A, B) ((A) << TAG_SHIFT | (B))
+
+#define NUM_MAX (INT_PTR_MAX >> TAG_SHIFT)
+#define NUM_MIN (INT_PTR_MIN >> TAG_SHIFT)
+#define NUM_BIT (PTR_BIT - TAG_SHIFT)
+
+#endif
#ifdef __GNUC__
-#define noreturn __attribute__((noreturn))
+#define NORETURN __attribute__((noreturn))
#define NOINLINE __attribute__((noinline))
+#define UNUSED __attribute__((unused))
#else
-#define noreturn
+#define NORETURN
#define NOINLINE
+#define UNUSED
#endif
typedef enum type {
- NIL = TAG_PTR, NUM = TAG_NUM, CHR = TAG_CHR, LIT = TAG_LIT, CONS,
- STR, SYM, PKG, FUN, VEC, LCONS, LSTR, COBJ, CPTR, ENV,
- BGNUM, FLNUM, RNG, BUF, TNOD, DARG, MAXTYPE = TNOD
+ NIL = TAG_PTR, NUM = TAG_NUM, CHR = TAG_CHR, LIT = TAG_LIT, FLNUM,
+ CONS, STR, SYM, PKG, FUN, VEC, LCONS, LSTR, COBJ, CPTR, ENV,
+ BGNUM, RNG, BUF, TNOD, DARG, MAXTYPE = DARG
/* If extending, check TYPE_SHIFT and all ocurrences of MAX_TYPE */
} type_t;
@@ -94,7 +132,8 @@ typedef unsigned char mem_t;
#if CONFIG_GEN_GC
#define obj_common \
type_t type : PTR_BIT/2; \
- int gen : PTR_BIT/2
+ unsigned fincount : PTR_BIT/4; \
+ int gen : PTR_BIT/4;
#else
#define obj_common \
type_t type
@@ -121,21 +160,23 @@ struct string {
obj_common;
wchar_t *str;
val len;
- val alloc;
+#if !HAVE_MALLOC_USABLE_SIZE
+ cnum alloc;
+#endif
};
typedef struct {
cnum id;
cnum slot;
} slot_cache_entry_t;
+
typedef slot_cache_entry_t slot_cache_set_t[4];
-typedef slot_cache_set_t *slot_cache_t;
struct sym {
obj_common;
val name;
val package;
- slot_cache_t slot_cache;
+ slot_cache_set_t *slot_cache;
};
struct package {
@@ -236,10 +277,22 @@ struct lazy_string {
struct lazy_string_props *props;
};
+struct cobj_class {
+ val cls_sym;
+ struct cobj_class *super;
+};
+
struct cobj {
obj_common;
mem_t *handle;
struct cobj_ops *ops;
+ struct cobj_class *cls;
+};
+
+struct cptr {
+ obj_common;
+ mem_t *handle;
+ struct cobj_ops *ops;
val cls;
};
@@ -247,7 +300,7 @@ struct dyn_args {
obj_common;
val car;
val cdr;
- struct args *args;
+ varg args;
};
struct strm_ctx;
@@ -293,10 +346,12 @@ struct bignum {
mp_int mp;
};
+#if !CONFIG_NAN_BOXING
struct flonum {
obj_common;
double n;
};
+#endif
struct range {
obj_common;
@@ -328,9 +383,12 @@ union obj {
struct lazy_cons lc;
struct lazy_string ls;
struct cobj co;
+ struct cptr cp;
struct env e;
struct bignum bn;
+#if !CONFIG_NAN_BOXING
struct flonum fl;
+#endif
struct range rn;
struct buf b;
struct tnod tn;
@@ -359,24 +417,24 @@ INLINE loc mkloc_fun(val *ptr, val obj)
#define valptr(lo) ((lo).ptr)
#define set(lo, val) (gc_set(lo, val))
#define setcheck(tgt, src) (gc_assign_check(tgt, src))
-#define mut(obj) (gc_mutated(obj));
+#define mut(obj) (gc_mutated(obj))
#define mpush(val, lo) (gc_push(val, lo))
#else
typedef val *loc;
-#define mkloc(expr, obj) (&(expr))
+#define mkloc(expr, obj) ((void) (obj), &(expr))
#define mkcloc(expr) (&(expr))
#define nulloc ((loc) 0)
#define nullocp(lo) (!(lo))
#define deref(lo) (*(lo))
#define valptr(lo) (lo)
#define set(lo, val) (*(lo) = (val))
-#define setcheck(tgt, src) ((void) 0)
+#define setcheck(tgt, src) ((void) (tgt))
#define mut(obj) ((void) (obj))
#define mpush(val, lo) (push(val, lo))
#endif
typedef enum seq_kind {
- SEQ_NIL, SEQ_LISTLIKE, SEQ_VECLIKE, SEQ_HASHLIKE, SEQ_NOTSEQ
+ SEQ_NIL, SEQ_LISTLIKE, SEQ_VECLIKE, SEQ_HASHLIKE, SEQ_TREELIKE, SEQ_NOTSEQ
} seq_kind_t;
typedef struct seq_info {
@@ -390,25 +448,101 @@ typedef struct seq_iter {
union {
val iter;
cnum index;
+ val vn;
+ cnum cn;
} ui;
- cnum len;
+ union {
+ cnum len;
+ val vbound;
+ cnum cbound;
+ val next;
+ } ul;
+ struct seq_iter_ops *ops;
+} seq_iter_t;
+
+struct seq_iter_ops {
int (*get)(struct seq_iter *, val *pval);
int (*peek)(struct seq_iter *, val *pval);
-} seq_iter_t;
+ void (*mark)(struct seq_iter *);
+};
+
+#define seq_iter_ops_init(get, peek) { get, peek, seq_iter_mark_op }
+#define seq_iter_ops_init_nomark(get, peek) { get, peek, 0 }
+
+typedef struct seq_build {
+ val obj;
+ loc tail;
+ val self;
+ union {
+ val from_list_meth;
+ val carray_type;
+ } u;
+ struct seq_build_ops *ops;
+} seq_build_t;
+
+struct seq_build_ops {
+ void (*add)(struct seq_build *, val);
+ void (*pend)(struct seq_build *, val);
+ void (*nconc)(struct seq_build *, val);
+ void (*finish)(struct seq_build *);
+ void (*mark)(struct seq_build *);
+};
+
+#define seq_build_ops_init(add, pend, nconc, finish, mark) \
+ { add, pend, nconc, finish, mark }
extern const seq_kind_t seq_kind_tab[MAXTYPE+1];
#define SEQ_KIND_PAIR(A, B) ((A) << 3 | (B))
+#if CONFIG_NAN_BOXING
+
+INLINE cnum tag(val obj)
+{
+ ucnum word = coerce(ucnum, obj) >> TAG_BIGSHIFT;
+ if (word <= TAG_LIT)
+ return word;
+ if ((word & (NAN_TAG_MASK >> TAG_BIGSHIFT)) == (NAN_TAG_MASK >> TAG_BIGSHIFT))
+ return TAG_NUM;
+ return TAG_PTR;
+}
+
+INLINE cnum tag_ex(val obj)
+{
+ ucnum word = coerce(ucnum, obj) >> TAG_BIGSHIFT;
+ if (word <= TAG_LIT)
+ return word;
+ if ((word & (NAN_TAG_MASK >> TAG_BIGSHIFT)) == (NAN_TAG_MASK >> TAG_BIGSHIFT))
+ return TAG_NUM;
+ return TAG_FLNUM;
+}
+
+INLINE int is_ptr(val obj)
+{
+ return obj && coerce(ucnum, obj) >> TAG_BIGSHIFT == TAG_PTR;
+}
+
+INLINE int is_flo(val obj)
+{
+ ucnum nantag = coerce(ucnum, obj) & NAN_TAG_MASK;
+ return nantag != 0 && nantag != NAN_TAG_MASK;
+}
+
+#else
+
INLINE cnum tag(val obj) { return coerce(cnum, obj) & TAG_MASK; }
+INLINE cnum tag_ex(val obj) { return tag(obj); }
INLINE int is_ptr(val obj) { return obj && tag(obj) == TAG_PTR; }
+
+#endif
+
INLINE int is_num(val obj) { return tag(obj) == TAG_NUM; }
INLINE int is_chr(val obj) { return tag(obj) == TAG_CHR; }
INLINE int is_lit(val obj) { return tag(obj) == TAG_LIT; }
INLINE type_t type(val obj)
{
- cnum tg = tag(obj);
+ cnum tg = tag_ex(obj);
return obj ? tg
? convert(type_t, tg)
: obj->t.type
@@ -417,10 +551,10 @@ INLINE type_t type(val obj)
typedef struct wli wchli_t;
-#if LIT_ALIGN < 4
+#if SIZEOF_WCHAR_T < 4 && !CONFIG_NAN_BOXING
#define wli_noex(lit) (coerce(const wchli_t *,\
convert(const wchar_t *,\
- "\0" L ## lit L"\0" + 1)))
+ L"\0" L ## lit L"\0" + 1)))
#define wini(ini) L"\0" L ## ini L"\0"
#define wref(arr) ((arr) + 1)
#else
@@ -434,22 +568,31 @@ typedef struct wli wchli_t;
INLINE val auto_str(const wchli_t *str)
{
+#if CONFIG_NAN_BOXING
+ return coerce(val, coerce(cnum, str) |
+ (coerce(cnum, TAG_LIT) << TAG_BIGSHIFT));
+#else
return coerce(val, coerce(cnum, str) | TAG_LIT);
+#endif
}
INLINE val static_str(const wchli_t *str)
{
+#if CONFIG_NAN_BOXING
+ return coerce(val, coerce(cnum, str) |
+ (coerce(cnum, TAG_LIT) << TAG_BIGSHIFT));
+#else
return coerce(val, coerce(cnum, str) | TAG_LIT);
+#endif
}
INLINE wchar_t *litptr(val obj)
{
-#if LIT_ALIGN < 4 && SIZEOF_WCHAR_T < 4
+#if SIZEOF_WCHAR_T < 4 && !CONFIG_NAN_BOXING
wchar_t *ret = coerce(wchar_t *, (coerce(cnum, obj) & ~TAG_MASK));
return (*ret == 0) ? ret + 1 : ret;
-#elif LIT_ALIGN < 4 && SIZEOF_WCHAR_T == 4
- short *ret = coerce(short *, (coerce(cnum, obj) & ~TAG_MASK));
- return coerce(wchar_t *, (*ret == 0) ? ret + 1 : ret);
+#elif CONFIG_NAN_BOXING
+ return coerce(wchar_t *, coerce(cnum, obj) & ~TAG_BIGMASK);
#else
return coerce(wchar_t *, coerce(cnum, obj) & ~TAG_MASK);
#endif
@@ -457,7 +600,13 @@ INLINE wchar_t *litptr(val obj)
INLINE val num_fast(cnum n)
{
+#if CONFIG_NAN_BOXING
+ return coerce(val, n | NAN_TAG_MASK);
+#elif HAVE_UBSAN
+ return coerce(val, (n * (1 << TAG_SHIFT)) | TAG_NUM);
+#else
return coerce(val, (n << TAG_SHIFT) | TAG_NUM);
+#endif
}
INLINE mp_int *mp(val bign)
@@ -467,19 +616,70 @@ INLINE mp_int *mp(val bign)
INLINE val chr(wchar_t ch)
{
+#if CONFIG_NAN_BOXING
+ return coerce(val, ch | convert(cnum, TAG_CHR) << TAG_BIGSHIFT);
+#else
return coerce(val, (convert(cnum, ch) << TAG_SHIFT) | TAG_CHR);
+#endif
+}
+
+INLINE cnum c_ch(val num)
+{
+#if CONFIG_NAN_BOXING
+ return coerce(cnum, num) & ~TAG_BIGMASK;
+#else
+ return coerce(cnum, num) >> TAG_SHIFT;
+#endif
}
INLINE cnum c_n(val num)
{
+#if CONFIG_NAN_BOXING
+ cnum n = coerce(cnum, num) & ~NAN_TAG_MASK;
+ return n << NAN_TAG_BIT >> NAN_TAG_BIT;
+#else
return coerce(cnum, num) >> TAG_SHIFT;
+#endif
+}
+
+INLINE ucnum c_u(val num)
+{
+#if CONFIG_NAN_BOXING
+ return coerce(ucnum, num) & ~NAN_TAG_MASK;
+#else
+ return convert(ucnum, coerce(cnum, num) >> TAG_SHIFT);
+#endif
}
-#if LIT_ALIGN < 4
+
+#if CONFIG_NAN_BOXING && defined __GNUC__
+#pragma GCC diagnostic ignored "-Wstrict-aliasing"
+#pragma GCC diagnostic ignored "-Wuninitialized"
+#endif
+
+INLINE double c_f(val num)
+{
+#if CONFIG_NAN_BOXING
+ ucnum u = coerce(ucnum, num) - NAN_FLNUM_DELTA;
+ return *coerce(double *, &u);
+#else
+ return num->fl.n;
+#endif
+}
+
+#if CONFIG_NAN_BOXING && defined __GNUC__
+#pragma GCC diagnostic warning "-Wstrict-aliasing"
+#pragma GCC diagnostic warning "-Wuninitialized"
+#endif
+
+#if SIZEOF_WCHAR_T < 4 && !CONFIG_NAN_BOXING
#define lit_noex(strlit) coerce(obj_t *,\
coerce(cnum, L"\0" L ## strlit L"\0" + 1) | \
TAG_LIT)
+#elif CONFIG_NAN_BOXING
+#define lit_noex(strlit) coerce(val, coerce(cnum, L ## strlit) | \
+ (coerce(cnum, TAG_LIT) << TAG_BIGSHIFT))
#else
-#define lit_noex(strlit) coerce(obj_t *, coerce(cnum, L ## strlit) | TAG_LIT)
+#define lit_noex(strlit) coerce(val, coerce(cnum, L ## strlit) | TAG_LIT)
#endif
#define lit(strlit) lit_noex(strlit)
@@ -503,7 +703,7 @@ extern val zeroplus_s, optional_s, compl_s, compound_s;
extern val or_s, and_s, quasi_s, quasilist_s;
extern val skip_s, trailer_s, block_s, next_s, freeform_s, fail_s, accept_s;
extern val all_s, some_s, none_s, maybe_s, cases_s, collect_s, until_s, coll_s;
-extern val define_s, output_s, single_s, first_s, last_s, empty_s;
+extern val define_s, output_s, push_s, single_s, first_s, last_s, empty_s;
extern val repeat_s, rep_s, flatten_s, forget_s;
extern val local_s, merge_s, bind_s, rebind_s, cat_s;
extern val try_s, catch_s, finally_s, throw_s, defex_s, deffilter_s;
@@ -511,25 +711,28 @@ extern val eof_s, eol_s, assert_s, name_s;
extern val error_s, type_error_s, internal_error_s, panic_s;
extern val numeric_error_s, range_error_s;
extern val query_error_s, file_error_s, process_error_s, syntax_error_s;
-extern val timeout_error_s, system_error_s, alloc_error_s;
+extern val timeout_error_s, system_error_s, alloc_error_s, stack_overflow_s;
extern val path_not_found_s, path_exists_s, path_permission_s;
extern val warning_s, defr_warning_s, restart_s, continue_s;
-extern val gensym_counter_s, length_s;
+extern val gensym_counter_s, length_s, length_lt_s;
extern val rplaca_s, rplacd_s, seq_iter_s;
+extern val lazy_streams_s;
+extern val plus_s;
#define gensym_counter (deref(lookup_var_l(nil, gensym_counter_s)))
extern val nothrow_k, args_k, colon_k, auto_k, fun_k;
extern val null_string;
-extern val null_list; /* (nil) */
extern val identity_f, identity_star_f;
extern val equal_f, eql_f, eq_f, car_f, cdr_f, null_f;
-extern val list_f, less_f, greater_f;
+extern val list_f, less_f, greater_f, gt_f;
extern val prog_string;
+extern char dec_point;
+
#if HAVE_ULONGLONG_T
typedef ulonglong_t alloc_bytes_t;
#define SIZEOF_ALLOC_BYTES_T SIZEOF_LONGLONG_T
@@ -542,26 +745,43 @@ extern alloc_bytes_t malloc_bytes;
extern alloc_bytes_t gc_bytes;
val identity(val obj);
+val built_in_type_p(val sym);
val typeof(val obj);
val subtypep(val sub, val sup);
val typep(val obj, val type);
seq_info_t seq_info(val cobj);
+void seq_iter_init_with_info(val self, seq_iter_t *it,
+ seq_info_t si, int support_rewind);
void seq_iter_init(val self, seq_iter_t *it, val obj);
-void seq_iter_rewind(val self, seq_iter_t *it);
-INLINE int seq_get(seq_iter_t *it, val *pval) { return it->get(it, pval); }
-INLINE int seq_peek(seq_iter_t *it, val *pval) { return it->peek(it, pval); }
+INLINE int seq_get(seq_iter_t *it, val *pval) { return it->ops->get(it, pval); }
+INLINE int seq_peek(seq_iter_t *it, val *pval) { return it->ops->peek(it, pval); }
val seq_geti(seq_iter_t *it);
+val seq_getpos(val self, seq_iter_t *it);
+void seq_setpos(val self, seq_iter_t *it, val pos);
val seq_begin(val obj);
val seq_next(val iter, val end_val);
val seq_reset(val iter, val obj);
-val throw_mismatch(val self, val obj, type_t);
+val iter_begin(val obj);
+val iter_more(val iter);
+val iter_item(val iter);
+val iter_step(val iter);
+val iter_reset(val iter, val obj);
+void seq_build_init(val self, seq_build_t *bu, val likeobj);
+void seq_add(seq_build_t *bu, val item);
+void seq_pend(seq_build_t *bu, val items);
+void seq_nconc(seq_build_t *bu, val items);
+val seq_finish(seq_build_t *bu);
+val seq_append2(val self, val seq0, val seq1);
+val seq_appendv(val self, varg seqs);
+val seq_nconc2(val self, val seq0, val seq1);
+val seq_nconcv(val self, varg seqs);
+NORETURN val throw_mismatch(val self, val obj, type_t);
INLINE val type_check(val self, val obj, type_t typecode)
{
if (type(obj) != typecode)
throw_mismatch(self, obj, typecode);
return t;
}
-val class_check(val self, val cobj, val class_sym);
val car(val cons);
val cdr(val cons);
INLINE val us_car(val cons) { return cons->c.car; }
@@ -587,6 +807,8 @@ val seventh(val cons);
val eighth(val cons);
val ninth(val cons);
val tenth(val cons);
+val cxr(val addr, val obj);
+val cyr(val addr, val obj);
val conses(val list);
val lazy_conses(val list);
val listref(val list, val ind);
@@ -604,8 +826,13 @@ val push(val v, val *plist);
val copy_list(val list);
val make_like(val list, val thatobj);
val tolist(val seq);
-val nullify(val seq);
+val nullify(val obj);
+val empty(val seq);
val seqp(val obj);
+val iterable(val obj);
+val list_seq(val seq);
+val vec_seq(val seq);
+val str_seq(val seq);
val nreverse(val in);
val reverse(val in);
val us_nreverse(val in);
@@ -613,12 +840,12 @@ val append2(val list1, val list2);
val nappend2(val list1, val list2);
val revappend(val list1, val list2);
val nreconc(val list1, val list2);
-val appendv(struct args *lists);
-val nconcv(struct args *lists);
+val appendv(varg lists);
+val nconcv(varg lists);
val sub_list(val list, val from, val to);
val replace_list(val list, val items, val from, val to);
val lazy_appendl(val lists);
-val lazy_appendv(struct args *lists);
+val lazy_appendv(varg lists);
val ldiff(val list1, val list2);
val ldiff_old(val list1, val list2);
val flatten(val list);
@@ -626,12 +853,15 @@ val lazy_flatten(val list);
val flatcar(val list);
val lazy_flatcar(val tree);
val tuples(val n, val seq, val fill);
+val tuples_star(val n, val seq, val fill);
val partition_by(val func, val seq);
+val partition_if(val func, val seq, val count_in);
val partition(val seq, val indices);
val split(val seq, val indices);
val partition_star(val seq, val indices);
val split_star(val seq, val indices);
val tailp(val obj, val list);
+val delcons(val cons, val list);
val memq(val obj, val list);
val rmemq(val obj, val list);
val memql(val obj, val list);
@@ -650,20 +880,26 @@ val keepq(val obj, val seq, val keyfun);
val keepql(val obj, val seq, val keyfun);
val keepqual(val obj, val seq, val keyfun);
val keep_if(val pred, val seq, val keyfun);
+val keep_keys_if(val pred, val seq_in, val keyfun_in);
+val separate(val pred, val seq, val keyfun);
+val separate_keys(val pred, val seq_in, val keyfun_in);
val remq_lazy(val obj, val list);
val remql_lazy(val obj, val list);
val remqual_lazy(val obj, val list);
val remove_if_lazy(val pred, val list, val key);
val keep_if_lazy(val pred, val list, val key);
val tree_find(val obj, val tree, val testfun);
+val cons_find(val obj, val tree, val testfun);
val countqual(val obj, val list);
val countql(val obj, val list);
val countq(val obj, val list);
val count_if(val pred, val list, val key);
+val count(val item, val seq, val testfun_in, val keyfun_in);
+val cons_count(val item, val tree, val testfun_in);
val some_satisfy(val list, val pred, val key);
val all_satisfy(val list, val pred, val key);
val none_satisfy(val list, val pred, val key);
-val multi(val func, struct args *lists);
+val multi(val func, varg lists);
val eql(val left, val right);
val equal(val left, val right);
val meq(val item, varg args);
@@ -680,7 +916,9 @@ mem_t *chk_manage_vec(mem_t *old, size_t oldfilled, size_t newfilled,
wchar_t *chk_wmalloc(size_t nwchar);
wchar_t *chk_wrealloc(wchar_t *, size_t nwchar);
wchar_t *chk_strdup(const wchar_t *str);
+wchar_t *chk_substrdup(const wchar_t *str, size_t off, size_t len);
char *chk_strdup_utf8(const char *str);
+char *chk_substrdup_utf8(const char *str, size_t off, size_t len);
unsigned char *chk_strdup_8bit(const wchar_t *str);
mem_t *chk_copy_obj(mem_t *orig, size_t size);
mem_t *chk_xalloc(ucnum m, ucnum n, val self);
@@ -692,12 +930,11 @@ val make_lazy_cons_pub(val func, val car, val cdr);
val lcons_car(val lcons);
val lcons_cdr(val lcons);
void rcyc_cons(val cons);
-void rcyc_list(val list);
void rcyc_empty(void);
val lcons_fun(val lcons);
INLINE val us_lcons_fun(val lcons) { return lcons->lc.func; }
val list(val first, ...); /* terminated by nao */
-val listv(struct args *);
+val listv(varg );
val consp(val obj);
val lconsp(val obj);
val atom(val obj);
@@ -705,14 +942,19 @@ val listp(val obj);
val endp(val obj);
val proper_list_p(val obj);
val length_list(val list);
+val length_list_lt(val list, val len);
val getplist(val list, val key);
val getplist_f(val list, val key, loc found);
val memp(val key, val plist);
val plist_to_alist(val list);
val improper_plist_to_alist(val list, val boolean_keys);
val num(cnum val);
+val unum(ucnum u);
+#define num_ex(x) if3((x) > INT_PTR_MAX, unum(x), num(x))
+
val flo(double val);
-cnum c_num(val num);
+cnum c_num(val num, val self);
+ucnum c_unum(val num, val self);
cnum c_fixnum(val num, val self);
double c_flo(val self, val num);
val fixnump(val num);
@@ -720,20 +962,21 @@ val bignump(val num);
val floatp(val num);
val integerp(val num);
val numberp(val num);
+val arithp(val obj);
val nary_op(val self, val (*bfun)(val, val),
val (*ufun)(val self, val),
- struct args *args, val emptyval);
-val nary_simple_op(val self, val (*bfun)(val, val),
- struct args *args, val emptyval);
+ varg args, val emptyval);
+val nary_simple_op(val (*bfun)(val, val),
+ varg args, val emptyval);
val plus(val anum, val bnum);
-val plusv(struct args *);
+val plusv(varg );
val minus(val anum, val bnum);
-val minusv(val minuend, struct args *nlist);
+val minusv(val minuend, varg nlist);
val neg(val num);
val abso(val num);
val mul(val anum, val bnum);
-val mulv(struct args *);
-val divv(val dividend, struct args *);
+val mulv(varg );
+val divv(val dividend, varg );
val trunc(val anum, val bnum);
val mod(val anum, val bnum);
val wrap_star(val start, val end, val num);
@@ -756,32 +999,32 @@ val lt(val anum, val bnum);
val ge(val anum, val bnum);
val le(val anum, val bnum);
val numeq(val anum, val bnum);
-val gtv(val first, struct args *rest);
-val ltv(val first, struct args *rest);
-val gev(val first, struct args *rest);
-val lev(val first, struct args *rest);
-val numeqv(val first, struct args *rest);
-val numneqv(struct args *list);
+val gtv(val first, varg rest);
+val ltv(val first, varg rest);
+val gev(val first, varg rest);
+val lev(val first, varg rest);
+val numeqv(val first, varg rest);
+val numneqv(varg list);
val sum(val seq, val keyfun);
val prod(val seq, val keyfun);
val max2(val a, val b);
val min2(val a, val b);
-val maxv(val first, struct args *rest);
-val minv(val first, struct args *rest);
+val maxv(val first, varg rest);
+val minv(val first, varg rest);
val maxl(val first, val rest);
val minl(val first, val rest);
val clamp(val low, val high, val num);
-val bracket(val larg, struct args *args);
+val bracket(val larg, varg args);
val expt(val base, val exp);
-val exptv(struct args *nlist);
+val exptv(varg nlist);
val exptmod(val base, val exp, val mod);
val sqroot(val anum);
val isqrt(val anum);
val square(val anum);
val gcd(val anum, val bnum);
-val gcdv(struct args *nlist);
+val gcdv(varg nlist);
val lcm(val anum, val bnum);
-val lcmv(struct args *nlist);
+val lcmv(varg nlist);
val floorf(val);
val floordiv(val, val);
val ceili(val);
@@ -810,8 +1053,8 @@ val logtwo(val num);
val expo(val);
val logand(val, val);
val logior(val, val);
-val logandv(struct args *nlist);
-val logiorv(struct args *nlist);
+val logandv(varg nlist);
+val logiorv(varg nlist);
val logxor(val, val);
val logxor_old(val, val);
val logtest(val, val);
@@ -820,7 +1063,7 @@ val logtrunc(val a, val bits);
val sign_extend(val num, val nbits);
val ash(val a, val bits);
val bit(val a, val bit);
-val maskv(struct args *bits);
+val maskv(varg bits);
val logcount(val n);
val bitset(val n);
val string_own(wchar_t *str);
@@ -830,16 +1073,21 @@ val string_8bit(const unsigned char *str);
val string_8bit_size(const unsigned char *str, size_t sz);
val mkstring(val len, val ch);
val mkustring(val len); /* must initialize immediately with init_str! */
-val init_str(val str, const wchar_t *);
+val init_str(val str, const wchar_t *, val self);
+val str(val len, val pattern);
val copy_str(val str);
val upcase_str(val str);
val downcase_str(val str);
-val string_extend(val str, val tail);
+val string_extend(val str, val tail, val finish);
+val string_finish(val str);
+val string_set_code(val str, val code);
+val string_get_code(val str);
val stringp(val str);
val lazy_stringp(val str);
val length_str(val str);
val coded_length(val str);
-const wchar_t *c_str(val str);
+val length_lt(val seq, val len);
+const wchar_t *c_str(val str, val self);
val search_str(val haystack, val needle, val start_num, val from_end);
val search_str_tree(val haystack, val tree, val start_num, val from_end);
val match_str(val bigstr, val str, val pos);
@@ -848,15 +1096,23 @@ val replace_str(val str_in, val items, val from, val to);
val sub_str(val str_in, val from_num, val to_num);
val cat_str(val list, val sep);
val scat(val sep, ...);
+val scat2(val s1, val s2);
+val scat3(val s1, val sep, val s2);
+val join_with(val sep, varg args);
+val fmt_join(varg args);
val split_str(val str, val sep);
-val split_str_keep(val str, val sep, val keep_sep);
+val split_str_keep(val str, val sep, val keep_sep_opt, val count_opt);
val spl(val sep, val arg1, val arg2);
+val spln(val count, val sep, val arg1, val arg2);
val split_str_set(val str, val set);
-val tok_str(val str, val tok_regex, val keep_sep);
+val sspl(val set, val str);
+val tok_str(val str, val tok_regex, val keep_sep_opt, val count_opt);
val tok(val tok_regex, val arg1, val arg2);
+val tokn(val count, val tok_regex, val arg1, val arg2);
val tok_where(val str, val tok_regex);
val list_str(val str);
val trim_str(val str);
+val str_esc(val escset, val escchr, val str);
val cmp_str(val astr, val bstr);
val str_eq(val astr, val bstr);
val str_lt(val astr, val bstr);
@@ -864,6 +1120,7 @@ val str_gt(val astr, val bstr);
val str_le(val astr, val bstr);
val str_ge(val astr, val bstr);
val int_str(val str, val base);
+val flo_str_utf8(const char *);
val flo_str(val str);
val num_str(val str);
val int_flo(val f);
@@ -871,11 +1128,10 @@ val flo_int(val i);
val less(val left, val right);
val greater(val left, val right);
val lequal(val left, val right);
-val gequal(val left, val right);
-val lessv(val first, struct args *rest);
-val greaterv(val first, struct args *rest);
-val lequalv(val first, struct args *rest);
-val gequalv(val first, struct args *rest);
+val lessv(val first, varg rest);
+val greaterv(val first, varg rest);
+val lequalv(val first, varg rest);
+val gequalv(val first, varg rest);
val chrp(val chr);
wchar_t c_chr(val chr);
val chr_isalnum(val ch);
@@ -905,8 +1161,8 @@ val compl_span_str(val str, val set);
val break_str(val str, val set);
val make_sym(val name);
val gensym(val prefix);
-val make_package(val name);
-val make_anon_package(void);
+val make_package(val name, val weak);
+val make_anon_package(val weak);
val packagep(val obj);
val find_package(val name);
val delete_package(val package);
@@ -915,7 +1171,8 @@ val package_alist(void);
val package_name(val package);
val package_symbols(val package);
val package_local_symbols(val package);
-val use_sym(val use_list, val package);
+val use_sym_as(val symbol, val name, val package_in);
+val use_sym(val sym, val package);
val unuse_sym(val symbol, val package);
val use_package(val use_list, val package);
val unuse_package(val unuse_list, val package);
@@ -963,9 +1220,6 @@ val func_n2v(val (*fun)(val, val, varg));
val func_n3v(val (*fun)(val, val, val, varg));
val func_n4v(val (*fun)(val, val, val, val, varg));
val func_n5v(val (*fun)(val, val, val, val, val, varg));
-val func_n6v(val (*fun)(val, val, val, val, val, val, varg));
-val func_n7v(val (*fun)(val, val, val, val, val, val, val, varg));
-val func_n8v(val (*fun)(val, val, val, val, val, val, val, val, varg));
val func_n1o(val (*fun)(val), int reqargs);
val func_n2o(val (*fun)(val, val), int reqargs);
val func_n3o(val (*fun)(val, val, val), int reqargs);
@@ -977,6 +1231,7 @@ val func_n8o(val (*fun)(val, val, val, val, val, val, val, val), int reqargs);
val func_n1ov(val (*fun)(val, varg), int reqargs);
val func_n2ov(val (*fun)(val, val, varg), int reqargs);
val func_n3ov(val (*fun)(val, val, val, varg), int reqargs);
+val func_n4ov(val (*fun)(val, val, val, val, varg), int reqargs);
val func_interp(val env, val form);
val func_vm(val closure, val desc, int fixparam, int reqargs, int variadic);
val copy_fun(val ofun);
@@ -990,7 +1245,7 @@ val vm_fun_p(val);
val fun_fixparam_count(val obj);
val fun_optparam_count(val obj);
val fun_variadic(val obj);
-val generic_funcall(val fun, struct args *);
+val generic_funcall(val fun, varg );
val funcall(val fun);
val funcall1(val fun, val arg);
val funcall2(val fun, val arg1, val arg2);
@@ -998,8 +1253,6 @@ val funcall3(val fun, val arg1, val arg2, val arg3);
val funcall4(val fun, val arg1, val arg2, val arg3, val arg4);
val reduce_left(val fun, val list, val init, val key);
val reduce_right(val fun, val list, val init, val key);
-val transposev(struct args *lists);
-val transpose(val lists);
/* The notation pa_12_2 means take some function f(arg1, arg2) and
fix a value for argument 1 to create a g(arg2).
Other variations follow by analogy. */
@@ -1008,18 +1261,18 @@ val pa_12_1(val fun2, val arg2);
val pa_123_3(val fun3, val arg1, val arg2);
val pa_123_2(val fun3, val arg1, val arg3);
val pa_123_1(val fun3, val arg2, val arg3);
-val pa_123_23(val fun3, val arg1);
val pa_1234_1(val fun4, val arg2, val arg3, val arg4);
val pa_1234_34(val fun3, val arg1, val arg2);
val chain(val first_fun, ...);
-val chainv(struct args *funlist);
-val chandv(struct args *funlist);
-val juxtv(struct args *funlist);
+val chainv(varg funlist);
+val chandv(varg funlist);
+val juxtv(varg funlist);
val andf(val first_fun, ...);
-val andv(struct args *funlist);
-val orf(val first_fun, ...);
-val orv(struct args *funlist);
+val andv(varg funlist);
+val orv(varg funlist);
val notf(val fun);
+val nandv(varg funlist);
+val norv(varg funlist);
val iff(val condfun, val thenfun, val elsefun);
val iffi(val condfun, val thenfun, val elsefun);
val dupl(val fun);
@@ -1032,7 +1285,7 @@ loc vecref_l(val vec, val ind);
val vec_push(val vec, val item);
val length_vec(val vec);
val size_vec(val vec);
-val vectorv(struct args *);
+val vectorv(varg );
val vec(val first, ...);
val vec_list(val list);
val list_vec(val vector);
@@ -1040,8 +1293,11 @@ val copy_vec(val vec);
val sub_vec(val vec_in, val from, val to);
val replace_vec(val vec_in, val items, val from, val to);
val replace_obj(val obj, val items, val from, val to);
+val fill_vec(val vec, val item, val from_in, val to_in);
val cat_vec(val list);
-val lazy_stream_cons(val stream);
+val nested_vec_of_v(val initval, struct args *);
+val nested_vec_v(struct args *);
+val lazy_stream_cons(val stream, val no_throw_close);
val lazy_str(val list, val term, val limit);
val lazy_str_force_upto(val lstr, val index);
val lazy_str_force(val lstr);
@@ -1052,11 +1308,14 @@ val length_str_gt(val str, val len);
val length_str_ge(val str, val len);
val length_str_lt(val str, val len);
val length_str_le(val str, val len);
-val cobj(mem_t *handle, val cls_sym, struct cobj_ops *ops);
+struct cobj_class *cobj_register(val cls_sym);
+struct cobj_class *cobj_register_super(val cls_sym, struct cobj_class *super);
+val cobj(mem_t *handle, struct cobj_class *cls, struct cobj_ops *ops);
val cobjp(val obj);
-val cobjclassp(val obj, val cls_sym);
-mem_t *cobj_handle(val self, val cobj, val cls_sym);
-struct cobj_ops *cobj_ops(val self, val cobj, val cls_sym);
+val cobjclassp(val obj, struct cobj_class *);
+val class_check(val self, val cobj, struct cobj_class *cls);
+mem_t *cobj_handle(val self, val cobj, struct cobj_class *cls);
+struct cobj_ops *cobj_ops(val self, val cobj, struct cobj_class *cls);
val cptr(mem_t *ptr);
val cptr_typed(mem_t *handle, val type_sym, struct cobj_ops *ops);
val cptrp(val obj);
@@ -1068,6 +1327,7 @@ val cptr_buf(val buf, val type_sym);
val cptr_zap(val cptr);
val cptr_free(val cptr);
val cptr_cast(val to_type, val cptr);
+val copy_cptr(val cptr);
val int_cptr(val cptr);
mem_t *cptr_get(val cptr);
mem_t *cptr_handle(val cobj, val type_sym, val self);
@@ -1082,39 +1342,50 @@ val acons(val car, val cdr, val list);
val acons_new(val key, val value, val list);
val acons_new_c(val key, loc new_p, loc list);
val aconsql_new(val key, val value, val list);
-val aconsql_new_c(val key, loc new_p, loc list);
val alist_remove(val list, val keys);
-val alist_removev(val list, struct args *keys);
+val alist_removev(val list, varg keys);
val alist_remove1(val list, val key);
val alist_nremove(val list, val keys);
-val alist_nremovev(val list, struct args *keys);
+val alist_nremovev(val list, varg keys);
val alist_nremove1(val list, val key);
val copy_cons(val cons);
val copy_tree(val tree);
val copy_alist(val list);
-val mapcar_listout(val fun, val list);
-val mapcar(val fun, val list);
+val pairlis(val keys, val values, val alist_in);
+val mapcar_listout(val fun, val seq);
+val mapcar(val fun, val seq);
val mapcon(val fun, val list);
-val mappend(val fun, val list);
-val mapdo(val fun, val list);
+val mappend(val fun, val seq);
+val mapdo(val fun, val seq);
val window_map(val range, val boundary, val fun, val seq);
val window_mappend(val range, val boundary, val fun, val seq);
val window_mapdo(val range, val boundary, val fun, val seq);
val interpose(val sep, val seq);
val merge(val list1, val list2, val lessfun, val keyfun);
+val nsort(val seq, val lessfun, val keyfun);
val sort(val seq, val lessfun, val keyfun);
-val shuffle(val seq);
+val snsort(val seq, val lessfun, val keyfun);
+val ssort(val seq, val lessfun, val keyfun);
+val nshuffle(val seq, val randstate);
+val shuffle(val seq, val randstate);
val multi_sort(val lists, val funcs, val key_funcs);
val sort_group(val seq, val keyfun, val lessfun);
-val unique(val seq, val keyfun, struct args *hashv_args);
+val unique(val seq, val keyfun, varg hashv_args);
val uniq(val seq);
val grade(val seq, val lessfun, val keyfun_in);
+val hist_sort_by(val fun, val seq, varg hashv_args);
+val hist_sort(val seq, varg hashv_args);
+val nrot(val seq, val n_in);
+val rot(val seq, val n_in);
val find(val list, val key, val testfun, val keyfun);
val rfind(val list, val key, val testfun, val keyfun);
val find_if(val pred, val list, val key);
val rfind_if(val pred, val list, val key);
val find_max(val seq, val testfun, val keyfun);
+val find_max_key(val seq, val testfun, val keyfun);
val find_min(val seq, val testfun, val keyfun);
+val find_min_key(val seq, val testfun, val keyfun);
+val find_true(val pred, val list, val keyfun);
val posqual(val obj, val list);
val rposqual(val obj, val list);
val posql(val obj, val list);
@@ -1127,6 +1398,10 @@ val pos_if(val pred, val list, val key);
val rpos_if(val pred, val list, val key);
val pos_max(val seq, val testfun, val keyfun);
val pos_min(val seq, val testfun, val keyfun);
+val subq(val oldv, val newv, val seq);
+val subql(val oldv, val newv, val seq);
+val subqual(val oldv, val newv, val seq);
+val subst(val oldv, val newv, val seq, val keyfun_in, val testfun_in);
val mismatch(val left, val right, val testfun, val keyfun);
val rmismatch(val left, val right, val testfun, val keyfun);
val starts_with(val little, val big, val testfun, val keyfun);
@@ -1142,23 +1417,26 @@ val set_diff(val list1, val list2, val testfun, val keyfun);
val diff(val seq1, val seq2, val testfun, val keyfun);
val symdiff(val seq1, val seq2, val testfun, val keyfun);
val isec(val list1, val list2, val testfun, val keyfun);
+val isecp(val list1, val list2, val testfun, val keyfun);
val uni(val list1, val list2, val testfun, val keyfun);
val copy(val seq);
val length(val seq);
-val empty(val seq);
val sub(val seq, val from, val to);
val ref(val seq, val ind);
val refset(val seq, val ind, val newval);
val dwim_set(val place_p, val seq, varg);
val dwim_del(val place_p, val seq, val ind_range);
+val mref(val obj, varg args);
val butlast(val seq, val idx);
val replace(val seq, val items, val from, val to);
val update(val seq, val fun);
val search(val seq, val key, val from, val to);
val contains(val key, val seq, val testfun, val keyfun);
val rsearch(val seq, val key, val from, val to);
+val search_all(val seq, val key, val testfun, val keyfun);
val where(val func, val seq);
val sel(val seq, val where);
+val reject(val seq, val where);
val relate(val domain_seq, val range_seq, val dfl_val);
val rcons(val from, val to);
val rangep(val obj);
@@ -1168,7 +1446,7 @@ val set_from(val range, val from);
val set_to(val range, val to);
val in_range(val range, val num);
val in_range_star(val range, val num);
-val env(void);
+val rangeref(val range, val ind);
void out_str_char(wchar_t ch, val out, int *semi_flag, int regex);
val obj_print_impl(val obj, val out, val pretty, struct strm_ctx *);
val obj_print(val obj, val stream, val pretty);
@@ -1176,36 +1454,21 @@ val print(val obj, val stream, val pretty);
val pprint(val obj, val stream);
val tostring(val obj);
val tostringp(val obj);
+val put_json(val obj, val stream, val flat);
+val put_jsonl(val obj, val stream, val flat);
+val tojson(val obj, val flat);
val display_width(val obj);
#if !HAVE_SETENV
void setenv(const char *name, const char *value, int overwrite);
void unsetenv(const char *name);
#endif
-val time_sec(void);
-val time_sec_usec(void);
-val time_string_local(val time, val format);
-val time_string_utc(val time, val format);
-val time_fields_local(val time);
-val time_fields_utc(val time);
-val time_struct_local(val time);
-val time_struct_utc(val time);
-val make_time(val year, val month, val day,
- val hour, val minute, val second,
- val isdst);
-val make_time_utc(val year, val month, val day,
- val hour, val minute, val second,
- val isdst);
-#if HAVE_STRPTIME
-val time_parse(val format, val string);
-val time_parse_local(val format, val string);
-val time_parse_utc(val format, val string);
-#endif
void init(val *stack_bottom);
int compat_fixup(int compat_ver);
void dump(val obj, val stream);
void d(val obj);
void breakpt(void);
+void dis(val obj);
#define nil convert(obj_t *, 0)
@@ -1217,7 +1480,12 @@ INLINE val null(val v) { return v ? nil : t; }
#define nilp(o) ((o) == nil)
-#define nao coerce(obj_t *, 1 << TAG_SHIFT) /* "not an object" sentinel value. */
+/* "not an object" sentinel value. */
+#if CONFIG_NAN_BOXING
+#define nao coerce(obj_t *, 1)
+#else
+#define nao coerce(obj_t *, 1 << TAG_SHIFT)
+#endif
#define missingp(v) ((v) == colon_k)
@@ -1227,9 +1495,13 @@ INLINE int null_or_missing_p(val v) { return (nilp(v) || missingp(v)); }
#define if3(a, b, c) ((a) ? (b) : (c))
+#ifdef __GNUC__
+#define uses_or2 enum { f_o_o_ ## __LINE__ }
+#define or2(a, b) ((a) ?: (b))
+#else
#define uses_or2 val or2_temp
-
#define or2(a, b) ((or2_temp = (a)) ? or2_temp : (b))
+#endif
#define or3(a, b, c) or2(a, or2(b, c))
@@ -1248,10 +1520,7 @@ INLINE val default_null_arg(val arg)
return if3(missingp(arg), nil, arg);
}
-INLINE val default_arg_strict(val arg, val dfl)
-{
- return if3(missingp(arg), dfl, arg);
-}
+#define default_arg_strict(arg, dfl) if3(missingp(arg), dfl, arg)
#define list_collect_decl(OUT, PTAIL) \
val OUT = nil; \
@@ -1298,3 +1567,9 @@ loc list_collect_revappend(loc ptail, val obj);
#define static_forward(decl) static decl
#define static_def(def) static def
#endif
+
+#ifdef __cplusplus
+#define all_zero_init { }
+#else
+#define all_zero_init { 0 }
+#endif
diff --git a/libtags.txr b/libtags.txr
new file mode 100755
index 00000000..6117890c
--- /dev/null
+++ b/libtags.txr
@@ -0,0 +1,469 @@
+#!/usr/bin/env txr
+@(mdo
+ ;; TODO
+ ;; #. etags support (update to new hash table format, etc.).
+ ;; #. Remove obsolete symbols (flip, etc.).
+ ;; #. Update to the new compat handling. There may be fewer if3s in the reg calls.
+ ;; #. merge into tags.tl the writing functions.
+ ;; #. handle reg_vars, etc. need to handle the reg_varl(sym,val) which is in the definition of reg_var.
+ ;; reg_var(sym, obj) too, with the -b option.
+ ;; (there are many cases where the reg_vars are used to initialize some variables.
+ ;; need special handling, probably.)
+ ;; #. others of my todos.
+ ;;
+ ;; #. *args-eff* not stored in var, so getting doubly stored.
+ ;;
+ ;; #. make sure some hard-to-determine things are printed to stderr,
+ ;; like the multiple occurrences of idents in the existing tags file.
+ ;; makes it easier to handle changes in the C source.
+ ;;
+ ;; #. Check if it still allows us to navigate to the right tags (e.g., acons-new vs acons_new).
+
+ ;; FIXME Why is .l getting added.
+ ;; and .y too.
+ ;; with only *.c pattern.
+ ;; Should I add .shipped ones?
+ ;; probably better to assume maintainer, since libtags.txr is for
+ ;; developers of txr.
+ ;; so check the .l, .y, yy.tab.c, etc.
+ ;; not the .shipped ones.
+
+ ;; libtags.txr can tag the source even without an existing tags file.
+ ;; It will just be less accurate.
+ ;;
+ ;; libtags.txr automatically ignores lines with any comments, so
+ ;; adding "/* OBS */" to for example num-chr does remove it.
+ ;; However, there may be no other comments, otherwise it will miss
+ ;; them.
+ ;;
+ ;; Even if some vars like path_sep_chars are declared and initialized
+ ;; at the same time, better to just tag the reg_var call directly.
+ ;; The user can navigate manually to the var in question; there would
+ ;; be too many useless false positives.
+ ;; also when they get assigned, like stderr_s, etc.
+ ;; *maybe* we can have a list of exceptions, of which path_sep_chars
+ ;; can be a part of.
+ ;; but even then, it's being assigned in a static_str, so that may
+ ;; be interesting to know.
+ ;;
+ ;; actually, completely unnecessary to specify that type is intrinsic,
+ ;; because they are in c files.
+ ;; any c files with such a tag is an intrinsic.
+
+ ;; Note that libtags.txr should be run from the TXR source tree.
+ ;; Because it globs for *.c.
+
+ (defvar *tags-lib*)
+
+ (let ((*tags-lib* t))
+ (load "txrtags"))
+
+ (define-option-struct libtags-opts tags-opts
+ (v verbose :bool "Print diagnostic messages during processing."))
+
+ (defvarl output)
+ (defvarl emacs)
+ (defvarl verbose)
+
+ (defvarl ix-tags (hash :equal-based))
+ ;; FIXME Rename to sym-vars?
+ (defvarl var-syms (hash :equal-based))
+ (defvarl fun-vars (hash :equal-based))
+
+ (defun update-ix-tags (tag newkey : oldkey)
+ ;; Remove the var_s tag because we need not tag it if we have the
+ ;; actual function.
+ (when oldkey
+ (del [ix-tags oldkey]))
+ (upd [ix-tags newkey] (append (sys:var 1) (list tag))))
+
+ (defun qualify-sym (sym pkg)
+ (join (casequal pkg
+ ("user_package" "")
+ ("system_package" "sys:")
+ ("keyword_package" ":")
+ (t (when verbose
+ (put-line `@sym: in unknown package @pkg` *stderr*))
+ pkg))
+ sym))
+
+ (defun op-error-fun-p (fun)
+ (mequal fun
+ "op_error" "op_meta_error"
+ "op_qquote_error" "op_unquote_error")))
+@(do
+ (let ((o (new libtags-opts)))
+ o.(getopts *args*)
+ (set output (cond (o.output o.output)
+ (o.emacs "TAGS")
+ (t "tags")))
+ (set emacs o.emacs)
+ (set verbose o.verbose)))
+@(bind var_s #/\w[\w\d]*_s/)
+@(bind cident #/\w[\w\d]*/)
+@(bind regfun #/reg_(op|mac|fun)/)
+@(bind regvar #/reg_(varl?|symacro)|ffi_typedef/)
+@(bind lpar "(")
+@(bind rpar ")")
+@;;
+@(define get-interned-sym (sym))@\
+@ (local lit pkg)intern(lit("@lit"), @{pkg cident})@\
+@ (bind sym @(qualify-sym lit pkg))@\
+@(end)
+@;;
+@(define get-fun (fun))@\
+@ func_@/[\w\d]+/(@{fun cident}@(maybe), @/\d+/@(end))@\
+@(end)
+@;;
+@(define get-sym-fun (fun))@\
+@ (local fun-var)@\
+@ (cases)func_@/[\w\d]+/(if3(opt_compat && opt_compat <= @/\d+/, @\
+@ cident, @{fun cident})@(maybe), @/\d+/@(end))@\
+@ ;; TODO There may be missing cases here of func_ with compat opt handling.
+@ (or)@(get-fun fun)@\
+@ (or)@{fun-var cident}@\
+@ (do (when verbose
+ (unless (or (starts-with "op_" fun-var)
+ [fun-vars fun-var])
+ (put-line `@{fun-var}: undefined function variable` *stderr*))))@\
+@ (bind fun @(or [fun-vars fun-var] fun-var))@\
+@ (end)@\
+@(end)
+@;;
+@(define get-sym-fun (fun))
+@ (cases)
+@ / +/@(get-sym-fun fun)@rpar;
+@ (or)
+@ / +/func_@/[\w\d]+/(if3(opt_compat && opt_compat <= @/\d+/,
+@ (cases)
+@ ;; For abs-path-p.
+@ / +/@cident, @{fun cident})@(maybe), @/\d+/@(end))@rpar;
+@ (or)
+@ ;; For lexical-var-p.
+@ / +/@cident,
+@ / +/@{fun cident}@rpar@(maybe), @/\d+/@(end)@rpar@rpar;
+@ (end)
+@ (or)
+@ ;; For match-regex, match-regex-right and match-regst-right.
+@ / +/func_@/[\w\d]+/((opt_compat && opt_compat <= @/\d+/) ?
+@ / +/@cident : @{fun cident}@(maybe), @/\d+/@(end))@rpar;
+@ (end)
+@(end)
+@(define get-file-ix-tags (file))
+@ (next file)
+@ (collect)
+@ (local sym var fun pkg)
+@ (all)
+@ line
+@ (and)
+@ (cases)
+@ / +/@(maybe)val @(end)@{var cident} = @(get-fun fun);
+@ (do (set [fun-vars var] fun))
+@ (or)
+@ / +/@(maybe)val @(end)@{var var_s} = @(get-interned-sym sym);
+@ (do (if [var-syms var]
+ (when verbose
+ (put-line `@var: reassigned variable` *stderr*))
+ (progn
+ (iflet ((tags [ix-tags var]))
+ ;; The variable is declared later in our search.
+ (progn
+ (each ((tag tags))
+ (let ((old-ident tag.ident))
+ (set tag.ident sym)
+ (typecase tag
+ (fun-tag (update-ix-tags tag old-ident))
+ (var-tag (update-ix-tags tag sym))
+ (t
+ ;; This would be a bug in libtags.txr,
+ ;; so print it regardless of --verbose.
+ (put-line `@(struct-type-name tag): unexpected struct type`
+ *stderr*)))))
+ (del [ix-tags var]))
+ ;; We may not find a corresponding C function or
+ ;; variable (either because of missing patterns in
+ ;; libtags.txr, or accidental omissions in the C
+ ;; source), in which case we will just tag the line of
+ ;; the var_s assignment.
+ (set [ix-tags var] (list (new tag
+ ident sym
+ path file
+ line line))))
+ ;; Keep track of the symbols, because when we find a
+ ;; symbol corresponding to the above tag to insert into
+ ;; ix-tags, we remove the above tag, but some symbols
+ ;; are multiply bound, for example ‘and’ which is both
+ ;; an operator and a function.
+ (set [var-syms var] sym))))
+@ (or)
+@ (cases)
+@ / +/@regfun(@{var var_s}, @(get-sym-fun fun));
+@ (or)
+@ / +/@regfun(@{var var_s},
+@ / +/@(get-sym-fun fun));
+@ (end)
+@ (do
+ ;; op_error and company appear only in the var_s cases
+ ;; (because otherwise the interned symbol would be used
+ ;; only for throwing an error).
+ (unless (op-error-fun-p fun)
+ (iflet ((sym [var-syms var])
+ ;; We store the path and line in case there is no such
+ ;; tagged function or variable in the tags file, so
+ ;; that we can still jump to the line where the symbol
+ ;; was interned.
+ (tag (new fun-tag
+ ident (or sym fun)
+ path file
+ line line))
+ ((have sym)))
+ (update-ix-tags tag fun var)
+ (update-ix-tags tag var))))
+@ (or)
+@ (cases)
+@ / +/@regfun(@(get-interned-sym sym), @(get-sym-fun fun));
+@ (bind var nil)
+@ (or)
+@ / +/@regfun@lpar@(get-interned-sym sym),
+@ (get-sym-fun fun)
+@ (bind var nil)
+@ (or)
+@ ;; The assignment form always spans two or more lines.
+@ / +/@regfun(@{var var_s} = @(get-interned-sym sym),
+@ / +/@(get-sym-fun fun));
+@ (or)
+@ / +/@regfun(@{var var_s} = intern(lit("@lit"),
+@ / +/@{pkg cident}), @(get-sym-fun fun));
+@ (bind sym @(qualify-sym lit pkg))
+@ (end)
+@ (do (when var
+ (if [var-syms var]
+ (when verbose
+ (put-line `@var: reassigned variable` *stderr*))
+ (set [var-syms var] sym)))
+ (update-ix-tags (new fun-tag
+ ident sym
+ path file
+ line line)
+ fun var))
+@ (or)
+@ (cases)
+@ / +/@regvar(@{var var_s}, @(skip));
+@ (or)
+@ ;; Cannot add a comma after the skip because the line
+@ ;; contains many comma.
+@ / +/ffi_typedef@lpar@{var var_s}, @(skip)
+@ (end)
+@ (do (iflet ((sym [var-syms var])
+ (tag (new var-tag
+ ;; The var value is not used.
+ ;; (except in debugging, to print the undefined
+ ;; variables.)
+ ident (or sym var)
+ path file
+ line line))
+ ((have sym)))
+ ;; FIXME Makes sense to have a list here?
+ ;; Or just following along with the style for funs?
+ (update-ix-tags tag
+ ;; Doesn't matter if we set the hash table
+ ;; key to sym, because in the output we
+ ;; separate the tags based on var-tag or
+ ;; tag/fun-tag.
+ ;; Only fun-tags need to have a key that
+ ;; corresponds to the existing tags.
+ sym var)
+ (update-ix-tags tag var)))
+@ (or)
+@ (cases)
+@ / +/@regvar(@(get-interned-sym sym), @(skip));
+@ (bind var nil)
+@ (or)
+@ / +/@regvar@lpar@(get-interned-sym sym),
+@ (bind var nil)
+@ (or)
+@ / +/@regvar(@{var var_s} = @(get-interned-sym sym), @(skip));
+@ (or)
+@ / +/@regvar@lpar@{var var_s} = @(get-interned-sym sym),
+@ (or)
+@ / +/@regvar(@{var var_s} = intern(lit("@lit"),
+@ / +/@{pkg cident}), @(skip));
+@ (bind sym @(qualify-sym lit pkg))
+@ (or)
+@ / +/@regvar@lpar@{var var_s} = intern(lit("@lit"),
+@ / +/@{pkg cident}),
+@ (bind sym @(qualify-sym lit pkg))
+@ (end)
+@ (do (when var
+ (if [var-syms var]
+ (when verbose
+ (put-line `@var: reassigned variable` *stderr*))
+ (set [var-syms var] sym)))
+ (update-ix-tags (new var-tag
+ ident sym
+ path file
+ line line)
+ sym var))
+@ (end)
+@ (end)
+@ (end)
+@(end)
+@;; Move lib.c to the front, because many _f variables are
+@;; defined there before being used elsewhere, for example in eval.c.
+@;; (And with such an order, none are ever defined after being used.)
+@;; However, if we ever need to do it, we could add the tags in question
+@;; to another hash table and replace the _f variables in question as soon
+@;; as we found suitable candidates.
+@(next :list (cons "lib.c" (remqual "lib.c"
+ (command-get-lines "git ls-files '*.c'"))))
+@(repeat)
+@ file.c
+@ (get-file-ix-tags `@file.c`)
+@(end)
+@(do
+ ;; Is nshuffle even getting detected as possible duplicate?
+ ;; FIXME The eval.c compat handling has changed.
+ ;; Need to update that.
+
+ (when nil
+ (dohash (ident tag ix-tags)
+ (when (mequal tag.ident
+ ;; Obsolete symbols.
+ "flip" "slot-p")
+ (del [ix-tags ident]))))
+
+ ;; TODO what if sym has _s? shouldn't happen, but could be more
+ ;; robust by using another kind of key. like (list ident "foo").
+
+ (when verbose
+ (let ((alist (keep-if (op ends-with "_s" (first @1))
+ (hash-pairs ix-tags)))
+ (undefined nil)
+ (missing nil))
+ (each ((pair alist))
+ (tree-bind (key tags) pair
+ (each ((tag tags))
+ (typecase tag
+ (fun-tag (push (list key (join "(" tag.ident ")")) undefined))
+ (var-tag (push (list key) undefined))
+ (tag (push (list key (join "(" tag.ident ")")) missing))
+ (t (put-line `@(struct-type-name tag): unexpected struct type`
+ *stderr*))))))
+ (upd undefined (nsort @1 : car))
+ (upd missing (nsort @1 : car))
+ (mapdo (op put-line `@(cat-str @1 " "): undefined variable`
+ *stderr*)
+ undefined)
+ (mapdo (op put-line `@(cat-str @1 " "): no corresponding function or value`
+ *stderr*)
+ missing)
+ (put-line `@(len undefined) undefined variables` *stderr*)
+ (put-line `@(len missing) missing corresponding functions` *stderr*)
+ (let ((vals (flow ix-tags hash-values flatten (nsort @1 : .ident))))
+ (put-line `@(len vals) ix-tags` *stderr*))))
+
+ (defun merge-ix-tags (orig-tags)
+ (let ((tags orig-tags)
+ ;; Empty if no original tags file.
+ (orig-tags (group-by (op identity @1.ident) orig-tags))
+ (ix-tags (hash-pairs ix-tags)))
+ (each ((pair ix-tags))
+ ;; These idents are unique, because we store them into the hash
+ ;; table and have lists of ix-tags for each ident.
+ (tree-bind (ident ix-tags) pair
+ (condlet
+ ((((ends-with "_s" ident)))
+ ;; We don't want the tag to point to the declaration of the
+ ;; variable (which is what would happen if we duplicate the
+ ;; tag in the existing tags file), because that is of
+ ;; limited usefulness, so fall back to our info.
+ (upd tags (revappend ix-tags)))
+ (((orig-tags-orig orig-tags)
+ (orig-tags (keep-if (andf (op mequal
+ (short-suffix @1.path)
+ ;; We know that the identifiers are
+ ;; in C source (in particular, not
+ ;; in TXR Lisp source).
+ ".c" ".l" ".y")
+ ;; Assume that an open parenthesis means the tagged
+ ;; identifier is a function.
+ ;; This way we can skipped tagged struct members, which
+ ;; can share the same name as an existing function, but
+ ;; which we want to ignore (because we are tagging Lisp
+ ;; functions here).
+ (op find #\( @1.line))
+ [orig-tags ident])))
+ ;; We may tag Lisp identifiers several times (possibly with
+ ;; same-named static functions in different compilation
+ ;; units, but more likely from #ifdef blocks), but it's the
+ ;; best we can do without fully parsing the C.
+ (when (and verbose (> (len orig-tags) 1))
+ (put-line `@ident: multiple occurrences in tags file` *stderr*))
+ (tree-bind (: var-tags other-tags) (separate (op equal @1.type "v")
+ ix-tags)
+ (upd tags (revappend var-tags))
+ (each-prod ((orig-tag orig-tags)
+ (ix-tag other-tags))
+ (unless (equal orig-tag.ident ix-tag.ident)
+ (let ((tag (copy-struct orig-tag)))
+ (set tag.ident ix-tag.ident)
+ (push tag tags))))))
+ (t
+ (when verbose
+ (whenlet ((orig-tags (keep-if (op mequal
+ (short-suffix @1.path)
+ ".c" ".l" ".y")
+ [orig-tags-orig ident])))
+ (each-prod ((orig-tag orig-tags)
+ (ix-tag ix-tags))
+ ;; FIXME args (for args_s) is duplicated four times.
+ (put-line `@ident | orig @{orig-tag.ident} @{orig-tag.path} | ix @{ix-tag.ident} @{ix-tag.path}`))))
+ ;; The tags file doesn't contain a tag for our ident.
+ ;; Fall back to our info.
+ (upd tags (revappend ix-tags))))))
+ ;; Not nsort so as not to modify orig-tags in caller.
+ (sort tags : .ident)))
+
+ ;; We may as well merge the ctags file (i.e., sort the lines), since
+ ;; we have to read all the existing lines.
+ ;;
+ ;; Greatly adjusted from tags.tl.
+ ;;
+ ;; For some reason, acons-new is found only if it is placed before
+ ;; acons_new, and asin is found only if it is placed before asine.
+ ;; Is there some alphabetical ordering particularity?
+ ;; Will need to resort the ctags since me_op could be associated to op
+ ;; or do.
+ (defun write-tagfile (ix-tags)
+ (let* ((orig-tags (read-tagfile output))
+ (ix-tags (merge-ix-tags orig-tags)))
+ (with-stream (stream (open-file output "w"))
+ (each ((tag ix-tags))
+ (put-line tag.(text) stream)))))
+
+ ;; Greatly adjusted from tags.tl.
+ ;;
+ ;; FIXME incomplete at the moment.
+ (defun write-etagfile (ix-tags)
+ (let ((orig-tags (read-etagfile output)))
+ (upd orig-tags (nsort @1 : car))
+ (file-put "tags.out" orig-tags)
+ (with-stream (stream (open-file output "w"))
+ (each ((pair orig-tags))
+ (tree-bind (path . etags) pair
+ (let ((str (with-out-string-stream (s)
+ (each ((etag etags))
+ (unless (ends-with "_s" etag.ident)
+ (each ((ix-tag [keep-if (op find etag.ident @1 : .ident)
+ ix-tags .ctags]))
+ (put-line `duping @ix-tag`)
+ ;; (put-line `@{lisptag.ident}@[tag.(text) (len tag.ident)..:]`
+ ;; stream)
+ ))
+ (put-line etag.(etext) s)))))
+ (put-string `@{etag-sec-start}\n@{path},@(len str)\n@{str}`
+ stream)))))))
+
+ (if emacs
+ (write-etagfile ix-tags)
+ (write-tagfile ix-tags)))
diff --git a/linenoise/linenoise.c b/linenoise/linenoise.c
index e61ba49d..ca75c39c 100644
--- a/linenoise/linenoise.c
+++ b/linenoise/linenoise.c
@@ -14,7 +14,7 @@
*
* Copyright (c) 2010-2015, Salvatore Sanfilippo <antirez at gmail dot com>
* Copyright (c) 2010-2013, Pieter Noordhuis <pcnoordhuis at gmail dot com>
- * Copyright (c) 2015-2020, Kaz Kylheku <kaz at kylheku dot com>
+ * Copyright (c) 2015-2024, Kaz Kylheku <kaz at kylheku dot com>
*
* All rights reserved.
*
@@ -42,8 +42,6 @@
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/
-#include <termios.h>
-#include <unistd.h>
#include <stddef.h>
#include <wchar.h>
#include <stdlib.h>
@@ -52,13 +50,16 @@
#include <string.h>
#include <ctype.h>
#include <wctype.h>
-#include <sys/types.h>
-#include <sys/ioctl.h>
#include <signal.h>
#include <limits.h>
#include <assert.h>
#include <stdarg.h>
+#include <unistd.h>
#include "config.h"
+#if CONFIG_FULL_REPL
+#include <termios.h>
+#include <sys/types.h>
+#include <sys/ioctl.h>
#if HAVE_POLL
#include <poll.h>
#endif
@@ -67,6 +68,7 @@
#include <sys/fcntl.h>
#include <io.h>
#endif
+#endif
#include "linenoise.h"
#ifdef __cplusplus
@@ -92,33 +94,46 @@ struct lino_state {
lino_t *next, *prev; /* Links for global list: must be first */
/* Lifetime enduring state */
+#if CONFIG_FULL_REPL
lino_compl_cb_t *completion_callback;
+#endif
void *cb_ctx; /* User context for completion callback */
+#if CONFIG_FULL_REPL
lino_atom_cb_t *atom_callback;
void *ca_ctx; /* User context for atom callback */
+#endif
lino_enter_cb_t *enter_callback;
void *ce_ctx; /* User context for enter callback */
+#if CONFIG_FULL_REPL
struct termios orig_termios; /* In order to restore at exit.*/
+#endif
#ifdef __CYGWIN__
int orig_imode, orig_omode;
#endif
+#if CONFIG_FULL_REPL
int rawmode; /* For atexit() function to check if restore is needed*/
int mlmode; /* Multi line mode. Default is single line. */
+#endif
int history_max_len;
int history_len;
int loaded_lines; /* How many lines come from load. */
wchar_t **history;
+#if CONFIG_FULL_REPL
wchar_t *clip; /* Selection */
wchar_t *result; /* Previous command result. */
+#endif
mem_t *tty_ifs; /* Terminal input file stream. */
mem_t *tty_ofs; /* Terminal output file stream. */
int save_hist_idx; /* Jump to history position on entry into edit */
/* Volatile state pertaining to just one linenoise call */
- wchar_t buf[LINENOISE_MAX_DISP]; /* Displayed line bufer. */
+#if CONFIG_FULL_REPL
+ wchar_t buf[LINENOISE_MAX_DISP]; /* Displayed line buffer. */
+#endif
wchar_t data[LINENOISE_MAX_LINE]; /* True data corresponding to display */
const wchar_t *prompt; /* Prompt to display. */
const char *suffix; /* Suffix when creating temp file. */
+#if CONFIG_FULL_REPL
int plen; /* Prompt length. */
int pos; /* Current cursor position. */
int sel; /* Selection start in terms of display. */
@@ -137,7 +152,11 @@ struct lino_state {
int selmode; /* Visual selection being made. */
int selinclusive; /* Selections include character right of endpoint. */
int noninteractive; /* No character editing, even if input is tty. */
+#endif
+ int show_prompt; /* Show prompting in non-interactive mode. */
+#if CONFIG_FULL_REPL
struct lino_undo *undo_stack;
+#endif
lino_error_t error; /* Most recent error. */
};
@@ -159,12 +178,16 @@ enum key_action {
};
static lino_os_t lino_os;
-static lino_t lino_list = { &lino_list, &lino_list };
+static lino_t lino_list;
volatile sig_atomic_t lino_list_busy;
+#if CONFIG_FULL_REPL
static int atexit_registered = 0; /* Register atexit just 1 time. */
+#endif
#define nelem(array) (sizeof (array) / sizeof (array)[0])
+#if CONFIG_FULL_REPL
+
static int wcsnprintf(wchar_t *s, size_t nchar, const wchar_t *fmt, ...)
{
int ret;
@@ -177,8 +200,11 @@ static int wcsnprintf(wchar_t *s, size_t nchar, const wchar_t *fmt, ...)
return wcslen(s);
}
+#endif
+
/* ======================= Low level terminal handling ====================== */
+#if CONFIG_FULL_REPL
/* Set if to use or not the multi line mode. */
void lino_set_multiline(lino_t *ls, int ml) {
ls->mlmode = ml;
@@ -197,6 +223,7 @@ int lino_get_selinculsive(lino_t *ls)
return ls->selinclusive;
}
+
void lino_set_noninteractive(lino_t *ls, int ni)
{
ls->noninteractive = ni;
@@ -207,18 +234,31 @@ int lino_get_noninteractive(lino_t *ls)
return ls->noninteractive;
}
+#endif
+
+void lino_enable_noninteractive_prompt(lino_t *ls, int enable)
+{
+ ls->show_prompt = enable;
+}
+
+#if CONFIG_FULL_REPL
+
void lino_set_atom_cb(lino_t *l, lino_atom_cb_t *cb, void *ctx)
{
l->atom_callback = cb;
l->ca_ctx = ctx;
}
+#endif
+
void lino_set_enter_cb(lino_t *l, lino_enter_cb_t *cb, void *ctx)
{
l->enter_callback = cb;
l->ce_ctx = ctx;
}
+#if CONFIG_FULL_REPL
+
static void atexit_handler(void);
/* Raw mode: 1960 magic shit. */
@@ -243,13 +283,13 @@ static int enable_raw_mode(lino_t *ls) {
raw = ls->orig_termios; /* modify the original mode */
/* input modes: no break, no CR to NL, no parity check, no strip char,
* no start/stop output control. */
- raw.c_iflag &= ~(BRKINT | ICRNL | INPCK | ISTRIP | IXON);
+ raw.c_iflag &= convert(tcflag_t, ~(BRKINT | ICRNL | INPCK | ISTRIP | IXON));
/* we don't change any output modes (c_oflag) */
/* control modes - set 8 bit chars */
raw.c_cflag |= (CS8);
/* local modes - choing off, canonical off, no extended functions,
* no signal chars (^Z,^C) */
- raw.c_lflag &= ~(ECHO | ICANON | IEXTEN | ISIG);
+ raw.c_lflag &= convert(tcflag_t, ~(ECHO | ICANON | IEXTEN | ISIG));
/* control chars - set return condition: min number of bytes and timer.
* We want read to return every single byte, without timeout. */
raw.c_cc[VMIN] = 1; raw.c_cc[VTIME] = 0; /* 1 byte, no timer */
@@ -406,8 +446,10 @@ static void free_undo_stack(lino_t *l)
static void record_undo(lino_t *l)
{
- struct lino_undo *rec = (struct lino_undo *) lino_os.alloc_fn(sizeof *rec), *iter;
- wchar_t *data = (wchar_t *) lino_os.wstrdup_fn(l->data);
+ struct lino_undo *rec = coerce(struct lino_undo *,
+ lino_os.alloc_fn(sizeof *rec));
+ struct lino_undo *iter;
+ wchar_t *data = lino_os.wstrdup_fn(l->data);
int count;
if (rec == 0 || data == 0) {
@@ -721,6 +763,8 @@ static int history_search(lino_t *l)
verbatim:
if (hl >= convert(int, nelem(hpat)))
break;
+ if (c == CTL('J'))
+ c = '\r';
hpat[hl++] = c;
/* fallthrough */
if (0) {
@@ -784,7 +828,7 @@ static int history_search(lino_t *l)
break;
case CTL('Z'):
disable_raw_mode(l);
- raise(SIGTSTP);
+ kill(0, SIGTSTP);
enable_raw_mode(l);
}
}
@@ -840,14 +884,14 @@ static void show_help(lino_t *l)
break;
continue;
case ESC:
- if ((seq[0] = lino_os.getch_fn(l->tty_ifs)) < 0)
+ if ((seq[0] = lino_os.getch_fn(l->tty_ifs)) == WEOF)
break;
- if ((seq[1] = lino_os.getch_fn(l->tty_ifs)) < 0)
+ if ((seq[1] = lino_os.getch_fn(l->tty_ifs)) == WEOF)
break;
if (seq[0] == '[') {
if (seq[1] >= '0' && seq[1] <= '9') {
- if ((seq[2] = lino_os.getch_fn(l->tty_ifs)) < 0)
+ if ((seq[2] = lino_os.getch_fn(l->tty_ifs)) == WEOF)
break;
if (seq[2] == '~') {
switch(seq[1]) {
@@ -886,7 +930,7 @@ static void show_help(lino_t *l)
continue;
case CTL('Z'):
disable_raw_mode(l);
- raise(SIGTSTP);
+ kill(0, SIGTSTP);
enable_raw_mode(l);
i -= 1;
continue;
@@ -965,7 +1009,7 @@ static void sync_data_to_buf(lino_t *l)
l->sel = pos;
if (l->dend == dpos)
l->end = pos;
- if (l->dsel == dpos - 1 && rev && l->selinclusive && ch && ch != '\r')
+ if (l->dsel == dpos - 1 && rev && l->selinclusive)
l->sel = pos;
if (ch) {
@@ -1303,7 +1347,7 @@ static void move_cursor(lino_t *l, int npos)
static int scan_match_rev(const wchar_t *s, int i, wchar_t mch)
{
while (i > 0) {
- int ch = s[--i];
+ wchar_t ch = s[--i];
if (ch == mch)
return i;
@@ -1348,7 +1392,7 @@ static int scan_rev(const wchar_t *s, int i)
static int scan_match_fwd(const wchar_t *s, int i, wchar_t mch)
{
while (s[++i]) {
- int ch = s[i];
+ wchar_t ch = s[i];
if (ch == mch)
return i;
@@ -1483,7 +1527,7 @@ static void flash(lino_t *l, int ch)
wchar_t on[2] = { ch };
const wchar_t *off = L"\b \b";
- if (l->dlen >= (int) nelem (l->data) - 1)
+ if (l->dlen >= convert(int, nelem (l->data)) - 1)
return;
for (i = 0; i < 2 && !cancel; i++) {
@@ -1572,7 +1616,7 @@ static void delete_sel(lino_t *l)
*
* On error writing to the terminal -1 is returned, otherwise 0. */
static int edit_insert(lino_t *l, wchar_t c) {
- if (l->dlen < (int) nelem(l->data) - 1) {
+ if (l->dlen < convert(int, nelem(l->data)) - 1) {
record_triv_undo(l);
delete_sel(l);
if (l->dpos == l->dlen) {
@@ -1631,7 +1675,7 @@ static int edit_insert(lino_t *l, wchar_t c) {
static int edit_insert_str(lino_t *l, const wchar_t *s, int nchar)
{
- if (l->dlen < (int) nelem (l->data) - nchar) {
+ if (l->dlen < convert(int, nelem (l->data)) - nchar) {
record_undo(l);
delete_sel(l);
@@ -1940,7 +1984,7 @@ static void edit_in_editor(lino_t *l) {
char *ed = getenv("EDITOR");
char path[128];
- if (ed) {
+ if (ed && ed[0] != '\0') {
const char *ho = get_home();
int fd;
#if HAVE_MKSTEMPS
@@ -1968,8 +2012,9 @@ static void edit_in_editor(lino_t *l) {
if (fo) {
char cmd[256];
- snprintf(cmd, sizeof cmd, "%s %s", ed, path);
int preserve = 0;
+
+ snprintf(cmd, sizeof cmd, "%s %s", ed, path);
tr(l->data, '\r', '\n');
if (lino_os.puts_file_fn(fo, l->data) && lino_os.puts_file_fn(fo, L"\n"))
@@ -2086,6 +2131,8 @@ static int edit(lino_t *l, const wchar_t *prompt)
if (verbatim ||
(paste && c != ESC && c != BACKSPACE && c != CTL('H')))
{
+ if (verbatim && c == CTL('J'))
+ c = '\r';
if (edit_insert(l,c)) {
l->error = lino_ioerr;
goto out;
@@ -2212,12 +2259,14 @@ static int edit(lino_t *l, const wchar_t *prompt)
}
break;
}
+ l->save_hist_idx = l->history_index;
+ /* fallthrough */
+ case CTL('F'):
+ ret = l->len;
if (l->mlmode)
edit_move_end(l);
if (l->need_refresh)
refresh_line(l);
- ret = l->len;
- l->save_hist_idx = l->history_index;
goto out;
case '?':
extended = 0;
@@ -2259,7 +2308,7 @@ static int edit(lino_t *l, const wchar_t *prompt)
break;
}
- if (c < 0)
+ if (c == WEOF)
goto out;
if (c == 0)
continue;
@@ -2477,7 +2526,7 @@ static int edit(lino_t *l, const wchar_t *prompt)
if (l->need_refresh)
refresh_line(l);
disable_raw_mode(l);
- raise(SIGTSTP);
+ kill(0, SIGTSTP);
enable_raw_mode(l);
l->maxrows = 0;
l->dpos = dpos;
@@ -2505,6 +2554,8 @@ static void sigwinch_handler(int sig)
{
lino_t *li;
+ (void) sig;
+
if (lino_list_busy)
return;
@@ -2513,6 +2564,8 @@ static void sigwinch_handler(int sig)
}
#endif
+#endif
+
/* The main function of the linenoise library
* handles a non-TTY input file descriptor by opening
* a standard I/O stream on it and reading lines
@@ -2520,23 +2573,74 @@ static void sigwinch_handler(int sig)
* the edit function. */
wchar_t *linenoise(lino_t *ls, const wchar_t *prompt)
{
- int count;
int ifd = lino_os.fileno_fn(ls->tty_ifs);
- if ( ls->noninteractive || !isatty(ifd)) {
- /* Not a tty: read from file / pipe. */
- if (lino_os.getl_fn(ls->tty_ifs, ls->data, nelem(ls->data)) == 0) {
- ls->error = (lino_os.eof_fn(ls->tty_ifs) ? lino_eof : lino_ioerr);
- return 0;
+#if CONFIG_FULL_REPL
+ int noninteractive = ls->noninteractive;
+ int plain = noninteractive || !isatty(ifd);
+#else
+ int noninteractive = 1;
+ int plain = 1;
+#endif
+
+ if (plain) {
+ wchar_t *ret = 0;
+ size_t len = 0;
+ const wchar_t *condensed_prompt = prompt + wcslen(prompt);
+ int show_prompt = ls->show_prompt || (noninteractive && isatty(ifd));
+
+ if (show_prompt) {
+ while (condensed_prompt > prompt &&
+ (*condensed_prompt == 0 || *condensed_prompt == ' '))
+ {
+ condensed_prompt--;
+ }
}
- count = wcslen(ls->data);
+ for (;;) {
+ size_t nlen;
+
+ if (show_prompt)
+ lino_os.puts_fn(ls->tty_ofs, ret ? condensed_prompt : prompt);
+
+ /* Not a tty: read from file / pipe. */
+ if (lino_os.getl_fn(ls->tty_ifs, ls->data, nelem(ls->data)) == 0) {
+ ls->error = (lino_os.eof_fn(ls->tty_ifs) ? lino_eof : lino_ioerr);
+ if (!lino_os.puts_fn(ls->tty_ofs, L"\n"))
+ ls->error = lino_ioerr;
+ break;
+ }
+
+ nlen = wcslen(ls->data);
- if (count && ls->data[count-1] == '\n')
- ls->data[count-1] = '\0';
- return lino_os.wstrdup_fn(ls->data);
+ {
+ wchar_t *nret = lino_os.wrealloc_fn(ret, len + nlen + 1);
+ if (nret == 0) {
+ lino_os.free_fn(ret);
+ return 0;
+ }
+ wmemcpy(nret + len, ls->data, nlen + 1);
+ ret = nret;
+ len = len + nlen;
+
+ if (len && ret[len-1] == '\n')
+ ret[len-1] = '\r';
+ }
+
+ if (!ls->enter_callback || ls->enter_callback(ret, ls->ce_ctx))
+ break;
+ }
+
+ if (ret != 0) {
+ if (len && ret[len - 1] == '\n')
+ ret[len-1] = '\0';
+ }
+
+ return ret;
} else {
wchar_t *ret = 0;
+#if CONFIG_FULL_REPL
+ int count;
#ifdef SIGWINCH
static struct sigaction blank;
struct sigaction sa = blank, oa;
@@ -2562,6 +2666,7 @@ wchar_t *linenoise(lino_t *ls, const wchar_t *prompt)
#ifdef SIGWINCH
sigaction(SIGWINCH, &oa, 0);
#endif
+#endif
return ret;
}
}
@@ -2609,10 +2714,12 @@ lino_t *lino_copy(lino_t *le)
*ls = *le;
ls->history_len = 0;
ls->history = 0;
+#if CONFIG_FULL_REPL
ls->rawmode = 0;
ls->clip = 0;
ls->result = 0;
ls->undo_stack = 0;
+#endif
link_into_list(&lino_list, ls);
}
@@ -2625,13 +2732,17 @@ static void free_hist(lino_t *ls);
static void lino_cleanup(lino_t *ls)
{
+#if CONFIG_FULL_REPL
disable_raw_mode(ls);
+#endif
free_hist(ls);
+#if CONFIG_FULL_REPL
free_undo_stack(ls);
lino_os.free_fn(ls->clip);
ls->clip = 0;
lino_os.free_fn(ls->result);
ls->result = 0;
+#endif
}
void lino_free(lino_t *ls)
@@ -2677,6 +2788,8 @@ static void free_hist(lino_t *ls) {
}
}
+#if CONFIG_FULL_REPL
+
/* At exit we'll try to fix the terminal to the initial conditions. */
static void atexit_handler(void) {
lino_t *ls;
@@ -2685,6 +2798,8 @@ static void atexit_handler(void) {
lino_cleanup(ls);
}
+#endif
+
/* This is the API call to add a new entry in the linenoise history.
* It uses a fixed array of char pointers that are shifted (memmoved)
* when the history max length is reached in order to remove the older
@@ -2724,7 +2839,9 @@ int lino_hist_add(lino_t *ls, const wchar_t *line) {
}
ls->history[ls->history_len] = linecopy;
ls->history_len++;
+#if CONFIG_FULL_REPL
undo_renumber_hist_idx(ls, 1);
+#endif
return 1;
}
@@ -2825,6 +2942,8 @@ int lino_have_new_lines(lino_t *ls)
return ls->history_len > ls->loaded_lines;
}
+#if CONFIG_FULL_REPL
+
void lino_set_result(lino_t *ls, wchar_t *res)
{
lino_os.free_fn(ls->result);
@@ -2833,7 +2952,10 @@ void lino_set_result(lino_t *ls, wchar_t *res)
*res = '\r';
}
+#endif
+
void lino_init(lino_os_t *os)
{
lino_os = *os;
+ lino_list.next = lino_list.prev = &lino_list;
}
diff --git a/linenoise/linenoise.h b/linenoise/linenoise.h
index da6e93de..34d0a993 100644
--- a/linenoise/linenoise.h
+++ b/linenoise/linenoise.h
@@ -9,7 +9,7 @@
*
* Copyright (c) 2010-2015, Salvatore Sanfilippo <antirez at gmail dot com>
* Copyright (c) 2010-2013, Pieter Noordhuis <pcnoordhuis at gmail dot com>
- * Copyright (c) 2015-2020, Kaz Kylheku <kaz at kylheku dot com>
+ * Copyright (c) 2015-2024, Kaz Kylheku <kaz at kylheku dot com>
*
* All rights reserved.
*
@@ -92,6 +92,8 @@ typedef struct lino_os {
wide_disp \
}
+#if CONFIG_FULL_REPL
+
typedef struct lino_completions {
size_t len;
wchar_t **cvec;
@@ -102,6 +104,8 @@ typedef void lino_compl_cb_t(const wchar_t *, lino_completions_t *, void *ctx);
void lino_set_completion_cb(lino_t *, lino_compl_cb_t *, void *ctx);
void lino_add_completion(lino_completions_t *, const wchar_t *);
+#endif
+
void lino_init(lino_os_t *);
lino_t *lino_make(mem_t *istream, mem_t *ostream);
lino_t *lino_copy(lino_t *);
@@ -116,6 +120,7 @@ int lino_hist_set_max_len(lino_t *, int len);
int lino_hist_save(lino_t *, const wchar_t *filename, int new_only);
int lino_hist_load(lino_t *, const wchar_t *filename);
int lino_have_new_lines(lino_t *);
+#if HAVE_TERMIOS
void lino_set_result(lino_t *, wchar_t *); /* takes ownership of malloced mem; modifies it */
int lino_clear_screen(lino_t *);
void lino_set_multiline(lino_t *, int ml);
@@ -124,9 +129,13 @@ void lino_set_selinclusive(lino_t *, int si);
int lino_get_selinculsive(lino_t *);
void lino_set_noninteractive(lino_t *, int ni);
int lino_get_noninteractive(lino_t *);
+#endif
+void lino_enable_noninteractive_prompt(lino_t *, int enable);
+#if HAVE_TERMIOS
typedef wchar_t *lino_atom_cb_t(lino_t *, const wchar_t *line, int n, void *ctx);
void lino_set_atom_cb(lino_t *, lino_atom_cb_t *, void *ctx);
+#endif
typedef int lino_enter_cb_t(const wchar_t *line, void *ctx);
void lino_set_enter_cb(lino_t *, lino_enter_cb_t *, void *ctx);
diff --git a/lisplib.c b/lisplib.c
deleted file mode 100644
index d1a2dd06..00000000
--- a/lisplib.c
+++ /dev/null
@@ -1,897 +0,0 @@
-/* Copyright 2015-2020
- * Kaz Kylheku <kaz@kylheku.com>
- * Vancouver, Canada
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are met:
- *
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
- *
- * 2. Redistributions in binary form must reproduce the above copyright notice,
- * this list of conditions and the following disclaimer in the documentation
- * and/or other materials provided with the distribution.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- */
-
-#include <stdio.h>
-#include <wchar.h>
-#include <stdarg.h>
-#include <signal.h>
-#include "config.h"
-#include "lib.h"
-#include "eval.h"
-#include "signal.h"
-#include "stream.h"
-#include "hash.h"
-#include "gc.h"
-#include "debug.h"
-#include "txr.h"
-#include "socket.h"
-#include "lisplib.h"
-
-val dl_table;
-int opt_dbg_autoload;
-val trace_loaded;
-
-static void set_dlt_entries_impl(val dlt, val *name, val fun, val package)
-{
- for (; *name; name++) {
- val sym = intern(*name, package);
-
- if (fun)
- sethash(dlt, sym, fun);
- else
- remhash(dlt, sym);
- }
-}
-
-void set_dlt_entries(val dlt, val *name, val fun)
-{
- set_dlt_entries_impl(dlt, name, fun, user_package);
-}
-
-static void set_dlt_entries_sys(val dlt, val *name, val fun)
-{
- set_dlt_entries_impl(dlt, name, fun, system_package);
-}
-
-static void intern_only(val *name)
-{
- for (; *name; name++)
- intern(*name, user_package);
-}
-
-static val place_set_entries(val dlt, val fun)
-{
- val sys_name[] = {
- lit("get-fun-getter-setter"), lit("get-mb"), lit("get-vb"),
- lit("register-simple-accessor"),
- nil
- };
- val name[] = {
- lit("*place-clobber-expander*"), lit("*place-update-expander*"),
- lit("*place-delete-expander*"), lit("*place-macro*"),
- lit("get-update-expander"), lit("get-clobber-expander"),
- lit("get-delete-expander"),
- lit("place-form-p"),
- lit("rlet"), lit("slet"), lit("alet"), lit("with-gensyms"),
- lit("call-update-expander"), lit("call-clobber-expander"),
- lit("call-delete-expander)"),
- lit("with-update-expander"), lit("with-clobber-expander"),
- lit("with-delete-expander"),
- lit("set"), lit("pset"), lit("zap"), lit("flip"), lit("inc"), lit("dec"),
- lit("pinc"), lit("pdec"),
- lit("push"), lit("pop"), lit("swap"), lit("shift"), lit("rotate"),
- lit("test-set"), lit("test-clear"), lit("compare-swap"),
- lit("test-inc"), lit("test-dec"),
- lit("pushnew"), lit("del"), lit("lset"), lit("upd"),
- lit("defplace"), lit("define-place-macro"), lit("define-modify-macro"),
- lit("placelet"), lit("placelet*"), lit("define-accessor"),
- lit("with-slots"),
- nil
- };
-
- set_dlt_entries_sys(dlt, sys_name, fun);
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val place_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~aplace"), stdlib_path, nao));
- return nil;
-}
-
-static val ver_set_entries(val dlt, val fun)
-{
- val name[] = { lit("*lib-version*"), lit("lib-version"), nil };
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val ver_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~aver"), stdlib_path, nao));
- return nil;
-}
-
-static val ifa_set_entries(val dlt, val fun)
-{
- val name[] = {
- lit("ifa"), lit("whena"), lit("conda"), lit("condlet"), lit("it"), nil
- };
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val ifa_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~aifa"), stdlib_path, nao));
- return nil;
-}
-
-static val txr_case_set_entries(val dlt, val fun)
-{
- val name[] = { lit("txr-if"), lit("txr-when"), lit("txr-case"), nil };
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val txr_case_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~atxr-case"), stdlib_path, nao));
- return nil;
-}
-
-static val with_resources_set_entries(val dlt, val fun)
-{
- val name[] = {
- lit("with-resources"),
- lit("with-objects"),
- nil
- };
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val with_resources_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~awith-resources"), stdlib_path, nao));
- return nil;
-}
-
-static val path_test_set_entries(val dlt, val fun)
-{
- val name[] = {
- lit("path-exists-p"), lit("path-file-p"), lit("path-dir-p"),
- lit("path-symlink-p"), lit("path-blkdev-p"), lit("path-chrdev-p"),
- lit("path-sock-p"), lit("path-pipe-p"), lit("path-pipe-p"),
- lit("path-setgid-p"), lit("path-setuid-p"), lit("path-sticky-p"),
- lit("path-mine-p"), lit("path-my-group-p"), lit("path-executable-to-me-p"),
- lit("path-writable-to-me-p"), lit("path-readable-to-me-p"),
- lit("path-read-writable-to-me-p"),
- lit("path-newer"), lit("path-older"),
- lit("path-same-object"), lit("path-private-to-me-p"),
- lit("path-strictly-private-to-me-p"),
- lit("path-dir-empty"),
- nil
- };
-
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val path_test_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~apath-test"), stdlib_path, nao));
- return nil;
-}
-
-static val struct_set_entries(val dlt, val fun)
-{
- val sys_name[] = {
- lit("define-method"), lit("rslotset"), nil
- };
- val name[] = {
- lit("defstruct"), lit("qref"), lit("uref"), lit("new"), lit("lnew"),
- lit("new*"), lit("lnew*"),
- lit("meth"), lit("umeth"), lit("usl"), lit("defmeth"), lit("rslot"), nil
- };
-
- set_dlt_entries_sys(dlt, sys_name, fun);
- set_dlt_entries(dlt, name, fun);
-
- if (fun)
- sethash(dlt, struct_lit_s, fun);
- else
- remhash(dlt, struct_lit_s);
-
- return nil;
-}
-
-static val struct_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~astruct"), stdlib_path, nao));
- return nil;
-}
-
-static val with_stream_set_entries(val dlt, val fun)
-{
- val name[] = {
- lit("with-out-string-stream"),
- lit("with-out-strlist-stream"),
- lit("with-out-buf-stream"),
- lit("with-in-string-stream"),
- lit("with-in-string-byte-stream"),
- lit("with-in-buf-stream"),
- lit("with-stream"),
- nil
- };
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val with_stream_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~awith-stream"), stdlib_path, nao));
- return nil;
-}
-
-static val hash_set_entries(val dlt, val fun)
-{
- val name[] = { lit("with-hash-iter"), nil };
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val hash_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~ahash"), stdlib_path, nao));
- return nil;
-}
-
-static val except_set_entries(val dlt, val fun)
-{
- val name[] = {
- lit("catch"), lit("catch*"), lit("catch**"), lit("handle"), lit("handle*"),
- lit("ignwarn"), lit("macro-time-ignwarn"),
- nil
- };
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val except_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~aexcept"), stdlib_path, nao));
- return nil;
-}
-
-static val type_set_entries(val dlt, val fun)
-{
- val name[] = { lit("typecase"), nil };
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val type_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~atype"), stdlib_path, nao));
- return nil;
-}
-
-static val yield_set_entries(val dlt, val fun)
-{
- val sys_name[] = {
- lit("obtain-impl"), nil
- };
- val name[] = {
- lit("obtain"), lit("obtain-block"), lit("yield-from"), lit("yield"),
- lit("obtain*"), lit("obtain*-block"),
- lit("suspend"), lit("hlet"), lit("hlet*"),
- nil
- };
-
- set_dlt_entries_sys(dlt, sys_name, fun);
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val yield_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~ayield"), stdlib_path, nao));
- return nil;
-}
-
-#if HAVE_SOCKETS
-static val sock_set_entries(val dlt, val fun)
-{
- val name[] = {
- lit("sockaddr"), lit("sockaddr-in"), lit("sockaddr-in6"),
- lit("sockaddr-un"), lit("addrinfo"),
- lit("getaddrinfo"),
- lit("af-unspec"), lit("af-unix"), lit("af-inet"), lit("af-inet6"),
- lit("sock-stream"), lit("sock-dgram"),
- lit("inaddr-any"), lit("inaddr-loopback"),
- lit("in6addr-any"), lit("in6addr-loopback"),
- lit("sock-nonblock"), lit("sock-cloexec"),
- lit("ai-passive"), lit("ai-canonname"), lit("ai-numerichost"),
- lit("ai-v4mapped"), lit("ai-all"), lit("ai-addrconfig"),
- lit("ai-numericserv"),
- lit("str-inaddr"), lit("str-in6addr"),
- lit("str-inaddr-net"), lit("str-in6addr-net"),
- lit("open-socket"), lit("open-socket-pair"),
- lit("sock-bind"), lit("sock-connect"), lit("sock-listen"),
- lit("sock-accept"), lit("sock-shutdown"), lit("open-socket"),
- lit("open-socket-pair"), lit("sock-send-timeout"), lit("sock-recv-timeout"),
- nil
- };
- val name_noload[] = {
- lit("family"), lit("addr"), lit("port"), lit("flow-info"),
- lit("scope-id"), lit("path"), lit("flags"), lit("socktype"),
- lit("protocol"), lit("canonname"), nil
- };
- set_dlt_entries(dlt, name, fun);
- intern_only(name_noload);
- return nil;
-}
-
-static val sock_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- sock_load_init();
- load(format(nil, lit("~asocket"), stdlib_path, nao));
- return nil;
-}
-
-#endif
-
-#if HAVE_TERMIOS
-
-static val termios_set_entries(val dlt, val fun)
-{
- val name[] = {
- lit("set-iflags"), lit("set-oflags"), lit("set-cflags"), lit("set-lflags"),
- lit("clear-iflags"), lit("clear-oflags"), lit("clear-cflags"), lit("clear-lflags"),
- lit("go-raw"), lit("go-cbreak"), lit("go-canon"),
- lit("string-encode"), lit("string-decode"), nil
- };
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val termios_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~atermios"), stdlib_path, nao));
- return nil;
-}
-
-#endif
-
-static val awk_set_entries(val dlt, val fun)
-{
- val sys_name[] = {
- lit("awk-state"), nil
- };
- val name[] = {
- lit("awk"), nil
- };
- val name_noload[] = {
- lit("rec"), lit("orec"), lit("f"), lit("nf"), lit("nr"), lit("fnr"),
- lit("arg"), lit("fname"), lit("rs"), lit("krs"), lit("fs"), lit("ft"),
- lit("fw"), lit("kfs"), lit("ofs"), lit("ors"), lit("next"), lit("again"),
- lit("next-file"), lit("rng"), lit("-rng"), lit("rng-"), lit("-rng-"),
- lit("--rng"), lit("--rng-"), lit("rng+"), lit("-rng+"), lit("--rng+"),
- lit("ff"), lit("f"), lit("mf"), lit("fconv"), lit("->"), lit("->>"),
- lit("<-"), lit("!>"), lit("<!"), lit("prn"), nil
- };
-
- set_dlt_entries_sys(dlt, sys_name, fun);
- set_dlt_entries(dlt, name, fun);
- intern_only(name_noload);
- return nil;
-}
-
-static val awk_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~aawk"), stdlib_path, nao));
- return nil;
-}
-
-static val build_set_entries(val dlt, val fun)
-{
- val name[] = {
- lit("list-builder"), lit("build-list"), lit("build"), lit("buildn"), nil
- };
- val name_noload[] = {
- lit("head"), lit("tail"), lit("add"), lit("add*"), lit("pend"),
- lit("pend*"), lit("ncon"), lit("ncon*"), lit("get"),
- lit("del"), lit("del*"),
- nil
- };
-
- set_dlt_entries(dlt, name, fun);
- intern_only(name_noload);
- return nil;
-}
-
-static val build_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~abuild"), stdlib_path, nao));
- return nil;
-}
-
-static val trace_set_entries(val dlt, val fun)
-{
- val sys_name[] = {
- lit("trace"), lit("untrace"), nil
- };
- val name[] = {
- lit("*trace-output*"), lit("trace"), lit("untrace"), nil
- };
-
- set_dlt_entries_sys(dlt, sys_name, fun);
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val trace_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~atrace"), stdlib_path, nao));
- trace_loaded = t;
- return nil;
-}
-
-static val getopts_set_entries(val dlt, val fun)
-{
- val name[] = {
- lit("opt-desc"), lit("opts"),
- lit("opt"), lit("getopts"), lit("opthelp"), lit("define-option-struct"),
- nil
- };
- val name_noload[] = {
- lit("short"), lit("long"), lit("helptext"), lit("type"),
- lit("in-args"), lit("out-args"), lit("cumul"), nil
- };
- set_dlt_entries(dlt, name, fun);
- intern_only(name_noload);
- return nil;
-}
-
-static val getopts_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~agetopts"), stdlib_path, nao));
- return nil;
-}
-
-static val package_set_entries(val dlt, val fun)
-{
- val name[] = {
- lit("defpackage"), lit("in-package"),
- nil
- };
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val package_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~apackage"), stdlib_path, nao));
- return nil;
-}
-
-static val getput_set_entries(val dlt, val fun)
-{
- val name[] = {
- lit("file-get"), lit("file-put"), lit("file-append"),
- lit("file-get-string"), lit("file-put-string"), lit("file-append-string"),
- lit("file-get-lines"), lit("file-put-lines"), lit("file-append-lines"),
- lit("file-get-buf"), lit("file-put-buf"),
- lit("file-place-buf"), lit("file-append-buf"),
- lit("command-get"), lit("command-put"),
- lit("command-get-string"), lit("command-put-string"),
- lit("command-get-lines"), lit("command-put-lines"),
- lit("command-get-buf"), lit("command-put-buf"),
- nil
- };
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val getput_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~agetput"), stdlib_path, nao));
- return nil;
-}
-
-static val tagbody_set_entries(val dlt, val fun)
-{
- val name[] = {
- lit("tagbody"), lit("go"), lit("prog"), lit("prog*"), nil
- };
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val tagbody_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~atagbody"), stdlib_path, nao));
- return nil;
-}
-
-static val pmac_set_entries(val dlt, val fun)
-{
- val name[] = {
- lit("define-param-expander"), nil
- };
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val pmac_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~apmac"), stdlib_path, nao));
- return nil;
-}
-
-static val error_set_entries(val dlt, val fun)
-{
- val sys_name[] = {
- lit("bind-mac-error"), lit("bind-mac-check"),
- lit("lambda-too-many-args"),
- lit("lambda-too-few-args"), lit("lambda-short-apply-list"),
- nil
- };
- val name[] = {
- lit("compile-error"), lit("compile-warning"), lit("compile-defr-warning"),
- nil
- };
- set_dlt_entries_sys(dlt, sys_name, fun);
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val error_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~aerror"), stdlib_path, nao));
- return nil;
-}
-
-static val keyparams_set_entries(val dlt, val fun)
-{
- val sys_name[] = {
- lit("extract-keys"),
- nil
- };
- val name_noload[] = {
- lit("--"),
- nil
- };
- val key_k = intern(lit("key"), keyword_package);
- set_dlt_entries_sys(dlt, sys_name, fun);
- if (fun)
- sethash(dlt, key_k, fun);
- else
- remhash(dlt, key_k);
- intern_only(name_noload);
- return nil;
-}
-
-static val keyparams_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~akeyparams"), stdlib_path, nao));
- return nil;
-}
-
-static val ffi_set_entries(val dlt, val fun)
-{
- val name[] = {
- lit("with-dyn-lib"), lit("deffi"), lit("deffi-type"), lit("deffi-cb"),
- lit("deffi-cb-unsafe"),
- lit("deffi-sym"), lit("deffi-var"), lit("typedef"), lit("sizeof"),
- lit("alignof"), lit("offsetof"), lit("arraysize"), lit("elemsize"),
- lit("elemtype"), lit("ffi"), lit("carray-ref"), lit("carray-sub"),
- lit("sub-buf"), lit("znew"),
- nil
- };
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val ffi_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~affi"), stdlib_path, nao));
- return nil;
-}
-
-static val doloop_set_entries(val dlt, val fun)
-{
- val name[] = {
- lit("doloop"), lit("doloop*"),
- nil
- };
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val doloop_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~adoloop"), stdlib_path, nao));
- return nil;
-}
-
-static val stream_wrap_set_entries(val dlt, val fun)
-{
- val name[] = {
- lit("stream-wrap"),
- nil
- };
- val name_noload[] = {
- lit("close"), lit("flush"), lit("seek"), lit("truncate"),
- lit("get-prop"), lit("set-prop"), lit("get-fd"), nil
- };
-
- set_dlt_entries(dlt, name, fun);
- intern_only(name_noload);
- return nil;
-}
-
-static val stream_wrap_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~astream-wrap"), stdlib_path, nao));
- return nil;
-}
-
-static val asm_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~aasm"), stdlib_path, nao));
- return nil;
-}
-
-static val asm_set_entries(val dlt, val fun)
-{
- val sys_name[] = {
- lit("assembler"),
- nil
- };
- val name[] = {
- lit("disassemble"),
- nil
- };
-
- set_dlt_entries_sys(dlt, sys_name, fun);
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val compiler_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~acompiler"), stdlib_path, nao));
- return nil;
-}
-
-static val compiler_set_entries(val dlt, val fun)
-{
- val sys_name[] = {
- lit("compiler"),
- nil
- };
- val name[] = {
- lit("compile-toplevel"), lit("compile"), lit("compile-file"),
- lit("compile-update-file"),
- lit("with-compilation-unit"), lit("dump-compiled-objects"),
- nil
- };
-
- set_dlt_entries_sys(dlt, sys_name, fun);
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val debugger_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~adebugger"), stdlib_path, nao));
- return nil;
-}
-
-static val debugger_set_entries(val dlt, val fun)
-{
- val sys_name[] = {
- lit("debugger"), lit("print-backtrace"),
- nil
- };
-
- set_dlt_entries_sys(dlt, sys_name, fun);
- return nil;
-}
-
-
-static val op_set_entries(val dlt, val fun)
-{
- val name[] = {
- lit("op"), lit("do"), lit("lop"), lit("ldo"), lit("ap"), lit("ip"),
- lit("ado"), lit("ido"), lit("ret"), lit("aret"),
- lit("opip"), lit("oand"),
- nil
- };
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val op_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~aop"), stdlib_path, nao));
- return nil;
-}
-
-static val save_exe_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~asave-exe"), stdlib_path, nao));
- return nil;
-}
-
-static val save_exe_set_entries(val dlt, val fun)
-{
- val name[] = {
- lit("save-exe"),
- nil
- };
-
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val defset_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~adefset"), stdlib_path, nao));
- return nil;
-}
-
-static val defset_set_entries(val dlt, val fun)
-{
- val name[] = {
- lit("defset"), lit("sub-list"), lit("sub-vec"), lit("sub-str"),
- lit("left"), lit("right"), lit("key"),
- nil
- };
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-static val copy_file_instantiate(val set_fun)
-{
- funcall1(set_fun, nil);
- load(format(nil, lit("~acopy-file"), stdlib_path, nao));
- return nil;
-}
-
-static val copy_file_set_entries(val dlt, val fun)
-{
- val name[] = {
- lit("copy-path-opts"), lit("copy-file"), lit("copy-files"),
- lit("copy-path-rec"), lit("remove-path-rec"),
- lit("chown-rec"), lit("chmod-rec"),
- nil
- };
- set_dlt_entries(dlt, name, fun);
- return nil;
-}
-
-
-val dlt_register(val dlt,
- val (*instantiate)(val),
- val (*set_entries)(val, val))
-{
- return set_entries(dl_table, func_f0(func_f1(dlt, set_entries), instantiate));
-}
-
-void lisplib_init(void)
-{
- prot1(&dl_table);
- dl_table = make_hash(nil, nil, nil);
- dlt_register(dl_table, place_instantiate, place_set_entries);
- dlt_register(dl_table, ver_instantiate, ver_set_entries);
- dlt_register(dl_table, ifa_instantiate, ifa_set_entries);
- dlt_register(dl_table, txr_case_instantiate, txr_case_set_entries);
- dlt_register(dl_table, with_resources_instantiate, with_resources_set_entries);
- dlt_register(dl_table, path_test_instantiate, path_test_set_entries);
- dlt_register(dl_table, struct_instantiate, struct_set_entries);
- dlt_register(dl_table, with_stream_instantiate, with_stream_set_entries);
- dlt_register(dl_table, hash_instantiate, hash_set_entries);
- dlt_register(dl_table, except_instantiate, except_set_entries);
- dlt_register(dl_table, type_instantiate, type_set_entries);
- dlt_register(dl_table, yield_instantiate, yield_set_entries);
-#if HAVE_SOCKETS
- dlt_register(dl_table, sock_instantiate, sock_set_entries);
-#endif
-#if HAVE_TERMIOS
- dlt_register(dl_table, termios_instantiate, termios_set_entries);
-#endif
- dlt_register(dl_table, awk_instantiate, awk_set_entries);
- dlt_register(dl_table, build_instantiate, build_set_entries);
- dlt_register(dl_table, trace_instantiate, trace_set_entries);
- dlt_register(dl_table, getopts_instantiate, getopts_set_entries);
- dlt_register(dl_table, package_instantiate, package_set_entries);
- dlt_register(dl_table, getput_instantiate, getput_set_entries);
- dlt_register(dl_table, tagbody_instantiate, tagbody_set_entries);
- dlt_register(dl_table, pmac_instantiate, pmac_set_entries);
- dlt_register(dl_table, error_instantiate, error_set_entries);
- dlt_register(dl_table, keyparams_instantiate, keyparams_set_entries);
- dlt_register(dl_table, ffi_instantiate, ffi_set_entries);
- dlt_register(dl_table, doloop_instantiate, doloop_set_entries);
- dlt_register(dl_table, stream_wrap_instantiate, stream_wrap_set_entries);
- dlt_register(dl_table, asm_instantiate, asm_set_entries);
- dlt_register(dl_table, compiler_instantiate, compiler_set_entries);
- dlt_register(dl_table, debugger_instantiate, debugger_set_entries);
-
- if (!opt_compat || opt_compat >= 185)
- dlt_register(dl_table, op_instantiate, op_set_entries);
-
- dlt_register(dl_table, save_exe_instantiate, save_exe_set_entries);
- dlt_register(dl_table, defset_instantiate, defset_set_entries);
- dlt_register(dl_table, copy_file_instantiate, copy_file_set_entries);
-
- reg_fun(intern(lit("try-load"), system_package), func_n1(lisplib_try_load));
-}
-
-val lisplib_try_load(val sym)
-{
- val fun = gethash(dl_table, sym);
-
- if (fun) {
- unsigned ds = debug_clear(opt_dbg_autoload ? 0 : DBG_ENABLE);
- val saved_dyn_env = dyn_env;
- dyn_env = make_env(nil, nil, dyn_env);
- env_vbind(dyn_env, package_s, system_package);
- env_vbind(dyn_env, package_alist_s, packages);
- funcall(fun);
- dyn_env = saved_dyn_env;
- debug_restore(ds);
- return t;
- }
- return nil;
-}
diff --git a/lisplib.h b/lisplib.h
deleted file mode 100644
index 5d6a08e8..00000000
--- a/lisplib.h
+++ /dev/null
@@ -1,35 +0,0 @@
-/* Copyright 2015-2020
- * Kaz Kylheku <kaz@kylheku.com>
- * Vancouver, Canada
- * All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are met:
- *
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
- *
- * 2. Redistributions in binary form must reproduce the above copyright notice,
- * this list of conditions and the following disclaimer in the documentation
- * and/or other materials provided with the distribution.
- *
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- */
-
-extern val dl_table;
-extern val trace_loaded;
-void lisplib_init(void);
-val lisplib_try_load(val sym);
-void set_dlt_entries(val dlt, val *name, val fun);
-val dlt_register(val dlt,
- val (*instantiate)(val),
- val (*set_entries)(val, val));
diff --git a/match.c b/match.c
index c3e71388..a3aabc5a 100644
--- a/match.c
+++ b/match.c
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stddef.h>
@@ -45,10 +46,9 @@
#include "txr.h"
#include "filter.h"
#include "hash.h"
-#include "debug.h"
#include "eval.h"
#include "cadr.h"
-#include "arith.h"
+#include "sysif.h"
#include "match.h"
int opt_print_bindings = 0;
@@ -65,7 +65,7 @@ val else_s, elif_s;
val longest_k, shortest_k, greedy_k;
val vars_k, lists_k, resolve_k;
val append_k, into_k, var_k, list_k, tlist_k, string_k, env_k, counter_k;
-val named_k, continue_k, finish_k, mandatory_k;
+val named_k, noclose_k, continue_k, finish_k, mandatory_k;
val filter_s;
@@ -74,6 +74,10 @@ val noval_s;
static val h_directive_table, v_directive_table;
static val non_matching_directive_table, binding_directive_table;
+static val v_next_keys;
+
+val v_output_keys;
+
static void debuglf(val form, val fmt, ...)
{
if (opt_loglevel >= 2) {
@@ -87,7 +91,7 @@ static void debuglf(val form, val fmt, ...)
}
}
-noreturn static void sem_error(val form, val fmt, ...)
+NORETURN static void sem_error(val form, val fmt, ...)
{
va_list vl;
val stream = make_string_output_stream();
@@ -174,7 +178,7 @@ static void dump_var(val var, char *pfx1, size_t len1,
dump_byte_string(pfx1);
dump_byte_string(pfx2);
put_char(chr('='), std_output);
- dump_shell_string(c_str(str));
+ dump_shell_string(c_str(str, nil));
put_char(chr('\n'), std_output);
}
}
@@ -377,8 +381,10 @@ static val dest_bind(val spec, val bindings, val pattern,
return t;
}
return cons(cons(pattern, value), bindings);
+ } else if (pattern) {
+ return t;
} else {
- return funcall2(testfun, pattern, value) ? bindings : t;
+ return bindings;
}
} else if (consp(pattern)) {
val piter = pattern, viter = value;
@@ -455,11 +461,11 @@ static val vars_to_bindings(val spec, val vars, val bindings)
}
typedef struct {
- val bindings, specline, dataline, base, pos, data, data_lineno, file;
+ val bindings, specline, dataline, base, pos, data, data_lineno, file, stream;
} match_line_ctx;
static match_line_ctx ml_all(val bindings, val specline, val dataline, val pos,
- val data, val data_lineno, val file)
+ val data, val data_lineno, val file, val stream)
{
match_line_ctx c;
c.bindings = bindings;
@@ -470,6 +476,7 @@ static match_line_ctx ml_all(val bindings, val specline, val dataline, val pos,
c.data = data;
c.data_lineno = data_lineno;
c.file = file;
+ c.stream = stream;
return c;
}
@@ -509,7 +516,6 @@ static match_line_ctx ml_bindings_specline_pos(match_line_ctx c, val bindings,
return nc;
}
-static val do_match_line(match_line_ctx *c);
static val match_line(match_line_ctx c);
typedef val (*h_match_func)(match_line_ctx *c);
@@ -518,15 +524,15 @@ typedef val (*h_match_func)(match_line_ctx *c);
debuglf(elem, lit(KIND " mismatch, position ~a (~a:~d)"), \
plus(c->pos, c->base), c->file, c->data_lineno, nao); \
debuglf(elem, lit(" ~a"), c->dataline, nao); \
- if (c_num(c->pos) < 77) \
- debuglf(elem, lit(" ~*a^"), c->pos, lit(""), nao)
+ if (c_num(c->pos, lit("txr")) < 77) \
+ debuglf(elem, lit(" ~*a^"), c->pos, null_string, nao)
#define LOG_MATCH(KIND, EXTENT) \
debuglf(elem, lit(KIND " matched, position ~a-~a (~a:~d)"), \
plus(c->pos, c->base), EXTENT, c->file, c->data_lineno, nao); \
debuglf(elem, lit(" ~a"), c->dataline, nao); \
- if (c_num(EXTENT) < 77) \
- debuglf(elem, lit(" ~*a~<*a^"), c->pos, lit(""), \
+ if (c_num(EXTENT, lit("txr")) < 77) \
+ debuglf(elem, lit(" ~*a~<*a^"), c->pos, null_string, \
minus(EXTENT, c->pos), lit("^"), nao)
#define elem_bind(elem_var, directive_var, specline) \
@@ -607,7 +613,7 @@ static val search_match_binding_var(match_line_ctx *c, val sym,
return nil;
}
-static val h_var(match_line_ctx *c)
+static val h_var_compat(match_line_ctx *c)
{
val elem = pop(&c->specline);
val sym = second(elem);
@@ -821,13 +827,215 @@ static val h_var(match_line_ctx *c)
return next_spec_k;
}
+static val h_var(match_line_ctx *c)
+{
+ val elem = pop(&c->specline);
+ val sym = second(elem);
+ val next = first(c->specline);
+ val modifiers = third(elem);
+ val modifier = first(modifiers);
+ val pair = if2(sym, tx_lookup_var(sym, c->bindings));
+
+ if (sym == t)
+ sem_error(elem, lit("t is not a bindable symbol"), nao);
+
+ if (gt(length_list(modifiers), one)) {
+ sem_error(elem, lit("multiple modifiers on variable ~s"),
+ sym, nao);
+ }
+
+ if (bindable(modifier)) {
+ val mpair = tx_lookup_var_ubc(modifier, c->bindings, elem);
+ modifier = cdr(mpair);
+ }
+
+ if (consp(modifier) || regexp(modifier)) {
+ /* var bound over text matched by regex or function */
+ cons_bind (new_bindings, new_pos,
+ match_line(ml_specline(*c, cons(modifier, nil))));
+
+ if (!new_pos) {
+ LOG_MISMATCH("var spanning form");
+ return nil;
+ }
+
+ new_pos = minus(new_pos, c->base);
+
+ LOG_MATCH("var spanning form", new_pos);
+
+ c->bindings = dest_bind(c->specline, new_bindings, sym,
+ sub_str(c->dataline, c->pos, new_pos), equal_f);
+ if (c->bindings == t) {
+ LOG_MISMATCH("span mismatch");
+ return nil;
+ }
+
+ c->pos = new_pos;
+ /* This may have another variable attached */
+ if (next) {
+ c->specline = rlcp(cons(next, rest(c->specline)), c->specline);
+ return repeat_spec_k;
+ }
+ } else if (integerp(modifier)) { /* fixed field */
+ val past = plus(c->pos, modifier);
+ if (length_str_lt(c->dataline, past) || lt(past, c->pos))
+ {
+ LOG_MISMATCH("count based var");
+ return nil;
+ }
+ LOG_MATCH("count based var", past);
+
+ c->bindings = dest_bind(c->specline, c->bindings, sym,
+ trim_str(sub_str(c->dataline, c->pos, past)),
+ equal_f);
+ if (c->bindings == t) {
+ LOG_MISMATCH("count based mismatch");
+ return nil;
+ }
+
+ c->pos = past;
+ /* This may have another variable attached */
+ if (next) {
+ c->specline = rlcp(cons(next, rest(c->specline)), c->specline);
+ return repeat_spec_k;
+ }
+ } else if (modifier && modifier != t) {
+ sem_error(elem, lit("invalid modifier ~s on variable ~s"),
+ modifier, sym, nao);
+ } else if ((pair = if2(sym, tx_lookup_var(sym, c->bindings)))) {
+ /* Variable is not of the above types and has an existing binding,
+ * Just substitute its value into the spec stream and match. */
+ c->specline = rlcp(cons(cdr(pair), c->specline), c->specline);
+ return repeat_spec_k;
+ } else if (next == nil) { /* no modifier, no elem -> to end of line */
+ if (sym)
+ c->bindings = acons(sym, sub_str(c->dataline, c->pos, nil), c->bindings);
+ c->pos = length_str(c->dataline);
+ } else if (type(next) == STR) {
+ val find = search_str(c->dataline, next, c->pos, modifier);
+ if (!find) {
+ LOG_MISMATCH("var delimiting string");
+ return nil;
+ }
+ LOG_MATCH("var delimiting string", find);
+ if (sym)
+ c->bindings = acons(sym, sub_str(c->dataline, c->pos, find), c->bindings);
+ c->pos = plus(find, length_str(next));
+ } else if (regexp(next)) {
+ val find = search_regex(c->dataline, next, c->pos, modifier);
+ val fpos = car(find);
+ val flen = cdr(find);
+ if (!find) {
+ LOG_MISMATCH("var delimiting regex");
+ return nil;
+ }
+ LOG_MATCH("var delimiting regex", fpos);
+ if (sym)
+ c->bindings = acons(sym, sub_str(c->dataline, c->pos, fpos), c->bindings);
+ c->pos = if3(flen == t, t, plus(fpos, flen));
+ } else if (consp(next)) {
+ val op = first(next);
+
+ if (op == var_s) {
+ /* Unbound var followed by var: the following one must either
+ be bound, or must specify a regex. */
+ val second_sym = second(next);
+ val next_modifiers = third(next);
+ val next_modifier = first(next_modifiers);
+ val pair = if2(second_sym, tx_lookup_var(second_sym, c->bindings));
+
+ if (gt(length_list(next_modifiers), one)) {
+ sem_error(elem, lit("multiple modifiers on variable ~s"),
+ second_sym, nao);
+ }
+
+ if (!pair && regexp(next_modifier)) {
+ val find = search_regex(c->dataline, next_modifier, c->pos, modifier);
+ val fpos = car(find);
+ val flen = cdr(find);
+
+ if (!find) {
+ LOG_MISMATCH("double var regex");
+ return nil;
+ }
+
+ /* Text from here to start of regex match goes to this
+ variable. */
+ if (sym)
+ c->bindings = acons(sym, sub_str(c->dataline, c->pos, fpos),
+ c->bindings);
+ /* Text from start of regex match to end goes to the
+ second variable */
+ if (second_sym)
+ c->bindings = acons(second_sym,
+ sub_str(c->dataline, fpos, plus(fpos, flen)),
+ c->bindings);
+ LOG_MATCH("double var regex (first var)", fpos);
+ c->pos = fpos;
+ LOG_MATCH("double var regex (second var)", plus(fpos, flen));
+ c->pos = plus(fpos, flen);
+ return next_spec_k;
+ } else if (!pair) {
+ sem_error(elem, lit("consecutive unbound variables"), nao);
+ } else {
+ /* Re-generate a new spec in which the next variable
+ is replaced by its value, and repeat. */
+ val r = rest(c->specline);
+ c->specline = rlcp(cons(elem, rlcp(cons(cdr(pair), r), r)), r);
+ return repeat_spec_k;
+ }
+ } else if (op == text_s) {
+ val text_only_spec = rlcp(cons(next, nil), next);
+ val find = search_match(c, modifier, text_only_spec);
+ val fpos = car(find);
+ if (!find) {
+ LOG_MISMATCH("var delimiting text compound");
+ return nil;
+ }
+ LOG_MATCH("var delimiting text compound", fpos);
+ if (sym)
+ c->bindings = acons(sym, sub_str(c->dataline, c->pos, fpos), c->bindings);
+ c->pos = fpos;
+ return repeat_spec_k;
+ } else if (consp(op) || stringp(op)) {
+ cons_bind (find, len, search_str_tree(c->dataline, next, c->pos, modifier));
+ if (!find) {
+ LOG_MISMATCH("string");
+ return nil;
+ }
+ if (sym)
+ c->bindings = acons(sym, sub_str(c->dataline, c->pos, find), c->bindings);
+ c->pos = plus(find, len);
+ } else {
+ val find = if3(opt_compat && opt_compat <= 172,
+ search_match(c, modifier, c->specline),
+ search_match_binding_var(c, sym, modifier, c->specline));
+ val fpos = car(find);
+ if (!find) {
+ LOG_MISMATCH("var delimiting spec");
+ return nil;
+ }
+ LOG_MATCH("var delimiting spec", fpos);
+ if (sym)
+ c->bindings = acons(sym, sub_str(c->dataline, c->pos, fpos), c->bindings);
+ c->pos = fpos;
+ return repeat_spec_k;
+ }
+ } else {
+ sem_error(elem, lit("variable followed by invalid element: ~s"), next, nao);
+ }
+
+ return next_spec_k;
+}
+
static val h_skip(match_line_ctx *c)
{
+ val self = lit("skip");
val elem = first(c->specline);
val max = tleval_144(elem, second(elem), c->bindings);
val min = tleval_144(elem, third(elem), c->bindings);
- cnum cmax = integerp(max) ? c_num(max) : 0;
- cnum cmin = integerp(min) ? c_num(min) : 0;
+ cnum cmax = integerp(max) ? c_num(max, self) : 0;
+ cnum cmin = integerp(min) ? c_num(min, self) : 0;
val greedy = eq(max, greedy_k);
val last_good_result = nil, last_good_pos = nil;
@@ -953,6 +1161,7 @@ static val h_accept_fail(match_line_ctx *c)
static val h_coll(match_line_ctx *c)
{
+ val self = lit("coll");
val elem = first(c->specline);
val op_sym = first(elem);
val coll_specline = second(elem);
@@ -982,12 +1191,12 @@ static val h_coll(match_line_ctx *c)
val have_vars, have_lists;
val vars = getplist_f(args, vars_k, mkcloc(have_vars));
val lists = getplist_f(args, lists_k, mkcloc(have_lists));
- cnum cmax = if3(gap, c_num(gap), if3(max, c_num(max), 0));
- cnum cmin = if3(gap, c_num(gap), if3(min, c_num(min), 0));
+ cnum cmax = if3(gap, c_num(gap, self), if3(max, c_num(max, self), 0));
+ cnum cmin = if3(gap, c_num(gap, self), if3(min, c_num(min, self), 0));
cnum mincounter = cmin, maxcounter = 0;
- cnum ctimax = if3(times, c_num(times), if3(maxtimes, c_num(maxtimes), 0));
- cnum ctimin = if3(times, c_num(times), if3(mintimes, c_num(mintimes), 0));
- cnum cchars = if3(chars, c_num(chars), 0);
+ cnum ctimax = if3(times, c_num(times, self), if3(maxtimes, c_num(maxtimes, self), 0));
+ cnum ctimin = if3(times, c_num(times, self), if3(mintimes, c_num(mintimes, self), 0));
+ cnum cchars = if3(chars, c_num(chars, self), 0);
cnum timescounter = 0, charscounter = 0;
int compat_222 = opt_compat && opt_compat <= 222;
val iter;
@@ -1485,11 +1694,11 @@ static val h_chr(match_line_ctx *c)
}
typedef struct {
- val spec, files, curfile, bindings, data, data_lineno;
+ val spec, files, curfile, stream, bindings, data, data_lineno;
} match_files_ctx;
-static match_files_ctx mf_all(val spec, val files, val bindings,
- val data, val curfile);
+static match_files_ctx mf_all(val spec, val files, val bindings, val data,
+ val curfile, val stream);
static val v_fun(match_files_ctx *c);
@@ -1513,7 +1722,7 @@ static val h_call(match_line_ctx *c)
if (ret == decline_k) {
val spec = cons(new_specline, nil);
- match_files_ctx vc = mf_all(spec, nil, c->bindings, nil, c->file);
+ match_files_ctx vc = mf_all(spec, nil, c->bindings, nil, c->file, c->stream);
val vresult = v_fun(&vc);
if (vresult == next_spec_k) {
@@ -1533,6 +1742,8 @@ static val do_match_line(match_line_ctx *c)
{
val lfe_save = set_last_form_evaled(nil);
+ gc_stack_check();
+
while (c->specline) {
val elem = first(c->specline);
@@ -1545,6 +1756,7 @@ static val do_match_line(match_line_ctx *c)
switch (type(elem)) {
case CONS: /* directive */
+ case LCONS:
{
val directive = first(elem);
@@ -1583,7 +1795,7 @@ static val do_match_line(match_line_ctx *c)
} else if (result == decline_k) {
val spec = rlcp(cons(cons(elem, nil), nil), elem);
match_files_ctx vc = mf_all(spec, nil, c->bindings,
- nil, c->file);
+ nil, c->file, c->stream);
val vresult = v_fun(&vc);
if (vresult == next_spec_k) {
@@ -1624,7 +1836,7 @@ static val do_match_line(match_line_ctx *c)
break;
}
case COBJ:
- if (elem->co.cls == regex_s) {
+ if (elem->co.cls == regex_cls) {
val past = match_regex(c->dataline, elem, c->pos);
if (nilp(past)) {
LOG_MISMATCH("regex");
@@ -1800,7 +2012,7 @@ static val do_txeval(val spec, val form, val bindings, val allow_unbound)
uw_catch (exc_sym, exc) {
val msg = if3(consp(exc), car(exc), exc);
- if (stringp(msg) && !equal(msg, lit("")) &&
+ if (stringp(msg) && !equal(msg, null_string) &&
chr_str(msg, zero) == chr('('))
{
uw_throw (exc_sym, exc);
@@ -1887,59 +2099,13 @@ static val bind_cdr(val bind_cons)
bind_cons);
}
-static val extract_vars(val output_spec)
-{
- list_collect_decl (vars, tai);
-
- if (consp(output_spec)) {
- val sym = first(output_spec);
- if (sym == var_s) {
- val name = second(output_spec);
- val modifiers = third(output_spec);
-
- if (bindable(name))
- tai = list_collect(tai, name);
- else
- tai = list_collect_nconc(tai, extract_vars(name));
-
- for (; modifiers; modifiers = cdr(modifiers)) {
- val mod = car(modifiers);
- if (bindable(mod)) {
- tai = list_collect(tai, mod);
- } else if (consp(mod)) {
- val msym = car(mod);
-
- if (msym == dwim_s) {
- val arg = second(mod);
-
- if (bindable(arg)) {
- tai = list_collect(tai, arg);
- } else if (consp(arg) && car(arg) == rcons_s) {
- val f = second(arg);
- val t = third(arg);
- if (bindable(f))
- tai = list_collect(tai, f);
- if (bindable(t))
- tai = list_collect(tai, t);
- }
- }
- }
- }
- } else if (sym != expr_s) {
- for (; output_spec; output_spec = cdr(output_spec))
- tai = list_collect_nconc(tai, extract_vars(car(output_spec)));
- }
- }
-
- return vars;
-}
-
-static val extract_bindings(val bindings, val output_spec, val vars)
+static val extract_bindings(val bindings, val output_spec,
+ val vars, val occur_vars)
{
list_collect_decl (bindings_out, ptail);
list_collect_decl (var_list, vtail);
- vtail = list_collect_nconc(vtail, extract_vars(output_spec));
+ vtail = list_collect_nconc(vtail, occur_vars);
for (; vars; vars = cdr(vars)) {
val var = car(vars);
@@ -1978,6 +2144,8 @@ static val extract_bindings(val bindings, val output_spec, val vars)
static void do_output_line(val bindings, val specline, val filter, val out)
{
+ val self = lit("output");
+
if (specline == t)
return;
@@ -2006,6 +2174,7 @@ static void do_output_line(val bindings, val specline, val filter, val out)
val empty_clauses = pop(&clauses);
val mod_clauses = pop(&clauses);
val modlast_clauses = pop(&clauses);
+ val occur_vars = pop(&clauses);
val counter_spec = getplist(args, counter_k);
val consp_counter = consp(counter_spec);
val counter = if3(consp_counter, first(counter_spec), counter_spec);
@@ -2014,10 +2183,10 @@ static void do_output_line(val bindings, val specline, val filter, val out)
second(counter_spec),
bindings), zero);
val vars = getplist(args, vars_k);
- val bind_cp = extract_bindings(bindings, elem, vars);
+ val bind_cp = extract_bindings(bindings, elem, vars, occur_vars);
val max_depth = reduce_left(func_n2(max2),
bind_cp, zero,
- chain(func_n1(cdr),
+ chain(cdr_f,
func_n1(robust_length),
nao));
@@ -2035,7 +2204,7 @@ static void do_output_line(val bindings, val specline, val filter, val out)
val counter_bind = if2(counter, cons(counter_var, nil));
cnum i;
- for (i = 0; i < c_num(max_depth); i++) {
+ for (i = 0; i < c_num(max_depth, self); i++) {
val bind_a = nappend2(mapcar(func_n1(bind_car), bind_cp), bindings);
val bind_d = mapcar(func_n1(bind_cdr), bind_cp);
@@ -2047,7 +2216,7 @@ static void do_output_line(val bindings, val specline, val filter, val out)
if (i == 0 && first_clauses) {
do_output_line(bind_a, first_clauses, filter, out);
- } else if (i == c_num(max_depth) - 1 &&
+ } else if (i == c_num(max_depth, self) - 1 &&
(last_clauses || modlast_clauses)) {
if (modlast_clauses) {
val iter;
@@ -2127,7 +2296,125 @@ static void do_output_line(val bindings, val specline, val filter, val out)
}
}
-static void do_output(val bindings, val specs, val filter, val out)
+static void do_output(val bindings, val specs, val filter, val out);
+
+static void do_repeat(val bindings, val repeat_syntax, val filter, val out)
+{
+ val self = lit("output");
+ val clauses = cdr(repeat_syntax);
+ val args = pop(&clauses);
+ val main_clauses = pop(&clauses);
+ val single_clauses = pop(&clauses);
+ val first_clauses = pop(&clauses);
+ val last_clauses = pop(&clauses);
+ val empty_clauses = pop(&clauses);
+ val mod_clauses = pop(&clauses);
+ val modlast_clauses = pop(&clauses);
+ val occur_vars = pop(&clauses);
+ val counter_spec = getplist(args, counter_k);
+ val consp_counter = consp(counter_spec);
+ val counter = if3(consp_counter, first(counter_spec), counter_spec);
+ val counter_base = if3(consp_counter,
+ tleval(repeat_syntax,
+ second(counter_spec),
+ bindings), zero);
+ val vars = getplist(args, vars_k);
+ val bind_cp = extract_bindings(bindings, repeat_syntax, vars, occur_vars);
+ val max_depth = reduce_left(func_n2(max2),
+ bind_cp, zero,
+ chain(cdr_f,
+ func_n1(robust_length),
+ nao));
+
+ if (equal(max_depth, zero) && empty_clauses) {
+ do_output(nappend2(bind_cp, bindings), empty_clauses, filter, out);
+ } else if (equal(max_depth, one) && single_clauses) {
+ val bind_a = nappend2(mapcar(func_n1(bind_car), bind_cp), bindings);
+ do_output(bind_a, single_clauses, filter, out);
+ } else if (!zerop(max_depth)) {
+ val counter_var = if2(counter, cons(counter, nil));
+ val counter_bind = if2(counter, cons(counter_var, nil));
+ cnum i;
+
+ for (i = 0; i < c_num(max_depth, self); i++) {
+ val bind_a = nappend2(mapcar(func_n1(bind_car), bind_cp), bindings);
+ val bind_d = mapcar(func_n1(bind_cdr), bind_cp);
+
+ if (counter) {
+ rplacd(counter_var, plus(num(i), counter_base));
+ rplacd(counter_bind, bind_a);
+ bind_a = counter_bind;
+ }
+
+ if (i == 0 && first_clauses) {
+ do_output(bind_a, first_clauses, filter, out);
+ } else if (i == c_num(max_depth, self) - 1 &&
+ (last_clauses || modlast_clauses))
+ {
+ if (modlast_clauses) {
+ val iter;
+ list_collect_decl (active_mods, ptail);
+
+ for (iter = modlast_clauses; iter != nil; iter = cdr(iter)) {
+ val clause = car(iter);
+ val args = first(clause);
+ val n = tleval_144(args, first(args), bind_a);
+ val m = tleval_144(args, second(args), bind_a);
+
+ if (eql(mod(num(i), m), n))
+ ptail = list_collect_append(ptail, rest(clause));
+ }
+
+ if (active_mods)
+ do_output(bind_a, active_mods, filter, out);
+ else if (last_clauses)
+ do_output(bind_a, last_clauses, filter, out);
+ else
+ goto mod_fallback;
+ } else {
+ do_output(bind_a, last_clauses, filter, out);
+ }
+ } else if (mod_clauses) mod_fallback: {
+ val iter;
+ list_collect_decl (active_mods, ptail);
+
+ for (iter = mod_clauses; iter != nil; iter = cdr(iter)) {
+ val clause = car(iter);
+ val args = first(clause);
+ val n = tleval_144(args, first(args), bind_a);
+ val m = tleval_144(args, second(args), bind_a);
+
+ if (eql(mod(num(i), m), n))
+ ptail = list_collect_append(ptail, rest(clause));
+ }
+
+ if (active_mods)
+ do_output(bind_a, active_mods, filter, out);
+ else
+ do_output(bind_a, main_clauses, filter, out);
+ } else {
+ do_output(bind_a, main_clauses, filter, out);
+ }
+
+ bind_cp = bind_d;
+ }
+ }
+}
+
+static void do_output_if(val bindings, val if_syntax, val filter, val out)
+{
+ val args = cdr(if_syntax);
+
+ for (; args; args = cdr(args)) {
+ cons_bind (expr, specs, car(args));
+ if (tleval(args, expr, bindings)) {
+ do_output(bindings, specs, filter, out);
+ return;
+ }
+ }
+}
+
+void do_output(val bindings, val specs, val filter, val out)
{
if (specs == t)
return;
@@ -2140,103 +2427,12 @@ static void do_output(val bindings, val specs, val filter, val out)
val sym = first(first_elem);
if (sym == repeat_s) {
- val clauses = cdr(first_elem);
- val args = pop(&clauses);
- val main_clauses = pop(&clauses);
- val single_clauses = pop(&clauses);
- val first_clauses = pop(&clauses);
- val last_clauses = pop(&clauses);
- val empty_clauses = pop(&clauses);
- val mod_clauses = pop(&clauses);
- val modlast_clauses = pop(&clauses);
- val counter_spec = getplist(args, counter_k);
- val consp_counter = consp(counter_spec);
- val counter = if3(consp_counter, first(counter_spec), counter_spec);
- val counter_base = if3(consp_counter,
- tleval(first_elem,
- second(counter_spec),
- bindings), zero);
- val vars = getplist(args, vars_k);
- val bind_cp = extract_bindings(bindings, first_elem, vars);
- val max_depth = reduce_left(func_n2(max2),
- bind_cp, zero,
- chain(func_n1(cdr),
- func_n1(robust_length),
- nao));
-
- if (equal(max_depth, zero) && empty_clauses) {
- do_output(nappend2(bind_cp, bindings), empty_clauses, filter, out);
- } else if (equal(max_depth, one) && single_clauses) {
- val bind_a = nappend2(mapcar(func_n1(bind_car), bind_cp), bindings);
- do_output(bind_a, single_clauses, filter, out);
- } else if (!zerop(max_depth)) {
- val counter_var = if2(counter, cons(counter, nil));
- val counter_bind = if2(counter, cons(counter_var, nil));
- cnum i;
-
- for (i = 0; i < c_num(max_depth); i++) {
- val bind_a = nappend2(mapcar(func_n1(bind_car), bind_cp), bindings);
- val bind_d = mapcar(func_n1(bind_cdr), bind_cp);
-
- if (counter) {
- rplacd(counter_var, plus(num(i), counter_base));
- rplacd(counter_bind, bind_a);
- bind_a = counter_bind;
- }
-
- if (i == 0 && first_clauses) {
- do_output(bind_a, first_clauses, filter, out);
- } else if (i == c_num(max_depth) - 1 &&
- (last_clauses || modlast_clauses))
- {
- if (modlast_clauses) {
- val iter;
- list_collect_decl (active_mods, ptail);
-
- for (iter = modlast_clauses; iter != nil; iter = cdr(iter)) {
- val clause = car(iter);
- val args = first(clause);
- val n = tleval_144(args, first(args), bind_a);
- val m = tleval_144(args, second(args), bind_a);
-
- if (eql(mod(num(i), m), n))
- ptail = list_collect_append(ptail, rest(clause));
- }
-
- if (active_mods)
- do_output(bind_a, active_mods, filter, out);
- else if (last_clauses)
- do_output(bind_a, last_clauses, filter, out);
- else
- goto mod_fallback;
- } else {
- do_output(bind_a, last_clauses, filter, out);
- }
- } else if (mod_clauses) mod_fallback: {
- val iter;
- list_collect_decl (active_mods, ptail);
-
- for (iter = mod_clauses; iter != nil; iter = cdr(iter)) {
- val clause = car(iter);
- val args = first(clause);
- val n = tleval_144(args, first(args), bind_a);
- val m = tleval_144(args, second(args), bind_a);
-
- if (eql(mod(num(i), m), n))
- ptail = list_collect_append(ptail, rest(clause));
- }
-
- if (active_mods)
- do_output(bind_a, active_mods, filter, out);
- else
- do_output(bind_a, main_clauses, filter, out);
- } else {
- do_output(bind_a, main_clauses, filter, out);
- }
+ do_repeat(bindings, first_elem, filter, out);
+ continue;
+ }
- bind_cp = bind_d;
- }
- }
+ if (sym == if_s) {
+ do_output_if(bindings, first_elem, filter, out);
continue;
}
}
@@ -2247,12 +2443,13 @@ static void do_output(val bindings, val specs, val filter, val out)
}
static match_files_ctx mf_all(val spec, val files, val bindings,
- val data, val curfile)
+ val data, val curfile, val stream)
{
match_files_ctx c;
c.spec = spec;
c.files = files;
c.curfile = curfile;
+ c.stream = stream;
c.bindings = bindings;
c.data = data;
c.data_lineno = if3(data, one, zero);
@@ -2293,11 +2490,12 @@ static match_files_ctx mf_spec_bindings(match_files_ctx c, val spec,
}
static match_files_ctx mf_file_data(match_files_ctx c, val file,
- val data, val data_lineno)
+ val stream, val data, val data_lineno)
{
match_files_ctx nc = c;
nc.files = cons(file, c.files);
nc.curfile = file;
+ nc.stream = stream;
nc.data = data;
nc.data_lineno = data_lineno;
return nc;
@@ -2310,6 +2508,7 @@ static match_files_ctx mf_from_ml(match_line_ctx ml)
mf.spec = cons(ml.specline, nil);
mf.files = nil;
mf.curfile = ml.file;
+ mf.stream = ml.stream;
mf.bindings = ml.bindings;
mf.data = nil;
mf.data_lineno = ml.data_lineno;
@@ -2325,8 +2524,45 @@ typedef val (*v_match_func)(match_files_ctx *cout);
val specline = first(spec); \
val first_spec = first(specline)
+static val v_var_compat(match_files_ctx *c)
+{
+ (void) c;
+ return decline_k;
+}
+
+static val v_var(match_files_ctx *c)
+{
+ spec_bind (specline, var_elem, c->spec);
+
+ if (!rest(specline)) {
+ val varsym = second(var_elem);
+ val modifiers = third(var_elem);
+ val modifier = first(modifiers);
+
+ if (consp(modifier)) {
+ match_files_ctx fc = mf_spec(*c, cons(modifiers, nil));
+ val data = c->data;
+
+ val ret = v_fun(&fc);
+
+ if (ret == next_spec_k) {
+ c->data = fc.data;
+ c->bindings = dest_bind(specline, fc.bindings, varsym,
+ ldiff(data, fc.data), equal_f);
+ if (c->bindings == t)
+ ret = nil;
+ }
+
+ return ret;
+ }
+ }
+
+ return decline_k;
+}
+
static val v_skip(match_files_ctx *c)
{
+ val self = lit("skip");
spec_bind (specline, first_spec, c->spec);
if (rest(specline))
@@ -2342,8 +2578,8 @@ static val v_skip(match_files_ctx *c)
val args = rest(first_spec);
val max = tleval_144(skipspec, first(args), c->bindings);
val min = tleval_144(skipspec, second(args), c->bindings);
- cnum cmax = integerp(max) ? c_num(max) : 0;
- cnum cmin = integerp(min) ? c_num(min) : 0;
+ cnum cmax = integerp(max) ? c_num(max, self) : 0;
+ cnum cmin = integerp(min) ? c_num(min, self) : 0;
val greedy = eq(max, greedy_k);
volatile val last_good_result = nil;
volatile val last_good_line = zero;
@@ -2416,6 +2652,7 @@ static val v_skip(match_files_ctx *c)
static val v_fuzz(match_files_ctx *c)
{
+ val self = lit("fuzz");
spec_bind (specline, first_spec, c->spec);
if (rest(specline))
@@ -2431,8 +2668,8 @@ static val v_fuzz(match_files_ctx *c)
val args = rest(first_spec);
val m = tleval_144(fuzz_spec, first(args), c->bindings);
val n = tleval_144(fuzz_spec, second(args), c->bindings);
- cnum cm = if3(m, c_num(m), 0);
- cnum cn = if3(n, c_num(n), 0);
+ cnum cm = if3(m, c_num(m, self), 0);
+ cnum cn = if3(n, c_num(n, self), 0);
{
cnum reps, good;
@@ -2544,7 +2781,7 @@ static val v_freeform(match_files_ctx *c)
}
if (integerp(success)) {
- c->data = lazy_str_get_trailing_list(mlc.dataline, success);
+ c->data = lazy_str_get_trailing_list(mlc.dataline, minus(success, mlc.base));
c->data_lineno = plus(c->data_lineno, one);
} else if (success == t && lim) {
c->data = lazy_str_get_trailing_list(mlc.dataline, length_str(mlc.dataline));
@@ -2568,7 +2805,7 @@ val freeform_prepare(val vals, match_files_ctx *c, match_line_ctx *mlc)
if2(stringp(second(vals)), second(vals)));
val dataline = lazy_str(c->data, term, limit);
*mlc = ml_all(c->bindings, first_spec, dataline, zero,
- c->data, c->data_lineno, c->curfile);
+ c->data, c->data_lineno, c->curfile, c->stream);
return limit;
}
@@ -2696,7 +2933,7 @@ static val v_next_impl(match_files_ctx *c)
sem_error(specline, lit("(next :env) takes no additional arguments"), nao);
} else {
cons_bind (new_bindings, success,
- match_files(mf_file_data(*c, lit("env"), env(), one)));
+ match_files(mf_file_data(*c, lit("env"), nil, env(), one)));
if (success)
return cons(new_bindings,
@@ -2709,7 +2946,8 @@ static val v_next_impl(match_files_ctx *c)
meta = t;
} else if (!source) {
cons_bind (new_bindings, success,
- match_files(mf_all(c->spec, nil, c->bindings, nil, lit("empty"))));
+ match_files(mf_all(c->spec, nil, c->bindings, nil,
+ lit("empty"), nil)));
if (success)
return cons(new_bindings,
@@ -2731,25 +2969,30 @@ static val v_next_impl(match_files_ctx *c)
{
int old_hacky_open = opt_compat && opt_compat <= 142;
- val alist = improper_plist_to_alist(args, list(nothrow_k, nao));
- val from_var = cdr(assoc(var_k, alist));
- val list_expr = cdr(assoc(list_k, alist));
- val tlist_expr = cdr(assoc(tlist_k, alist));
- val string_expr = cdr(assoc(string_k, alist));
+ val alist = improper_plist_to_alist(args, v_next_keys);
+ val from_var_p = assoc(var_k, alist);
+ val from_var = cdr(from_var_p);
+ val list_p = assoc(list_k, alist);
+ val list_expr = cdr(list_p);
+ val tlist_p = assoc(tlist_k, alist);
+ val tlist_expr = cdr(tlist_p);
+ val string_p = assoc(string_k, alist);
+ val string_expr = cdr(string_p);
val nothrow = cdr(assoc(nothrow_k, alist));
+ val noclose = cdr(assoc(noclose_k, alist));
val str = if3(meta,
txeval(specline, source, c->bindings),
tleval_nothrow(specline, source, c->bindings, nothrow));
- if (!from_var && !source && !string_expr && !list_expr && !tlist_expr)
+ if (!from_var_p && !source && !string_p && !list_p && !tlist_p)
sem_error(specline, lit("next: source required before keyword arguments"), nao);
{
int count = (source != nil) +
- (from_var != nil) +
- (list_expr != nil) +
- (tlist_expr != nil) +
- (string_expr != nil);
+ (from_var_p != nil) +
+ (list_p != nil) +
+ (tlist_p != nil) +
+ (string_p != nil);
if (count > 1)
{
@@ -2760,12 +3003,12 @@ static val v_next_impl(match_files_ctx *c)
if (!meta && source && nothrow && str == colon_k)
goto nothrow_lisp;
- if (from_var) {
+ if (from_var_p) {
val existing = tx_lookup_var_ubc(from_var, c->bindings, first_spec);
{
cons_bind (new_bindings, success,
- match_files(mf_file_data(*c, lit("var"),
+ match_files(mf_file_data(*c, lit("var"), nil,
lazy_flatten(cdr(existing)), one)));
if (success)
@@ -2773,7 +3016,7 @@ static val v_next_impl(match_files_ctx *c)
if3(c->data, cons(c->data, c->data_lineno), t));
return nil;
}
- } else if (list_expr) {
+ } else if (list_p) {
val list_val = if3(opt_compat && opt_compat <= 143,
txeval(specline, list_expr, c->bindings),
tleval_nothrow(specline, list_expr, c->bindings, nothrow));
@@ -2783,7 +3026,7 @@ static val v_next_impl(match_files_ctx *c)
{
cons_bind (new_bindings, success,
- match_files(mf_file_data(*c, lit("var"),
+ match_files(mf_file_data(*c, lit("var"), nil,
lazy_flatten(list_val), one)));
if (success)
@@ -2791,17 +3034,17 @@ static val v_next_impl(match_files_ctx *c)
if3(c->data, cons(c->data, c->data_lineno), t));
return nil;
}
- } else if (tlist_expr) {
+ } else if (tlist_p) {
val list_val = txeval(specline, tlist_expr, c->bindings);
cons_bind (new_bindings, success,
- match_files(mf_file_data(*c, lit("var"),
+ match_files(mf_file_data(*c, lit("var"), nil,
lazy_flatten(list_val), one)));
if (success)
return cons(new_bindings,
if3(c->data, cons(c->data, c->data_lineno), t));
return nil;
- } else if (string_expr) {
+ } else if (string_p) {
val str_val = tleval_144_nothrow(specline, string_expr, c->bindings, nothrow);
if (nothrow && str_val == colon_k)
@@ -2812,7 +3055,7 @@ static val v_next_impl(match_files_ctx *c)
{
cons_bind (new_bindings, success,
- match_files(mf_file_data(*c, lit("var"),
+ match_files(mf_file_data(*c, lit("var"), nil,
split_str(str_val, lit("\n")), one)));
if (success)
@@ -2844,13 +3087,29 @@ static val v_next_impl(match_files_ctx *c)
val stream = complex_open(str, nil, nil, nothrow, nil);
if (stream) {
- cons_bind (new_bindings, success,
- match_files(mf_file_data(*c, str,
- lazy_stream_cons(stream), one)));
+ val res = nil;
+ uw_simple_catch_begin;
- if (success)
- return cons(new_bindings,
- if3(c->data, cons(c->data, c->data_lineno), t));
+ {
+ cons_bind (new_bindings, success,
+ match_files(mf_file_data(*c, str, stream,
+ lazy_stream_cons(stream, nothrow),
+ one)));
+
+ if (success)
+ res = cons(new_bindings,
+ if3(c->data, cons(c->data, c->data_lineno), t));
+ }
+
+ uw_unwind {
+ if (!noclose)
+ close_stream(stream, nil);
+ }
+
+ uw_catch_end;
+
+ if (res)
+ return res;
} else {
debuglf(first_spec, lit("could not open ~a: "
"treating as failed match due to nothrow"),
@@ -2917,7 +3176,7 @@ static val v_parallel(match_files_ctx *c)
val sym = first(first_spec);
val all_match = t;
val some_match = nil;
- val max_line = zero;
+ val max_line = nil;
val max_data = nil;
val specs = second(first_spec);
val plist = third(first_spec);
@@ -2999,7 +3258,7 @@ static val v_parallel(match_files_ctx *c)
max_data = t;
} else if (consp(success) && max_data != t) {
cons_bind (new_data, new_line, success);
- if (gt(new_line, max_line)) {
+ if (max_line == nil || gt(new_line, max_line)) {
max_line = new_line;
max_data = new_data;
}
@@ -3144,19 +3403,25 @@ static val v_gather(match_files_ctx *c)
if (have_vars) {
val iter;
+ val missing = nil;
for (iter = vars; iter != nil; iter = cdr(iter)) {
cons_bind (var, dfl_val, car(iter));
if (!tx_lookup_var(var, c->bindings)) {
if (dfl_val == noval_s) {
- debuglf(specline, lit("gather failed to match some required vars"), nao);
- return nil;
+ push(var, &missing);
} else {
c->bindings = acons(var, dfl_val, c->bindings);
}
}
}
+ if (missing) {
+ debuglf(specline, lit("gather failed to match required vars ~s"),
+ missing, nao);
+ return nil;
+ }
+
debuglf(specline, lit("gather matched all required vars"), nao);
return next_spec_k;
}
@@ -3301,6 +3566,7 @@ out:
static val v_collect(match_files_ctx *c)
{
+ val self = lit("collect");
spec_bind (specline, first_spec, c->spec);
val op_sym = first(first_spec);
val coll_spec = second(first_spec);
@@ -3330,14 +3596,14 @@ static val v_collect(match_files_ctx *c)
val have_vars, have_lists;
volatile val vars = getplist_f(args, vars_k, mkcloc(have_vars));
val lists = getplist_f(args, lists_k, mkcloc(have_lists));
- cnum cmax = if3(gap, c_num(gap), if3(max, c_num(max), 0));
- cnum cmin = if3(gap, c_num(gap), if3(min, c_num(min), 0));
+ cnum cmax = if3(gap, c_num(gap, self), if3(max, c_num(max, self), 0));
+ cnum cmin = if3(gap, c_num(gap, self), if3(min, c_num(min, self), 0));
cnum mincounter = cmin, maxcounter = 0;
- cnum ctimax = if3(times, c_num(times), if3(maxtimes, c_num(maxtimes), 0));
- cnum ctimin = if3(times, c_num(times), if3(mintimes, c_num(mintimes), 0));
+ cnum ctimax = if3(times, c_num(times, self), if3(maxtimes, c_num(maxtimes, self), 0));
+ cnum ctimin = if3(times, c_num(times, self), if3(mintimes, c_num(mintimes, self), 0));
volatile cnum timescounter = 0, linescounter = 0;
- cnum ctimes = if3(times, c_num(times), 0);
- cnum clines = if3(lines, c_num(lines), 0);
+ cnum ctimes = if3(times, c_num(times, self), 0);
+ cnum clines = if3(lines, c_num(lines, self), 0);
int compat_222 = opt_compat && opt_compat <= 222;
val iter;
uw_mark_frame;
@@ -3475,7 +3741,13 @@ static val v_collect(match_files_ctx *c)
if (consp(success)) {
cons_bind (new_data, new_line, success);
- bug_unless (ge(new_line, c->data_lineno));
+ /* The following assertion was in the code for the longest time.
+ * It doesn't hold because of @(push).
+ * In h_collect, the corresponding assertion that the
+ * character position advances is still there.
+ *
+ * bug_unless (ge(new_line, c->data_lineno));
+ */
if (new_line == c->data_lineno) {
new_data = cdr(new_data);
@@ -3720,7 +3992,7 @@ static val v_rebind(match_files_ctx *c)
val form = second(args);
val val = txeval(specline, form, c->bindings);
- c->bindings = alist_remove(c->bindings, args);
+ c->bindings = alist_remove(c->bindings, flatten(pattern));
c->bindings = dest_bind(specline, c->bindings,
pattern, val, equal_f);
@@ -3781,7 +4053,7 @@ static val v_output(match_files_ctx *c)
pop(&dest_spec);
}
- alist = improper_plist_to_alist(dest_spec, list(nothrow_k, append_k, nao));
+ alist = improper_plist_to_alist(dest_spec, v_output_keys);
nothrow = cdr(assoc(nothrow_k, alist));
append = cdr(assoc(append_k, alist));
@@ -3889,6 +4161,52 @@ out:
return ret;
}
+static val v_push(match_files_ctx *c)
+{
+ spec_bind (specline, first_spec, c->spec);
+ val specs = second(first_spec);
+ val dest_spec = third(first_spec);
+ val filter = nil;
+ val alist;
+ val stream = make_strlist_output_stream();
+
+ uw_match_env_begin;
+
+ val saved_de = set_dyn_env(make_env(c->bindings, nil, nil));
+
+ uw_set_match_context(cons(c->spec, c->spec));
+
+ alist = improper_plist_to_alist(dest_spec, v_output_keys);
+
+ {
+ val filter_sym = cdr(assoc(filter_k, alist));
+
+ if (filter_sym) {
+ filter = get_filter(filter_sym);
+
+ if (!filter)
+ sem_error(specline, lit("~s specifies unknown filter"), filter_sym, nao);
+ }
+ }
+
+ do_output(c->bindings, specs, filter, stream);
+
+ {
+ val list_out = get_list_from_stream(stream);
+ val len = length(list_out);
+
+ if (c->data_lineno)
+ c->data_lineno = minus(c->data_lineno, len);
+ c->data = append2(list_out, c->data);
+
+ debuglf(specs, lit("prepended ~s lines of output: adjusted lineno is ~s"),
+ len, c->data_lineno, nao);
+ }
+
+ set_dyn_env(saved_de);
+ uw_match_env_end;
+ return next_spec_k;
+}
static val v_try(match_files_ctx *c)
{
spec_bind (specline, first_spec, c->spec);
@@ -4092,7 +4410,8 @@ static val v_throw(match_files_ctx *c)
{
val values = mapcar(pa_123_2(func_n3(txeval_allow_ub),
specline, c->bindings), args);
- uw_throw(type, values);
+ uw_rthrow(type, values);
+ return next_spec_k;
}
}
@@ -4112,7 +4431,7 @@ static val v_deffilter(match_files_ctx *c)
if (!all_satisfy(table_evaled, andf(func_n1(listp),
chain(func_n1(length_list),
pa_12_1(func_n2(ge), two), nao),
- chain(func_n1(rest),
+ chain(cdr_f,
pa_123_1(func_n3(all_satisfy),
func_n1(stringp),
nil),
@@ -4159,7 +4478,26 @@ static val v_eof(match_files_ctx *c)
if (c->data && car(c->data)) {
debuglf(c->spec, lit("eof failed to match at ~d"), c->data_lineno, nao);
return nil;
+ } else {
+ spec_bind (specline, first_spec, c->spec);
+ val args = rest(first_spec);
+
+ if (rest(args))
+ sem_error(specline, lit("eof directive takes takes at most one argument"), nao);
+
+ if (args) {
+ val pat = car(args);
+ val close_status = if3(streamp(c->stream), close_stream(c->stream, t), t);
+
+ c->bindings = dest_bind(specline, c->bindings, pat, close_status, eql_f);
+
+ if (c->bindings == t) {
+ debuglf(specline, lit("line mismatch (line ~d vs. ~s)"), c->data_lineno, pat, nao);
+ return nil;
+ }
+ }
}
+
return next_spec_k;
}
@@ -4311,7 +4649,7 @@ static val v_assert(match_files_ctx *c)
} else if (type) {
val values = mapcar(pa_123_2(func_n3(txeval_allow_ub),
specline, c->bindings), args);
- uw_throw(type, values);
+ return uw_rthrow(type, values);
} else {
if (c->curfile)
typed_error(assert_s, first_spec, lit("assertion (at ~a:~d)"), c->curfile, c->data_lineno, nao);
@@ -4343,20 +4681,20 @@ static val v_load(match_files_ctx *c)
{
val path = if3(!pure_rel_path_p(target),
target,
- cat_str(nappend2(sub_list(split_str(parent, lit("/")),
- zero, negone),
- cons(target, nil)), lit("/")));
- val stream, name;
+ path_cat(dir_name(parent), target));
+ val stream, name = target;
val txr_lisp_p = nil;
- val ret = nil;
+ val ret = next_spec_k;
val saved_dyn_env = dyn_env;
- val rec = cdr(lookup_var(saved_dyn_env, load_recursive_s));
+ val load_dyn_env = make_env(nil, nil, dyn_env);
+ val rec = cdr(lookup_var(nil, load_recursive_s));
+ uw_block_begin (load_s, load_ret);
- open_txr_file(path, &txr_lisp_p, &name, &stream);
+ open_txr_file(path, &txr_lisp_p, &name, &stream, t, self);
uw_simple_catch_begin;
- dyn_env = make_env(nil, nil, dyn_env);
+ dyn_env = load_dyn_env;
env_vbind(dyn_env, load_path_s, name);
env_vbind(dyn_env, load_recursive_s, t);
env_vbind(dyn_env, package_s, cur_package);
@@ -4369,8 +4707,10 @@ static val v_load(match_files_ctx *c)
parse_once(self, stream, name);
gc_state(gc);
- if (parser->errors)
+ if (parser->errors) {
+ uw_release_deferred_warnings();
sem_error(specline, lit("~s: errors encountered in ~a"), sym, path, nao);
+ }
if (sym == include_s) {
ret = parser->syntax_tree;
@@ -4397,8 +4737,6 @@ static val v_load(match_files_ctx *c)
nao);
c->data = nil;
}
-
- ret = next_spec_k;
}
}
} else {
@@ -4425,12 +4763,15 @@ static val v_load(match_files_ctx *c)
uw_unwind {
close_stream(stream, nil);
+ run_load_hooks(saved_dyn_env);
if (!rec)
uw_dump_deferred_warnings(std_null);
}
uw_catch_end;
+ uw_block_end;
+
return ret;
}
}
@@ -4516,17 +4857,11 @@ static val v_call(match_files_ctx *c)
val funval = tleval_144(specline, funexpr, c->bindings);
val argexprs = cdr(exprs);
val call = cons(funval, argexprs);
- val spec = cons(cons(call, nil), nil);
- match_files_ctx ctx = mf_spec_bindings(*c, spec, c->bindings);
- val ret = v_fun(&ctx);
+ val spec = cons(cons(call, nil), cdr(c->spec));
- if (ret == nil)
- return nil;
+ c->spec = spec;
- if (ret == decline_k)
- sem_error(nil, lit("call: function ~s not found"), funval, nao);
-
- return cons(ctx.bindings, if3(ctx.data, cons(ctx.data, ctx.data_lineno), t));
+ return v_fun(c);
}
static val h_do(match_line_ctx *c)
@@ -4548,7 +4883,7 @@ static val h_assert(match_line_ctx *c)
} else if (type) {
val values = mapcar(pa_123_2(func_n3(txeval_allow_ub),
c->specline, c->bindings), elem);
- uw_throw(type, values);
+ return uw_rthrow(type, values);
} else {
if (c->file)
typed_error(assert_s, elem, lit("assertion (at ~a:~d)"), c->file, c->data_lineno, nao);
@@ -4559,27 +4894,40 @@ static val h_assert(match_line_ctx *c)
static void open_data_source(match_files_ctx *c)
{
- spec_bind (specline, first_spec, c->spec);
- int non_matching_dir = (consp(first_spec) &&
- (gethash(non_matching_directive_table,
- first(first_spec))) &&
- !rest(specline));
-
/* c->data == t is set up by the top level call to match_files.
* It indicates that we have not yet opened any data source.
*/
- if (c->data == t && c->files) {
+ if (c->data == t) {
+ spec_bind (specline, first_spec, c->spec);
+
val source_spec = first(c->files);
val ss_consp = consp(source_spec);
val name = ss_consp ? cdr(source_spec) : source_spec;
- val nothrow = tnil(ss_consp && car(source_spec) == nothrow_k);
+ val op = if2(consp(first_spec), first(first_spec));
+ int non_matching_dir = (!rest(specline) && op && symbolp(op) &&
+ (gethash(non_matching_directive_table, op) ||
+ car(uw_get_func(op))));
- if (non_matching_dir) {
+ if (c->files == nil) {
+ if (opt_compat && opt_compat <= 170) {
+ c->data = nil;
+ } else if (non_matching_dir) {
+ debuglf(first_spec, lit("not opening standard input "
+ "since query starts with non-matching "
+ "directive."), nao);
+ } else {
+ debuglf(first_spec, lit("opening standard input as data source"), nao);
+ c->curfile = lit("-");
+ c->data = lazy_stream_cons(std_input, nil);
+ c->data_lineno = one;
+ }
+ } else if (non_matching_dir) {
debuglf(first_spec, lit("not opening source ~a "
"since query starts with non-matching "
"directive."), name, nao);
} else if (stringp(name)) {
+ val nothrow = tnil(ss_consp && car(source_spec) == nothrow_k);
val stream = complex_open(name, nil, nil, nothrow, t);
debuglf(specline, lit("opening data source ~a"), name, nao);
@@ -4593,35 +4941,30 @@ static void open_data_source(match_files_ctx *c)
c->files = cons(name, cdr(c->files)); /* Get rid of cons and nothrow */
c->curfile = source_spec;
+ c->stream = stream;
- if ((c->data = lazy_stream_cons(stream)) != nil)
+ if ((c->data = lazy_stream_cons(stream, nothrow)) != nil)
c->data_lineno = one;
} else if (streamp(name)) {
- if ((c->data = lazy_stream_cons(name)))
+ if ((c->data = lazy_stream_cons(name, nil)))
c->data_lineno = one;
} else {
sem_error(specline, lit("~s doesn't denote a valid data source"), name, nao);
}
- } else if (c->data == t && c->files == nil) {
- if (opt_compat && opt_compat <= 170) {
- c->data = nil;
- } else if (non_matching_dir) {
- debuglf(first_spec, lit("not opening standard input "
- "since query starts with non-matching "
- "directive."), nao);
- } else {
- debuglf(first_spec, lit("opening standard input as data source"), nao);
- c->curfile = lit("-");
- c->data = lazy_stream_cons(std_input);
- c->data_lineno = one;
- }
}
}
static val match_files(match_files_ctx c)
{
+ val stream_in = c.stream;
+ val res = nil;
+
+ uw_simple_catch_begin;
+
gc_hint(c.data);
+ gc_stack_check();
+
for (; c.spec; c.spec = rest(c.spec),
c.data = rest(c.data),
c.data_lineno = plus(c.data_lineno, one))
@@ -4635,11 +4978,11 @@ repeat_spec_same_data:
if (consp(first_spec) && !rest(specline)) {
val lfe_save = set_last_form_evaled(first_spec);
val sym = first(first_spec);
- val entry = gethash(v_directive_table, sym);
+ val entry;
- if (sym == var_s || sym == text_s) {
- /* It's actually a var or text; go to horizontal processing below */
- } else if (entry) {
+ if (sym == text_s) {
+ /* It's literal text; go to horizontal processing below */
+ } else if ((entry = gethash(v_directive_table, sym))) {
v_match_func vmf = coerce(v_match_func, cptr_get(entry));
val result = vmf(&c);
@@ -4652,7 +4995,8 @@ repeat_spec_same_data:
} else if (result == decline_k) {
/* Vertical directive declined; go to horizontal processing */
} else {
- return result;
+ res = result;
+ goto out;
}
} else if (gethash(h_directive_table,sym)) {
/* Lone horizontal-only directive: go to horizontal processing */
@@ -4666,11 +5010,15 @@ repeat_spec_same_data:
break;
goto repeat_spec_same_data;
} else if (result == decline_k) {
- /* Function declined; we know the lookup failed because
- since rest(specline) is nil, this is not horizontal fallback. */
- sem_error(specline, lit("function ~s not found"), sym, nao);
+ /* Function declined, so we know there is no vertical function.
+ If the horizontal one doesn't exist also, let's error out
+ now instead of trying to get data for matching a horizontal
+ call that we know won't work out. */
+ if (!cdr(uw_get_func(sym)))
+ sem_error(specline, lit("function ~s not found"), sym, nao);
} else {
- return result;
+ res = result;
+ goto out;
}
}
}
@@ -4684,21 +5032,32 @@ repeat_spec_same_data:
cons_bind (new_bindings, success,
match_line_completely(ml_all(c.bindings, specline,
dataline, zero,
- c.data, c.data_lineno, c.curfile)));
+ c.data, c.data_lineno,
+ c.curfile, c.stream)));
if (!success)
- return nil;
+ goto out;
c.bindings = new_bindings;
} else if (consp(c.data) || nilp(c.data)) {
debuglf(specline, lit("spec ran out of data"), nao);
- return nil;
+ goto out;
} else {
internal_error("bug in data stream opening logic");
}
}
- return cons(c.bindings, if3(c.data, cons(c.data, c.data_lineno), t));
+ res = cons(c.bindings, if3(c.data, cons(c.data, c.data_lineno), t));
+
+out:
+ uw_unwind {
+ if (c.stream && c.stream != stream_in)
+ close_stream(c.stream, nil);
+ }
+
+ uw_catch_end;
+
+ return res;
}
val match_filter(val name, val arg, val other_args)
@@ -4711,7 +5070,7 @@ val match_filter(val name, val arg, val other_args)
val spec = cons(list(cons(name,
cons(in_arg_sym, cons(out_arg_sym, other_args))),
nao), nil);
- match_files_ctx c = mf_all(spec, nil, bindings, nil, nil);
+ match_files_ctx c = mf_all(spec, nil, bindings, nil, nil, nil);
val ret = v_fun(&c);
(void) first_spec;
@@ -4746,10 +5105,11 @@ val match_fun(val name, val args, val input_in, val files_in)
val files = cons(curfile, default_null_arg(files_in));
val in_bindings = cdr(uw_get_match_context());
val data = if3(streamp(input),
- lazy_stream_cons(input),
+ lazy_stream_cons(input, nil),
input);
/* TODO: pass through source location context */
- match_files_ctx c = mf_all(spec, files, in_bindings, data, curfile);
+ match_files_ctx c = mf_all(spec, files, in_bindings, data,
+ curfile, if2(streamp(input), input));
val ret;
ret = v_fun(&c);
@@ -4763,17 +5123,22 @@ val match_fun(val name, val args, val input_in, val files_in)
return cons(c.bindings, if3(c.data, cons(c.data, c.data_lineno), t));
}
+val match_fboundp(val name)
+{
+ return tnil(uw_get_func(name));
+}
+
val include(val specline)
{
val spec = cons(specline, nil);
- match_files_ctx c = mf_all(spec, nil, nil, nil, nil);
+ match_files_ctx c = mf_all(spec, nil, nil, nil, nil, nil);
return v_load(&c);
}
val extract(val spec, val files, val predefined_bindings)
{
val result = match_files(mf_all(spec, files, predefined_bindings,
- t, nil));
+ t, nil, nil));
cons_bind (bindings, success, result);
if (opt_print_bindings) {
@@ -4878,6 +5243,7 @@ static void syms_init(void)
string_k = intern(lit("string"), keyword_package);
env_k = intern(lit("env"), keyword_package);
named_k = intern(lit("named"), keyword_package);
+ noclose_k = intern(lit("noclose"), keyword_package);
continue_k = intern(lit("continue"), keyword_package);
finish_k = intern(lit("finish"), keyword_package);
mandatory_k = intern(lit("mandatory"), keyword_package);
@@ -4905,10 +5271,10 @@ static void dir_tables_init(void)
&non_matching_directive_table, &binding_directive_table,
convert(val *, 0));
- h_directive_table = make_hash(nil, nil, nil);
- v_directive_table = make_hash(nil, nil, nil);
- non_matching_directive_table = make_hash(nil, nil, nil);
- binding_directive_table = make_hash(nil, nil, nil);
+ h_directive_table = make_hash(hash_weak_none, nil);
+ v_directive_table = make_hash(hash_weak_none, nil);
+ non_matching_directive_table = make_hash(hash_weak_none, nil);
+ binding_directive_table = make_hash(hash_weak_none, nil);
sethash(v_directive_table, skip_s, cptr(coerce(mem_t *, v_skip)));
sethash(v_directive_table, fuzz_s, cptr(coerce(mem_t *, v_fuzz)));
@@ -4936,6 +5302,7 @@ static void dir_tables_init(void)
sethash(v_directive_table, set_s, cptr(coerce(mem_t *, v_set)));
sethash(v_directive_table, cat_s, cptr(coerce(mem_t *, v_cat)));
sethash(v_directive_table, output_s, cptr(coerce(mem_t *, v_output)));
+ sethash(v_directive_table, push_s, cptr(coerce(mem_t *, v_push)));
sethash(v_directive_table, define_s, cptr(coerce(mem_t *, v_define)));
sethash(v_directive_table, try_s, cptr(coerce(mem_t *, v_try)));
sethash(v_directive_table, defex_s, cptr(coerce(mem_t *, v_defex)));
@@ -4953,7 +5320,7 @@ static void dir_tables_init(void)
sethash(v_directive_table, data_s, cptr(coerce(mem_t *, v_data)));
sethash(v_directive_table, name_s, cptr(coerce(mem_t *, v_name)));
sethash(v_directive_table, call_s, cptr(coerce(mem_t *, v_call)));
-
+ sethash(v_directive_table, var_s, cptr(coerce(mem_t *, v_var)));
sethash(h_directive_table, text_s, cptr(coerce(mem_t *, h_text)));
sethash(h_directive_table, var_s, cptr(coerce(mem_t *, h_var)));
sethash(h_directive_table, skip_s, cptr(coerce(mem_t *, h_skip)));
@@ -5013,6 +5380,7 @@ static void dir_tables_init(void)
sethash(non_matching_directive_table, do_s, t);
sethash(non_matching_directive_table, load_s, t);
sethash(non_matching_directive_table, close_s, t);
+ sethash(non_matching_directive_table, call_s, t);
sethash(binding_directive_table, var_s, one);
sethash(binding_directive_table, merge_s, one);
@@ -5024,8 +5392,24 @@ static void dir_tables_init(void)
sethash(binding_directive_table, name_s, one);
}
+static void plist_keys_init(void)
+{
+ protect(&v_next_keys, &v_output_keys, convert(val *, 0));
+ v_next_keys = list(nothrow_k, noclose_k, nao);
+ v_output_keys = list(nothrow_k, append_k, nao);
+}
+
void match_init(void)
{
syms_init();
dir_tables_init();
+ plist_keys_init();
+}
+
+void match_compat_fixup(int compat_ver)
+{
+ if (compat_ver <= 272) {
+ sethash(v_directive_table, var_s, cptr(coerce(mem_t *, v_var_compat)));
+ sethash(h_directive_table, var_s, cptr(coerce(mem_t *, h_var_compat)));
+ }
}
diff --git a/match.h b/match.h
index 26eee251..ee16b5b1 100644
--- a/match.h
+++ b/match.h
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,36 +6,43 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
extern val text_s, choose_s, gather_s, do_s, mdo_s, require_s, in_package_s;
extern val close_s, load_s, include_s, mod_s, modlast_s, line_s;
extern val else_s, elif_s;
-extern val counter_k, vars_k, lists_k, env_k, var_k, into_k, named_k;
+extern val counter_k, vars_k, lists_k, env_k, var_k, into_k, named_k, noclose_k;
+extern val append_k, continue_k, finish_k;
+
+extern val v_output_keys;
+
val match_expand_keyword_args(val elem);
val match_expand_elem(val elem);
val match_filter(val name, val arg, val other_args);
val match_fun(val name, val args, val input, val files);
+val match_fboundp(val name);
val include(val specline);
val extract(val spec, val filenames, val bindings);
void match_reg_var(val sym);
void match_reg_params(val params);
void match_reg_elem(val elem);
void match_init(void);
+void match_compat_fixup(int compat_ver);
diff --git a/mpi/mpi-config.h b/mpi/mpi-config.h
index 801eaae7..19ee91bb 100644
--- a/mpi/mpi-config.h
+++ b/mpi/mpi-config.h
@@ -8,6 +8,10 @@
#define MP_MODARITH 1 /* include modular arithmetic ? */
#endif
+#ifndef MP_FOR_TXR
+#define MP_FOR_TXR 1
+#endif
+
#ifndef MP_NUMTH
#define MP_NUMTH 1 /* include number theoretic functions? */
#endif
@@ -32,10 +36,6 @@
#define MP_ARGCHK 2 /* how to check input arguments */
#endif
-#ifndef MP_DEBUG
-#define MP_DEBUG 0 /* print diagnostic output? */
-#endif
-
#ifndef MP_DEFPREC
#define MP_DEFPREC 8 /* default precision, in digits */
#endif
diff --git a/mpi/mpi.c b/mpi/mpi.c
index e5d76f93..5aa3d06f 100644
--- a/mpi/mpi.c
+++ b/mpi/mpi.c
@@ -35,14 +35,6 @@
typedef unsigned char mem_t;
extern mem_t *chk_calloc(size_t n, size_t size);
-#if MP_DEBUG
-#include <stdio.h>
-
-#define DIAG(T,V) {fprintf(stderr,T);mp_print(V,stderr);fputc('\n',stderr);}
-#else
-#define DIAG(T,V)
-#endif
-
#include "logtab.h"
/* Default precision for newly created mp_int's */
@@ -158,6 +150,7 @@ int s_mp_tovalue(wchar_t ch, int r); /* convert ch to value */
char s_mp_todigit(int val, int r, int low); /* convert val to digit */
size_t s_mp_outlen(mp_size bits, int r); /* output length in bytes */
+#if !MP_FOR_TXR
unsigned int mp_get_prec(void)
{
return s_mp_defprec;
@@ -170,6 +163,7 @@ void mp_set_prec(unsigned int prec)
else
s_mp_defprec = prec;
}
+#endif
/* Initialize a new zero-valued mp_int. Returns MP_OKAY if successful,
* MP_MEM if memory could not be allocated for the structure.
@@ -179,6 +173,7 @@ mp_err mp_init(mp_int *mp)
return mp_init_size(mp, s_mp_defprec);
}
+#if !MP_FOR_TXR
mp_err mp_init_array(mp_int mp[], int count)
{
mp_err res;
@@ -199,6 +194,7 @@ mp_err mp_init_array(mp_int mp[], int count)
return res;
}
+#endif
/* Initialize a new zero-valued mp_int with at least the given
* precision; returns MP_OKAY if successful, or MP_MEM if memory could
@@ -331,6 +327,7 @@ void mp_clear(mp_int *mp)
ALLOC(mp) = 0;
}
+#if !MP_FOR_TXR
void mp_clear_array(mp_int mp[], int count)
{
ARGCHK(mp != NULL && count > 0, MP_BADARG);
@@ -338,6 +335,7 @@ void mp_clear_array(mp_int mp[], int count)
while (--count >= 0)
mp_clear(&mp[count]);
}
+#endif
/* Set mp to zero. Does not change the allocated size of the structure,
* and therefore cannot fail (except on a bad argument, which we ignore)
@@ -423,7 +421,7 @@ mp_err mp_set_uintptr(mp_int *mp, uint_ptr_t z)
mp_err mp_set_intptr(mp_int *mp, int_ptr_t z)
{
- uint_ptr_t w = z;
+ uint_ptr_t w = convert(uint_ptr_t, z);
uint_ptr_t v = z >= 0 ? w : -w;
mp_err err = mp_set_uintptr(mp, v);
@@ -441,9 +439,10 @@ mp_err mp_get_uintptr(mp_int *mp, uint_ptr_t *z)
#if MP_DIGIT_SIZE < SIZEOF_PTR
mp_size ix;
- mp_size nd = USED(mp);
- for (ix = 0; ix < nd; ix++, out <<= MP_DIGIT_BIT)
+ for (ix = USED(mp) - 1; ix < MP_SIZE_MAX; ix--) {
+ out <<= MP_DIGIT_BIT;
out |= DIGIT(mp, ix);
+ }
#else
out = DIGIT(mp, 0);
#endif
@@ -463,7 +462,7 @@ mp_err mp_get_intptr(mp_int *mp, int_ptr_t *z)
int mp_in_range(mp_int *mp, uint_ptr_t lim, int unsig)
{
- const unsigned ptrnd = (SIZEOF_PTR + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT;
+ const unsigned ptrnd = (SIZEOF_PTR + MP_DIGIT_SIZE - 1) / MP_DIGIT_SIZE;
mp_size nd = USED(mp);
int neg = ISNEG(mp);
@@ -556,9 +555,10 @@ mp_err mp_get_double_uintptr(mp_int *mp, double_uintptr_t *z)
{
double_uintptr_t out = 0;
mp_size ix;
- mp_size nd = USED(mp);
- for (ix = 0; ix < nd; ix++, out <<= MP_DIGIT_BIT)
+ for (ix = USED(mp) - 1; ix < MP_SIZE_MAX; ix--) {
+ out <<= MP_DIGIT_BIT;
out |= DIGIT(mp, ix);
+ }
*z = (SIGN(mp) == MP_NEG) ? -out : out;
return MP_OKAY;
@@ -569,16 +569,17 @@ mp_err mp_get_double_intptr(mp_int *mp, double_intptr_t *z)
double_uintptr_t tmp = 0;
mp_get_double_uintptr(mp, &tmp);
/* Reliance on bitwise unsigned to two's complement conversion */
- *z = convert(int_ptr_t, tmp);
+ *z = convert(double_intptr_t, tmp);
return MP_OKAY;
}
static int s_mp_in_big_range(mp_int *mp, double_uintptr_t lim, int unsig)
{
- const unsigned ptrnd = (SIZEOF_DOUBLE_INTPTR + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT;
+ const unsigned ptrnd = (SIZEOF_DOUBLE_INTPTR + MP_DIGIT_SIZE - 1) / MP_DIGIT_SIZE;
mp_size nd = USED(mp);
+ int neg = ISNEG(mp);
- if (unsig && ISNEG(mp))
+ if (unsig && neg)
return 0;
if (nd < ptrnd)
@@ -587,6 +588,26 @@ static int s_mp_in_big_range(mp_int *mp, double_uintptr_t lim, int unsig)
if (nd > ptrnd)
return 0;
+ if (neg) {
+ mp_digit *dp = DIGITS(mp);
+ const mp_digit Ox8__0 = MP_DIGIT_MAX ^ (MP_DIGIT_MAX >> 1);
+
+ switch (ptrnd) {
+ case 1:
+ if (dp[0] == Ox8__0)
+ return 1;
+ break;
+ case 2:
+ if (dp[0] == 0 && dp[1] == Ox8__0)
+ return 1;
+ break;
+ case 4:
+ if (dp[0] == 0 && dp[1] == 0 && dp[2] == 0 && dp[3] == Ox8__0)
+ return 1;
+ break;
+ }
+ }
+
{
mp_digit top = DIGITS(mp)[ptrnd - 1];
lim >>= ((ptrnd - 1) * MP_DIGIT_BIT);
@@ -606,6 +627,7 @@ int mp_in_double_uintptr_range(mp_int *mp)
#endif
+#if !MP_FOR_TXR
mp_err mp_set_word(mp_int *mp, mp_word w, int sign)
{
USED(mp) = 2;
@@ -614,6 +636,7 @@ mp_err mp_set_word(mp_int *mp, mp_word w, int sign)
SIGN(mp) = sign;
return MP_OKAY;
}
+#endif
/* Compute the sum b = a + d, for a single digit d. Respects the sign of
* its primary addend (single digits are unsigned anyway).
@@ -695,6 +718,7 @@ mp_err mp_mul_d(mp_int *a, mp_digit d, mp_int *b)
return res;
}
+#if !MP_FOR_TXR
mp_err mp_mul_2(mp_int *a, mp_int *c)
{
mp_err res;
@@ -706,6 +730,7 @@ mp_err mp_mul_2(mp_int *a, mp_int *c)
return s_mp_mul_2(c);
}
+#endif
/* Compute the quotient q = a / d and remainder r = a mod d, for a
* single digit d. Respects the sign of its divisor (single digits are
@@ -1274,12 +1299,14 @@ X:
/* Compute a = 2^k */
+#if !MP_FOR_TXR
mp_err mp_2expt(mp_int *a, mp_digit k)
{
ARGCHK(a != NULL, MP_BADARG);
return s_mp_2expt(a, k);
}
+#endif
/* Compute c = a (mod m). Result will always be 0 <= c < m. */
mp_err mp_mod(mp_int *a, mp_int *m, mp_int *c)
@@ -1410,6 +1437,7 @@ out:
#if MP_MODARITH
+#if !MP_FOR_TXR
/* Compute c = (a + b) mod m */
mp_err mp_addmod(mp_int *a, mp_int *b, mp_int *m, mp_int *c)
{
@@ -1470,6 +1498,7 @@ mp_err mp_sqrmod(mp_int *a, mp_int *m, mp_int *c)
return MP_OKAY;
}
#endif
+#endif
/* Compute c = (a ** b) mod m. Uses a standard square-and-multiply
* method with modular reductions at each step. (This is basically the
@@ -1559,6 +1588,7 @@ mp_err mp_exptmod(mp_int *a, mp_int *b, mp_int *m, mp_int *c)
return res;
}
+#if !MP_FOR_TXR
mp_err mp_exptmod_d(mp_int *a, mp_digit d, mp_int *m, mp_int *c)
{
mp_int s, x;
@@ -1596,6 +1626,7 @@ X:
return res;
}
+#endif
#endif /* if MP_MODARITH */
@@ -1611,6 +1642,7 @@ int mp_cmp_z(mp_int *a)
}
/* Compare a <=> d. Returns <0 if a<d, 0 if a=d, >0 if a>d */
+#if !MP_FOR_TXR
int mp_cmp_d(mp_int *a, mp_digit d)
{
ARGCHK(a != NULL, MP_EQ);
@@ -1620,6 +1652,7 @@ int mp_cmp_d(mp_int *a, mp_digit d)
return s_mp_cmp_d(a, d);
}
+#endif
int mp_cmp(mp_int *a, mp_int *b)
{
@@ -1643,6 +1676,7 @@ int mp_cmp(mp_int *a, mp_int *b)
}
}
+#if !MP_FOR_TXR
/* Compares |a| <=> |b|, and returns an appropriate comparison result */
int mp_cmp_mag(mp_int *a, mp_int *b)
{
@@ -1669,6 +1703,7 @@ int mp_cmp_int(mp_int *a, long z)
return out;
}
+#endif
/* Returns a true (non-zero) value if a is odd, false (zero) otherwise.
*/
@@ -1808,6 +1843,7 @@ mp_err mp_gcd(mp_int *a, mp_int *b, mp_int *c)
return res;
}
+#if !MP_FOR_TXR
/* We compute the least common multiple using the rule:
*
* ab = [a, b](a, b)
@@ -1994,6 +2030,7 @@ X:
return res;
}
+#endif
#endif /* if MP_NUMTH */
@@ -2095,13 +2132,14 @@ out:
mp_err mp_or(mp_int *a, mp_int *b, mp_int *c)
{
mp_err res;
- mp_size ix, extent = 0;
+ mp_size ix, extent, mindig;
mp_digit *pa, *pb, *pc;
mp_int tmp_a, tmp_b;
ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG);
extent = MAX(USED(a), USED(b));
+ mindig = MIN(USED(a), USED(b));
if (a == b)
return mp_copy(a, c);
@@ -2127,11 +2165,16 @@ mp_err mp_or(mp_int *a, mp_int *b, mp_int *c)
goto out;
for (pa = DIGITS(a), pb = DIGITS(b), pc = DIGITS(c), ix = 0;
- ix < extent; ix++)
+ ix < mindig; ix++)
{
pc[ix] = pa[ix] | pb[ix];
}
+ if (ix < USED(a))
+ s_mp_copy(pa + ix, pc + ix, USED(a) - ix);
+ else if (ix < USED(b))
+ s_mp_copy(pb + ix, pc + ix, USED(b) - ix);
+
USED(c) = extent;
if (ISNEG(a) || ISNEG(b)) {
@@ -2154,7 +2197,7 @@ out:
mp_err mp_xor(mp_int *a, mp_int *b, mp_int *c)
{
mp_err res;
- mp_size ix, extent = 0;
+ mp_size ix, extent, mindig;
mp_digit *pa, *pb, *pc;
mp_int tmp_a, tmp_b;
@@ -2166,6 +2209,7 @@ mp_err mp_xor(mp_int *a, mp_int *b, mp_int *c)
}
extent = MAX(USED(a), USED(b));
+ mindig = MIN(USED(a), USED(b));
if (ISNEG(a)) {
if ((res = mp_2comp(a, &tmp_a, extent)) != MP_OKAY)
@@ -2188,11 +2232,16 @@ mp_err mp_xor(mp_int *a, mp_int *b, mp_int *c)
goto out;
for (pa = DIGITS(a), pb = DIGITS(b), pc = DIGITS(c), ix = 0;
- ix < extent; ix++)
+ ix < mindig; ix++)
{
pc[ix] = pa[ix] ^ pb[ix];
}
+ if (ix < USED(a))
+ s_mp_copy(pa + ix, pc + ix, USED(a) - ix);
+ else if (ix < USED(b))
+ s_mp_copy(pb + ix, pc + ix, USED(b) - ix);
+
USED(c) = extent;
if (ISNEG(a) ^ ISNEG(b)) {
@@ -2818,10 +2867,12 @@ mp_err mp_toradix(mp_int *mp, unsigned char *str, int radix)
return mp_toradix_case(mp, str, radix, 0);
}
+#if !MP_FOR_TXR
int mp_char2value(char ch, int r)
{
return s_mp_tovalue(ch, r);
}
+#endif
/* Return a string describing the meaning of error code 'ec'. The
* string returned is allocated in static memory, so the caller should
@@ -3334,35 +3385,35 @@ mp_err s_mp_mul_2d(mp_int *mp, mp_digit d)
return res;
dp = DIGITS(mp); used = USED(mp);
- d %= DIGIT_BIT;
- mask = (convert(mp_digit, 1) << d) - 1;
+ if ((d %= DIGIT_BIT) != 0) {
+ mask = (convert(mp_digit, 1) << d) - 1;
- /* If the shift requires another digit, make sure we've got one to
- work with */
- if ((dp[used - 1] >> (DIGIT_BIT - d)) & mask) {
- if ((res = s_mp_grow(mp, used + 1)) != MP_OKAY)
- return res;
- dp = DIGITS(mp);
- }
+ /* If the shift requires another digit, make sure we've got one to
+ work with */
+ if ((dp[used - 1] >> (DIGIT_BIT - d)) & mask) {
+ if ((res = s_mp_grow(mp, used + 1)) != MP_OKAY)
+ return res;
+ dp = DIGITS(mp);
+ }
- /* Do the shifting... */
- save = 0;
- for (ix = 0; ix < used; ix++) {
- next = (dp[ix] >> (DIGIT_BIT - d)) & mask;
- dp[ix] = (dp[ix] << d) | save;
- save = next;
- }
+ /* Do the shifting... */
+ save = 0;
+ for (ix = 0; ix < used; ix++) {
+ next = (dp[ix] >> (DIGIT_BIT - d)) & mask;
+ dp[ix] = (dp[ix] << d) | save;
+ save = next;
+ }
- /* If, at this point, we have a nonzero carryout into the next
- * digit, we'll increase the size by one digit, and store it...
- */
- if (save) {
- dp[used] = save;
- USED(mp) += 1;
+ /* If, at this point, we have a nonzero carryout into the next
+ * digit, we'll increase the size by one digit, and store it...
+ */
+ if (save) {
+ dp[used] = save;
+ USED(mp) += 1;
+ }
}
- s_mp_clamp(mp);
return MP_OKAY;
}
@@ -4045,7 +4096,7 @@ mp_size s_mp_ispow2(mp_int *v)
{
mp_digit d, *dp;
mp_size uv = USED(v);
- mp_size extra = 0, ix;
+ mp_size ix;
d = DIGIT(v, uv - 1); /* most significant digit of v */
@@ -4053,8 +4104,6 @@ mp_size s_mp_ispow2(mp_int *v)
if ((d & (d - 1)) != 0)
return MP_SIZE_MAX; /* not a power of two */
- extra = s_highest_bit(d) - 1;
-
if (uv >= 2) {
ix = uv - 2;
dp = DIGITS(v) + ix;
@@ -4067,7 +4116,7 @@ mp_size s_mp_ispow2(mp_int *v)
}
}
- return ((uv - 1) * DIGIT_BIT) + extra;
+ return ((uv - 1) * DIGIT_BIT) + s_highest_bit(d) - 1;
}
int s_mp_ispow2d(mp_digit d)
@@ -4077,7 +4126,7 @@ int s_mp_ispow2d(mp_digit d)
return -1; /* not a power of two */
/* If d == 0, s_highest_bit returns 0, thus we return -1. */
- return (int) s_highest_bit(d) - 1;
+ return convert(int, s_highest_bit(d)) - 1;
}
/* Convert the given character to its digit value, in the given radix.
diff --git a/mpi/mpi.h b/mpi/mpi.h
index 2a73f233..fa926eeb 100644
--- a/mpi/mpi.h
+++ b/mpi/mpi.h
@@ -10,11 +10,6 @@
*/
#include "mpi-config.h"
-#if MP_DEBUG
-#undef MP_IOFUNC
-#define MP_IOFUNC 1
-#endif
-
#include <limits.h>
#define MP_NEG 1
diff --git a/parser.c b/parser.c
index 4da0b150..7b685181 100644
--- a/parser.c
+++ b/parser.c
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stdio.h>
@@ -33,7 +34,6 @@
#include <stdarg.h>
#include <wchar.h>
#include <signal.h>
-#include <ctype.h>
#include <wctype.h>
#include <errno.h>
#include "config.h"
@@ -44,6 +44,9 @@
#if HAVE_SYS_STAT
#include <sys/stat.h>
#endif
+#if HAVE_ZLIB
+#include <zlib.h>
+#endif
#include "lib.h"
#include "signal.h"
#include "unwind.h"
@@ -53,6 +56,9 @@
#include "hash.h"
#include "eval.h"
#include "stream.h"
+#if HAVE_ZLIB
+#include "gzio.h"
+#endif
#include "y.tab.h"
#include "sysif.h"
#include "cadr.h"
@@ -61,22 +67,26 @@
#include "parser.h"
#include "regex.h"
#include "itypes.h"
+#include "arith.h"
#include "buf.h"
#include "vm.h"
+#include "ffi.h"
#include "txr.h"
-#if HAVE_TERMIOS
#include "linenoise/linenoise.h"
-#endif
val parser_s, unique_s, circref_s;
val listener_hist_len_s, listener_multi_line_p_s, listener_sel_inclusive_p_s;
-val listener_pprint_s, listener_greedy_eval_s;
-val rec_source_loc_s;
+val listener_pprint_s, listener_greedy_eval_s, listener_auto_compound_s;
+val rec_source_loc_s, read_unknown_structs_s, read_bad_json_s;
+val json_s;
val intr_s;
+
+struct cobj_class *parser_cls;
+
static lino_t *lino_ctx;
static int repl_level = 0;
-static val stream_parser_hash, catch_all;
+static val stream_parser_hash, catch_all, catch_error;
static void yy_tok_mark(struct yy_token *tok)
{
@@ -107,19 +117,19 @@ static void parser_destroy(val obj)
free(p);
}
-static struct cobj_ops parser_ops = {
- eq,
- cobj_print_op,
- parser_destroy,
- parser_mark,
- cobj_eq_hash_op,
-};
+static struct cobj_ops parser_ops = cobj_ops_init(eq,
+ cobj_print_op,
+ parser_destroy,
+ parser_mark,
+ cobj_eq_hash_op);
void parser_common_init(parser_t *p)
{
int i;
yyscan_t yyscan;
val rec_source_loc_var = lookup_var(nil, rec_source_loc_s);
+ val read_unknown_structs_var = lookup_var(nil, read_unknown_structs_s);
+ val read_bad_json_var = lookup_var(nil, read_bad_json_s);
p->parser = nil;
p->lineno = 1;
@@ -137,13 +147,17 @@ void parser_common_init(parser_t *p)
p->scanner = convert(scanner_t *, yyscan);
yyset_extra(p, p->scanner);
p->recent_tok.yy_char = 0;
+ p->recent_tok.yy_lex_state = 0;
p->recent_tok.yy_lval.val = 0;
for (i = 0; i < 4; i++) {
p->tok_pushback[i].yy_char = 0;
+ p->tok_pushback[i].yy_lex_state = 0;
p->tok_pushback[i].yy_lval.val = 0;
}
p->tok_idx = 0;
p->rec_source_loc = !nilp(cdr(rec_source_loc_var));
+ p->read_unknown_structs = !nilp(cdr(read_unknown_structs_var));
+ p->read_bad_json = !nilp(cdr(read_bad_json_var));
}
void parser_cleanup(parser_t *p)
@@ -164,12 +178,13 @@ void parser_reset(parser_t *p)
val parser(val stream, val name, val lineno)
{
+ val self = lit("parser");
parser_t *p = coerce(parser_t *, chk_malloc(sizeof *p));
val parser;
parser_common_init(p);
- parser = cobj(coerce(mem_t *, p), parser_s, &parser_ops);
+ parser = cobj(coerce(mem_t *, p), parser_cls, &parser_ops);
p->parser = parser;
- p->lineno = c_num(default_arg(lineno, one));
+ p->lineno = c_num(default_arg(lineno, one), self);
p->name = name;
p->stream = stream;
@@ -178,7 +193,7 @@ val parser(val stream, val name, val lineno)
parser_t *parser_get_impl(val self, val parser)
{
- return coerce(parser_t *, cobj_handle(self, parser, parser_s));
+ return coerce(parser_t *, cobj_handle(self, parser, parser_cls));
}
val ensure_parser(val stream, val name)
@@ -202,13 +217,13 @@ val parser_set_lineno(val self, val stream, val lineno)
{
val parser = ensure_parser(stream, nil);
parser_t *pi = parser_get_impl(self, parser);
- pi->lineno = c_num(lineno);
+ pi->lineno = c_num(lineno, self);
return stream;
}
void prime_parser(parser_t *p, val name, enum prime_parser prim)
{
- struct yy_token sec_tok = { 0 };
+ struct yy_token sec_tok = all_zero_init;
switch (prim) {
case prime_lisp:
@@ -220,9 +235,12 @@ void prime_parser(parser_t *p, val name, enum prime_parser prim)
case prime_regex:
sec_tok.yy_char = SECRET_ESCAPE_R;
break;
+ case prime_json:
+ sec_tok.yy_char = SECRET_ESCAPE_J;
+ break;
}
- if (p->recent_tok.yy_char)
+ if (p->recent_tok.yy_char && prim != prime_json)
pushback_token(p, &p->recent_tok);
pushback_token(p, &sec_tok);
prime_scanner(p->scanner, prim);
@@ -267,6 +285,7 @@ static val patch_ref(parser_t *p, val obj)
static void circ_backpatch(parser_t *p, struct circ_stack *up, val obj)
{
+ val self = lit("parser");
struct circ_stack cs = { up, obj };
if (!parser_callgraph_circ_check(up, obj))
@@ -300,7 +319,7 @@ tail:
case VEC:
{
cnum i;
- cnum l = c_num(length_vec(obj));
+ cnum l = c_num(length_vec(obj), self);
for (i = 0; i < l; i++) {
val v = obj->v.vec[i];
@@ -411,7 +430,7 @@ tail:
break;
}
} else if (treep(obj)) {
- val iter = tree_begin(obj);
+ val iter = tree_begin(obj, colon_k, colon_k);
val node;
val nodes = nil;
cnum old_circ_count = p->circ_count;
@@ -431,7 +450,7 @@ tail:
while (nodes) {
val node = rcyc_pop(&nodes);
- tree_insert_node(obj, node);
+ tree_insert_node(obj, node, t);
}
} else {
while (nodes)
@@ -469,7 +488,7 @@ void parser_resolve_circ(parser_t *p)
void parser_circ_def(parser_t *p, val num, val expr)
{
if (!p->circ_ref_hash) {
- p->circ_ref_hash = make_eq_hash(nil, nil);
+ p->circ_ref_hash = make_eq_hash(hash_weak_none);
setcheck(p->parser, p->circ_ref_hash);
}
@@ -499,115 +518,180 @@ val parser_circ_ref(parser_t *p, val num)
return obj;
}
-void open_txr_file(val spec_file, val *txr_lisp_p, val *name, val *stream)
+void open_txr_file(val first_try_path, val *txr_lisp_p,
+ val *orig_in_resolved_out, val *stream,
+ val search_dirs, val self)
{
- enum { none, tl, tlo, txr } suffix;
+ enum { none, tl, tlo, tlz, txr } suffix;
+#if HAVE_ZLIB
+ struct stdio_mode m_r = stdio_mode_init_r;
+#endif
- if (match_str(spec_file, lit(".txr"), negone))
+ if (match_str(first_try_path, lit(".txr"), negone))
suffix = txr;
- else if (match_str(spec_file, lit(".tl"), negone))
+ else if (match_str(first_try_path, lit(".tl"), negone))
suffix = tl;
- else if (match_str(spec_file, lit(".tlo"), negone))
+ else if (match_str(first_try_path, lit(".tlo"), negone))
suffix = tlo;
- else if (match_str(spec_file, lit(".txr_profile"), negone))
+ else if (match_str(first_try_path, lit(".tlo.gz"), negone))
+ suffix = tlz;
+ else if (match_str(first_try_path, lit(".txr_profile"), negone))
suffix = tl;
else
suffix = none;
+#if !HAVE_ZLIB
+ if (suffix == tlz)
+ uw_ethrowf(file_error_s, lit("~s: cannot open ~s files: "
+ "not built with zlib support"),
+ self, nao);
+#endif
+
errno = 0;
{
- val spec_file_try = nil;
+ val try_path = nil;
FILE *in = 0;
+#if HAVE_ZLIB
+ gzFile zin = 0;
+#else
+ const int zin = 0;
+#endif
+
+ {
+ try_path = first_try_path;
+ errno = 0;
+#if HAVE_ZLIB
+ if (suffix == tlz)
+ zin = w_gzopen_mode(c_str(try_path, self), L"r", m_r, self);
+ else
+#endif
+ in = w_fopen(c_str(try_path, self), L"r");
+
+ if (in != 0 || zin != 0) {
+ switch (suffix) {
+ case tl:
+ *txr_lisp_p = t;
+ break;
+ case tlo: case tlz:
+ *txr_lisp_p = chr('o');
+ break;
+ case txr:
+ *txr_lisp_p = nil;
+ break;
+ default:
+ break;
+ }
+ goto found;
+ } else {
+#ifdef ENOENT
+ if (errno != ENOENT)
+ goto except;
+#endif
+ }
+ }
if (suffix == none && !*txr_lisp_p) {
- spec_file_try = scat(lit("."), spec_file, lit("txr"), nao);
- if ((in = w_fopen(c_str(spec_file_try), L"r")) != 0)
+ try_path = scat(lit("."), first_try_path, lit("txr"), nao);
+ if ((in = w_fopen(c_str(try_path, nil), L"r")) != 0)
goto found;
#ifdef ENOENT
- if (in == 0 && errno != ENOENT)
+ if (errno != ENOENT)
goto except;
#endif
}
if (suffix == none) {
{
- spec_file_try = scat(lit("."), spec_file, lit("tlo"), nao);
+ try_path = scat(lit("."), first_try_path, lit("tlo"), nao);
errno = 0;
- if ((in = w_fopen(c_str(spec_file_try), L"r")) != 0) {
+ if ((in = w_fopen(c_str(try_path, nil), L"r")) != 0) {
*txr_lisp_p = chr('o');
goto found;
}
#ifdef ENOENT
- if (in == 0 && errno != ENOENT)
+ if (errno != ENOENT)
goto except;
#endif
}
+#if HAVE_ZLIB
{
- spec_file_try = scat(lit("."), spec_file, lit("tl"), nao);
+ try_path = scat(lit("."), first_try_path, lit("tlo.gz"), nao);
errno = 0;
- if ((in = w_fopen(c_str(spec_file_try), L"r")) != 0) {
- *txr_lisp_p = t;
+ if ((zin = w_gzopen_mode(c_str(try_path, nil), L"r", m_r, self)) != 0) {
+ *txr_lisp_p = chr('o');
goto found;
}
#ifdef ENOENT
- if (in == 0 && errno != ENOENT)
+ if (errno != ENOENT)
goto except;
#endif
}
- }
-
- {
- spec_file_try = spec_file;
- errno = 0;
- in = w_fopen(c_str(spec_file_try), L"r");
- if (in != 0) {
- switch (suffix) {
- case tl:
+#endif
+ {
+ try_path = scat(lit("."), first_try_path, lit("tl"), nao);
+ errno = 0;
+ if ((in = w_fopen(c_str(try_path, nil), L"r")) != 0) {
*txr_lisp_p = t;
- break;
- case tlo:
- *txr_lisp_p = chr('o');
- break;
- case txr:
- *txr_lisp_p = nil;
- break;
- default:
- break;
+ goto found;
}
+#ifdef ENOENT
+ if (errno != ENOENT)
+ goto except;
+#endif
}
}
- if (in == 0) {
+ if (in == 0 && zin == 0) {
+ val try_next;
#ifdef ENOENT
except:
#endif
- uw_throwf(errno_to_file_error(errno),
- lit("unable to open ~a"), spec_file_try, nao);
+ if (abs_path_p(*orig_in_resolved_out))
+ search_dirs = nil;
+ else if (search_dirs == t)
+ search_dirs = load_search_dirs;
+
+#ifdef ENOENT
+ if (errno != ENOENT || search_dirs == nil)
+#else
+ if (search_dirs == nil)
+#endif
+ uw_ethrowf(errno_to_file_error(errno),
+ lit("~a: unable to open ~a"), self, *orig_in_resolved_out, nao);
+ try_next = path_cat(pop(&search_dirs), *orig_in_resolved_out);
+ open_txr_file(try_next, txr_lisp_p, orig_in_resolved_out, stream,
+ search_dirs, self);
+ return;
}
found:
- *stream = make_stdio_stream(in, spec_file_try);
- *name = spec_file_try;
+ if (in != 0)
+ *stream = make_stdio_stream(in, try_path);
+#if HAVE_ZLIB
+ else
+ *stream = make_gzio_stream(zin, -1, try_path, 0);
+#endif
+ *orig_in_resolved_out = try_path;
}
}
val regex_parse(val string, val error_stream)
{
- uses_or2;
val save_stream = std_error;
val stream = make_string_byte_input_stream(string);
parser_t parser;
- error_stream = default_null_arg(error_stream);
- std_error = if3(error_stream == t, std_output, or2(error_stream, std_null));
+ error_stream = default_arg_strict(error_stream, std_null);
+ std_error = if3(error_stream == t, std_output, error_stream);
parser_common_init(&parser);
parser.stream = stream;
{
int gc = gc_state(0);
- parse(&parser, if3(std_error != std_null, lit("regex"), lit("")), prime_regex);
+ parse(&parser, if3(std_error != std_null, lit("regex"), null_string),
+ prime_regex);
gc_state(gc);
}
@@ -620,19 +704,18 @@ val regex_parse(val string, val error_stream)
return parser.syntax_tree;
}
-static val lisp_parse_impl(val self, val interactive, val rlcp_p, val source_in,
+static val lisp_parse_impl(val self, enum prime_parser prime,
+ val rlcp_p, val source_in,
val error_stream, val error_return_val, val name_in,
val lineno)
{
- uses_or2;
- val source = default_null_arg(source_in);
- val input_stream = if3(stringp(source),
- make_string_byte_input_stream(source),
- or2(source, std_input));
- val name = or2(default_null_arg(name_in),
- if3(stringp(source),
- lit("string"),
- stream_get_prop(input_stream, name_k)));
+ val source = default_arg_strict(source_in, std_input);
+ val str = stringp(source);
+ val input_stream = if3(str, make_string_byte_input_stream(source), source);
+ val name = default_arg_strict(name_in,
+ if3(str,
+ lit("string"),
+ stream_get_prop(input_stream, name_k)));
val parser = ensure_parser(input_stream, name);
val saved_dyn = dyn_env;
parser_t *pi = parser_get_impl(self, parser);
@@ -645,27 +728,40 @@ static val lisp_parse_impl(val self, val interactive, val rlcp_p, val source_in,
dyn_env = make_env(nil, nil, dyn_env);
- error_stream = default_null_arg(error_stream);
- error_stream = if3(error_stream == t, std_output, or2(error_stream, std_null));
- class_check (self, error_stream, stream_s);
+ error_stream = default_arg_strict(error_stream, std_null);
+ error_stream = if3(error_stream == t, std_output, error_stream);
+ class_check (self, error_stream, stream_cls);
if (lineno && !missingp(lineno))
- pi->lineno = c_num(lineno);
+ pi->lineno = c_num(lineno, self);
env_vbind(dyn_env, stderr_s, error_stream);
for (;;) {
int gc = gc_state(0);
- enum prime_parser prime = if3(interactive, prime_interactive, prime_lisp);
- parse(pi, if3(std_error != std_null, name, lit("")), prime);
+ parse(pi, if3(std_error != std_null, name, null_string), prime);
+ mut(parser);
gc_state(gc);
- if (pi->syntax_tree == nao && pi->errors == 0 && !parser_eof(parser))
+ if (pi->syntax_tree == nao && pi->errors == 0 && !pi->eof)
continue;
break;
}
+ if (str) {
+ int junk = 0;
+ if (prime == prime_json) {
+ YYSTYPE yyl;
+ junk = yylex(&yyl, pi->scanner);
+ } else {
+ junk = pi->recent_tok.yy_char;
+ }
+
+ if (junk)
+ yyerrorf(pi->scanner, lit("trailing material after expression"), nao);
+ }
+
parsed = t;
uw_unwind {
@@ -686,6 +782,8 @@ static val lisp_parse_impl(val self, val interactive, val rlcp_p, val source_in,
return error_return_val;
}
+ gc_hint(parser);
+
return pi->syntax_tree;
}
@@ -693,7 +791,7 @@ val lisp_parse(val source_in, val error_stream, val error_return_val,
val name_in, val lineno)
{
val self = lit("lisp-parse");
- return lisp_parse_impl(self, nil, t, source_in, error_stream,
+ return lisp_parse_impl(self, prime_lisp, t, source_in, error_stream,
error_return_val, name_in, lineno);
}
@@ -701,7 +799,7 @@ val nread(val source_in, val error_stream, val error_return_val,
val name_in, val lineno)
{
val self = lit("nread");
- return lisp_parse_impl(self, nil, nil, source_in, error_stream,
+ return lisp_parse_impl(self, prime_lisp, nil, source_in, error_stream,
error_return_val, name_in, lineno);
}
@@ -709,7 +807,15 @@ val iread(val source_in, val error_stream, val error_return_val,
val name_in, val lineno)
{
val self = lit("iread");
- return lisp_parse_impl(self, t, nil, source_in, error_stream,
+ return lisp_parse_impl(self, prime_interactive, nil, source_in, error_stream,
+ error_return_val, name_in, lineno);
+}
+
+val get_json(val source_in, val error_stream, val error_return_val,
+ val name_in, val lineno)
+{
+ val self = lit("get-json");
+ return lisp_parse_impl(self, prime_json, nil, source_in, error_stream,
error_return_val, name_in, lineno);
}
@@ -721,6 +827,7 @@ static val read_file_common(val self, val stream, val error_stream, val compiled
val big_endian = nil;
val parser = ensure_parser(stream, name);
val not_compiled = null(compiled);
+ val version_form = nil;
if (compiled) {
parser_t *pi = parser_get_impl(self, parser);
@@ -728,46 +835,47 @@ static val read_file_common(val self, val stream, val error_stream, val compiled
}
for (;;) {
- val form = lisp_parse_impl(self, nil, not_compiled, stream,
+ val form = lisp_parse_impl(self, prime_lisp, not_compiled, stream,
error_stream, error_val, name, colon_k);
if (form == error_val) {
if (parser_errors(parser) != zero)
return nil;
- if (parser_eof(parser))
- break;
- continue;
+ break;
}
if (compiled && first) {
val major = car(form);
- if (lt(major, one) || gt(major, num_fast(5)))
+ if (neq(major, num_fast(6)) && neq(major, num_fast(7)))
uw_throwf(error_s,
lit("cannot load ~s: version number mismatch"),
stream, nao);
big_endian = caddr(form);
first = nil;
+ version_form = form;
} else if (compiled) {
- for (; form; form = cdr(form)) {
- val item = car(form);
- val nlevels = pop(&item);
- val nregs = pop(&item);
- val bytecode = pop(&item);
- val datavec = pop(&item);
- val funvec = car(item);
- val desc = vm_make_desc(nlevels, nregs, bytecode, datavec, funvec);
- if ((big_endian && itypes_little_endian) ||
- (!big_endian && !itypes_little_endian))
- buf_swap32(bytecode);
- (void) vm_execute_toplevel(desc);
- gc_hint(desc);
+ if (consp(car(form))) {
+ for (; form; form = cdr(form)) {
+ val item = car(form);
+ val nlevels = pop(&item);
+ val nregs = pop(&item);
+ val bytecode = pop(&item);
+ val datavec = pop(&item);
+ val funvec = car(item);
+ val desc = vm_make_desc(nlevels, nregs, bytecode, datavec, funvec);
+ if ((big_endian && HAVE_LITTLE_ENDIAN) ||
+ (!big_endian && !HAVE_LITTLE_ENDIAN))
+ buf_swap32(bytecode);
+ (void) vm_execute_toplevel(desc);
+ gc_hint(desc);
+ }
+ } else if (nequal(form, version_form)) {
+ uw_throwf(error_s, lit("~s: mismatched version ~s in combined .tlo file"),
+ stream, form, nao);
}
} else {
- (void) eval_intrinsic(form, nil);
+ (void) eval_intrinsic(form, nil, nil);
}
-
- if (parser_eof(parser))
- break;
}
return t;
@@ -783,29 +891,161 @@ val read_compiled_file(val self, val stream, val error_stream)
return read_file_common(self, stream, error_stream, t);
}
-#if HAVE_TERMIOS
+static val read_objects_common(val stream, val error_stream_in,
+ val error_return_val, val name,
+ val lineno, val self)
+{
+ val error_stream = if3(error_stream_in == t,
+ std_output,
+ default_arg_strict(error_stream_in, std_null));
+ val parser = ensure_parser(stream, name);
+ parser_t *pi = parser_get_impl(self, parser);
+ list_collect_decl (out, ptail);
-static void load_rcfile(val name)
+ if (lineno && !missingp(lineno))
+ pi->lineno = c_num(lineno, self);
+
+ for (;;) {
+ val form = lisp_parse_impl(self, prime_lisp, t, stream,
+ error_stream, unique_s, name, colon_k);
+
+ if (form == unique_s) {
+ if (pi->errors) {
+ if (missingp(error_return_val))
+ uw_throwf(syntax_error_s, lit("read: ~a: errors encountered"),
+ name, nao);
+ return error_return_val;
+ }
+ break;
+ }
+
+ ptail = list_collect(ptail, form);
+ }
+
+ return out;
+}
+
+val read_objects_from_string(val string, val error_stream,
+ val error_return_val, val name_in)
+{
+ val self = lit("read-objects-from-string");
+ val stream = make_string_byte_input_stream(string);
+ val name = default_arg(name_in, lit("string"));
+
+ return read_objects_common(stream, error_stream, error_return_val,
+ name, one, self);
+}
+
+val read_objects(val source_in, val error_stream, val error_return_val,
+ val name_in, val lineno_in)
{
- val resolved_name;
+ val self = lit("read-objects");
+ val source = default_arg_strict(source_in, std_input);
+ val str = stringp(source);
+ val input_stream = if3(str, make_string_byte_input_stream(source), source);
+ val name = default_arg_strict(name_in,
+ if3(str,
+ lit("string"),
+ stream_get_prop(input_stream, name_k)));
+ return read_objects_common(input_stream, error_stream, error_return_val,
+ name, lineno_in, self);
+}
+
+val txr_parse(val source_in, val error_stream,
+ val error_return_val, val name_in)
+{
+ val self = lit("txr-parse");
+ val source = default_arg_strict(source_in, std_input);
+ val input_stream = if3(stringp(source),
+ make_string_byte_input_stream(source),
+ source);
+ val name = default_arg_strict(name_in,
+ if3(stringp(source),
+ lit("string"),
+ stream_get_prop(input_stream, name_k)));
+ int gc = gc_state(0);
+ val saved_dyn = dyn_env;
+ val parser_obj = ensure_parser(input_stream, name);
+ parser_t *pi = parser_get_impl(self, parser_obj);
+ val loading = cdr(lookup_var(nil, load_recursive_s));
+
+ uw_simple_catch_begin;
+
+ dyn_env = make_env(nil, nil, dyn_env);
+ error_stream = default_arg_strict(error_stream, std_null);
+ error_stream = if3(error_stream == t, std_output, error_stream);
+ class_check (self, error_stream, stream_cls);
+
+ parse_once(self, input_stream, name);
+
+ uw_unwind {
+ dyn_env = saved_dyn;
+ mut(parser_obj);
+ gc_state(gc);
+ if (!loading)
+ uw_release_deferred_warnings();
+ }
+
+ uw_catch_end;
+
+ if (pi->errors || pi->syntax_tree == nao) {
+ if (missingp(error_return_val))
+ uw_throwf(syntax_error_s, lit("~a: ~a: ~a"), self, name,
+ if3(pi->syntax_tree == nao,
+ lit("end of input reached without seeing object"),
+ lit("errors encountered")), nao);
+
+ return error_return_val;
+ }
+
+ return pi->syntax_tree;
+}
+
+static void report_file_perm_problem(val name)
+{
+#ifdef __CYGWIN__
+ (void) name;
+#else
+ format(std_output,
+ lit("** security problem: ~a is readable by others\n"),
+ name, nao);
+#endif
+}
+
+static void report_path_perm_problem(val name)
+{
+#ifdef __CYGWIN__
+ (void) name;
+#else
+ format(std_output,
+ lit("** security problem: a component of ~a is writable to others\n"),
+ name, nao);
+#endif
+}
+
+static void load_rcfile(val name, val psafe_s, val ppriv_s)
+{
+ val self = lit("listener");
+ val resolved_name = name;
val lisp_p = t;
val stream = nil;
- val catch_syms = cons(error_s, nil);
- val path_private_to_me_p = intern(lit("path-private-to-me-p"), user_package);
- uw_catch_begin (catch_syms, sy, va);
+ if (!funcall1(psafe_s, name)) {
+ report_path_perm_problem(name);
+ return;
+ }
+
+ uw_catch_begin (catch_error, sy, va);
- open_txr_file(name, &lisp_p, &resolved_name, &stream);
+ open_txr_file(name, &lisp_p, &resolved_name, &stream, nil, self);
if (stream) {
- if (!funcall1(path_private_to_me_p, stat_wrap(stream))) {
- format(std_output,
- lit("** possible security problem: ~a is writable to others\n"),
- name, nao);
+ if (!funcall1(ppriv_s, stream)) {
+ report_file_perm_problem(name);
} else {
val saved_dyn_env = set_dyn_env(make_env(nil, nil, dyn_env));
env_vbind(dyn_env, load_path_s, resolved_name);
- read_eval_stream(lit("listener"), stream, std_output);
+ read_eval_stream(self, stream, std_output);
dyn_env = saved_dyn_env;
}
}
@@ -828,6 +1068,8 @@ static void load_rcfile(val name)
uw_catch_end;
}
+#if CONFIG_FULL_REPL
+
static val get_visible_syms(val package, int include_fallback)
{
val fblist;
@@ -865,11 +1107,9 @@ static void find_matching_syms(lino_completions_t *cpl,
val qualify = tnil(force_qualify || !is_cur);
val pkg_name = if2(qualify,
if3(package == keyword_package && !force_qualify,
- lit(""),
+ null_string,
package_name(package)));
- val syms = ((kind == 'S' || kind == 'M')
- ? hash_keys((get_slot_syms(package, is_cur, tnil(kind == 'M'))))
- : get_visible_syms(package, is_cur != nil && !qualify));
+ val syms = get_visible_syms(package, is_cur != nil && !qualify);
for ( ; syms; syms = cdr(syms)) {
val sym = car(syms);
@@ -883,29 +1123,41 @@ static void find_matching_syms(lino_completions_t *cpl,
switch (kind) {
case '(':
- if (!fboundp(sym) && !mboundp(sym) && !special_operator_p(sym))
- continue;
- break;
- case '[':
- if (!boundp(sym) && !lookup_fun(nil, sym))
- continue;
- break;
+ if (fboundp(sym) || mboundp(sym) || special_operator_p(sym))
+ break;
+ continue;
case 'M':
+ if (static_slot_types(sym))
+ break;
+ continue;
case 'S':
+ if (slot_types(sym))
+ break;
+ continue;
break;
+ case 'Q':
+ if (mboundp(sym) || special_operator_p(sym))
+ break;
+ /* fallthrough */
default:
- break;
+ if (find_struct_type(sym) || ffi_type_p(sym))
+ break;
+ /* fallthrough */
+ case '[':
+ if (fboundp(sym) || boundp(sym))
+ break;
+ continue;
}
if (equal(name, prefix))
continue;
if (qualify)
- comple = format(nil, lit("~a~a:~a"), line_prefix, pkg_name, name, nao);
+ comple = scat(nil, line_prefix, pkg_name, lit(":"), name, nao);
else
- comple = format(nil, lit("~a~a"), line_prefix, name, nao);
+ comple = scat2(line_prefix, name);
- lino_add_completion(cpl, c_str(comple));
+ lino_add_completion(cpl, c_str(comple, nil));
gc_hint(comple);
}
}
@@ -924,12 +1176,13 @@ static void provide_completions(const wchar_t *data,
(void) ctx;
- uw_catch_begin (catch_all, exsym, exvals);
+ uw_catch_begin (catch_error, exsym, exvals);
if (!ptr)
goto out;
- while ((iswalnum(convert(wint_t, *ptr)) || wcschr(gly, *ptr)) &&
+ while ((iswalnum(convert(wint_t, *ptr)) || wcschr(gly, *ptr) ||
+ *ptr >= 0x80) &&
(sym = ptr) && ptr > data)
ptr--;
@@ -944,7 +1197,8 @@ static void provide_completions(const wchar_t *data,
} else {
ptr--;
- while ((iswalnum(convert(wint_t, *ptr)) || wcschr(gly, *ptr)) &&
+ while ((iswalnum(convert(wint_t, *ptr)) || wcschr(gly, *ptr) ||
+ *ptr >= 0x80) &&
(pkg = ptr) && ptr > data)
ptr--;
@@ -985,17 +1239,18 @@ static void provide_completions(const wchar_t *data,
val line_pfx = string(line_pfxs);
char prev = (end > data) ? end[-1] : 0;
char pprev = (end > data + 1) ? end[-2] : 0;
- int quote = (pprev == '^' || pprev == '\'' || pprev == '#');
+ int quote = (prev == '^' || prev == '\'');
+ int pquote = (pprev == '^' || pprev == '\'' || pprev == '#');
int ppar = (pprev == '(');
int dwim = (prev == '[');
int par = (prev == '(');
int slot = (prev == '.');
int meth = (pprev == '.') && (dwim || par);
- char kind = (slot
- ? 'S'
- : (meth
- ? 'M'
- : (!pprev || (!quote && !ppar) || dwim) ? prev : 0));
+ char kind = if3(slot, 'S',
+ if3(meth, 'M',
+ if3(quote, 'Q',
+ if3(!pprev || (!pquote && !ppar) || dwim,
+ prev, 0))));
find_matching_syms(cpl, or2(package, cur_package),
sym_pfx, line_pfx, kind, if2(package, null(keyword)));
@@ -1036,7 +1291,7 @@ static wchar_t *provide_atom(lino_t *l, const wchar_t *str, int n, void *ctx)
}
if (obj != nao)
- out = chk_strdup(c_str(tostring(obj)));
+ out = chk_strdup(c_str(tostring(obj), nil));
uw_catch (exsym, exvals) {
(void) exsym;
@@ -1050,9 +1305,13 @@ static wchar_t *provide_atom(lino_t *l, const wchar_t *str, int n, void *ctx)
return out;
}
+#endif
+
static val repl_intr(val signo, val async_p)
{
- uw_throw(intr_s, lit("intr"));
+ (void) signo;
+ (void) async_p;
+ return uw_rthrow(intr_s, lit("intr"));
}
static val read_eval_ret_last(val env, val counter,
@@ -1062,24 +1321,19 @@ static val read_eval_ret_last(val env, val counter,
val error_val = gensym(nil);
val name = format(nil, lit("paste-~a"), counter, nao);
val value = nil;
- val loading = cdr(lookup_var(dyn_env, load_recursive_s));
+ val loading = cdr(lookup_var(nil, load_recursive_s));
val saved_dyn_env = set_dyn_env(make_env(nil, nil, dyn_env));
env_vbind(dyn_env, load_recursive_s, t);
+ (void) env;
+
for (;; lineno = succ(lineno)) {
val form = lisp_parse(in_stream, out_stream, error_val, name, lineno);
- val parser = get_parser(in_stream);
-
- if (form == error_val) {
- if (parser_errors(parser) != zero || parser_eof(parser))
- break;
- continue;
- }
-
- value = eval_intrinsic(form, nil);
- if (parser_eof(parser))
+ if (form == error_val)
break;
+
+ value = eval_intrinsic(form, nil, nil);
}
dyn_env = saved_dyn_env;
@@ -1104,16 +1358,18 @@ static val get_home_path(void)
return getenv_wrap(lit("HOME"));
}
-static val repl_warning(val out_stream, val exc, struct args *rest)
+static val repl_warning(val out_stream, val exc, varg rest)
{
val args = args_get_list(rest);
+ (void) exc;
+
if (cdr(args))
uw_defer_warning(args);
else
- format(out_stream, lit("** warning: ~!~a\n"), car(args), nao);
+ format(out_stream, lit("** ~!~a\n"), car(args), nao);
- uw_throw(continue_s, nil);
+ return uw_rthrow(continue_s, nil);
}
static int is_balanced_line(const wchar_t *line, void *ctx)
@@ -1125,9 +1381,12 @@ static int is_balanced_line(const wchar_t *line, void *ctx)
};
int count[32], sp = 0;
enum state state[32];
+ wchar_t ch;
+
+ (void) ctx;
+
count[sp] = 0;
state[sp] = ST_START;
- wchar_t ch;
while ((ch = *line++) != 0) {
again:
@@ -1167,6 +1426,12 @@ static int is_balanced_line(const wchar_t *line, void *ctx)
else
state[++sp] = ST_BKT;
break;
+ case '{':
+ if (state[sp] == ST_BRC)
+ count[sp]++;
+ else
+ state[++sp] = ST_BRC;
+ break;
case ')': case ']': case '}':
{
enum state match = ST_START;
@@ -1330,12 +1595,13 @@ static void hist_save(lino_t *ls, val in_stream, val out_stream,
val histfile, const wchar_t *histfile_w,
val hist_len_var)
{
+ val self = lit("listener");
if (histfile_w && lino_have_new_lines(ls)) {
- val histfile_tmp = format(nil, lit("~a.tmp"), histfile, nao);
- const wchar_t *histfile_tmp_w = c_str(histfile_tmp);
+ val histfile_tmp = scat2(histfile, lit(".tmp"));
+ const wchar_t *histfile_tmp_w = c_str(histfile_tmp, self);
lino_t *ltmp = lino_make(coerce(mem_t *, in_stream),
coerce(mem_t *, out_stream));
- lino_hist_set_max_len(ltmp, c_num(cdr(hist_len_var)));
+ lino_hist_set_max_len(ltmp, c_num(cdr(hist_len_var), self));
lino_hist_load(ltmp, histfile_w);
lino_hist_save(ltmp, histfile_tmp_w, 0);
if (lino_hist_save(ls, histfile_tmp_w, 1) == 0)
@@ -1349,35 +1615,49 @@ static void hist_save(lino_t *ls, val in_stream, val out_stream,
val repl(val bindings, val in_stream, val out_stream, val env)
{
+ val self = lit("listener");
lino_t *ls = if3(repl_level++,
lino_ctx,
lino_ctx = lino_make(coerce(mem_t *, in_stream),
coerce(mem_t *, out_stream)));
- wchar_t *line_w = 0;
+ wchar_t *volatile line_w = 0;
val quit_k = intern(lit("quit"), keyword_package);
val read_k = intern(lit("read"), keyword_package);
val prompt_k = intern(lit("prompt"), keyword_package);
+ val prompt_on_k = intern(lit("prompt-on"), keyword_package);
val p_k = intern(lit("p"), keyword_package);
val save_k = intern(lit("save"), keyword_package);
val counter_sym = intern(lit("*n"), user_package);
val var_counter_sym = intern(lit("*v"), user_package);
val result_hash_sym = intern(lit("*r"), user_package);
- val result_hash = make_hash(nil, nil, nil);
+ val pexist_s = intern(lit("path-exists-p"), user_package);
+#ifdef __CYGWIN__
+ val ppriv_s = intern(lit("tf"), user_package);
+ val psafe_s = ppriv_s;
+#else
+ val ppriv_s = intern(lit("path-strictly-private-to-me-p"), user_package);
+ val psafe_s = intern(lit("path-components-safe"), user_package);
+#endif
+ val result_hash = make_hash(hash_weak_none, nil);
val done = nil;
val counter = one;
val home = if3(repl_level == 1, get_home_path(), nil);
- val histfile = if2(home, format(nil, lit("~a/.txr_history"), home, nao));
- const wchar_t *histfile_w = if3(home, c_str(histfile), NULL);
- val rcfile = if2(home, format(nil, lit("~a/.txr_profile"), home, nao));
+ val histfile = if2(home, scat2(home, lit("/.txr_history")));
+ const wchar_t *histfile_w = if3(home, c_str(histfile, self), NULL);
+ val rcfile = if2(home && !opt_noprofile, scat2(home, lit("/.txr_profile")));
val old_sig_handler = set_sig_handler(num(SIGINT), func_n2(repl_intr));
val hist_len_var = lookup_global_var(listener_hist_len_s);
+#if CONFIG_FULL_REPL
val multi_line_var = lookup_global_var(listener_multi_line_p_s);
val sel_inclusive_var = lookup_global_var(listener_sel_inclusive_p_s);
+#endif
val pprint_var = lookup_global_var(listener_pprint_s);
val greedy_eval = lookup_global_var(listener_greedy_eval_s);
+ val auto_parens = lookup_global_var(listener_auto_compound_s);
val rw_f = func_f1v(out_stream, repl_warning);
val saved_dyn_env = set_dyn_env(make_env(nil, nil, dyn_env));
val brackets = mkstring(num_fast(repl_level), chr('>'));
+ cnum i;
env_vbind(dyn_env, stderr_s, out_stream);
@@ -1386,22 +1666,45 @@ val repl(val bindings, val in_stream, val out_stream, val env)
reg_varl(car(binding), cdr(binding));
}
+ for (i = 1; i <= 20; i++) {
+ val name = format(nil, lit("*-~d"), num_fast(i), nao);
+ val sym = intern(name, user_package);
+ reg_symacro(sym, list(dwim_s, result_hash_sym,
+ list(macro_time_s,
+ list(mod_s,
+ list(minus_s, var_counter_sym,
+ num_fast(i), nao),
+ num_fast(100), nao), nao), nao));
+ }
+
reg_varl(result_hash_sym, result_hash);
+#if CONFIG_FULL_REPL
lino_set_completion_cb(ls, provide_completions, 0);
lino_set_atom_cb(ls, provide_atom, 0);
+#endif
+
lino_set_enter_cb(ls, is_balanced_line, 0);
lino_set_tempfile_suffix(ls, ".tl");
- if (rcfile)
- load_rcfile(rcfile);
+ if (rcfile && funcall1(pexist_s, rcfile))
+ load_rcfile(rcfile, psafe_s, ppriv_s);
- lino_hist_set_max_len(ls, c_num(cdr(hist_len_var)));
+ lino_hist_set_max_len(ls, c_num(cdr(hist_len_var), self));
+
+ if (histfile_w && funcall1(pexist_s, histfile)) {
+ if (!funcall1(psafe_s, home)) {
+ report_path_perm_problem(home);
+ } else if (!funcall1(ppriv_s, histfile)) {
+ report_file_perm_problem(histfile);
+ }
- if (histfile_w)
lino_hist_load(ls, histfile_w);
+ }
+#if CONFIG_FULL_REPL
lino_set_noninteractive(ls, opt_noninteractive);
+#endif
while (!done) {
val prompt = format(nil, lit("~d~a "), counter, brackets,nao);
@@ -1411,59 +1714,70 @@ val repl(val bindings, val in_stream, val out_stream, val env)
val var_sym = intern(var_name, user_package);
uw_frame_t uw_handler;
- lino_hist_set_max_len(ls, c_num(cdr(hist_len_var)));
+ lino_hist_set_max_len(ls, c_num(cdr(hist_len_var), self));
+#if CONFIG_FULL_REPL
lino_set_multiline(ls, cdr(multi_line_var) != nil);
lino_set_selinclusive(ls, cdr(sel_inclusive_var) != nil);
+#endif
reg_varl(counter_sym, counter);
reg_varl(var_counter_sym, var_counter);
- line_w = linenoise(ls, c_str(prompt));
+ uw_catch_begin (catch_all, exsym, exvals);
+
+ uw_push_handler(&uw_handler, cons(warning_s, nil), rw_f);
+
+ line_w = linenoise(ls, c_str(prompt, self));
+
+ uw_pop_frame(&uw_handler);
+
+#if CONFIG_FULL_REPL
rplacd(multi_line_var, tnil(lino_get_multiline(ls)));
+#endif
if (line_w == 0) {
switch (lino_get_error(ls)) {
case lino_intr:
put_line(lit("** intr"), out_stream);
- continue;
+ goto contin;
case lino_eof:
break;
default:
put_line(lit("** error reading interactive input"), out_stream);
break;
}
- break;
+ done = t;
+ goto contin;
}
{
size_t wsp = wcsspn(line_w, L" \t\n\r");
- if (line_w[wsp] == 0) {
- free(line_w);
- continue;
- }
+ if (line_w[wsp] == 0)
+ goto contin;
if (line_w[wsp] == ';') {
lino_hist_add(ls, line_w);
- free(line_w);
- continue;
+ goto contin;
}
}
counter = succ(counter);
- uw_catch_begin (catch_all, exsym, exvals);
-
uw_push_handler(&uw_handler, cons(warning_s, nil), rw_f);
{
val name = format(nil, lit("expr-~d"), prev_counter, nao);
val line = string(line_w);
- val form = lisp_parse(line, out_stream, colon_k, name, colon_k);
+ val forms = read_objects_from_string(line, std_error, colon_k, name);
+ val form = if2(and2(consp(forms), null(cdr(forms))), car(forms));
if (form == quit_k) {
done = t;
} else if (form == prompt_k) {
pprinl(prompt, out_stream);
counter = prev_counter;
+ } else if (form == prompt_on_k) {
+ lino_enable_noninteractive_prompt(ls, 1);
+ counter = prev_counter;
} else if (form == p_k) {
pprinl(prev_counter, out_stream);
counter = prev_counter;
@@ -1471,17 +1785,27 @@ val repl(val bindings, val in_stream, val out_stream, val env)
hist_save(ls, in_stream, out_stream, histfile, histfile_w, hist_len_var);
counter = prev_counter;
} else {
+ val expr = if2(form != read_k,
+ if3(consp(forms),
+ if3(cdr(auto_parens) && cdr(forms),
+ forms,
+ cons(progn_s, forms)),
+ forms));
val value = if3(form != read_k,
- eval_intrinsic(form, env),
+ eval_intrinsic(expr, nil, env),
read_eval_ret_last(nil, prev_counter,
in_stream, out_stream));
val pprin = cdr(pprint_var);
val (*pfun)(val, val) = if3(pprin, pprinl, prinl);
+#if CONFIG_FULL_REPL
val (*tsfun)(val) = if3(pprin, tostringp, tostring);
+#endif
reg_varl(var_sym, value);
sethash(result_hash, var_counter, value);
pfun(value, out_stream);
- lino_set_result(ls, chk_strdup(c_str(tsfun(value))));
+#if CONFIG_FULL_REPL
+ lino_set_result(ls, chk_strdup(c_str(tsfun(value), self)));
+#endif
lino_hist_add(ls, line_w);
if (cdr(greedy_eval)) {
val error_p = nil;
@@ -1503,10 +1827,13 @@ val repl(val bindings, val in_stream, val out_stream, val env)
val exinfo = cons(exsym, exvals);
reg_varl(var_sym, exinfo);
sethash(result_hash, var_counter, exinfo);
- lino_hist_add(ls, line_w);
+ if (line_w)
+ lino_hist_add(ls, line_w);
if (uw_exception_subtype_p(exsym, syntax_error_s)) {
- put_line(lit("** syntax error"), out_stream);
+ format(out_stream, lit("** syntax error: ~a\n"), car(exvals), nao);
+ } else if (uw_exception_subtype_p(exsym, intr_s)) {
+ format(out_stream, lit("** intr\n"), nao);
} else if (uw_exception_subtype_p(exsym, error_s)) {
error_trace(exsym, exvals, out_stream, lit("**"));
} else {
@@ -1515,6 +1842,7 @@ val repl(val bindings, val in_stream, val out_stream, val env)
}
}
+ contin:
uw_unwind {
free(line_w);
line_w = 0;
@@ -1540,25 +1868,24 @@ val repl(val bindings, val in_stream, val out_stream, val env)
return nil;
}
-#endif
-
-val get_parser(val stream)
-{
- return gethash(stream_parser_hash, stream);
-}
-
val parser_errors(val parser)
{
val self = lit("parser-errors");
- parser_t *p = coerce(parser_t *, cobj_handle(self, parser, parser_s));
+ parser_t *p = coerce(parser_t *, cobj_handle(self, parser, parser_cls));
return num(p->errors);
}
-val parser_eof(val parser)
+val parse_errors(val stream)
{
- val self = lit("parser-eof");
- parser_t *p = coerce(parser_t *, cobj_handle(self, parser, parser_s));
- return tnil(p->eof);
+ val self = lit("parse-errors");
+ val errors = nil;
+ val parser = gethash(stream_parser_hash, stream);
+ if (parser) {
+ parser_t *p = coerce(parser_t *, cobj_handle(self, parser, parser_cls));
+ if (p->errors)
+ errors = num(p->errors);
+ }
+ return errors;
}
static val circref(val n)
@@ -1569,8 +1896,9 @@ static val circref(val n)
static int lino_fileno(mem_t *stream_in)
{
+ val self = lit("listener");
val stream = coerce(val, stream_in);
- return c_num(stream_fd(stream));
+ return c_num(stream_fd(stream), self);
}
static int lino_puts(mem_t *stream_in, const wchar_t *str_in)
@@ -1597,6 +1925,7 @@ static int lino_puts_file(mem_t *stream_in, const wchar_t *str_in)
static wint_t lino_getch(mem_t *stream_in)
{
+ val self = lit("listener");
wint_t ret = WEOF;
val stream, ch;
@@ -1606,7 +1935,7 @@ static wint_t lino_getch(mem_t *stream_in)
stream = coerce(val, stream_in);
ch = get_char(stream);
- ret = if3(ch, c_num(ch), WEOF);
+ ret = if3(ch, convert(wint_t, c_num(ch, self)), WEOF);
uw_catch (sy, va) {
(void) sy;
@@ -1622,6 +1951,7 @@ static wint_t lino_getch(mem_t *stream_in)
static wchar_t *lino_getl(mem_t *stream_in, wchar_t *buf, size_t nchar)
{
+ val self = lit("listener");
wchar_t *ptr = buf;
val stream = coerce(val, stream_in);
@@ -1632,7 +1962,7 @@ static wchar_t *lino_getl(mem_t *stream_in, wchar_t *buf, size_t nchar)
val ch = get_char(stream);
if (!ch)
break;
- if ((*ptr++ = c_num(ch)) == '\n')
+ if ((*ptr++ = c_num(ch, self)) == '\n')
break;
}
@@ -1642,6 +1972,7 @@ static wchar_t *lino_getl(mem_t *stream_in, wchar_t *buf, size_t nchar)
static wchar_t *lino_gets(mem_t *stream_in, wchar_t *buf, size_t nchar)
{
+ val self = lit("listener");
wchar_t *ptr = buf;
val stream = coerce(val, stream_in);
@@ -1652,7 +1983,7 @@ static wchar_t *lino_gets(mem_t *stream_in, wchar_t *buf, size_t nchar)
val ch = get_char(stream);
if (!ch)
break;
- *ptr++ = c_num(ch);
+ *ptr++ = c_num(ch, self);
}
*ptr++ = 0;
@@ -1672,6 +2003,7 @@ static const wchli_t *lino_mode_str[] = {
static mem_t *lino_open(const wchar_t *name_in, lino_file_mode_t mode_in)
{
+ val self = lit("listener");
val name = string(name_in);
val mode = static_str(lino_mode_str[mode_in]);
val ret = 0;
@@ -1679,7 +2011,7 @@ static mem_t *lino_open(const wchar_t *name_in, lino_file_mode_t mode_in)
ret = open_file(name, mode);
#if HAVE_CHMOD
if (mode_in == lino_overwrite || mode_in == lino_append)
- (void) fchmod(c_num(stream_fd(ret)), S_IRUSR | S_IWUSR);
+ (void) fchmod(c_num(stream_fd(ret), self), S_IRUSR | S_IWUSR);
#endif
ignerr_end;
return coerce(mem_t *, ret);
@@ -1699,7 +2031,7 @@ static mem_t *lino_open8(const char *name_in, lino_file_mode_t mode_in)
static mem_t *lino_fdopen(int fd, lino_file_mode_t mode_in)
{
val mode = static_str(lino_mode_str[mode_in]);
- return coerce(mem_t *, open_fileno(num(fd), mode));
+ return coerce(mem_t *, open_fileno(num(fd), mode, nil));
}
static void lino_close(mem_t *stream)
@@ -1715,6 +2047,12 @@ static_def(lino_os_t linenoise_txr_binding =
lino_open, lino_open8, lino_fdopen, lino_close,
wide_display_char_p));
+static val me_json(val form, val menv)
+{
+ (void) menv;
+ return cdr(form);
+}
+
void parse_init(void)
{
parser_s = intern(lit("parser"), user_package);
@@ -1725,22 +2063,36 @@ void parse_init(void)
listener_sel_inclusive_p_s = intern(lit("*listener-sel-inclusive-p*"), user_package);
listener_pprint_s = intern(lit("*listener-pprint-p*"), user_package);
listener_greedy_eval_s = intern(lit("*listener-greedy-eval-p*"), user_package);
+ listener_auto_compound_s = intern(lit("*listener-auto-compound-p*"), user_package);
rec_source_loc_s = intern(lit("*rec-source-loc*"), user_package);
+ read_unknown_structs_s = intern(lit("*read-unknown-structs*"), user_package);
+ read_bad_json_s = intern(lit("*read-bad-json*"), user_package);
+ json_s = intern(lit("json"), user_package);
unique_s = gensym(nil);
- protect(&stream_parser_hash, &unique_s, &catch_all, convert(val *, 0));
- stream_parser_hash = make_hash(t, nil, nil);
+
+ parser_cls = cobj_register(parser_s);
+
+ protect(&stream_parser_hash, &unique_s,
+ &catch_all, &catch_error, convert(val *, 0));
+ stream_parser_hash = make_hash(hash_weak_and, nil);
catch_all = cons(t, nil);
+ catch_error = cons(error_s, nil);
+
parser_l_init();
+
lino_init(&linenoise_txr_binding);
+
reg_var(listener_hist_len_s, num_fast(500));
reg_var(listener_multi_line_p_s, t);
- reg_var(listener_sel_inclusive_p_s, nil);
+ reg_var(listener_sel_inclusive_p_s, t);
reg_var(listener_pprint_s, nil);
reg_var(listener_greedy_eval_s, nil);
+ reg_var(listener_auto_compound_s, nil);
reg_var(rec_source_loc_s, nil);
+ reg_var(read_unknown_structs_s, nil);
+ reg_var(read_bad_json_s, nil);
reg_fun(circref_s, func_n1(circref));
- reg_fun(intern(lit("get-parser"), system_package), func_n1(get_parser));
- reg_fun(intern(lit("parser-errors"), system_package), func_n1(parser_errors));
- reg_fun(intern(lit("parser-eof"), system_package), func_n1(parser_eof));
+ reg_fun(intern(lit("parse-errors"), user_package), func_n1(parse_errors));
reg_fun(intern(lit("repl"), system_package), func_n4(repl));
+ reg_mac(json_s, func_n2(me_json));
}
diff --git a/parser.h b/parser.h
index 337dca9b..abf9c4ef 100644
--- a/parser.h
+++ b/parser.h
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
typedef struct yyguts_t scanner_t;
@@ -39,6 +40,7 @@ typedef struct parser parser_t;
struct yy_token {
int yy_char;
YYSTYPE yy_lval;
+ int yy_lex_state;
};
struct circ_stack {
@@ -64,16 +66,22 @@ struct parser {
struct yy_token tok_pushback[4];
int tok_idx;
int rec_source_loc;
+ int read_unknown_structs;
+ int read_bad_json;
};
#endif
-enum prime_parser { prime_lisp, prime_interactive, prime_regex };
+enum prime_parser { prime_lisp, prime_interactive, prime_regex, prime_json };
extern const int have_yydebug;
extern const wchar_t *spec_file;
extern val form_to_ln_hash;
extern val parser_s, unique_s, circref_s;
-extern val rec_source_loc_s;
+extern val rec_source_loc_s, read_unknown_structs_s, read_bad_json_s;
+extern val json_s;
+
+extern struct cobj_class *parser_cls;
+
void yydebug_onoff(int);
void yyerror(scanner_t *scanner, parser_t *, const char *s);
void yyerr(scanner_t *scanner, const char *s);
@@ -82,6 +90,8 @@ void yybadtoken(parser_t *, int tok, val context);
void end_of_regex(scanner_t *scanner);
void end_of_char(scanner_t *scanner);
void end_of_buflit(scanner_t *scanner);
+void end_of_json(scanner_t *scanner);
+void end_of_json_unquote(scanner_t *scanner);
#ifdef SPACE
int yylex(YYSTYPE *yylval_param, yyscan_t yyscanner);
#endif
@@ -91,7 +101,9 @@ parser_t *yyget_extra(yyscan_t scanner);
void yyset_extra(parser_t *, yyscan_t);
void yyset_hold_char(yyscan_t, int);
void parser_l_init(void);
-void open_txr_file(val spec_file, val *txr_lisp_p, val *name, val *stream);
+void open_txr_file(val first_try_path, val *txr_lisp_p,
+ val *orig_in_resolved_out, val *stream,
+ val search_dirs, val self);
void prime_parser(parser_t *, val name, enum prime_parser);
void prime_parser_post(parser_t *, enum prime_parser);
#ifdef SPACE
@@ -121,18 +133,23 @@ val nread(val source_in, val error_stream, val error_return_val,
val name_in, val lineno);
val iread(val source_in, val error_stream, val error_return_val,
val name_in, val lineno);
+val get_json(val source_in, val error_stream, val error_return_val,
+ val name_in, val lineno);
val read_eval_stream(val self, val stream, val error_stream);
val read_compiled_file(val self, val stream, val error_stream);
-#if HAVE_TERMIOS
+val read_objects_from_string(val string, val error_stream,
+ val error_return_val, val name_in);
+val read_objects(val source_in, val error_stream, val error_return_val,
+ val name_in, val lineno_in);
+val txr_parse(val source, val error_stream,
+ val error_return_val, val name_in);
val repl(val bindings, val in_stream, val out_stream, val env);
-#endif
void parser_common_init(parser_t *);
void parser_cleanup(parser_t *);
val parser(val stream, val name, val lineno);
parser_t *parser_get_impl(val self, val parser);
-val get_parser(val stream);
val ensure_parser(val stream, val name);
val parser_set_lineno(val self, val stream, val lineno);
val parser_errors(val parser);
-val parser_eof(val parser);
+val parse_errors(val stream);
void parse_init(void);
diff --git a/parser.l b/parser.l
index 87215221..f3f6d075 100644
--- a/parser.l
+++ b/parser.l
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
%{
@@ -32,15 +33,9 @@
#include <stdarg.h>
#include <stdlib.h>
#include <limits.h>
-#include <errno.h>
-#include <dirent.h>
#include <wchar.h>
-#include <setjmp.h>
#include <signal.h>
#include "config.h"
-#if HAVE_UNISTD_H
-#include <unistd.h>
-#endif
#include "lib.h"
#include "gc.h"
#include "stream.h"
@@ -52,18 +47,19 @@
#include "parser.h"
#include "txr.h"
-#define YY_INPUT(buf, result, max_size) \
- do { \
- val c = get_byte(yyextra->stream); \
- int n = 0; \
- if (c) \
- buf[n++] = convert(char, c_num(c)); \
- result = n; \
+#define YY_INPUT(buf, result, max_size) \
+ do { \
+ val self = lit("parser"); \
+ val n = get_bytes(self, yyextra->stream, \
+ coerce(mem_t *, buf), max_size); \
+ result = c_num(n, self); \
} while (0)
#define YY_DECL \
static int yylex_impl(YYSTYPE *yylval_param, yyscan_t yyscanner)
+#define YY_FATAL_ERROR(msg) lex_irrecoverable_error(msg)
+
int opt_loglevel = 1; /* 0 - quiet; 1 - normal; 2 - verbose */
val form_to_ln_hash;
@@ -137,10 +133,16 @@ static void yyerrprepf(scanner_t *scanner, val fmt, ...)
}
}
-static void out_of_range_float(scanner_t *scanner, val tok)
+static void lex_irrecoverable_error(const char *msg8)
+{
+ val msg = string_utf8(msg8);
+ uw_throwf(error_s, lit("error in parser: ~a"), msg, nao);
+}
+
+static void out_of_range_float(scanner_t *scanner, const char *tok)
{
yyerrorf(scanner, lit("out-of-range floating-point literal: ~a"),
- tok, nao);
+ string_utf8(tok), nao);
}
static wchar_t char_esc(int letter)
@@ -170,7 +172,7 @@ static wchar_t num_esc(scanner_t *scn, char *num)
{
long val = 0;
- if (num[0] == 'x') {
+ if (num[0] == 'x' || num[0] == 'u') {
if (strlen(num) > 7)
yyerror(scn, yyget_extra(scn), "too many digits in hex character escape");
else
@@ -233,22 +235,50 @@ static wchar_t *unicode_ident(scanner_t *scn, const char *lex)
return wlex;
}
+static char *remove_char(char *str, int c)
+{
+ char *dst = str, *src = str;
+
+ while (*src) {
+ int ch = *src++;
+ if (ch != c)
+ *dst++ = ch;
+ }
+
+ *dst = 0;
+
+ return str;
+}
+
%}
%option stack noinput reentrant bison-bridge extra-type="parser_t *"
+%option never-interactive
TOK [a-zA-Z0-9_]+
SGN [+\-]
EXP [eE][+\-]?[0-9]+
DIG [0-9]
+DIG19 [1-9]
+DIGSEP {DIG}({DIG}|,)*{DIG}|{DIG}
XDIG [0-9A-Fa-f]
+XDIGSEP {XDIG}({XDIG}|,)*{XDIG}|{XDIG}
NUM {SGN}?{DIG}+
+NUMSEP {SGN}?{DIGSEP}
FLO {SGN}?({DIG}*[.]{DIG}+{EXP}?|{DIG}+[.]?{EXP})
-FLODOT {SGN}?{DIG}+[.]
+FLOSEP {SGN}?({DIGSEP}*[.]{DIGSEP}+{EXP}?|{DIGSEP}+[.]?{EXP})
+FLODOT {SGN}?{DIGSEP}+[.]
DOTFLO [.]{DIG}+
XNUM #x{SGN}?{XDIG}+
-ONUM #o{SGN}?[0-7]+
-BNUM #b{SGN}?[0-1]+
+XNUMSEP #x{SGN}?{XDIGSEP}
+ODIG [0-7]
+ODIGSEP {ODIG}({ODIG}|,)*{ODIG}|{ODIG}
+BDIG [01]
+BDIGSEP {BDIG}({BDIG}|,)*{BDIG}|{BDIG}
+ONUM #o{SGN}?{ODIG}+
+ONUMSEP #o{SGN}?{ODIGSEP}
+BNUM #b{SGN}?{BDIG}+
+BNUMSEP #b{SGN}?{BDIGSEP}
BSCHR ([a-zA-Z0-9!$%&*+\-<=>?\\_~]|{UONLY})
NSCHR ([a-zA-Z0-9!$%&*+\-<=>?\\_~/]|{UONLY})
ID_END [^a-zA-Z0-9!$%&*+\-<=>?\\_~/]
@@ -284,8 +314,13 @@ UANY {ASC}|{U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
UANYN {ASCN}|{U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
+JNUM -?(0|{DIG19}{DIG}*)([.]{DIG}+)?{EXP}?
+JPUNC [(){},:\[\]"~*^]
+NJPUNC [^(){},:\[\]"~*^ \t\r\n]
+
%x SPECIAL BRACED NESTED REGEX SREGEX STRLIT CHRLIT
%x QSILIT QSPECIAL WLIT QWLIT BUFLIT
+%x JSON JLIT JMARKER
%%
@@ -301,8 +336,20 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
return NUMBER;
}
-<SPECIAL,QSPECIAL,NESTED,BRACED>({XNUM}|{ONUM}|{BNUM}) {
- val str = string_own(utf8_dup_from(yytext + 2));
+<SPECIAL,QSPECIAL,NESTED,BRACED>{NUMSEP} {
+ val str = string_own(utf8_dup_from(remove_char(yytext, ',')));
+
+ if (yy_top_state(yyscanner) == INITIAL
+ || yy_top_state(yyscanner) == QSILIT
+ || yy_top_state(yyscanner) == QWLIT)
+ yy_pop_state(yyscanner);
+
+ yylval->val = int_str(str, num(10));
+ return NUMBER;
+}
+
+<SPECIAL,QSPECIAL,NESTED,BRACED>{XNUMSEP}|{ONUMSEP}|{BNUMSEP} {
+ val str = string_own(utf8_dup_from(remove_char(yytext + 2, ',')));
int base;
switch (yytext[1]) {
@@ -320,7 +367,7 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
return NUMBER;
}
-<SPECIAL,QSPECIAL,NESTED,BRACED>({BNUM}|{ONUM}|{XNUM}){TOK} {
+<SPECIAL,QSPECIAL,NESTED,BRACED>({BNUMSEP}|{ONUMSEP}|{XNUMSEP}){TOK} {
int base = 0;
val str = string_own(utf8_dup_from(yytext + 2));
@@ -343,22 +390,35 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
}
<SPECIAL,NESTED,BRACED>{WS}{FLO} {
- val str = string_own(utf8_dup_from(yytext));
+ if (yy_top_state(yyscanner) == INITIAL
+ || yy_top_state(yyscanner) == QSILIT
+ || yy_top_state(yyscanner) == QWLIT)
+ yy_pop_state(yyscanner);
+
+ if ((yylval->val = flo_str_utf8(yytext)) == nil)
+ out_of_range_float(yyg, yytext);
+
+ return NUMBER;
+}
+<SPECIAL,NESTED,BRACED>{WS}{FLOSEP} {
if (yy_top_state(yyscanner) == INITIAL
|| yy_top_state(yyscanner) == QSILIT
|| yy_top_state(yyscanner) == QWLIT)
yy_pop_state(yyscanner);
- if ((yylval->val = flo_str(str)) == nil)
- out_of_range_float(yyg, str);
+ remove_char(yytext, ',');
+
+ if ((yylval->val = flo_str_utf8(yytext)) == nil)
+ out_of_range_float(yyg, yytext);
return NUMBER;
}
-<SPECIAL>{WS}({FLO}[.]?|{FLODOT}){TOK} |
-<BRACED>{WS}({FLO}[.]?|{FLODOT}){BTOK} |
-<NESTED>{WS}({FLO}[.]?|{FLODOT}){NTOK} {
+
+<SPECIAL>{WS}({FLOSEP}[.]?|{FLODOT}){TOK} |
+<BRACED>{WS}({FLOSEP}[.]?|{FLODOT}){BTOK} |
+<NESTED>{WS}({FLOSEP}[.]?|{FLODOT}){NTOK} {
val str = string_utf8(yytext);
yyerrorf(yyg, lit("trailing junk in floating-point literal: ~a"), str, nao);
@@ -368,22 +428,20 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
|| yy_top_state(yyscanner) == QWLIT)
yy_pop_state(yyscanner);
- if ((yylval->val = flo_str(str)) == nil)
- out_of_range_float(yyg, str);
+ if ((yylval->val = flo_str_utf8(yytext)) == nil)
+ out_of_range_float(yyg, yytext);
return NUMBER;
}
<SPECIAL,QSPECIAL,NESTED,BRACED>{FLODOT}/[^.] {
- val str = string_own(utf8_dup_from(yytext));
-
if (yy_top_state(yyscanner) == INITIAL
|| yy_top_state(yyscanner) == QSILIT
|| yy_top_state(yyscanner) == QWLIT)
yy_pop_state(yyscanner);
- if ((yylval->val = flo_str(str)) == nil)
- out_of_range_float(yyg, str);
+ if ((yylval->val = flo_str_utf8(yytext)) == nil)
+ out_of_range_float(yyg, yytext);
return NUMBER;
}
@@ -543,6 +601,10 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
return directive_tok(yyg, REPEAT, NESTED);
}
+<SPECIAL>\({WS}({NT0}?:)?push/{ID_END} {
+ return directive_tok(yyg, PUSH, NESTED);
+}
+
<SPECIAL>\({WS}({NT0}?:)?rep/{ID_END} {
return directive_tok(yyg, REP, NESTED);
}
@@ -613,7 +675,7 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
<NESTED,BRACED,QSPECIAL>@ {
yylval->lineno = yyextra->lineno;
- return yytext[0];
+ return (opt_compat && opt_compat <= 248) ? OLD_AT : '@';
}
<NESTED,QSPECIAL,BRACED>,[*] {
@@ -650,7 +712,7 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
}
-<SPECIAL,QSPECIAL,NESTED>[)\]] {
+<SPECIAL,QSPECIAL,NESTED>[)\]}] {
yy_pop_state(yyscanner);
if (yy_top_state(yyscanner) == INITIAL
|| yy_top_state(yyscanner) == QSILIT
@@ -744,18 +806,24 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
return HASH_T;
}
+<NESTED,BRACED>#J {
+ yylval->lineno = yyextra->lineno;
+ yy_push_state(JSON, yyscanner);
+ return HASH_J;
+}
+
<NESTED,BRACED>#; {
yylval->lineno = yyextra->lineno;
return HASH_SEMI;
}
-<NESTED,BRACED>#{DIG}+= {
+<NESTED,BRACED,JSON>#{DIG}+= {
val str = string_own(utf8_dup_from(yytext + 1));
yylval->val = int_str(str, num(10));
return HASH_N_EQUALS;
}
-<NESTED,BRACED>#{DIG}+# {
+<NESTED,BRACED,JSON>#{DIG}+# {
val str = string_own(utf8_dup_from(yytext + 1));
yylval->val = int_str(str, num(10));
return HASH_N_HASH;
@@ -842,11 +910,15 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
return TEXT;
}
+<SPECIAL>[\\]x {
+ yyerrorf(yyg, lit("\\x escape without digits"), nao);
+}
+
<SPECIAL>[\\]. {
yyerrorf(yyg, lit("unrecognized escape \\~a"), chr(yytext[1]), nao);
}
-<SPECIAL,QSPECIAL,NESTED,BRACED>[;][^\n\r]* {
+<SPECIAL,QSPECIAL,NESTED,BRACED,JSON>[;][^\n\r]* {
/* comment */
}
@@ -925,7 +997,10 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
return REGCHAR;
}
- yyerrprepf(yyg, lit("unrecognized escape in regex"), nao);
+ if (yytext[1] == 'x')
+ yyerrprepf(yyg, lit("\\x escape without digits in regex"), nao);
+ else
+ yyerrprepf(yyg, lit("unrecognized escape in regex"), nao);
return ERRTOK;
}
@@ -937,26 +1012,18 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
<REGEX,SREGEX>{UANYN} {
wchar_t wchr[8];
if (utf8_from_buf(wchr, coerce(unsigned char *, yytext), yyleng) != 2) {
- yyerrprepf(yyg, lit("non-UTF-8 byte in regex: '\\x~02x'"),
- num(convert(unsigned char, yytext[0])), nao);
- return ERRTOK;
+ yylval->lexeme = chk_strdup(wchr);
+ return TEXT;
}
yylval->chr = wchr[0];
return REGCHAR;
}
-<SREGEX>. {
- /* Allow non-UTF-8 byte for regexes scanned from string */
+<SREGEX,REGEX>. {
yylval->chr = convert(unsigned char, yytext[0]) + 0xDC00;
return REGCHAR;
}
-<REGEX>. {
- yyerrprepf(yyg, lit("non-UTF-8 byte in regex: '\\x~02x'"),
- num(convert(unsigned char, yytext[0])), nao);
- return ERRTOK;
-}
-
<INITIAL>[ ]+ {
yylval->lexeme = utf8_dup_from(yytext);
return SPACE;
@@ -1027,6 +1094,10 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
return LITCHAR;
}
+<STRLIT,QSILIT,WLIT,QWLIT>[\\]x {
+ yyerrorf(yyg, lit("\\x escape without digits"), nao);
+}
+
<STRLIT,QSILIT,WLIT,QWLIT>[\\]. {
yyerrorf(yyg, lit("unrecognized escape: \\~a"), chr(yytext[1]), nao);
}
@@ -1092,12 +1163,51 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
return ' ';
}
-<STRLIT,CHRLIT,QSILIT,WLIT,QWLIT>{UANYN} {
+<JLIT>\" {
+ yy_pop_state(yyscanner);
+ return yytext[0];
+}
+
+<JLIT>[\\][bfnrt"\\/] {
+ yylval->chr = char_esc(yytext[1]);
+ return LITCHAR;
+}
+
+<JLIT>[\\]u[Dd][8-9A-Fa-f]{HEX}{2}[\\]u[Dd][C-Fc-f]{HEX}{2} {
+ wchar_t ch0, ch1;
+ yytext[6] = 0;
+ ch0 = num_esc(yyg, yytext + 1);
+ ch1 = num_esc(yyg, yytext + 7);
+ yylval->chr = ((ch0 - 0xD800) << 10 | (ch1 - 0xDC00)) + 0x10000;
+ return LITCHAR;
+}
+
+<JLIT>[\\]u{HEX}{4} {
+ wchar_t ch = num_esc(yyg, yytext + 1);
+ yylval->chr = if3(ch, ch, 0xDC00);
+ return LITCHAR;
+}
+
+<JLIT>[\\]u {
+ yyerrorf(yyg, lit("JSON \\u escape needs four digits"), nao);
+}
+
+<JLIT>[\\]. {
+ yyerrorf(yyg, lit("unrecognized JSON escape: \\~a"), chr(yytext[1]), nao);
+}
+
+<JLIT>{NL} {
+ yyerrprepf(yyg, lit("newline in JSON string"), nao);
+ yyextra->lineno++;
+ yylval->chr = yytext[0];
+ return ERRTOK;
+}
+
+<STRLIT,CHRLIT,QSILIT,WLIT,QWLIT,JLIT>{UANYN} {
wchar_t wchr[8];
if (utf8_from_buf(wchr, coerce(unsigned char *, yytext), yyleng) != 2) {
- yyerrprepf(yyg, lit("non-UTF-8 byte in literal: '\\x~02x'"),
- num(convert(unsigned char, yytext[0])), nao);
- return ERRTOK;
+ yylval->lexeme = chk_strdup(wchr);
+ return TEXT;
}
yylval->chr = wchr[0];
return LITCHAR;
@@ -1120,14 +1230,93 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
}
<BUFLIT>. {
- yyerrorf(yyg, lit("bad character in buffer literal: \\~a"),
+ yyerrorf(yyg, lit("bad character ~s in buffer literal"),
chr(yytext[0]), nao);
}
-<STRLIT,CHRLIT,QSILIT,WLIT,QWLIT>. {
- yyerrprepf(yyg, lit("non-UTF-8 byte in literal: '\\x~02x'"),
- num(convert(unsigned char, yytext[0])), nao);
- return ERRTOK;
+<STRLIT,CHRLIT,QSILIT,WLIT,QWLIT,JLIT>. {
+ yylval->chr = convert(unsigned char, yytext[0]) + 0xDC00;
+ return LITCHAR;
+}
+
+<JSON>{JNUM} {
+ if ((yylval->val = flo_str_utf8(yytext)) == nil)
+ out_of_range_float(yyg, yytext);
+ return NUMBER;
+}
+
+<JSON>true/({JPUNC}|[ \t\n]) {
+ yylval->val = t;
+ return JSKW;
+}
+
+<JSON>false/({JPUNC}|[ \t\n]) {
+ yylval->val = nil;
+ return JSKW;
+}
+
+<JSON>null/({JPUNC}|[ \t\n]) {
+ yylval->val = null_s;
+ return JSKW;
+}
+
+<JSON>{NJPUNC}+ {
+ if (strcmp("true", yytext) == 0) {
+ yylval->val = t;
+ return JSKW;
+ }
+
+ if (strcmp("false", yytext) == 0) {
+ yylval->val = nil;
+ return JSKW;
+ }
+
+ if (strcmp("null", yytext) == 0) {
+ yylval->val = null_s;
+ return JSKW;
+ }
+
+ {
+ val str = string_own(utf8_dup_from(yytext));
+ yyerrorf(yyg, lit("unrecognized JSON syntax: ~a"), str, nao);
+ }
+}
+
+<JSON>\" {
+ yy_push_state(JLIT, yyscanner);
+ return yytext[0];
+}
+
+<JSON>~[*] {
+ yy_push_state(JMARKER, yyscanner);
+ yy_push_state(NESTED, yyscanner);
+ return JSPLICE;
+}
+
+<JSON>~ {
+ yy_push_state(JMARKER, yyscanner);
+ yy_push_state(NESTED, yyscanner);
+ return yytext[0];
+}
+
+<JSON>{JPUNC} {
+ return yytext[0];
+}
+
+<JSON>{NL} {
+ yyextra->lineno++;
+}
+
+<JSON>{WS} {
+}
+
+<JSON>. {
+ yyerrorf(yyg, lit("bad character ~s in JSON literal"),
+ chr(yytext[0]), nao);
+}
+
+<JMARKER>. {
+ internal_error("scanner processed input JMARKER state");
}
%%
@@ -1205,6 +1394,76 @@ void end_of_buflit(scanner_t *yyg)
yy_pop_state(yyg);
}
+void end_of_json(scanner_t *yyg)
+{
+ if (YYSTATE == JLIT)
+ yy_pop_state(yyg);
+
+ if (YYSTATE != JSON)
+ internal_error("end_of_json called in wrong scanner state");
+
+ yy_pop_state(yyg);
+}
+
+/* The complexity here is necessary because TXR Lisp parsing looks ahead
+ * by one token. (The reason for *that* is the support of a.b.c referencing dot
+ * syntax in TXR Lisp.)
+ *
+ * Consider these two different cases:
+ *
+ * ^#J[,~(+ 2.0 2.0)]
+ * ^#J[,~(+ 2.0 2.0) #J42]
+ *
+ * This end_of_json_unquote function gets called when the (+ 2.0 2.0)
+ * has been parsed, but the Yacc-generated parser has shifted one tokan
+ * ahead. It has read the ] token in the one case or the #J token in
+ * the other. These tokens have totally different effects on the Lex
+ * start condition. When the lexer reads the ] token, it pops off a NESTED
+ * state, whereas the #J token wants to push on a new JSON state.
+ * By the time end_of_json_unquote has been called, this has already happened.
+ *
+ * To deal with this, we use the dummy JMARKER start state which serves as a
+ * kind of parenthesis inside the start condition stack. BHefore scanning Lisp
+ * unquote within JSON, we push JMARKER state first, then the NESTED state.
+ *
+ * If the lookahead token is like ], and pops off a state, it will pop off
+ * our NESTED state, so we are left at the JMARKER state. If the lookahead
+ * token is something else like #J (HASH_J), then it will push a new
+ * state like JSON on top, and we have JMARKER NESTED JSON.
+ *
+ * So what we are doing here is popping off everything until we get down
+ * to the JMARKER state, and putting it into our little save area.
+ *
+ * Then we lose the JMARKER state.
+ *
+ * If the save area is empty, it means that the lookahead token consumed
+ * our NESTED state, and so we are done.
+ *
+ * If the save area is not empty, it means the lookahead put something
+ * extra over our NESTED state. We drop that state from our save area,
+ * and restore the rest of the save area back into the stack.
+ * Effectively, we are deleting the unquote-related states from the
+ * interior of the start condition stack, not to disturb new material
+ * initiated by the lookahead token.
+ */
+void end_of_json_unquote(scanner_t *yyg)
+{
+ int stacksave[8];
+ int top = 0;
+
+ while (YYSTATE != JMARKER) {
+ stacksave[top++] = YYSTATE;
+ yy_pop_state(yyg);
+ }
+
+ yy_pop_state(yyg);
+
+ if (top-- > 0) {
+ while (top > 0)
+ yy_push_state(stacksave[--top], yyg);
+ }
+}
+
val source_loc(val form)
{
return gethash(form_to_ln_hash, form);
@@ -1227,11 +1486,14 @@ int yylex(YYSTYPE *yylval_param, yyscan_t yyscanner)
struct yy_token *tok = &yyextra->tok_pushback[--yyextra->tok_idx];
yyextra->recent_tok = *tok;
*yylval_param = tok->yy_lval;
+ if (tok->yy_lex_state && tok->yy_lex_state != YYSTATE)
+ yy_push_state(tok->yy_lex_state, yyg);
return tok->yy_char;
}
yy_char = yyextra->recent_tok.yy_char = yylex_impl(yylval_param, yyscanner);
yyextra->recent_tok.yy_lval = *yylval_param;
+ yyextra->recent_tok.yy_lex_state = YYSTATE;
return yy_char;
}
@@ -1251,6 +1513,9 @@ void prime_scanner(scanner_t *yyg, enum prime_parser prim)
case prime_regex:
yy_push_state(SREGEX, yyg);
break;
+ case prime_json:
+ yy_push_state(JSON, yyg);
+ break;
}
}
@@ -1267,5 +1532,6 @@ void scrub_scanner(scanner_t *yyg, int yy_char, wchar_t *lexeme)
void parser_l_init(void)
{
prot1(&form_to_ln_hash);
- form_to_ln_hash = make_eq_hash(t, nil);
+ form_to_ln_hash = make_eq_hash(hash_weak_keys);
+ (void) &yy_fatal_error; /* suppress unused function warning */
}
diff --git a/parser.y b/parser.y
index 81e7dd0a..66d5eabe 100644
--- a/parser.y
+++ b/parser.y
@@ -1,6 +1,6 @@
%{
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -8,33 +8,31 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stddef.h>
#include <stdio.h>
#include <assert.h>
#include <limits.h>
-#include <dirent.h>
#include <stdlib.h>
-#include <stdarg.h>
-#include <setjmp.h>
#include <wchar.h>
#include <signal.h>
#include "config.h"
@@ -44,34 +42,34 @@
#include "unwind.h"
#include "regex.h"
#include "match.h"
+#include "filter.h"
#include "hash.h"
#include "struct.h"
#include "eval.h"
#include "tree.h"
#include "y.tab.h"
-#include "gc.h"
#include "debug.h"
#include "txr.h"
#include "itypes.h"
#include "buf.h"
#include "parser.h"
+static void set_syntax_tree(parser_t *parser, val tree);
static val sym_helper(parser_t *parser, wchar_t *lexeme, val meta_allowed);
static val repeat_rep_helper(val sym, val args, val main, val parts);
static void process_catch_exprs(val exprs);
static val define_transform(parser_t *parser, val define_form);
static val optimize_text(val text_form);
-static val unquotes_occur(val quoted_form, int level);
static val rlrec(parser_t *, val form, val line);
static val rlcp_parser(parser_t *parser, val to, val from);
static wchar_t char_from_name(const wchar_t *name);
static val make_expr(parser_t *, val sym, val rest, val lineno);
static val check_parse_time_action(val spec_rev);
-static void misplaced_consing_dot_check(scanner_t *scanner, val term_atom_cons);
static val uref_helper(parser_t *, val expr);
static val uoref_helper(parser_t *, val expr);
static val qref_helper(parser_t *, val lexpr, val rexpr);
static val fname_helper(parser_t *, val name);
+static val output_helper(parser_t *, val sym, val exprs, val clauses);
#if YYBISON
union YYSTYPE;
@@ -118,19 +116,19 @@ INLINE val expand_form_ver(val form, int ver)
%token <lexeme> SPACE TEXT SYMTOK
%token <lineno> ALL SOME NONE MAYBE CASES BLOCK CHOOSE GATHER
%token <lineno> AND OR END COLLECT
-%token <lineno> UNTIL COLL OUTPUT REPEAT REP SINGLE FIRST LAST EMPTY
+%token <lineno> UNTIL COLL OUTPUT REPEAT PUSH REP SINGLE FIRST LAST EMPTY
%token <lineno> MOD MODLAST DEFINE TRY CATCH FINALLY IF
%token <lineno> ERRTOK /* deliberately not used in grammar */
-%token <lineno> HASH_BACKSLASH HASH_SLASH DOTDOT HASH_H HASH_S HASH_R HASH_SEMI
-%token <lineno> HASH_B_QUOTE HASH_N HASH_T
+%token <lineno> HASH_BACKSLASH HASH_SLASH DOTDOT HASH_H HASH_S HASH_R HASH_J
+%token <lineno> HASH_SEMI HASH_B_QUOTE HASH_N HASH_T
%token <lineno> WORDS WSPLICE QWORDS QWSPLICE
-%token <lineno> SECRET_ESCAPE_R SECRET_ESCAPE_E SECRET_ESCAPE_I
+%token <lineno> SECRET_ESCAPE_R SECRET_ESCAPE_E SECRET_ESCAPE_I SECRET_ESCAPE_J
%token <lineno> OLD_DOTDOT
-%token <val> NUMBER METANUM
+%token <val> NUMBER METANUM JSKW
%token <val> HASH_N_EQUALS HASH_N_HASH
-%token <chr> REGCHAR REGTOKEN LITCHAR SPLICE
+%token <chr> REGCHAR REGTOKEN LITCHAR SPLICE JSPLICE OLD_AT
%token <chr> CONSDOT LAMBDOT UREFDOT OREFDOT UOREFDOT
%type <val> spec hash_semi_or_n_expr hash_semi_or_i_expr
@@ -139,16 +137,18 @@ INLINE val expand_form_ver(val form, int ver)
%type <val> cases_clause choose_clause gather_clause collect_clause until_last
%type <val> collect_repeat
%type <val> clause_parts additional_parts gather_parts additional_gather_parts
-%type <val> output_clause define_clause try_clause catch_clauses_opt
+%type <val> output_clause output_push define_clause try_clause catch_clauses_opt
%type <val> if_clause elif_clauses_opt else_clause_opt
%type <val> line elems_opt elems clause_parts_h additional_parts_h
%type <val> text texts elem var var_op modifiers
%type <val> vector hash struct range tnode tree
-%type <val> exprs exprs_opt n_exprs r_exprs i_expr i_dot_expr
+%type <val> json json_val json_vals json_pairs json_col
+%type <val> exprs exprs_opt n_exprs listacc i_expr i_dot_expr
%type <val> n_expr n_exprs_opt n_dot_expr
%type <val> list dwim meta compound
%type <val> out_clauses out_clauses_opt out_clause
%type <val> repeat_clause repeat_parts_opt o_line
+%type <val> out_if_clause out_elif_clauses_opt out_else_clause_opt
%type <val> o_elems_opt o_elems o_elem o_var q_var rep_elem rep_parts_opt
%type <val> regex lisp_regex regexpr regbranch
%type <val> regterm regtoken regclass regclassterm regrange
@@ -164,23 +164,24 @@ INLINE val expand_form_ver(val form, int ver)
%right OUTPUT REPEAT REP FIRST LAST EMPTY DEFINE IF ELIF ELSE
%right SPACE TEXT NUMBER METANUM HASH_N_EQUALS HASH_N_HASH HASH_B_QUOTE
%nonassoc '[' ']' '(' ')'
-%left '-' ',' '\'' '^' SPLICE '@'
+%left '-' ',' '\'' '^' SPLICE OLD_AT
%left '|' '/'
%left '&'
%right '~' '*' '?' '+' '%'
%right DOTDOT
%right '.' CONSDOT LAMBDOT UREFDOT OREFDOT UOREFDOT REGCHAR REGTOKEN LITCHAR
-%right OLD_DOTDOT
+%right OLD_DOTDOT '@'
%%
-spec : clauses_opt { parser->syntax_tree = $1; }
- | SECRET_ESCAPE_R regexpr { parser->syntax_tree = $2; end_of_regex(scnr); }
+spec : clauses_opt { set_syntax_tree(parser, $1); }
+ | SECRET_ESCAPE_R regexpr { set_syntax_tree(parser, $2);
+ end_of_regex(scnr); }
| SECRET_ESCAPE_E hash_semi_or_n_expr
- { parser->syntax_tree = $2; YYACCEPT; }
+ { set_syntax_tree(parser, $2); YYACCEPT; }
byacc_fool { internal_error("notreached"); }
| SECRET_ESCAPE_I hash_semi_or_i_expr
- { parser->syntax_tree = $2; YYACCEPT; }
+ { set_syntax_tree(parser, $2); YYACCEPT; }
byacc_fool { internal_error("notreached"); }
| SECRET_ESCAPE_E { if (yychar == YYEOF) {
parser->syntax_tree = nao;
@@ -196,6 +197,16 @@ spec : clauses_opt { parser->syntax_tree = $1; }
yybadtok(yychar, nil);
parser->syntax_tree = nil;
} }
+ | SECRET_ESCAPE_J json_val { set_syntax_tree(parser, $2);
+ YYACCEPT; }
+ byacc_fool { internal_error("notreached"); }
+ | SECRET_ESCAPE_J { if (yychar == YYEOF) {
+ parser->syntax_tree = nao;
+ YYACCEPT;
+ } else {
+ yybadtok(yychar, nil);
+ parser->syntax_tree = nil;
+ } }
| error '\n' { parser->syntax_tree = nil;
if (parser->errors >= 8)
YYABORT;
@@ -489,6 +500,9 @@ elem : texts { $$ = rlc(cons(text_s, $1), $1);
$$ = rlc(cons(sym,
expand_forms(rest($1), nil)),
$1);
+ else if (sym == mdo_s)
+ { eval_intrinsic(cons(progn_s, cdr($1)), nil, nil);
+ $$ = cons(do_s, nil); }
else
{ $$ = match_expand_elem($1);
match_reg_elem($$); } }
@@ -607,53 +621,51 @@ catch_clauses_opt : CATCH ')' newl
;
-output_clause : OUTPUT ')' o_elems '\n'
+output_clause : output_push ')' o_elems '\n'
out_clauses
END newl { $$ = nil;
- yyerr("obsolete output syntax: trailing material"); }
- | OUTPUT ')' newl
- END newl { $$ = rl(list(output_s, nao), num($1)); }
- | OUTPUT ')' newl
+ yyerrorf(scnr, lit("~a: traling material"),
+ car($1), nao); }
+ | output_push ')' newl
+ END newl { $$ = rl(list(car($1), nao), $1); }
+ | output_push ')' newl
out_clauses
- END newl { $$ = rl(list(output_s, $4, nao), num($1)); }
- | OUTPUT exprs ')' newl
+ END newl { $$ = rl(list(car($1), $4, nao), $1); }
+ | output_push exprs ')' newl
out_clauses
- END newl { cons_bind (dest, rest, $2);
- val dest_ex = expand_form_ver(dest, 166);
- val args = if3(dest_ex == dest,
- $2, cons(dest_ex, rest));
- $$ = list(output_s, $5, args, nao);
- rl($$, num($1));
- { val into_var = second(memql(into_k, args));
- val named_var = second(memql(named_k, args));
- match_reg_var(into_var);
- match_reg_var(named_var); } }
- | OUTPUT exprs ')' o_elems '\n'
+ END newl { $$ = output_helper(parser, car($1), $2, $5);
+ rl($$, $1); }
+ | output_push exprs ')' o_elems '\n'
out_clauses
END newl { $$ = nil;
yyerr("invalid combination of old and "
- "new syntax in output directive"); }
- | OUTPUT error { $$ = nil;
+ "new syntax in output directive"); }
+ | output_push error { $$ = nil;
yybadtok(yychar, lit("output directive")); }
- | OUTPUT ')' o_elems '\n'
+ | output_push ')' o_elems '\n'
error { $$ = nil;
yybadtok(yychar, lit("output clause")); }
- | OUTPUT ')' newl
+ | output_push ')' newl
error { $$ = nil;
yybadtok(yychar, lit("output clause")); }
- | OUTPUT exprs ')' o_elems '\n'
+ | output_push exprs ')' o_elems '\n'
error { $$ = nil;
yybadtok(yychar, lit("output clause")); }
- | OUTPUT exprs ')' newl
+ | output_push exprs ')' newl
error { $$ = nil;
yybadtok(yychar, lit("output clause")); }
;
+output_push : OUTPUT { $$ = cons(output_s, num($1)); }
+ | PUSH { $$ = cons(push_s, num($1)); }
+ ;
+
out_clauses : out_clause { $$ = cons($1, nil); }
| out_clause out_clauses { $$ = cons($1, $2); }
;
out_clause : repeat_clause { $$ = cons($1, nil); }
+ | out_if_clause { $$ = cons($1, nil); }
| o_line { $$ = $1; }
;
@@ -706,6 +718,44 @@ repeat_parts_opt : SINGLE newl
| /* empty */ { $$ = nil; }
;
+out_if_clause : IF n_expr ')' newl
+ out_clauses_opt
+ out_elif_clauses_opt
+ out_else_clause_opt
+ END newl { val expr = expand($2, nil);
+ val ifs = $5;
+ val branch = cons(cons(expr, ifs), nil);
+ val elifs = $6;
+ val els = $7;
+ $$ = cons(if_s,
+ nappend2(branch, nappend2(elifs, els)));
+ rl($$, num($1)); }
+ | IF ')'
+ { $$ = nil;
+ yyerr("if requires expression"); }
+ | IF n_expr ')' newl
+ error { $$ = nil; yybadtok(yychar, lit("if clause")); }
+ ;
+
+out_elif_clauses_opt : ELIF n_exprs_opt ')' newl
+ out_clauses_opt
+ out_elif_clauses_opt
+ { val expr = expand(car($2), nil);
+ val elifs = $5;
+ val branch = cons(cons(expr, elifs), nil);
+ if (null($2))
+ yyerr("elif requires expression");
+ else if (cdr($2))
+ yyerr("extra expression in elif");
+ $$ = nappend2(branch, $6); }
+ | { $$ = nil; }
+ ;
+
+out_else_clause_opt : ELSE newl
+ out_clauses_opt
+ { $$ = cons(cons(t, $3), nil); }
+ | { $$ = nil; }
+ ;
out_clauses_opt : out_clauses { $$ = $1; }
| /* empty */ { $$ = nil; }
@@ -783,13 +833,16 @@ var : SYMTOK { $$ = list(var_s, symhlpr($1, nil), nao); }
| var_op SYMTOK { $$ = list(var_s, symhlpr($2, nil), $1, nao); }
| var_op '{' SYMTOK '}' { $$ = list(var_s, symhlpr($3, nil), $1, nao); }
| var_op '{' SYMTOK regex '}' { $$ = nil;
+ free($3);
yyerr("longest match "
"not useable with regex"); }
| var_op '{' SYMTOK NUMBER '}' { $$ = nil;
+ free($3);
yyerr("longest match "
"not useable with "
"fixed width match"); }
| SYMTOK error { $$ = nil;
+ free($1);
yybadtok(yychar, lit("variable spec")); }
| var_op error { $$ = nil;
yybadtok(yychar, lit("variable spec")); }
@@ -821,6 +874,7 @@ o_var : SYMTOK { val expr = symhlpr($1, nil);
val quasi_items = cons(quasi_var, nil);
$$ = car(expand_quasi(quasi_items, nil)); } }
| SYMTOK error { $$ = nil;
+ free($1);
yybadtok(yychar, lit("variable spec")); }
;
@@ -832,7 +886,7 @@ q_var : '@' '{' n_expr n_exprs_opt '}'
;
-vector : '#' list { if (parser->quasi_level > 0 && unquotes_occur($2, 0))
+vector : '#' list { if (parser->quasi_level > 0)
$$ = rlc(cons(vector_lit_s,
cons($2, nil)), $2);
else
@@ -841,7 +895,9 @@ vector : '#' list { if (parser->quasi_level > 0 && unquotes_occur(
yybadtok(yychar, lit("unassigned/reserved # notation")); }
;
-hash : HASH_H list { if (parser->quasi_level > 0 && unquotes_occur($2, 0))
+hash : HASH_H list { if (parser->ignore)
+ $$ = nil;
+ else if (parser->quasi_level > 0)
$$ = rl(cons(hash_lit_s, $2), num($1));
else
$$ = rl(hash_construct(first($2),
@@ -851,9 +907,12 @@ hash : HASH_H list { if (parser->quasi_level > 0 && unquotes_occur(
yybadtok(yychar, lit("hash literal")); }
;
-struct : HASH_S list { if (parser->quasi_level > 0 && unquotes_occur($2, 0))
- $$ = rl(cons(struct_lit_s, $2),
- num($1));
+struct : HASH_S list { if (parser->ignore)
+ { $$ = nil; }
+ else if ((parser->quasi_level > 0) ||
+ (parser->read_unknown_structs &&
+ !find_struct_type(first($2))))
+ { $$ = rl(cons(struct_lit_s, $2), num($1)); }
else
{ val strct = make_struct_lit(first($2),
rest($2));
@@ -879,8 +938,10 @@ tnode : HASH_N list { if (gt(length($2), three))
yybadtok(yychar, lit("tree node literal")); }
;
-tree : HASH_T list { if (parser->quasi_level > 0 && unquotes_occur($2, 0))
- $$ = rl(cons(tree_lit_s, $2), num($1));
+tree : HASH_T list { if (parser->ignore)
+ { $$ = nil; }
+ else if (parser->quasi_level > 0)
+ { $$ = rl(cons(tree_lit_s, $2), num($1)); }
else
{ val opts = first($2);
val key_fn_name = pop(&opts);
@@ -890,12 +951,109 @@ tree : HASH_T list { if (parser->quasi_level > 0 && unquotes_occur($
val less_fn = fname_helper(parser, less_fn_name);
val equal_fn = fname_helper(parser, equal_fn_name);
val tr = tree(rest($2), key_fn,
- less_fn, equal_fn);
+ less_fn, equal_fn, t);
$$ = rl(tr, num($1)); } }
| HASH_T error { $$ = nil;
yybadtok(yychar, lit("tree node literal")); }
;
+json : HASH_J json_val { $$ = list(json_s, quote_s, $2, nao);
+ end_of_json(scnr); }
+ | HASH_J '^' { parser->quasi_level++; }
+ json_val { parser->quasi_level--;
+ end_of_json(scnr);
+ $$ = list(json_s, sys_qquote_s, $4, nao); }
+json_val : NUMBER { $$ = $1; }
+ | JSKW { $$ = $1; }
+ | '"' '"' { $$ = null_string; }
+ | '"' litchars '"' { $$ = $2;
+ rl($$, num(parser->lineno)); }
+ | '[' ']' { $$ = vector(zero, nil); }
+ | '[' json_vals
+ opt_comma ']' { $$ = if3(vectorp($2),
+ $2,
+ rl(cons(vector_lit_s,
+ cons(nreverse($2), nil)),
+ $2)); }
+ | '{' '}' { $$ = make_hash(hash_weak_none, t); }
+ | '{' json_pairs
+ opt_comma '}' { $$ = if3(hashp($2),
+ $2,
+ rl(cons(hash_lit_s,
+ cons(nil, nreverse($2))),
+ $2)); }
+ | '~' { parser->quasi_level--; }
+ n_dot_expr { parser->quasi_level++;
+ end_of_json_unquote(scnr);
+ $$ = rl(rlc(list(sys_unquote_s, $3, nao), $3),
+ num(parser->lineno)); }
+ | JSPLICE { parser->quasi_level--; }
+ n_dot_expr { parser->quasi_level++;
+ end_of_json_unquote(scnr);
+ $$ = rl(rlc(list(sys_splice_s, $3, nao), $3),
+ num(parser->lineno)); }
+ | HASH_N_EQUALS { parser_circ_def(parser, $1, unique_s); }
+ json_val { parser_circ_def(parser, $1, $3);
+ $$ = $3; }
+ | HASH_N_HASH { $$ = parser_circ_ref(parser, $1); }
+ | '"' error { $$ = nil;
+ yybadtok(yychar, lit("JSON string")); }
+ | '[' error { $$ = nil;
+ yybadtok(yychar, lit("JSON array")); }
+ | '{' error { $$ = nil;
+ yybadtok(yychar, lit("JSON hash")); }
+ ;
+
+opt_comma : ',' { if (!parser->read_bad_json)
+ yyerr("trailing comma in JSON array"); }
+ |
+ ;
+
+json_vals : json_val { $$ = if3(parser->quasi_level > 0,
+ cons($1, nil),
+ vector(one, $1)); }
+ | json_vals ',' json_val { if (consp($1))
+ { $$ = cons($3, $1); }
+ else if (parser->quasi_level > 0)
+ { val li = list_vec($1);
+ $$ = cons($3, li); }
+ else
+ { vec_push($1, $3);
+ $$ = $1; } }
+ | json_vals json_val { yyerr("missing comma in JSON array");
+ $$ = $1; }
+ | json_vals error { yybadtok(yychar, lit("JSON array"));
+ $$ = $1; }
+ ;
+
+json_pairs : json_val json_col json_val { if (parser->quasi_level > 0)
+ { $$ = cons(list($1, $3, nao), nil); }
+ else
+ { $$ = make_hash(hash_weak_none, t);
+ sethash($$, $1, $3); } }
+ | json_pairs ','
+ json_val json_col json_val { if (consp($1))
+ { $$ = cons(list($3, $5, nao), $1); }
+ else if (parser->quasi_level > 0)
+ { val pa = hash_pairs($1);
+ $$ = cons(list($3, $5, nao), pa); }
+ else
+ { sethash($1, $3, $5);
+ $$ = $1; } }
+ | json_val json_val { yyerr("missing colon in JSON hash"); }
+ | json_pairs json_val
+ error { yyerr("missing comma in JSON hash"); }
+ | json_val error { yybadtok(yychar, lit("JSON hash")); }
+ ;
+
+json_col : SYMTOK { if ($1[0] == ':' && $1[1] == 0)
+ { $$ = nil; }
+ else
+ { yybadtok(yychar, lit("JSON hash")); } }
+ | ':' { $$ = nil; }
+ ;
+
+
list : '(' n_exprs ')' { $$ = rl($2, num($1)); }
| '(' '.' n_exprs ')' { val a = car($3);
val ur = uref_helper(parser, a);
@@ -919,12 +1077,23 @@ meta : '@' n_expr { if (consp($2))
yybadtok(yychar, lit("meta expression")); }
;
+meta : OLD_AT n_expr { if (consp($2))
+ $$ = rl(cons(expr_s, cons($2, nil)), num($1));
+ else
+ $$ = rl(cons(var_s, cons($2, nil)),
+ num($1)); }
+ | OLD_AT error { $$ = nil;
+ yybadtok(yychar, lit("meta expression")); }
+ ;
+
dwim : '[' '.' n_exprs ']' { val a = car($3);
val ur = uref_helper(parser, a);
$$ = rlcp_tree(cons(dwim_s,
cons(ur, cdr($3))), ur); }
| '[' n_exprs ']' { $$ = rl(cons(dwim_s, $2), num($1)); }
| '[' ']' { $$ = rl(cons(dwim_s, nil), num($1)); }
+ | '[' LAMBDOT n_expr ']' { $$ = rl(cons(dwim_s, $3), num($1)); }
+ | '[' CONSDOT n_expr ']' { $$ = rl(cons(dwim_s, $3), num($1)); }
| '[' error { $$ = nil;
yybadtok(yychar, lit("DWIM expression")); }
;
@@ -941,54 +1110,47 @@ exprs_opt : exprs { $$ = $1; }
| /* empty */ { $$ = nil; }
;
-n_exprs : r_exprs { val term_atom = pop(&$1);
- val tail_cons = $1;
- $$ = us_nreverse($1);
- if (term_atom != unique_s)
- rplacd(tail_cons, term_atom); }
+n_exprs : listacc { $$ = $1->c.cdr;
+ $1->c.cdr = nil;
+ if ($$->c.car == nao)
+ $$ = $$->c.cdr; }
+ | listacc CONSDOT n_expr
+ { $$ = $1->c.cdr;
+ $1->c.cdr = $3; }
;
-r_exprs : n_expr { val exprs = cons($1, nil);
- rlc(exprs, $1);
- $$ = rlc(cons(unique_s, exprs), exprs); }
+listacc : n_expr { $$ = cons($1, nil);
+ rlc($$, $1);
+ $$->c.cdr = $$; }
| HASH_SEMI { parser->ignore = 1; }
n_expr { parser->ignore = 0;
- $$ = cons(unique_s, nil); }
- | r_exprs HASH_SEMI { parser->ignore = 1; }
+ $$ = cons(nao, nil);
+ $$->c.cdr = $$; }
+ | HASH_SEMI '.' { parser->ignore = 1; }
+ n_expr { parser->ignore = 0;
+ $$ = cons(nao, nil);
+ $$->c.cdr = $$; }
+ | listacc HASH_SEMI { parser->ignore = 1; }
n_expr { parser->ignore = 0;
$$ = $1; }
- | r_exprs n_expr { uses_or2;
- val term_atom_cons = $1;
- val exprs = cdr($1);
- misplaced_consing_dot_check(scnr, term_atom_cons);
- rplacd(term_atom_cons,
- rlc(cons($2, exprs), or2($2, exprs)));
- $$ = term_atom_cons; }
- | r_exprs CONSDOT n_expr
- { val term_atom_cons = $1;
- misplaced_consing_dot_check(scnr, term_atom_cons);
- rplaca(term_atom_cons, $3);
+ | listacc HASH_SEMI '.' { parser->ignore = 1; }
+ n_expr { parser->ignore = 0;
$$ = $1; }
- | WSPLICE wordslit { $$ = cons(unique_s, us_nreverse(rl($2, num($1))));
- rlc($$, cdr($$)); }
- | r_exprs WSPLICE
- wordslit { val term_atom_cons = $1;
- val exprs = cdr($1);
- misplaced_consing_dot_check(scnr, term_atom_cons);
- rplacd(term_atom_cons,
- nappend2(rl(us_nreverse($3), num($2)),
- exprs));
- $$ = term_atom_cons; }
- | QWSPLICE wordsqlit { $$ = cons(unique_s, rl($2, num($1)));
- rlc($$, cdr($$)); }
- | r_exprs QWSPLICE
- wordsqlit { val term_atom_cons = $1;
- val exprs = cdr($1);
- misplaced_consing_dot_check(scnr, term_atom_cons);
- rplacd(term_atom_cons,
- nappend2(rl(us_nreverse($3), num($2)),
- exprs));
- $$ = term_atom_cons; }
+ | listacc n_expr { uses_or2;
+ $$ = rlc(cons($2, $1->c.cdr), or2($2, $1->c.cdr));
+ $1->c.cdr = $$; }
+ | WSPLICE wordslit { $$ = lastcons(rl($2, num($1)));
+ $$->c.cdr = $2; }
+ | listacc WSPLICE
+ wordslit { $$ = lastcons(rl($3, num($2)));
+ $$->c.cdr = $1->c.cdr;
+ $1->c.cdr = $3; }
+ | QWSPLICE wordsqlit { $$ = lastcons(rl($2, num($1)));
+ $$->c.cdr = $2; }
+ | listacc QWSPLICE
+ wordsqlit { $$ = lastcons(rl($3, num($2)));
+ $$->c.cdr = $1->c.cdr;
+ $1->c.cdr = $3; }
;
i_expr : SYMTOK { $$ = ifnign(symhlpr($1, t)); }
@@ -1002,6 +1164,7 @@ i_expr : SYMTOK { $$ = ifnign(symhlpr($1, t)); }
| range { $$ = $1; }
| tnode { $$ = $1; }
| tree { $$ = $1; }
+ | json { $$ = $1; }
| lisp_regex { $$ = $1; }
| chrlit { $$ = $1; }
| strlit { $$ = $1; }
@@ -1043,6 +1206,7 @@ n_expr : SYMTOK { $$ = ifnign(symhlpr($1, t)); }
| range { $$ = $1; }
| tnode { $$ = $1; }
| tree { $$ = $1; }
+ | json { $$ = $1; }
| lisp_regex { $$ = $1; }
| chrlit { $$ = $1; }
| strlit { $$ = $1; }
@@ -1155,6 +1319,7 @@ regterm : regterm '*' { $$ = list(zeroplus_s, $1, nao); }
| '-' { $$ = chr('-'); }
| REGCHAR { $$ = chr($1); }
| regtoken { $$ = $1; }
+ | TEXT { $$ = list(compound_s, string_own($1), nao); }
| '(' regexpr ')' { $$ = $2; }
| '(' error { $$ = nil;
yybadtok(yychar, lit("regex subexpression")); }
@@ -1213,7 +1378,7 @@ strlit : '"' '"' { $$ = null_string; }
chrlit : HASH_BACKSLASH SYMTOK { wchar_t ch;
val str = string_own($2);
- const wchar_t *cstr = c_str(str);
+ const wchar_t *cstr = c_str(str, nil);
if (cstr[1] == 0)
{ ch = cstr[0]; }
@@ -1226,6 +1391,10 @@ chrlit : HASH_BACKSLASH SYMTOK { wchar_t ch;
$$ = chr(ch); }
| HASH_BACKSLASH LITCHAR { $$ = chr($2);
end_of_char(scnr); }
+ | HASH_BACKSLASH TEXT { free($2);
+ yyerrorf(scnr,
+ lit("invalid UTF-8 used as character name"),
+ nao); }
| HASH_BACKSLASH error { $$ = nil;
yybadtok(yychar,
lit("character literal")); }
@@ -1246,7 +1415,6 @@ quasi_items : quasi_item { $$ = cons($1, nil);
;
quasi_item : litchars { $$ = $1; }
- | TEXT { $$ = string_own($1); }
| q_var { $$ = $1; }
| METANUM { $$ = cons(var_s, cons($1, nil));
rl($$, num(parser->lineno)); }
@@ -1259,11 +1427,15 @@ quasi_item : litchars { $$ = $1; }
litchars : LITCHAR { $$ = mkstring(one, chr($1)); }
| LITCHAR restlitchar { val ch = mkstring(one, chr($1));
- $$ = string_extend(ch, $2); }
+ $$ = string_extend(ch, $2, t); }
+ | TEXT { $$ = string_own($1); }
+ | TEXT restlitchar { $$ = string_extend(string_own($1), $2, t); }
;
restlitchar : LITCHAR { $$ = mkstring(one, chr($1)); }
- | restlitchar LITCHAR { $$ = string_extend($1, chr($2)); }
+ | restlitchar LITCHAR { $$ = string_extend($1, chr($2), nil); }
+ | TEXT { $$ = string_own($1); }
+ | restlitchar TEXT { $$ = string_extend($1, string_own($2), nil); }
;
wordslit : '"' { $$ = nil; }
@@ -1317,8 +1489,6 @@ not_a_clause : ALL { $$ = mkexp(all_s, nil, num(parser->lineno)); }
| OR { $$ = mkexp(or_s, nil, num(parser->lineno)); }
| TRY { $$ = mkexp(try_s, nil, num(parser->lineno)); }
| FINALLY { $$ = mkexp(finally_s, nil, num(parser->lineno)); }
- | ELSE { $$ = mkexp(else_s, nil, num(parser->lineno)); }
- | ELIF { $$ = mkexp(elif_s, nil, num(parser->lineno)); }
| BLOCK
exprs_opt ')' { $$ = mkexp(block_s, $2, nil); }
| CHOOSE
@@ -1334,10 +1504,14 @@ not_a_clause : ALL { $$ = mkexp(all_s, nil, num(parser->lineno)); }
| CATCH
exprs_opt ')' { $$ = mkexp(catch_s, $2, nil); }
| IF
- exprs_opt ')' { $$ = mkexp(if_s, $2, nil); }
+ n_expr n_expr exprs_opt ')' { $$ = mkexp(if_s,
+ cons($2,
+ cons($3, $4)),
+ nil); }
| OUTPUT
exprs_opt ')' { yyerr("@(output) doesn't nest"); }
-
+ | PUSH
+ exprs_opt ')' { yyerr("@(push) doesn't nest"); }
;
%%
@@ -1350,9 +1524,19 @@ void yydebug_onoff(int val)
{
#if YYDEBUG
yydebug = val;
+#else
+ (void) val;
#endif
}
+static void set_syntax_tree(parser_t *parser, val tree)
+{
+ if (tree == nao)
+ parser->syntax_tree = tree;
+ else
+ set(mkloc(parser->syntax_tree, parser->parser), tree);
+}
+
static val sym_helper(parser_t *parser, wchar_t *lexeme, val meta_allowed)
{
scanner_t *scnr = parser->scanner;
@@ -1450,15 +1634,70 @@ static val expand_repeat_rep_args(val args)
}
} else if (exp_pair) {
match_reg_var(arg);
+ ptail = list_collect(ptail, arg);
}
exp_pair = exp_pairs = nil;
- ptail = list_collect(ptail, arg);
}
return out;
}
+static val extract_vars(val output_spec)
+{
+ list_collect_decl (vars, tai);
+
+ if (consp(output_spec)) {
+ val sym = first(output_spec);
+ if (sym == var_s) {
+ val expr = second(output_spec);
+ val modifiers = third(output_spec);
+
+ if (bindable(expr)) {
+ tai = list_collect(tai, expr);
+ } else if (opt_compat && opt_compat <= 128) {
+ tai = list_collect_nconc(tai, extract_vars(expr));
+ } else {
+ val frefs = expand_with_free_refs(expr, nil, nil);
+ tai = list_collect_nconc(tai, second(frefs));
+ }
+
+ for (; modifiers; modifiers = cdr(modifiers)) {
+ val mod = car(modifiers);
+ if (bindable(mod)) {
+ tai = list_collect(tai, mod);
+ } else if (consp(mod)) {
+ val msym = car(mod);
+
+ if (msym == dwim_s) {
+ val arg = second(mod);
+
+ if (bindable(arg)) {
+ tai = list_collect(tai, arg);
+ } else if (consp(arg) && car(arg) == rcons_s) {
+ val f = second(arg);
+ val t = third(arg);
+ if (bindable(f))
+ tai = list_collect(tai, f);
+ if (bindable(t))
+ tai = list_collect(tai, t);
+ }
+ }
+ }
+ }
+ } else if (sym == expr_s) {
+ val expr = second(output_spec);
+ val frefs = expand_with_free_refs(expr, nil, nil);
+ tai = list_collect_nconc(tai, second(frefs));
+ } else {
+ for (; output_spec; output_spec = cdr(output_spec))
+ tai = list_collect_nconc(tai, extract_vars(car(output_spec)));
+ }
+ }
+
+ return vars;
+}
+
static val repeat_rep_helper(val sym, val args, val main, val parts)
{
uses_or2;
@@ -1469,6 +1708,7 @@ static val repeat_rep_helper(val sym, val args, val main, val parts)
val empty_parts = nil, empty_parts_p = nil;
val mod_parts = nil, mod_parts_p = nil;
val modlast_parts = nil, modlast_parts_p = nil;
+ val occur_vars = nil;
val iter;
for (iter = parts; iter != nil; iter = cdr(iter)) {
@@ -1506,9 +1746,17 @@ static val repeat_rep_helper(val sym, val args, val main, val parts)
mod_parts = or2(nreverse(mod_parts), mod_parts_p);
modlast_parts = or2(nreverse(modlast_parts), modlast_parts_p);
+ occur_vars = extract_vars(main);
+ occur_vars = nappend2(occur_vars, extract_vars(single_parts));
+ occur_vars = nappend2(occur_vars, extract_vars(first_parts));
+ occur_vars = nappend2(occur_vars, extract_vars(last_parts));
+ occur_vars = nappend2(occur_vars, extract_vars(empty_parts));
+ occur_vars = nappend2(occur_vars, extract_vars(mod_parts));
+ occur_vars = uniq(occur_vars);
+
return list(sym, exp_args, main, single_parts, first_parts,
last_parts, empty_parts, nreverse(mod_parts),
- nreverse(modlast_parts), nao);
+ nreverse(modlast_parts), occur_vars, nao);
}
static void process_catch_exprs(val exprs)
@@ -1570,23 +1818,6 @@ static val optimize_text(val text_form)
return text_form;
}
-static val unquotes_occur(val quoted_form, int level)
-{
- uses_or2;
-
- if (atom(quoted_form)) {
- return nil;
- } else {
- val sym = car(quoted_form);
- if (sym == sys_unquote_s || sym == sys_splice_s)
- return (level == 0) ? t : unquotes_occur(cdr(quoted_form), level - 1);
- if (sym == sys_qquote_s)
- return unquotes_occur(cdr(quoted_form), level + 1);
- return or2(unquotes_occur(sym, level),
- unquotes_occur(cdr(quoted_form), level));
- }
-}
-
val expand_meta(val form, val menv)
{
val sym;
@@ -1766,12 +1997,8 @@ static val check_parse_time_action(val spec_rev)
if (sym == include_s) {
return nappend2(nreverse(include(line)), rest(spec_rev));
}
- if (sym == mdo_s) {
- eval_intrinsic(cons(progn_s, cdr(elem)), nil);
- return nil;
- }
if (sym == in_package_s) {
- eval_intrinsic(elem, nil);
+ eval_intrinsic(elem, nil, nil);
return nil;
}
}
@@ -1779,14 +2006,6 @@ static val check_parse_time_action(val spec_rev)
return spec_rev;
}
-static void misplaced_consing_dot_check(scanner_t *scanner, val term_atom_cons)
-{
- if (car(term_atom_cons) != unique_s) {
- yyerrorf(scanner, lit("misplaced consing dot"), nao);
- rplaca(term_atom_cons, unique_s);
- }
-}
-
static val uref_helper(parser_t *parser, val expr)
{
if (consp(expr) && car(expr) == qref_s) {
@@ -1838,6 +2057,52 @@ static val fname_helper(parser_t *parser, val name)
return nil;
}
+static val output_helper(parser_t *parser, val sym, val exprs, val clauses)
+{
+ cons_bind (dest, rest, exprs);
+
+ val dest_ex = expand_form_ver(dest, 166);
+ val args = if3(dest_ex == dest, exprs, cons(dest_ex, rest));
+ val args_kw = keywordp(car(args));
+ val alist = improper_plist_to_alist(if3(args_kw, args, cdr(args)),
+ v_output_keys);
+
+ if (!args_kw && sym == push_s)
+ {
+ yyerrorf(parser->scanner, lit("~s: doesn't support destination argument"),
+ sym, nao);
+ }
+
+
+ while (alist) {
+ val key = car(pop(&alist));
+
+ if (key == filter_k)
+ continue;
+
+ if (sym != push_s) {
+ if (key == nothrow_k || key == append_k ||
+ key == named_k || key == continue_k ||
+ key == finish_k || key == into_k)
+ {
+ continue;
+ }
+ }
+
+ yyerrorf(parser->scanner, lit("~s: unsupported keyword ~s"),
+ sym, key, nao);
+ }
+
+ if (sym != push_s) {
+ val into_var = second(memql(into_k, args));
+ val named_var = second(memql(named_k, args));
+ match_reg_var(into_var);
+ match_reg_var(named_var);
+ }
+
+ return list(sym, clauses, args, nao);
+}
+
#ifndef YYEOF
#define YYEOF 0
#endif
@@ -1859,7 +2124,9 @@ void yybadtoken(parser_t *parser, int tok, val context)
case NONE: problem = lit("\"none\""); break;
case MAYBE: problem = lit("\"maybe\""); break;
case CASES: problem = lit("\"cases\""); break;
+ case BLOCK: problem = lit("\"block\""); break;
case CHOOSE: problem = lit("\"choose\""); break;
+ case GATHER: problem = lit("\"gather\""); break;
case AND: problem = lit("\"and\""); break;
case OR: problem = lit("\"or\""); break;
case END: problem = lit("\"end\""); break;
@@ -1873,6 +2140,8 @@ void yybadtoken(parser_t *parser, int tok, val context)
case FIRST: problem = lit("\"first\""); break;
case LAST: problem = lit("\"last\""); break;
case EMPTY: problem = lit("\"empty\""); break;
+ case MOD: problem = lit("\"mod\""); break;
+ case MODLAST: problem = lit("\"modlast\""); break;
case DEFINE: problem = lit("\"define\""); break;
case TRY: problem = lit("\"try\""); break;
case CATCH: problem = lit("\"catch\""); break;
@@ -1881,9 +2150,12 @@ void yybadtoken(parser_t *parser, int tok, val context)
case ELIF: problem = lit("\"elif\""); break;
case ELSE: problem = lit("\"else\""); break;
case NUMBER: problem = lit("number"); break;
+ case JSKW: problem = lit("JSON keyword"); break;
case REGCHAR: problem = lit("regular expression character"); break;
case REGTOKEN: problem = lit("regular expression token"); break;
case LITCHAR: problem = lit("string literal character"); break;
+ case SPLICE: problem = lit("*"); break;
+ case JSPLICE: problem = lit("~*"); break;
case CONSDOT:
case LAMBDOT: problem = lit("consing dot"); break;
case DOTDOT: problem = lit(".."); break;
@@ -1898,6 +2170,7 @@ void yybadtoken(parser_t *parser, int tok, val context)
case HASH_R: problem = lit("#R"); break;
case HASH_N: problem = lit("#N"); break;
case HASH_T: problem = lit("#T"); break;
+ case HASH_J: problem = lit("#J"); break;
case HASH_SEMI: problem = lit("#;"); break;
case HASH_N_EQUALS: problem = lit("#<n>="); break;
case HASH_N_HASH: problem = lit("#<n>#"); break;
@@ -1906,6 +2179,7 @@ void yybadtoken(parser_t *parser, int tok, val context)
case WSPLICE: problem = lit("#*\""); break;
case QWORDS: problem = lit("#`"); break;
case QWSPLICE: problem = lit("#*`"); break;
+ case OLD_AT: problem = lit("@"); break;
}
if (problem != 0)
@@ -1999,8 +2273,11 @@ int parse(parser_t *parser, val name, enum prime_parser prim)
if (parser->errors && parser->syntax_tree == nil &&
parser->lineno != start_line)
{
- yyerrorf(parser->scanner, lit("while parsing form starting at line ~a"),
- num(start_line), nao);
+ cnum curline = parser->lineno;
+ parser->lineno = start_line;
+ yyerrorf(parser->scanner,
+ lit("while parsing expression starting on this line"), nao);
+ parser->lineno = curline;
}
return res;
diff --git a/pdf-clobber-stamps.tl b/pdf-clobber-stamps.tl
new file mode 100644
index 00000000..78ea06c6
--- /dev/null
+++ b/pdf-clobber-stamps.tl
@@ -0,0 +1,22 @@
+(let* ((epoch (or (tointz (getenv "SOURCE_DATE_EPOCH")) 0))
+ (pdf (file-get-string "txr-manpage.pdf"))
+ (start (search-str pdf "<?xpacket begin="))
+ (end (if start (search-str pdf "/Creator(" start)))
+ (xml (if end [pdf start..end]))
+ (orig-len (len xml))
+ (isotime (time-string-utc epoch "%FT%T"))
+ (gstime (time-string-utc epoch "%Y%m%d%H%M%SZ0000")))
+ (unless xml
+ (format *stderr* "XML block not found in PDF")
+ (exit nil))
+ (upd xml
+ (regsub #/uuid:........-....-....-....-............/
+ "uuid:00000000-0000-0000-0000-000000000000")
+ (regsub #/Date>....-..-..T..:..:..(Z|[+\-]..:..)/
+ (ret `Date>@isotime@(if (ends-with "Z" @1) "Z" "+00:00")`))
+ (regsub #/Date\(D:..............[Z+\-]..../
+ `Date(D:@gstime`))
+ (assert (eql (len xml) orig-len))
+ (set [pdf start..end] xml)
+ (file-put-string "txr-manpage.pdf.temp" pdf)
+ (rename-path "txr-manpage.pdf.temp" "txr-manpage.pdf"))
diff --git a/protsym.c b/protsym.c
index 863033c5..5b636f59 100644
--- a/protsym.c
+++ b/protsym.c
@@ -1,6 +1,6 @@
/* This file is generated by genprotsym.txr */
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -8,23 +8,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stddef.h>
@@ -34,119 +35,138 @@
extern val abs_s, accept_s, acos_s, acosh_s, addr_k;
extern val align_s, all_s, alloc_error_s, and_s, append_each_s;
extern val append_each_star_s, append_k, append_s, apply_s, args_k;
-extern val array_s, ash_s, asin_s, asinh_s, assert_s;
-extern val atan2_s, atan_s, atanh_s, atime_k, atime_nsec_s;
-extern val atime_s, atom_s, auto_k, bchar_s, be_double_s;
-extern val be_float_s, be_int16_s, be_int32_s, be_int64_s, be_uint16_s;
-extern val be_uint32_s, be_uint64_s, bignum_s, bind_s, bit_s;
-extern val bitset_s, blksize_k, blksize_s, block_s, block_star_s;
-extern val blocks_k, blocks_s, bool_s, bstr_d_s, bstr_s;
-extern val buf_d_s, buf_s, byte_oriented_k, call_s, car_s;
-extern val carray_s, caseq_s, caseq_star_s, caseql_s, caseql_star_s;
-extern val casequal_s, casequal_star_s, cases_s, cat_s, catch_s;
+extern val args_s, array_s, ash_s, asin_s, asinh_s;
+extern val assert_s, atan2_s, atan_s, atanh_s, atime_k;
+extern val atime_nsec_s, atime_s, atom_s, auto_k, bchar_s;
+extern val be_double_s, be_float_s, be_int16_s, be_int32_s, be_int64_s;
+extern val be_uint16_s, be_uint32_s, be_uint64_s, bignum_s, bind_s;
+extern val bit_s, bitset_s, blksize_k, blksize_s, block_s;
+extern val block_star_s, blocks_k, blocks_s, bool_s, bstr_d_s;
+extern val bstr_s, bstr_s_s, buf_d_s, buf_s, byte_oriented_k;
+extern val call_s, car_s, carray_s, case_error_s, caseq_s;
+extern val caseq_star_s, caseql_s, caseql_star_s, casequal_s, casequal_star_s;
+extern val cases_s, cat_s, catch_frame_s, catch_s, cbrt_s;
extern val cdigit_k, cdr_s, ceil1_s, ceil_s, char_s;
-extern val chars_k, choose_s, chr_s, chset_s, circref_s;
-extern val clear_error_s, close_s, closure_s, cobj_s, coll_s;
-extern val collect_each_s, collect_each_star_s, collect_s, colon_k, compile_only_s;
-extern val compl_s, compound_s, cond_s, cons_s, continue_k;
-extern val continue_s, cos_s, cosh_s, counter_k, cptr_s;
-extern val cset_s, cspace_k, ctime_k, ctime_nsec_s, ctime_s;
+extern val chars_k, child_env_s, choose_s, chr_s, chset_s;
+extern val circref_s, clear_error_s, close_s, closure_s, cobj_s;
+extern val coll_s, collect_each_s, collect_each_star_s, collect_s, colon_k;
+extern val compile_only_s, compiler_let_s, compl_s, compound_s, cond_s;
+extern val cons_s, const_foldable_s, continue_k, continue_s, copysign_s;
+extern val cos_s, cosh_s, counter_k, cptr_s, cset_s;
+extern val cspace_k, ctime_k, ctime_nsec_s, ctime_s, cur_s;
extern val cword_char_k, data_s, day_s, decline_k, defex_s;
extern val deffilter_s, define_s, defmacro_s, defparm_s, defparml_s;
extern val defr_warning_s, defsymacro_s, defun_s, defvar_s, defvarl_s;
-extern val derived_s, dev_k, dev_s, digit_k, div_s;
-extern val do_s, dohash_s, double_s, downcase_k, dst_s;
-extern val dvbind_s, dwim_s, each_op_s, each_s, each_star_s;
-extern val elemtype_s, elif_s, else_s, empty_s, enum_s;
-extern val enumed_s, env_k, env_s, eof_s, eol_s;
-extern val eq_based_k, eq_s, eql_based_k, eql_s, equal_based_k;
-extern val equal_s, error_s, eval_error_s, eval_only_s, evenp_s;
-extern val exp_s, expr_s, expt_s, exptmod_s, fail_s;
-extern val fbind_s, fd_k, ffi_call_desc_s, ffi_closure_s, ffi_type_s;
-extern val file_error_s, fill_buf_s, filter_k, filter_s, filters_s;
-extern val finally_s, finish_k, first_s, fixnum_s, flatten_s;
-extern val flet_s, float_s, floor1_s, floor_s, flush_s;
-extern val for_op_s, for_s, for_star_s, force_s, forget_s;
-extern val form_k, format_s, freeform_s, from_current_k, from_end_k;
-extern val from_list_s, from_start_k, frombase64_k, fromhtml_k, frompercent_k;
-extern val fromurl_k, fun_k, fun_s, fuzz_s, gap_k;
-extern val gather_s, ge_s, gen_s, generate_s, gensym_counter_s;
-extern val get_byte_s, get_char_s, get_error_s, get_error_str_s, get_fd_s;
-extern val get_line_s, get_prop_s, gid_k, gid_s, gmtoff_s;
-extern val greedy_k, gt_s, gun_s, handler_bind_s, hash_construct_s;
-extern val hash_iter_s, hash_lit_s, hash_s, hash_seed_s, hextoint_k;
-extern val hour_s, iapply_s, identity_s, if_s, iflet_s;
-extern val in_package_s, inc_s, include_s, init_k, ino_k;
-extern val ino_s, int16_s, int32_s, int64_s, int8_s;
-extern val int_s, integer_s, internal_error_s, into_k, intr_s;
-extern val inv_div_s, inv_minus_s, isqrt_s, keyword_package_s, labels_s;
-extern val lambda_s, lambda_set_s, last_s, lbind_s, lcons_s;
-extern val le_double_s, le_float_s, le_int16_s, le_int32_s, le_int64_s;
-extern val le_s, le_uint16_s, le_uint32_s, le_uint64_s, length_s;
-extern val less_s, let_s, let_star_s, lfilt_k, line_s;
-extern val lines_k, list_k, list_s, list_star_s, listener_greedy_eval_s;
-extern val listener_hist_len_s, listener_multi_line_p_s, listener_pprint_s, listener_sel_inclusive_p_s, lists_k;
-extern val lit_s, load_path_s, load_recursive_s, load_s, load_time_lit_s;
-extern val load_time_s, local_s, log10_s, log2_s, log_s;
-extern val logand_s, logcount_s, logior_s, lognot1_s, lognot_s;
-extern val logtrunc_s, logxor_s, long_s, longest_k, lstr_s;
-extern val lt_s, mac_param_bind_s, macro_s, macro_time_s, macrolet_s;
-extern val make_struct_lit_s, mandatory_k, maxgap_k, maxtimes_k, maybe_s;
-extern val mdo_s, memq_s, memql_s, memqual_s, merge_s;
-extern val meth_s, min_s, mingap_k, mintimes_k, minus_s;
-extern val minusp_s, mod_s, mode_k, mode_s, modlast_s;
-extern val month_s, mtime_k, mtime_nsec_s, mtime_s, mul_s;
-extern val name_k, name_s, named_k, neg_s, next_s;
-extern val next_spec_k, nlink_k, nlink_s, none_s, nongreedy_s;
+extern val derived_s, dev_k, dev_s, digit_k, dir_s;
+extern val dirent_s, div_s, do_s, dohash_s, double_s;
+extern val downcase_k, drem_s, dst_s, dvbind_s, dwim_s;
+extern val each_op_s, each_s, each_star_s, elemtype_s, elif_s;
+extern val else_s, empty_s, enum_s, enumed_s, env_k;
+extern val env_s, eof_s, eol_s, eq_based_k, eq_s;
+extern val eql_based_k, eql_s, equal_based_k, equal_s, erf_s;
+extern val erfc_s, error_s, eval_error_s, eval_only_s, evenp_s;
+extern val exp10_s, exp2_s, exp_s, expm1_s, expr_s;
+extern val expt_s, exptmod_s, fail_s, fbind_s, fd_k;
+extern val fdim_s, ffi_call_desc_s, ffi_closure_s, ffi_type_s, file_error_s;
+extern val fill_buf_s, filter_k, filter_s, filters_s, finally_s;
+extern val finish_k, first_s, fixnum_s, flatten_s, flet_s;
+extern val float_s, floor1_s, floor_s, flush_s, fmax_s;
+extern val fmin_s, for_op_s, for_s, for_star_s, force_s;
+extern val forget_s, form_k, format_s, freeform_s, from_current_k;
+extern val from_end_k, from_list_s, from_start_k, frombase64_k, frombase64url_k;
+extern val fromhtml_k, frompercent_k, fromurl_k, fun_k, fun_s;
+extern val fuzz_s, gamma_s, gap_k, gather_s, ge_s;
+extern val gen_s, generate_s, gensym_counter_s, get_byte_s, get_char_s;
+extern val get_error_s, get_error_str_s, get_fd_s, get_line_s, get_prop_s;
+extern val gid_k, gid_s, gmtoff_s, greedy_k, gt_s;
+extern val gun_s, handler_bind_s, hash_construct_s, hash_iter_s, hash_lit_s;
+extern val hash_s, hash_seed_s, hextoint_k, hour_s, hypot_s;
+extern val iapply_s, identity_s, if_s, iflet_s, in_package_s;
+extern val inc_s, include_s, init_k, ino_k, ino_s;
+extern val int16_s, int32_s, int64_s, int8_s, int_s;
+extern val integer_s, internal_error_s, into_k, intr_s, inv_div_s;
+extern val inv_minus_s, isqrt_s, iter_begin_s, iter_item_s, iter_more_s;
+extern val iter_reset_s, iter_step_s, j0_s, j1_s, jmp_buf_s;
+extern val jn_s, json_s, keyword_package_s, labels_s, lambda_s;
+extern val lambda_set_s, last_s, lazy_streams_s, lbind_s, lcons_s;
+extern val ldexp_s, le_double_s, le_float_s, le_int16_s, le_int32_s;
+extern val le_int64_s, le_s, le_uint16_s, le_uint32_s, le_uint64_s;
+extern val length_lt_s, length_s, less_s, let_s, let_star_s;
+extern val lfilt_k, lgamma_s, line_s, lines_k, list_k;
+extern val list_s, list_star_s, listener_auto_compound_s, listener_greedy_eval_s, listener_hist_len_s;
+extern val listener_multi_line_p_s, listener_pprint_s, listener_sel_inclusive_p_s, lists_k, lit_s;
+extern val load_args_s, load_hooks_s, load_path_s, load_recursive_s, load_s;
+extern val load_search_dirs_s, load_time_lit_s, load_time_s, local_s, log10_s;
+extern val log1p_s, log2_s, log_s, logand_s, logb_s;
+extern val logcount_s, logior_s, lognot1_s, lognot_s, logtrunc_s;
+extern val logxor_s, long_s, longest_k, lstr_s, lt_s;
+extern val mac_env_param_bind_s, mac_param_bind_s, macro_k, macro_s, macro_time_s;
+extern val macrolet_s, make_struct_lit_s, mandatory_k, max_s, maxgap_k;
+extern val maxtimes_k, maybe_s, mdo_s, memq_s, memql_s;
+extern val memqual_s, merge_s, meth_s, min_s, mingap_k;
+extern val mintimes_k, minus_s, minusp_s, mod_s, mode_k;
+extern val mode_s, modlast_s, month_s, mtime_k, mtime_nsec_s;
+extern val mtime_s, mul_s, name_k, name_s, named_k;
+extern val nearbyint_s, neg_s, next_s, next_spec_k, nextafter_s;
+extern val nlink_k, nlink_s, noclose_k, none_s, nongreedy_s;
extern val not_s, nothrow_k, noval_s, null_s, nullify_s;
extern val number_s, numeq_s, numeric_error_s, oddp_s, oneplus_s;
-extern val op_s, optional_s, or_s, output_s, package_alist_s;
-extern val package_s, panic_s, parser_s, path_exists_s, path_not_found_s;
-extern val path_permission_s, path_s, pkg_s, plus_s, plusp_s;
-extern val postinit_k, pprint_flo_format_s, print_base_s, print_circle_s, print_flo_digits_s;
-extern val print_flo_format_s, print_flo_precision_s, print_s, process_error_s, prof_s;
-extern val prog1_s, progn_s, promise_forced_s, promise_inprogress_s, promise_s;
+extern val op_s, optional_s, or_s, output_s, pack_s;
+extern val package_alist_s, package_s, panic_s, parser_s, path_exists_s;
+extern val path_not_found_s, path_permission_s, path_s, pct_fun_s, pkg_s;
+extern val plus_s, plusp_s, postinit_k, pprint_flo_format_s, print_base_s;
+extern val print_circle_s, print_flo_digits_s, print_flo_format_s, print_flo_precision_s, print_json_format_s;
+extern val print_s, process_error_s, prof_s, prog1_s, prog2_s;
+extern val progn_s, progv_s, promise_forced_s, promise_inprogress_s, promise_s;
extern val ptr_in_d_s, ptr_in_s, ptr_out_d_s, ptr_out_s, ptr_out_s_s;
-extern val ptr_s, put_buf_s, put_byte_s, put_char_s, put_string_s;
-extern val qquote_s, qref_s, quasi_s, quasilist_s, query_error_s;
-extern val quote_s, r_atan2_s, r_ceil_s, r_expt_s, r_floor_s;
-extern val r_lognot_s, r_logtrunc_s, r_mod_s, r_round_s, r_trunc_s;
-extern val random_state_s, random_state_var_s, random_warmup_s, range_error_s, range_s;
-extern val rcons_s, rdev_k, rdev_s, real_time_k, rebind_s;
-extern val rec_source_loc_s, recip_s, reflect_k, regex_s, rep_s;
-extern val repeat_s, repeat_spec_k, require_s, resolve_k, rest_s;
-extern val restart_s, return_from_s, return_s, rfilt_k, round1_s;
-extern val round_s, rplaca_s, rplacd_s, sbit_s, sec_s;
-extern val seek_s, seq_iter_s, sequence_s, set_prop_s, set_s;
-extern val setq_s, setqf_s, short_s, shortest_k, sign_extend_s;
-extern val signum_s, sin_s, single_s, sinh_s, size_k;
-extern val size_s, skip_s, slot_s, some_s, space_k;
-extern val special_s, splice_s, sqrt_s, square_s, stat_s;
+extern val ptr_s, push_s, put_buf_s, put_byte_s, put_char_s;
+extern val put_string_s, qquote_s, qref_s, quasi_s, quasilist_s;
+extern val query_error_s, quote_s, r_atan2_s, r_ceil_s, r_copysign_s;
+extern val r_drem_s, r_expt_s, r_fdim_s, r_floor_s, r_fmax_s;
+extern val r_fmin_s, r_hypot_s, r_jn_s, r_ldexp_s, r_lognot_s;
+extern val r_logtrunc_s, r_mod_s, r_nextafter_s, r_remainder_s, r_round_s;
+extern val r_scalb_s, r_scalbln_s, r_trunc_s, r_yn_s, random_state_s;
+extern val random_state_var_s, random_warmup_s, range_error_s, range_s, rcons_s;
+extern val rdev_k, rdev_s, read_bad_json_s, read_unknown_structs_s, real_time_k;
+extern val rebind_s, rec_source_loc_s, recip_s, reflect_k, regex_s;
+extern val remainder_s, rep_s, repeat_s, repeat_spec_k, require_s;
+extern val resolve_k, rest_s, restart_s, return_from_s, return_s;
+extern val rfilt_k, rint_s, rlim_s, round1_s, round_s;
+extern val rplaca_s, rplacd_s, sbit_s, scalb_s, scalbln_s;
+extern val sec_s, seek_s, self_path_s, seq_iter_s, sequence_s;
+extern val set_prop_s, set_s, setq_s, setqf_s, short_s;
+extern val shortest_k, sign_extend_s, significand_s, signum_s, sin_s;
+extern val single_s, sinh_s, size_k, size_s, skip_s;
+extern val slot_s, some_s, space_k, special_s, splice_s;
+extern val sqrt_s, square_s, stack_overflow_s, standard_k, stat_s;
extern val stddebug_s, stderr_s, stdin_s, stdio_stream_s, stdnull_s;
-extern val stdout_s, str_d_s, str_s, stream_s, string_k;
-extern val string_s, struct_lit_s, struct_s, struct_type_s, switch_s;
-extern val sym_s, symacro_k, symacrolet_s, syntax_error_s, sys_abscond_from_s;
-extern val sys_apply_s, sys_catch_s, sys_l1_setq_s, sys_l1_val_s, sys_lisp1_setq_s;
-extern val sys_lisp1_value_s, sys_mark_special_s, sys_qquote_s, sys_splice_s, sys_unquote_s;
-extern val system_error_s, system_package_s, tan_s, tanh_s, text_s;
-extern val throw_s, time_local_s, time_parse_s, time_s, time_string_s;
-extern val time_utc_s, timeout_error_s, times_k, tlist_k, tnode_s;
-extern val tobase64_k, tofloat_k, tohtml_k, tohtml_star_k, toint_k;
-extern val tonumber_k, topercent_k, tourl_k, trailer_s, tree_bind_s;
-extern val tree_case_s, tree_construct_s, tree_fun_whitelist_s, tree_iter_s, tree_lit_s;
-extern val tree_s, trunc1_s, trunc_s, truncate_s, try_s;
-extern val type_error_s, ubit_s, uchar_s, uid_k, uid_s;
-extern val uint16_s, uint32_s, uint64_s, uint8_s, uint_s;
-extern val ulong_s, unbound_s, unget_byte_s, unget_char_s, union_s;
-extern val unique_s, unquote_s, until_s, until_star_s, upcase_k;
-extern val uref_s, user_package_s, userdata_k, ushort_s, usr_var_s;
-extern val uw_protect_s, val_s, var_k, var_s, vars_k;
-extern val vec_list_s, vec_s, vecref_s, vector_lit_s, vm_closure_s;
-extern val vm_desc_s, void_s, warning_s, wchar_s, weak_keys_k;
-extern val weak_vals_k, when_s, while_s, while_star_s, whole_k;
-extern val width_s, wild_s, word_char_k, wrap_k, wstr_d_s;
-extern val wstr_s, year_s, zap_s, zarray_s, zchar_s;
-extern val zerop_s, zeroplus_s, zone_s;
+extern val stdout_s, str_d_s, str_s, str_s_s, stream_s;
+extern val string_k, string_s, struct_lit_s, struct_s, struct_type_s;
+extern val switch_s, sym_s, symacro_k, symacrolet_s, syntax_error_s;
+extern val sys_abscond_from_s, sys_apply_s, sys_blk_s, sys_catch_s, sys_l1_setq_s;
+extern val sys_l1_val_s, sys_lisp1_setq_s, sys_lisp1_value_s, sys_mark_special_s, sys_qquote_s;
+extern val sys_splice_s, sys_unquote_s, system_error_s, system_package_s, tan_s;
+extern val tanh_s, text_s, tgamma_s, throw_s, time_local_s;
+extern val time_parse_s, time_s, time_string_s, time_utc_s, timeout_error_s;
+extern val times_k, tlist_k, tnode_s, tobase64_k, tobase64url_k;
+extern val tofloat_k, tofloat_s, tohtml_k, tohtml_star_k, toint_k;
+extern val toint_s, tonumber_k, topercent_k, tourl_k, trailer_s;
+extern val tree_bind_s, tree_case_s, tree_construct_s, tree_fun_whitelist_s, tree_iter_s;
+extern val tree_lit_s, tree_s, trunc1_s, trunc_s, truncate_s;
+extern val try_s, type_error_s, ubit_s, uchar_s, uid_k;
+extern val uid_s, uint16_s, uint32_s, uint64_s, uint8_s;
+extern val uint_s, ulong_s, unbound_s, unget_byte_s, unget_char_s;
+extern val union_s, unique_s, unquote_s, until_s, until_star_s;
+extern val upcase_k, uref_s, user_package_s, userdata_k, ushort_s;
+extern val usr_var_s, uw_protect_s, val_s, var_k, var_s;
+extern val vars_k, vec_list_s, vec_s, vecref_s, vector_lit_s;
+extern val vm_closure_s, vm_desc_s, void_s, warning_s, wchar_s;
+extern val wday_s, weak_and_k, weak_keys_k, weak_or_k, weak_vals_k;
+extern val when_s, while_s, while_star_s, whole_k, width_s;
+extern val wild_s, word_char_k, wrap_k, wstr_d_s, wstr_s;
+extern val wstr_s_s, y0_s, y1_s, yday_s, year_s;
+extern val yn_s, zarray_s, zchar_s, zerop_s, zeroplus_s;
+extern val zone_s;
#if HAVE_DLOPEN
extern val dlhandle_s, dlsym_s;
@@ -159,7 +179,10 @@ extern val whence_s;
extern val group_s, mem_s;
#endif
#if HAVE_PWUID
-extern val dir_s, gecos_s, passwd_s, shell_s;
+extern val gecos_s, shell_s;
+#endif
+#if HAVE_PWUID || HAVE_GRGID
+extern val passwd_s;
#endif
#if HAVE_SOCKETS
extern val addr_s, addrinfo_s, canonname_s, family_s, flags_s;
@@ -177,124 +200,146 @@ extern val oflag_s, ospeed_s, termios_s;
extern val domainname_s, machine_s, nodename_s, release_s, sysname_s;
extern val utsname_s, version_s;
#endif
+#if HAVE_ZLIB
+extern val gzio_stream_s;
+#endif
val *protected_sym[] = {
&abs_s, &accept_s, &acos_s, &acosh_s, &addr_k,
&align_s, &all_s, &alloc_error_s, &and_s, &append_each_s,
&append_each_star_s, &append_k, &append_s, &apply_s, &args_k,
- &array_s, &ash_s, &asin_s, &asinh_s, &assert_s,
- &atan2_s, &atan_s, &atanh_s, &atime_k, &atime_nsec_s,
- &atime_s, &atom_s, &auto_k, &bchar_s, &be_double_s,
- &be_float_s, &be_int16_s, &be_int32_s, &be_int64_s, &be_uint16_s,
- &be_uint32_s, &be_uint64_s, &bignum_s, &bind_s, &bit_s,
- &bitset_s, &blksize_k, &blksize_s, &block_s, &block_star_s,
- &blocks_k, &blocks_s, &bool_s, &bstr_d_s, &bstr_s,
- &buf_d_s, &buf_s, &byte_oriented_k, &call_s, &car_s,
- &carray_s, &caseq_s, &caseq_star_s, &caseql_s, &caseql_star_s,
- &casequal_s, &casequal_star_s, &cases_s, &cat_s, &catch_s,
+ &args_s, &array_s, &ash_s, &asin_s, &asinh_s,
+ &assert_s, &atan2_s, &atan_s, &atanh_s, &atime_k,
+ &atime_nsec_s, &atime_s, &atom_s, &auto_k, &bchar_s,
+ &be_double_s, &be_float_s, &be_int16_s, &be_int32_s, &be_int64_s,
+ &be_uint16_s, &be_uint32_s, &be_uint64_s, &bignum_s, &bind_s,
+ &bit_s, &bitset_s, &blksize_k, &blksize_s, &block_s,
+ &block_star_s, &blocks_k, &blocks_s, &bool_s, &bstr_d_s,
+ &bstr_s, &bstr_s_s, &buf_d_s, &buf_s, &byte_oriented_k,
+ &call_s, &car_s, &carray_s, &case_error_s, &caseq_s,
+ &caseq_star_s, &caseql_s, &caseql_star_s, &casequal_s, &casequal_star_s,
+ &cases_s, &cat_s, &catch_frame_s, &catch_s, &cbrt_s,
&cdigit_k, &cdr_s, &ceil1_s, &ceil_s, &char_s,
- &chars_k, &choose_s, &chr_s, &chset_s, &circref_s,
- &clear_error_s, &close_s, &closure_s, &cobj_s, &coll_s,
- &collect_each_s, &collect_each_star_s, &collect_s, &colon_k, &compile_only_s,
- &compl_s, &compound_s, &cond_s, &cons_s, &continue_k,
- &continue_s, &cos_s, &cosh_s, &counter_k, &cptr_s,
- &cset_s, &cspace_k, &ctime_k, &ctime_nsec_s, &ctime_s,
+ &chars_k, &child_env_s, &choose_s, &chr_s, &chset_s,
+ &circref_s, &clear_error_s, &close_s, &closure_s, &cobj_s,
+ &coll_s, &collect_each_s, &collect_each_star_s, &collect_s, &colon_k,
+ &compile_only_s, &compiler_let_s, &compl_s, &compound_s, &cond_s,
+ &cons_s, &const_foldable_s, &continue_k, &continue_s, &copysign_s,
+ &cos_s, &cosh_s, &counter_k, &cptr_s, &cset_s,
+ &cspace_k, &ctime_k, &ctime_nsec_s, &ctime_s, &cur_s,
&cword_char_k, &data_s, &day_s, &decline_k, &defex_s,
&deffilter_s, &define_s, &defmacro_s, &defparm_s, &defparml_s,
&defr_warning_s, &defsymacro_s, &defun_s, &defvar_s, &defvarl_s,
- &derived_s, &dev_k, &dev_s, &digit_k, &div_s,
- &do_s, &dohash_s, &double_s, &downcase_k, &dst_s,
- &dvbind_s, &dwim_s, &each_op_s, &each_s, &each_star_s,
- &elemtype_s, &elif_s, &else_s, &empty_s, &enum_s,
- &enumed_s, &env_k, &env_s, &eof_s, &eol_s,
- &eq_based_k, &eq_s, &eql_based_k, &eql_s, &equal_based_k,
- &equal_s, &error_s, &eval_error_s, &eval_only_s, &evenp_s,
- &exp_s, &expr_s, &expt_s, &exptmod_s, &fail_s,
- &fbind_s, &fd_k, &ffi_call_desc_s, &ffi_closure_s, &ffi_type_s,
- &file_error_s, &fill_buf_s, &filter_k, &filter_s, &filters_s,
- &finally_s, &finish_k, &first_s, &fixnum_s, &flatten_s,
- &flet_s, &float_s, &floor1_s, &floor_s, &flush_s,
- &for_op_s, &for_s, &for_star_s, &force_s, &forget_s,
- &form_k, &format_s, &freeform_s, &from_current_k, &from_end_k,
- &from_list_s, &from_start_k, &frombase64_k, &fromhtml_k, &frompercent_k,
- &fromurl_k, &fun_k, &fun_s, &fuzz_s, &gap_k,
- &gather_s, &ge_s, &gen_s, &generate_s, &gensym_counter_s,
- &get_byte_s, &get_char_s, &get_error_s, &get_error_str_s, &get_fd_s,
- &get_line_s, &get_prop_s, &gid_k, &gid_s, &gmtoff_s,
- &greedy_k, &gt_s, &gun_s, &handler_bind_s, &hash_construct_s,
- &hash_iter_s, &hash_lit_s, &hash_s, &hash_seed_s, &hextoint_k,
- &hour_s, &iapply_s, &identity_s, &if_s, &iflet_s,
- &in_package_s, &inc_s, &include_s, &init_k, &ino_k,
- &ino_s, &int16_s, &int32_s, &int64_s, &int8_s,
- &int_s, &integer_s, &internal_error_s, &into_k, &intr_s,
- &inv_div_s, &inv_minus_s, &isqrt_s, &keyword_package_s, &labels_s,
- &lambda_s, &lambda_set_s, &last_s, &lbind_s, &lcons_s,
- &le_double_s, &le_float_s, &le_int16_s, &le_int32_s, &le_int64_s,
- &le_s, &le_uint16_s, &le_uint32_s, &le_uint64_s, &length_s,
- &less_s, &let_s, &let_star_s, &lfilt_k, &line_s,
- &lines_k, &list_k, &list_s, &list_star_s, &listener_greedy_eval_s,
- &listener_hist_len_s, &listener_multi_line_p_s, &listener_pprint_s, &listener_sel_inclusive_p_s, &lists_k,
- &lit_s, &load_path_s, &load_recursive_s, &load_s, &load_time_lit_s,
- &load_time_s, &local_s, &log10_s, &log2_s, &log_s,
- &logand_s, &logcount_s, &logior_s, &lognot1_s, &lognot_s,
- &logtrunc_s, &logxor_s, &long_s, &longest_k, &lstr_s,
- &lt_s, &mac_param_bind_s, &macro_s, &macro_time_s, &macrolet_s,
- &make_struct_lit_s, &mandatory_k, &maxgap_k, &maxtimes_k, &maybe_s,
- &mdo_s, &memq_s, &memql_s, &memqual_s, &merge_s,
- &meth_s, &min_s, &mingap_k, &mintimes_k, &minus_s,
- &minusp_s, &mod_s, &mode_k, &mode_s, &modlast_s,
- &month_s, &mtime_k, &mtime_nsec_s, &mtime_s, &mul_s,
- &name_k, &name_s, &named_k, &neg_s, &next_s,
- &next_spec_k, &nlink_k, &nlink_s, &none_s, &nongreedy_s,
+ &derived_s, &dev_k, &dev_s, &digit_k, &dir_s,
+ &dirent_s, &div_s, &do_s, &dohash_s, &double_s,
+ &downcase_k, &drem_s, &dst_s, &dvbind_s, &dwim_s,
+ &each_op_s, &each_s, &each_star_s, &elemtype_s, &elif_s,
+ &else_s, &empty_s, &enum_s, &enumed_s, &env_k,
+ &env_s, &eof_s, &eol_s, &eq_based_k, &eq_s,
+ &eql_based_k, &eql_s, &equal_based_k, &equal_s, &erf_s,
+ &erfc_s, &error_s, &eval_error_s, &eval_only_s, &evenp_s,
+ &exp10_s, &exp2_s, &exp_s, &expm1_s, &expr_s,
+ &expt_s, &exptmod_s, &fail_s, &fbind_s, &fd_k,
+ &fdim_s, &ffi_call_desc_s, &ffi_closure_s, &ffi_type_s, &file_error_s,
+ &fill_buf_s, &filter_k, &filter_s, &filters_s, &finally_s,
+ &finish_k, &first_s, &fixnum_s, &flatten_s, &flet_s,
+ &float_s, &floor1_s, &floor_s, &flush_s, &fmax_s,
+ &fmin_s, &for_op_s, &for_s, &for_star_s, &force_s,
+ &forget_s, &form_k, &format_s, &freeform_s, &from_current_k,
+ &from_end_k, &from_list_s, &from_start_k, &frombase64_k, &frombase64url_k,
+ &fromhtml_k, &frompercent_k, &fromurl_k, &fun_k, &fun_s,
+ &fuzz_s, &gamma_s, &gap_k, &gather_s, &ge_s,
+ &gen_s, &generate_s, &gensym_counter_s, &get_byte_s, &get_char_s,
+ &get_error_s, &get_error_str_s, &get_fd_s, &get_line_s, &get_prop_s,
+ &gid_k, &gid_s, &gmtoff_s, &greedy_k, &gt_s,
+ &gun_s, &handler_bind_s, &hash_construct_s, &hash_iter_s, &hash_lit_s,
+ &hash_s, &hash_seed_s, &hextoint_k, &hour_s, &hypot_s,
+ &iapply_s, &identity_s, &if_s, &iflet_s, &in_package_s,
+ &inc_s, &include_s, &init_k, &ino_k, &ino_s,
+ &int16_s, &int32_s, &int64_s, &int8_s, &int_s,
+ &integer_s, &internal_error_s, &into_k, &intr_s, &inv_div_s,
+ &inv_minus_s, &isqrt_s, &iter_begin_s, &iter_item_s, &iter_more_s,
+ &iter_reset_s, &iter_step_s, &j0_s, &j1_s, &jmp_buf_s,
+ &jn_s, &json_s, &keyword_package_s, &labels_s, &lambda_s,
+ &lambda_set_s, &last_s, &lazy_streams_s, &lbind_s, &lcons_s,
+ &ldexp_s, &le_double_s, &le_float_s, &le_int16_s, &le_int32_s,
+ &le_int64_s, &le_s, &le_uint16_s, &le_uint32_s, &le_uint64_s,
+ &length_lt_s, &length_s, &less_s, &let_s, &let_star_s,
+ &lfilt_k, &lgamma_s, &line_s, &lines_k, &list_k,
+ &list_s, &list_star_s, &listener_auto_compound_s, &listener_greedy_eval_s, &listener_hist_len_s,
+ &listener_multi_line_p_s, &listener_pprint_s, &listener_sel_inclusive_p_s, &lists_k, &lit_s,
+ &load_args_s, &load_hooks_s, &load_path_s, &load_recursive_s, &load_s,
+ &load_search_dirs_s, &load_time_lit_s, &load_time_s, &local_s, &log10_s,
+ &log1p_s, &log2_s, &log_s, &logand_s, &logb_s,
+ &logcount_s, &logior_s, &lognot1_s, &lognot_s, &logtrunc_s,
+ &logxor_s, &long_s, &longest_k, &lstr_s, &lt_s,
+ &mac_env_param_bind_s, &mac_param_bind_s, &macro_k, &macro_s, &macro_time_s,
+ &macrolet_s, &make_struct_lit_s, &mandatory_k, &max_s, &maxgap_k,
+ &maxtimes_k, &maybe_s, &mdo_s, &memq_s, &memql_s,
+ &memqual_s, &merge_s, &meth_s, &min_s, &mingap_k,
+ &mintimes_k, &minus_s, &minusp_s, &mod_s, &mode_k,
+ &mode_s, &modlast_s, &month_s, &mtime_k, &mtime_nsec_s,
+ &mtime_s, &mul_s, &name_k, &name_s, &named_k,
+ &nearbyint_s, &neg_s, &next_s, &next_spec_k, &nextafter_s,
+ &nlink_k, &nlink_s, &noclose_k, &none_s, &nongreedy_s,
&not_s, &nothrow_k, &noval_s, &null_s, &nullify_s,
&number_s, &numeq_s, &numeric_error_s, &oddp_s, &oneplus_s,
- &op_s, &optional_s, &or_s, &output_s, &package_alist_s,
- &package_s, &panic_s, &parser_s, &path_exists_s, &path_not_found_s,
- &path_permission_s, &path_s, &pkg_s, &plus_s, &plusp_s,
- &postinit_k, &pprint_flo_format_s, &print_base_s, &print_circle_s, &print_flo_digits_s,
- &print_flo_format_s, &print_flo_precision_s, &print_s, &process_error_s, &prof_s,
- &prog1_s, &progn_s, &promise_forced_s, &promise_inprogress_s, &promise_s,
+ &op_s, &optional_s, &or_s, &output_s, &pack_s,
+ &package_alist_s, &package_s, &panic_s, &parser_s, &path_exists_s,
+ &path_not_found_s, &path_permission_s, &path_s, &pct_fun_s, &pkg_s,
+ &plus_s, &plusp_s, &postinit_k, &pprint_flo_format_s, &print_base_s,
+ &print_circle_s, &print_flo_digits_s, &print_flo_format_s, &print_flo_precision_s, &print_json_format_s,
+ &print_s, &process_error_s, &prof_s, &prog1_s, &prog2_s,
+ &progn_s, &progv_s, &promise_forced_s, &promise_inprogress_s, &promise_s,
&ptr_in_d_s, &ptr_in_s, &ptr_out_d_s, &ptr_out_s, &ptr_out_s_s,
- &ptr_s, &put_buf_s, &put_byte_s, &put_char_s, &put_string_s,
- &qquote_s, &qref_s, &quasi_s, &quasilist_s, &query_error_s,
- &quote_s, &r_atan2_s, &r_ceil_s, &r_expt_s, &r_floor_s,
- &r_lognot_s, &r_logtrunc_s, &r_mod_s, &r_round_s, &r_trunc_s,
- &random_state_s, &random_state_var_s, &random_warmup_s, &range_error_s, &range_s,
- &rcons_s, &rdev_k, &rdev_s, &real_time_k, &rebind_s,
- &rec_source_loc_s, &recip_s, &reflect_k, &regex_s, &rep_s,
- &repeat_s, &repeat_spec_k, &require_s, &resolve_k, &rest_s,
- &restart_s, &return_from_s, &return_s, &rfilt_k, &round1_s,
- &round_s, &rplaca_s, &rplacd_s, &sbit_s, &sec_s,
- &seek_s, &seq_iter_s, &sequence_s, &set_prop_s, &set_s,
- &setq_s, &setqf_s, &short_s, &shortest_k, &sign_extend_s,
- &signum_s, &sin_s, &single_s, &sinh_s, &size_k,
- &size_s, &skip_s, &slot_s, &some_s, &space_k,
- &special_s, &splice_s, &sqrt_s, &square_s, &stat_s,
+ &ptr_s, &push_s, &put_buf_s, &put_byte_s, &put_char_s,
+ &put_string_s, &qquote_s, &qref_s, &quasi_s, &quasilist_s,
+ &query_error_s, &quote_s, &r_atan2_s, &r_ceil_s, &r_copysign_s,
+ &r_drem_s, &r_expt_s, &r_fdim_s, &r_floor_s, &r_fmax_s,
+ &r_fmin_s, &r_hypot_s, &r_jn_s, &r_ldexp_s, &r_lognot_s,
+ &r_logtrunc_s, &r_mod_s, &r_nextafter_s, &r_remainder_s, &r_round_s,
+ &r_scalb_s, &r_scalbln_s, &r_trunc_s, &r_yn_s, &random_state_s,
+ &random_state_var_s, &random_warmup_s, &range_error_s, &range_s, &rcons_s,
+ &rdev_k, &rdev_s, &read_bad_json_s, &read_unknown_structs_s, &real_time_k,
+ &rebind_s, &rec_source_loc_s, &recip_s, &reflect_k, &regex_s,
+ &remainder_s, &rep_s, &repeat_s, &repeat_spec_k, &require_s,
+ &resolve_k, &rest_s, &restart_s, &return_from_s, &return_s,
+ &rfilt_k, &rint_s, &rlim_s, &round1_s, &round_s,
+ &rplaca_s, &rplacd_s, &sbit_s, &scalb_s, &scalbln_s,
+ &sec_s, &seek_s, &self_path_s, &seq_iter_s, &sequence_s,
+ &set_prop_s, &set_s, &setq_s, &setqf_s, &short_s,
+ &shortest_k, &sign_extend_s, &significand_s, &signum_s, &sin_s,
+ &single_s, &sinh_s, &size_k, &size_s, &skip_s,
+ &slot_s, &some_s, &space_k, &special_s, &splice_s,
+ &sqrt_s, &square_s, &stack_overflow_s, &standard_k, &stat_s,
&stddebug_s, &stderr_s, &stdin_s, &stdio_stream_s, &stdnull_s,
- &stdout_s, &str_d_s, &str_s, &stream_s, &string_k,
- &string_s, &struct_lit_s, &struct_s, &struct_type_s, &switch_s,
- &sym_s, &symacro_k, &symacrolet_s, &syntax_error_s, &sys_abscond_from_s,
- &sys_apply_s, &sys_catch_s, &sys_l1_setq_s, &sys_l1_val_s, &sys_lisp1_setq_s,
- &sys_lisp1_value_s, &sys_mark_special_s, &sys_qquote_s, &sys_splice_s, &sys_unquote_s,
- &system_error_s, &system_package_s, &tan_s, &tanh_s, &text_s,
- &throw_s, &time_local_s, &time_parse_s, &time_s, &time_string_s,
- &time_utc_s, &timeout_error_s, &times_k, &tlist_k, &tnode_s,
- &tobase64_k, &tofloat_k, &tohtml_k, &tohtml_star_k, &toint_k,
- &tonumber_k, &topercent_k, &tourl_k, &trailer_s, &tree_bind_s,
- &tree_case_s, &tree_construct_s, &tree_fun_whitelist_s, &tree_iter_s, &tree_lit_s,
- &tree_s, &trunc1_s, &trunc_s, &truncate_s, &try_s,
- &type_error_s, &ubit_s, &uchar_s, &uid_k, &uid_s,
- &uint16_s, &uint32_s, &uint64_s, &uint8_s, &uint_s,
- &ulong_s, &unbound_s, &unget_byte_s, &unget_char_s, &union_s,
- &unique_s, &unquote_s, &until_s, &until_star_s, &upcase_k,
- &uref_s, &user_package_s, &userdata_k, &ushort_s, &usr_var_s,
- &uw_protect_s, &val_s, &var_k, &var_s, &vars_k,
- &vec_list_s, &vec_s, &vecref_s, &vector_lit_s, &vm_closure_s,
- &vm_desc_s, &void_s, &warning_s, &wchar_s, &weak_keys_k,
- &weak_vals_k, &when_s, &while_s, &while_star_s, &whole_k,
- &width_s, &wild_s, &word_char_k, &wrap_k, &wstr_d_s,
- &wstr_s, &year_s, &zap_s, &zarray_s, &zchar_s,
- &zerop_s, &zeroplus_s, &zone_s,
+ &stdout_s, &str_d_s, &str_s, &str_s_s, &stream_s,
+ &string_k, &string_s, &struct_lit_s, &struct_s, &struct_type_s,
+ &switch_s, &sym_s, &symacro_k, &symacrolet_s, &syntax_error_s,
+ &sys_abscond_from_s, &sys_apply_s, &sys_blk_s, &sys_catch_s, &sys_l1_setq_s,
+ &sys_l1_val_s, &sys_lisp1_setq_s, &sys_lisp1_value_s, &sys_mark_special_s, &sys_qquote_s,
+ &sys_splice_s, &sys_unquote_s, &system_error_s, &system_package_s, &tan_s,
+ &tanh_s, &text_s, &tgamma_s, &throw_s, &time_local_s,
+ &time_parse_s, &time_s, &time_string_s, &time_utc_s, &timeout_error_s,
+ &times_k, &tlist_k, &tnode_s, &tobase64_k, &tobase64url_k,
+ &tofloat_k, &tofloat_s, &tohtml_k, &tohtml_star_k, &toint_k,
+ &toint_s, &tonumber_k, &topercent_k, &tourl_k, &trailer_s,
+ &tree_bind_s, &tree_case_s, &tree_construct_s, &tree_fun_whitelist_s, &tree_iter_s,
+ &tree_lit_s, &tree_s, &trunc1_s, &trunc_s, &truncate_s,
+ &try_s, &type_error_s, &ubit_s, &uchar_s, &uid_k,
+ &uid_s, &uint16_s, &uint32_s, &uint64_s, &uint8_s,
+ &uint_s, &ulong_s, &unbound_s, &unget_byte_s, &unget_char_s,
+ &union_s, &unique_s, &unquote_s, &until_s, &until_star_s,
+ &upcase_k, &uref_s, &user_package_s, &userdata_k, &ushort_s,
+ &usr_var_s, &uw_protect_s, &val_s, &var_k, &var_s,
+ &vars_k, &vec_list_s, &vec_s, &vecref_s, &vector_lit_s,
+ &vm_closure_s, &vm_desc_s, &void_s, &warning_s, &wchar_s,
+ &wday_s, &weak_and_k, &weak_keys_k, &weak_or_k, &weak_vals_k,
+ &when_s, &while_s, &while_star_s, &whole_k, &width_s,
+ &wild_s, &word_char_k, &wrap_k, &wstr_d_s, &wstr_s,
+ &wstr_s_s, &y0_s, &y1_s, &yday_s, &year_s,
+ &yn_s, &zarray_s, &zchar_s, &zerop_s, &zeroplus_s,
+ &zone_s,
#if HAVE_DLOPEN
&dlhandle_s, &dlsym_s,
@@ -307,7 +352,10 @@ val *protected_sym[] = {
&group_s, &mem_s,
#endif
#if HAVE_PWUID
- &dir_s, &gecos_s, &passwd_s, &shell_s,
+ &gecos_s, &shell_s,
+#endif
+#if HAVE_PWUID || HAVE_GRGID
+ &passwd_s,
#endif
#if HAVE_SOCKETS
&addr_s, &addrinfo_s, &canonname_s, &family_s, &flags_s,
@@ -325,5 +373,8 @@ val *protected_sym[] = {
&domainname_s, &machine_s, &nodename_s, &release_s, &sysname_s,
&utsname_s, &version_s,
#endif
+#if HAVE_ZLIB
+ &gzio_stream_s,
+#endif
convert(val *, 0)
};
diff --git a/psquare.c b/psquare.c
new file mode 100644
index 00000000..0a1dfb05
--- /dev/null
+++ b/psquare.c
@@ -0,0 +1,169 @@
+#include <stddef.h>
+#include <wchar.h>
+#include <limits.h>
+#include <string.h>
+#include <stdlib.h>
+#include <stdarg.h>
+#include <signal.h>
+#include <stdio.h>
+#include <math.h>
+#include "config.h"
+#include "lib.h"
+#include "signal.h"
+#include "unwind.h"
+#include "psquare.h"
+
+static void psq_reset(struct psquare *psq)
+{
+ double p = psq->p;
+
+ psq->n[0] = 1;
+ psq->n[1] = 2;
+ psq->n[2] = 3;
+ psq->n[3] = 4;
+ psq->n[4] = 5;
+
+ psq->wn[0] = 1.0;
+ psq->wn[1] = 1.0 + 2.0 * p;
+ psq->wn[2] = 1.0 + 4.0 * p;
+ psq->wn[3] = 3.0 + 2.0 * p;
+ psq->wn[4] = 5.0;
+
+ psq->dn[1] = p / 2.0;
+ psq->dn[2] = p;
+ psq->dn[3] = (1.0 + p) / 2.0;
+ psq->dn[4] = 1.0;
+}
+
+void psq_init(struct psquare *psq, double p)
+{
+ memset(psq, 0, sizeof *psq);
+ psq->p = p;
+ psq_reset(psq);
+}
+
+void psq_init_grouped(struct psquare *psq, double p,
+ ucnum grsize, double rate)
+{
+ psq_init(psq, p);
+ psq->type = psq_grouped;
+ psq->grsize = grsize;
+ psq->rate = rate;
+ psq->blend = 1.0;
+}
+
+static int dbl_cmp(const void *lp, const void *rp)
+{
+ double ln = *coerce(const double *, lp);
+ double rn = *coerce(const double *, rp);
+
+ if (ln < rn)
+ return -1;
+ if (ln > rn)
+ return 1;
+ return 0;
+}
+
+void psq_add_sample(struct psquare *psq, double s, val self)
+{
+ ucnum c = psq->count++;
+
+ if (psq->type == psq_grouped && c >= psq->grsize) {
+ psq->prev = psq_get_estimate(psq);
+ psq->blending = 1;
+ psq->count = 1;
+ psq_reset(psq);
+ c = 0;
+ }
+
+ if (c < 5) {
+ psq->q[c] = s;
+ } else {
+ int k = 0, i;
+
+ if (c == 5)
+ qsort(psq->q, c, sizeof psq->q[0], dbl_cmp);
+
+ if (s < psq->q[0]) {
+ psq->q[0] = s;
+ } else if (psq->q[4] <= s) {
+ psq->q[4] = s;
+ k = 3;
+ } else for (k = 0; k < 4; k++) {
+ if (psq->q[k] <= s && s < psq->q[k + 1])
+ break;
+ }
+
+ if (psq->n[4] == INT_PTR_MAX)
+ uw_throwf(numeric_error_s, lit("~a: sample capacity overflow"),
+ self, nao);
+
+ for (i = k + 1; i < 5; i++)
+ psq->n[i]++;
+
+ for (i = 0; i < 5; i++)
+ psq->wn[i] += psq->dn[i];
+
+ for (i = 1; i <= 3; i++) {
+ double d = psq->wn[i] - psq->n[i];
+ double ds = psq->n[i + 1] - psq->n[i];
+ double dp = psq->n[i - 1] - psq->n[i];
+
+ if ((d >= 1 && ds > 1) || (d <= -1 && dp < -1)) {
+ int sgd = d < 0 ? -1 : 1;
+ double qs = (psq->q[i + 1] - psq->q[i]) / ds;
+ double qp = (psq->q[i - 1] - psq->q[i]) / dp;
+ double q = psq->q[i] + sgd/(ds - dp)*((sgd - dp)*qs + (ds - sgd)*qp);
+
+ if (psq->q[i - 1] < q && q < psq->q[i + 1]) {
+ psq->q[i] = q;
+ } else {
+ if (d > 0)
+ psq->q[i] += qs;
+ else if (d < 0)
+ psq->q[i] -= qp;
+ }
+
+ psq->n[i] += sgd;
+ }
+ }
+ }
+
+ if (psq->blending)
+ psq->blend *= psq->rate;
+}
+
+double psq_get_estimate(struct psquare *psq)
+{
+ ucnum c = psq->count;
+ double est;
+
+ if (c > 2 && c < 5)
+ qsort(psq->q, c, sizeof psq->q[0], dbl_cmp);
+
+ switch (psq->count) {
+ case 0:
+ est = 0.0;
+ break;
+ case 1:
+ est = psq->q[0];
+ break;
+ case 2:
+ est = psq->q[0] + (psq->q[1] - psq->q[0]) / 2;
+ break;
+ case 3:
+ est = psq->q[1];
+ break;
+ case 4:
+ est = psq->q[1] + (psq->q[2] - psq->q[1]) / 2;
+ break;
+ default:
+ est = psq->q[2];
+ break;
+ }
+
+ if (!psq->blending)
+ return est;
+
+ return psq->blend * psq->prev + (1 - psq->blend) * est;
+}
diff --git a/psquare.h b/psquare.h
new file mode 100644
index 00000000..d09abd30
--- /dev/null
+++ b/psquare.h
@@ -0,0 +1,54 @@
+/* Copyright 2021-2024
+ * Kaz Kylheku <kaz@kylheku.com>
+ * Vancouver, Canada
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ */
+
+enum psq_type {
+ psq_regular,
+ psq_grouped
+};
+
+struct psquare {
+ enum psq_type type;
+ double p;
+ double q[5];
+ double wn[5];
+ double dn[5];
+ cnum n[5];
+ ucnum count;
+ /* psq_grouped fields */
+ ucnum grsize;
+ double prev;
+ double rate;
+ double blend;
+ int blending;
+};
+
+void psq_init(struct psquare *, double p);
+void psq_init_grouped(struct psquare *, double p,
+ ucnum grsize, double rate);
+void psq_add_sample(struct psquare *, double s, val self);
+double psq_get_estimate(struct psquare *);
diff --git a/rand.c b/rand.c
index 18ea62a2..7539714b 100644
--- a/rand.c
+++ b/rand.c
@@ -1,4 +1,4 @@
-/* Copyright 2010-2020
+/* Copyright 2010-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,31 +6,32 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <string.h>
#include <wctype.h>
-#include <stdarg.h>
#include <wchar.h>
#include <limits.h>
#include <signal.h>
+#include <math.h>
#include "config.h"
#if HAVE_UNISTD_H
#include <unistd.h>
@@ -39,8 +40,13 @@
#include "signal.h"
#include "unwind.h"
#include "arith.h"
-#include "rand.h"
#include "eval.h"
+#include "time.h"
+#include "buf.h"
+#include "txr.h"
+#include "itypes.h"
+#include "gc.h"
+#include "rand.h"
#define random_warmup (deref(lookup_var_l(nil, random_warmup_s)))
@@ -51,7 +57,7 @@ typedef unsigned long rand32_t;
#endif
/*
- * The algorithm here is WELL 512.
+ * The algorithm here is WELL512a.
* (Francois Panneton, Pierre L'Ecuyer.)
*/
struct rand_state {
@@ -61,6 +67,8 @@ struct rand_state {
val random_state_s, random_state_var_s, random_warmup_s;
+struct cobj_class *random_state_cls;
+
static struct cobj_ops random_state_ops = cobj_ops_init(eq,
cobj_print_op,
cobj_destroy_free_op,
@@ -78,12 +86,12 @@ static rand32_t rand_tab[16] = {
static val make_state(void)
{
struct rand_state *r = coerce(struct rand_state *, chk_malloc(sizeof *r));
- return cobj(coerce(mem_t *, r), random_state_s, &random_state_ops);
+ return cobj(coerce(mem_t *, r), random_state_cls, &random_state_ops);
}
val random_state_p(val obj)
{
- return cobjclassp(obj, random_state_s);
+ return cobjclassp(obj, random_state_cls);
}
INLINE rand32_t *rstate(struct rand_state *r, int offs)
@@ -91,7 +99,7 @@ INLINE rand32_t *rstate(struct rand_state *r, int offs)
return &r->state[(r->cur + offs) % 16];
}
-static rand32_t rand32(struct rand_state *r)
+static rand32_t rand32_bug(struct rand_state *r)
{
rand32_t s0 = *rstate(r, 0);
rand32_t s9 = *rstate(r, 9);
@@ -110,13 +118,33 @@ static rand32_t rand32(struct rand_state *r)
return ns15;
}
+static rand32_t rand32_good(struct rand_state *r)
+{
+ rand32_t s0 = *rstate(r, 0);
+ rand32_t s9 = *rstate(r, 9);
+ rand32_t s13 = *rstate(r, 13);
+ rand32_t s15 = *rstate(r, 15);
+
+ rand32_t r1 = s0 ^ (s0 << 16) ^ s13 ^ (s13 << 15);
+ rand32_t r2 = s9 ^ (s9 >> 11);
+
+ rand32_t ns0 = *rstate(r, 0) = r1 ^ r2;
+ rand32_t ns15 = s15 ^ (s15 << 2) ^ r1 ^ (r1 << 18) ^ (r2 << 28) ^
+ (ns0 ^ ((ns0 << 5) & 0xDA442D24UL));
+
+ *rstate(r, 15) = ns15;
+ r->cur = (r->cur + 15) % 16;
+ return ns15;
+}
+
+static rand32_t (*rand32)(struct rand_state *) = rand32_good;
+
val make_random_state(val seed, val warmup)
{
val self = lit("make-random-state");
val rs = make_state();
int i = 0;
- struct rand_state *r = coerce(struct rand_state *,
- cobj_handle(self, rs, random_state_s));
+ struct rand_state *r = coerce(struct rand_state *, rs->co.handle);
seed = default_null_arg(seed);
warmup = default_null_arg(warmup);
@@ -132,7 +160,7 @@ val make_random_state(val seed, val warmup)
dig++, bit = 0;
}
} else if (fixnump(seed)) {
- cnum s = c_num(seed) & NUM_MAX;
+ cnum s = c_num(seed, self) & NUM_MAX;
r->state[0] = s & 0xFFFFFFFFul;
i = 1;
@@ -144,9 +172,9 @@ val make_random_state(val seed, val warmup)
#error port me!
#endif
} else if (nilp(seed)) {
- val time = time_sec_usec();
- r->state[0] = convert(rand32_t, c_num(car(time)));
- r->state[1] = convert(rand32_t, c_num(cdr(time)));
+ val time = time_sec_nsec();
+ r->state[0] = convert(rand32_t, c_num(car(time), self));
+ r->state[1] = convert(rand32_t, c_num(cdr(time), self));
#if HAVE_UNISTD_H
r->state[2] = convert(rand32_t, getpid());
i = 3;
@@ -155,22 +183,60 @@ val make_random_state(val seed, val warmup)
#endif
} else if (random_state_p(seed)) {
struct rand_state *rseed = coerce(struct rand_state *,
- cobj_handle(self, seed, random_state_s));
+ cobj_handle(self, seed, random_state_cls));
*r = *rseed;
return rs;
} else if (vectorp(seed)) {
if (length(seed) < num_fast(17))
- uw_throwf(error_s, lit("make-random-state: vector ~s too short"),
- seed, nao);
+ uw_throwf(error_s, lit("~a: vector ~s too short"),
+ self, seed, nao);
for (i = 0; i < 16; i++)
- r->state[i] = c_unum(seed->v.vec[i]);
+ r->state[i] = c_unum(seed->v.vec[i], self);
- r->cur = c_num(seed->v.vec[i]);
+ r->cur = c_num(seed->v.vec[i], self);
return rs;
+ } else if (bufp(seed)) {
+ ucnum len = c_unum(seed->b.len, self);
+ mem_t *data = seed->b.data;
+
+ for (i = 0; i < 16; i++) {
+ if (len >= 4) {
+ r->state[i] = ((convert(rand32_t, data[0])) << 24 |
+ (convert(rand32_t, data[1])) << 16 |
+ (convert(rand32_t, data[2])) << 8 |
+ (convert(rand32_t, data[3])));
+ data += 4;
+ len -= 4;
+ } else if (len == 0) {
+ r->state[i] = 0;
+ } else {
+ switch (len % 4) {
+ case 0:
+ r->state[i] = 0;
+ len = 0;
+ break;
+ case 1:
+ r->state[i] = ((convert(rand32_t, data[0])) << 24);
+ len = 0;
+ break;
+ case 2:
+ r->state[i] = ((convert(rand32_t, data[0])) << 24 |
+ (convert(rand32_t, data[1])) << 16);
+ len = 0;
+ break;
+ case 3:
+ r->state[i] = ((convert(rand32_t, data[0])) << 24 |
+ (convert(rand32_t, data[1])) << 16 |
+ (convert(rand32_t, data[2])) << 8);
+ len = 0;
+ break;
+ }
+ }
+ }
} else {
- uw_throwf(error_s, lit("make-random-state: seed ~s is not a number"),
- seed, nao);
+ uw_throwf(error_s, lit("~a: unable to seed random state with ~s"),
+ self, seed, nao);
}
while (i > 0 && r->state[i - 1] == 0)
@@ -183,7 +249,7 @@ val make_random_state(val seed, val warmup)
{
uses_or2;
- cnum wu = c_num(or2(warmup, random_warmup));
+ cnum wu = c_num(or2(warmup, random_warmup), self);
for (i = 0; i < wu; i++)
(void) rand32(r);
@@ -198,7 +264,7 @@ val random_state_get_vec(val state)
struct rand_state *r = coerce(struct rand_state *,
cobj_handle(self,
default_arg(state, random_state),
- random_state_s));
+ random_state_cls));
int i;
val vec = vector(num_fast(17), nil);
@@ -216,17 +282,17 @@ val random_fixnum(val state)
struct rand_state *r = coerce(struct rand_state *,
cobj_handle(self,
default_arg(state, random_state),
- random_state_s));
+ random_state_cls));
return num(rand32(r) & NUM_MAX);
}
-static val random_float(val state)
+static double random_float_impl(val state)
{
val self = lit("random-float");
struct rand_state *r = coerce(struct rand_state *,
cobj_handle(self,
default_arg(state, random_state),
- random_state_s));
+ random_state_cls));
union hack {
volatile double d;
struct {
@@ -245,21 +311,64 @@ static val random_float(val state)
* this subtraction, reducing us to 51 bits of precision.
* Still; an attractive approach.
*/
- return flo(h.d - 1.0);
+ return h.d - 1.0;
+}
+
+static val random_float(val state)
+{
+ return flo(random_float_impl(state));
+}
+
+static val random_float_incl(val state)
+{
+ val self = lit("random-float-incl");
+ struct rand_state *r = coerce(struct rand_state *,
+ cobj_handle(self,
+ default_arg(state, random_state),
+ random_state_cls));
+ union hack {
+ volatile double d;
+ struct {
+#if HAVE_LITTLE_ENDIAN
+ volatile rand32_t lo, hi;
+#else
+ volatile rand32_t hi, lo;
+#endif
+ } r;
+ } h;
+
+ h.r.lo = rand32(r);
+
+ for (;;) {
+ rand32_t hi = rand32(r) & 0x1FFFFF;
+ rand32_t lo = rand32(r);
+
+ if (hi == 0x100000 && lo == 0)
+ return flo(1.0);
+
+ if ((hi & 0x100000) != 0)
+ continue;
+
+ h.r.hi = (hi & 0xFFFFF) | (1023UL << 20);
+
+ return flo(h.d - 1.0);
+ }
}
val random(val state, val modulus)
{
val self = lit("random");
struct rand_state *r = coerce(struct rand_state *,
- cobj_handle(self, state, random_state_s));
+ cobj_handle(self, state, random_state_cls));
mp_int *m;
if (bignump(modulus) && !mp_isneg(m = mp(modulus))) {
ucnum bits = mp_count_bits(m) - mp_is_pow_two(m);
ucnum rands_needed = (bits + 32 - 1) / 32;
ucnum msb_rand_bits = bits % 32;
- rand32_t msb_rand_mask = convert(rand32_t, -1) >> (32 - msb_rand_bits);
+ rand32_t msb_rand_mask = convert(rand32_t, -1) >> (msb_rand_bits
+ ? 32 - msb_rand_bits
+ : 0);
val out = make_bignum();
mp_int *om = mp(out);
@@ -299,16 +408,16 @@ val random(val state, val modulus)
return normalize(out);
} else if (fixnump(modulus)) {
- cnum m = c_num(modulus);
+ cnum m = c_num(modulus, self);
if (m == 1) {
return zero;
} else if (m > 1) {
- int bits = highest_bit(m - 1);
+ unsigned bits = highest_bit(m - 1);
#if CHAR_BIT * SIZEOF_PTR >= 64
ucnum rands_needed = (bits + 32 - 1) / 32;
#endif
- ucnum msb_rand_bits = bits % 32;
- rand32_t msb_rand_mask = convert(rand32_t, -1) >> (32 - msb_rand_bits);
+ ucnum msb_rand_bit_shift = (- bits) % 32;
+ rand32_t msb_rand_mask = convert(rand32_t, -1) >> msb_rand_bit_shift;
for (;;) {
cnum out = 0;
#if CHAR_BIT * SIZEOF_PTR >= 64
@@ -331,8 +440,8 @@ val random(val state, val modulus)
}
}
- uw_throwf(numeric_error_s, lit("random: invalid modulus ~s"),
- modulus, nao);
+ uw_throwf(numeric_error_s, lit("~a: invalid modulus ~s"),
+ self, modulus, nao);
}
val rnd(val modulus, val state)
@@ -341,23 +450,128 @@ val rnd(val modulus, val state)
return random(state, modulus);
}
+val random_buf(val size, val state)
+{
+ val self = lit("random-buf");
+ struct rand_state *r = coerce(struct rand_state *,
+ cobj_handle(self,
+ default_arg(state, random_state),
+ random_state_cls));
+ size_t sz = c_size(size, self);
+ mem_t *data = chk_malloc(sz);
+ val buf = make_owned_buf(size, data);
+
+ for (; sz >= 4; sz -= 4, data += 4) {
+ rand32_t rnd = rand32(r);
+#if HAVE_LITTLE_ENDIAN
+ *coerce(rand32_t *, data) = rnd;
+#else
+ rnd = (0xFF00FF00U & rnd) >> 8 | (0x00FF00FFU & rnd) << 8;
+ *coerce(rand32_t *, data) = (rnd << 16 | rnd >> 16);
+#endif
+ }
+
+ if (sz > 0) {
+ rand32_t rnd = rand32(r);
+ switch (sz % 4) {
+ case 3:
+ data[2] = rnd >> 16;
+ /* fallthrough */
+ case 2:
+ data[1] = rnd >> 8;
+ /* fallthrough */
+ case 1:
+ data[0] = rnd;
+ }
+ }
+
+ return buf;
+}
+
void rand_compat_fixup(int compat_ver)
{
- if (compat_ver <= 139) {
+ if (compat_ver <= 243) {
loc l = lookup_var_l(nil, random_state_var_s);
- memset(rand_tab, 0xAA, sizeof rand_tab);
- if (compat_ver <= 114)
- random_state_s = random_state_var_s;
+ if (compat_ver <= 139) {
+ memset(rand_tab, 0xAA, sizeof rand_tab);
+ if (compat_ver <= 114)
+ random_state_s = random_state_var_s;
+ }
+ rand32 = rand32_bug;
set(l, make_random_state(num_fast(42), num_fast(8)));
}
}
+static double elrd(double denom, val state)
+{
+ return exp(log(random_float_impl(state))/denom);
+}
+
+static double flrd(double weight, val state)
+{
+ return floor(log(random_float_impl(state))/log(1.0 - weight));
+}
+
+static val random_sample(val size, val seq, val state_in)
+{
+ val self = lit("random-sample");
+ val state = default_arg(state_in, random_state);
+ cnum sz = c_fixnum(size, self), i;
+ seq_iter_t iter;
+ val samp, elem;
+
+ seq_iter_init(self, &iter, seq);
+
+ samp = vector(size, nil);
+
+ for (i = 0; i < sz && seq_get(&iter, &elem); i++)
+ samp->v.vec[i] = elem;
+
+ if (i < sz) {
+ vec_set_length(samp, unum(i));
+ return samp;
+ }
+
+ if (iter.inf.kind == SEQ_VECLIKE) {
+ cnum len = c_fixnum(length(seq), self);
+ double weight = elrd(sz, state);
+
+ while (i < len) {
+ i += flrd(weight, state) + 1;
+ if (i < len) {
+ samp->v.vec[c_n(random(state, size))] = ref(seq, unum(i));
+ mut(samp);
+ weight *= elrd(sz, state);
+ }
+ }
+ } else {
+ double weight = elrd(sz, state);
+
+ for (;;) {
+ cnum nx = i + flrd(weight, state) + 1;
+ for (; seq_get(&iter, &elem) && i < nx; i++)
+ ; /* nothing */
+
+ if (i < nx)
+ break;
+
+ samp->v.vec[c_n(random(state, size))] = elem;
+ mut(samp);
+ weight *= elrd(sz, state);
+ }
+ }
+
+ return samp;
+}
+
void rand_init(void)
{
random_state_var_s = intern(lit("*random-state*"), user_package);
random_state_s = intern(lit("random-state"), user_package);
random_warmup_s = intern(lit("*random-warmup*"), user_package);
+ random_state_cls = cobj_register(random_state_s);
+
reg_var(random_state_var_s, make_random_state(num_fast(42), num_fast(8)));
reg_var(random_warmup_s, num_fast(8));
@@ -368,6 +582,9 @@ void rand_init(void)
reg_fun(intern(lit("random-state-p"), user_package), func_n1(random_state_p));
reg_fun(intern(lit("random-fixnum"), user_package), func_n1o(random_fixnum, 0));
reg_fun(intern(lit("random-float"), user_package), func_n1o(random_float, 0));
+ reg_fun(intern(lit("random-float-incl"), user_package), func_n1o(random_float_incl, 0));
reg_fun(intern(lit("random"), user_package), func_n2(random));
reg_fun(intern(lit("rand"), user_package), func_n2o(rnd, 1));
+ reg_fun(intern(lit("random-buf"), user_package), func_n2o(random_buf, 1));
+ reg_fun(intern(lit("random-sample"), user_package), func_n3o(random_sample, 2));
}
diff --git a/rand.h b/rand.h
index 1026e518..f709882f 100644
--- a/rand.h
+++ b/rand.h
@@ -1,4 +1,4 @@
-/* Copyright 2011-2020
+/* Copyright 2011-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,32 +6,35 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#define random_state (deref(lookup_var_l(nil, random_state_var_s)))
extern val random_state_s, random_state_var_s;
+extern struct cobj_class *random_state_cls;
val make_random_state(val seed, val warmup);
val random_state_get_vec(val state);
val random_state_p(val obj);
val random_fixnum(val state);
val random(val state, val modulus);
val rnd(val modulus, val state);
+val random_buf(val size, val state);
void rand_compat_fixup(int compat_ver);
void rand_init(void);
diff --git a/regex.c b/regex.c
index a4dc69eb..4bfc2f28 100644
--- a/regex.c
+++ b/regex.c
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stdio.h>
@@ -256,6 +257,9 @@ union regex_machine {
int opt_derivative_regex = 0;
+struct cobj_class *regex_cls;
+static struct cobj_class *chset_cls;
+
wchar_t spaces[] = {
0x0009, 0x000a, 0x000b, 0x000c, 0x000d, 0x0020, 0x00a0, 0x1680, 0x180e,
0x2000, 0x2001, 0x2002, 0x2003, 0x2004, 0x2005, 0x2006, 0x2007, 0x2008,
@@ -296,7 +300,8 @@ static void L0_fill_range(cset_L0_t *L0, wchar_t ch0, wchar_t ch1)
static int L0_contains(cset_L0_t *L0, wchar_t ch)
{
- return ((*L0)[CHAR_SET_INDEX(ch)] & (1 << CHAR_SET_BIT(ch))) != 0;
+ return ((*L0)[CHAR_SET_INDEX(ch)] &
+ (convert(bitcell_t, 1) << CHAR_SET_BIT(ch))) != 0;
}
static int L1_full(cset_L1_t *L1)
@@ -320,8 +325,10 @@ static void L1_fill_range(cset_L1_t *L1, wchar_t ch0, wchar_t ch1)
cset_L0_t *L0;
if (i1 > i10 && i1 < i11) {
- free((*L1)[i1]);
- (*L1)[i1] = coerce(cset_L0_t *, -1);
+ if ((*L1)[i1] != coerce(cset_L0_t *, -1)) {
+ free((*L1)[i1]);
+ (*L1)[i1] = coerce(cset_L0_t *, -1);
+ }
continue;
} else if (i10 == i11) {
c0 = ch0;
@@ -401,8 +408,10 @@ static void L2_fill_range(cset_L2_t *L2, wchar_t ch0, wchar_t ch1)
cset_L1_t *L1;
if (i2 > i20 && i2 < i21) {
- free((*L2)[i2]);
- (*L2)[i2] = coerce(cset_L1_t *, -1);
+ if ((*L2)[i2] != coerce(cset_L1_t *, -1)) {
+ free((*L2)[i2]);
+ (*L2)[i2] = coerce(cset_L1_t *, -1);
+ }
continue;
} else if (i20 == i21) {
c0 = ch0;
@@ -473,8 +482,10 @@ static void L3_fill_range(cset_L3_t *L3, wchar_t ch0, wchar_t ch1)
cset_L2_t *L2;
if (i3 > i30 && i3 < i31) {
- free((*L3)[i3]);
- (*L3)[i3] = coerce(cset_L2_t *, -1);
+ if ((*L3)[i3] != coerce(cset_L2_t *, -1)) {
+ free((*L3)[i3]);
+ (*L3)[i3] = coerce(cset_L2_t *, -1);
+ }
continue;
} else if (i30 == i31) {
c0 = ch0;
@@ -587,7 +598,8 @@ static void char_set_add(char_set_t *set, wchar_t ch)
/* fallthrough */
case CHSET_SMALL:
assert (ch < 256);
- set->s.bitcell[CHAR_SET_INDEX(ch)] |= (1 << CHAR_SET_BIT(ch));
+ set->s.bitcell[CHAR_SET_INDEX(ch)] |= (convert(bitcell_t, 1)
+ << CHAR_SET_BIT(ch));
break;
case CHSET_LARGE:
assert (ch < 0x10000);
@@ -1094,8 +1106,8 @@ static void nfa_map_states(nfa_state_t *s,
static void nfa_count_one(nfa_state_t *s, mem_t *ctx)
{
- (void) s;
int *pcount = coerce(int *, ctx);
+ (void) s;
(*pcount)++;
}
@@ -1603,17 +1615,17 @@ static val reg_nary_to_bin(val regex)
static val reg_compile_csets(val exp)
{
if (exp == space_k) {
- return cobj(coerce(mem_t *, space_cs), chset_s, &char_set_obj_ops);
+ return cobj(coerce(mem_t *, space_cs), chset_cls, &char_set_obj_ops);
} else if (exp == digit_k) {
- return cobj(coerce(mem_t *, digit_cs), chset_s, &char_set_obj_ops);
+ return cobj(coerce(mem_t *, digit_cs), chset_cls, &char_set_obj_ops);
} else if (exp == word_char_k) {
- return cobj(coerce(mem_t *, word_cs), chset_s, &char_set_obj_ops);
+ return cobj(coerce(mem_t *, word_cs), chset_cls, &char_set_obj_ops);
} else if (exp == cspace_k) {
- return cobj(coerce(mem_t *, cspace_cs), chset_s, &char_set_obj_ops);
+ return cobj(coerce(mem_t *, cspace_cs), chset_cls, &char_set_obj_ops);
} else if (exp == cdigit_k) {
- return cobj(coerce(mem_t *, cdigit_cs), chset_s, &char_set_obj_ops);
+ return cobj(coerce(mem_t *, cdigit_cs), chset_cls, &char_set_obj_ops);
} else if (exp == cword_char_k) {
- return cobj(coerce(mem_t *, cword_cs), chset_s, &char_set_obj_ops);
+ return cobj(coerce(mem_t *, cword_cs), chset_cls, &char_set_obj_ops);
} else if (symbolp(exp) || chrp(exp)) {
return exp;
} else if (stringp(exp)) {
@@ -1624,7 +1636,7 @@ static val reg_compile_csets(val exp)
if (sym == set_s || sym == cset_s) {
char_set_t *set = char_set_compile(args, eq(sym, cset_s));
- return cobj(coerce(mem_t *, set), chset_s, &char_set_obj_ops);
+ return cobj(coerce(mem_t *, set), chset_cls, &char_set_obj_ops);
} else if (sym == compound_s || sym == zeroplus_s || sym == oneplus_s ||
sym == optional_s || sym == compl_s || sym == nongreedy_s ||
sym == or_s || sym == and_s)
@@ -1835,7 +1847,7 @@ static val reg_derivative(val exp, val ch)
return t;
} else if (chrp(exp)) {
return null(eq(exp, ch));
- } else if (cobjclassp(exp, chset_s)) {
+ } else if (cobjclassp(exp, chset_cls)) {
char_set_t *set = coerce(char_set_t *, exp->co.handle);
return if3(char_set_contains(set, c_chr(ch)), nil, t);
} else if (exp == wild_s) {
@@ -2203,16 +2215,23 @@ static val regex_requires_dv(val exp)
}
}
+static val regex_optimize(val regex_sexp)
+{
+ return reg_optimize(reg_expand_nongreedy(reg_nary_to_bin(regex_sexp)));
+}
+
val regex_compile(val regex_sexp, val error_stream)
{
- val regex_source = regex_sexp;
+ val regex_source;
if (stringp(regex_sexp)) {
- regex_sexp = regex_parse(regex_sexp, default_null_arg(error_stream));
+ regex_sexp = regex_parse(regex_sexp, error_stream);
return if2(regex_sexp, regex_compile(regex_sexp, error_stream));
}
- regex_sexp = reg_optimize(reg_expand_nongreedy(reg_nary_to_bin(regex_sexp)));
+ regex_source = reg_nary_to_bin(regex_sexp);
+
+ regex_sexp = reg_optimize(reg_expand_nongreedy(regex_source));
if (opt_derivative_regex || regex_requires_dv(regex_sexp)) {
regex_t *regex = coerce(regex_t *, chk_malloc(sizeof *regex));
@@ -2221,7 +2240,7 @@ val regex_compile(val regex_sexp, val error_stream)
regex->kind = REGEX_DV;
regex->nstates = 0;
regex->source = nil;
- ret = cobj(coerce(mem_t *, regex), regex_s, &regex_obj_ops);
+ ret = cobj(coerce(mem_t *, regex), regex_cls, &regex_obj_ops);
regex->r.dv = dv;
regex->source = regex_source;
return ret;
@@ -2230,7 +2249,7 @@ val regex_compile(val regex_sexp, val error_stream)
val ret;
regex->kind = REGEX_NFA;
regex->source = nil;
- ret = cobj(coerce(mem_t *, regex), regex_s, &regex_obj_ops);
+ ret = cobj(coerce(mem_t *, regex), regex_cls, &regex_obj_ops);
regex->r.nfa = nfa_optimize(nfa_compile_regex(regex_sexp));
regex->nstates = nfa_count_states(regex->r.nfa.start);
regex->source = regex_source;
@@ -2240,14 +2259,14 @@ val regex_compile(val regex_sexp, val error_stream)
val regexp(val obj)
{
- return cobjclassp(obj, regex_s);
+ return cobjclassp(obj, regex_cls);
}
val regex_source(val compiled_regex)
{
val self = lit("regex-source");
regex_t *regex = coerce(regex_t *,
- cobj_handle(self, compiled_regex, regex_s));
+ cobj_handle(self, compiled_regex, regex_cls));
return regex->source;
}
@@ -2290,6 +2309,8 @@ static void paren_print_rec(val exp, val stream, int *semi_flag)
static void print_rec(val exp, val stream, int *semi_flag)
{
+ val self = lit("regex-print");
+
if (exp == space_k) {
puts_clear_flag(lit("\\s"), stream, semi_flag);
} else if (exp == digit_k) {
@@ -2319,7 +2340,7 @@ static void print_rec(val exp, val stream, int *semi_flag)
}
} else if (stringp(exp)) {
cnum i;
- cnum l = c_num(length(exp));
+ cnum l = c_num(length(exp), self);
for (i = 0; i < l; i++)
print_rec(chr_str(exp, num(i)), stream, semi_flag);
} else if (consp(exp)) {
@@ -2327,10 +2348,10 @@ static void print_rec(val exp, val stream, int *semi_flag)
val args = rest(exp);
if (sym == set_s || sym == cset_s) {
- putc_clear_flag(chr('['), stream, semi_flag);
-
val first_p = t;
+ putc_clear_flag(chr('['), stream, semi_flag);
+
if (sym == cset_s) {
put_char(chr('^'), stream);
first_p = nil;
@@ -2419,7 +2440,7 @@ static void print_rec(val exp, val stream, int *semi_flag)
static void regex_print(val obj, val stream, val pretty, struct strm_ctx *ctx)
{
val self = lit("regex-print");
- regex_t *regex = coerce(regex_t *, cobj_handle(self, obj, regex_s));
+ regex_t *regex = coerce(regex_t *, cobj_handle(self, obj, regex_cls));
int semi_flag = 0;
(void) pretty;
@@ -2433,7 +2454,7 @@ static void regex_print(val obj, val stream, val pretty, struct strm_ctx *ctx)
static cnum regex_run(val compiled_regex, const wchar_t *str)
{
val self = lit("regex-run");
- regex_t *regex = coerce(regex_t *, cobj_handle(self, compiled_regex, regex_s));
+ regex_t *regex = coerce(regex_t *, cobj_handle(self, compiled_regex, regex_cls));
return if3(regex->kind == REGEX_DV,
dv_run(regex->r.dv, str),
@@ -2477,7 +2498,7 @@ static void regex_machine_reset(regex_machine_t *regm)
static void regex_machine_init(val self, regex_machine_t *regm, val reg)
{
- regex_t *regex = coerce(regex_t *, cobj_handle(self, reg, regex_s));
+ regex_t *regex = coerce(regex_t *, cobj_handle(self, reg, regex_cls));
if (regex->kind == REGEX_DV) {
regm->n.is_nfa = 0;
@@ -2584,15 +2605,15 @@ val search_regex(val haystack, val needle_regex, val start,
if (from_end) {
cnum i;
- cnum s = c_num(start);
- const wchar_t *h = c_str(haystack);
+ cnum s = c_num(start, self);
+ const wchar_t *h = c_str(haystack, self);
slen = (slen ? slen : length_str(haystack));
if (regex_run(needle_regex, L"") >= 0)
return cons(slen, zero);
- for (i = c_num(slen) - 1; i >= s; i--) {
+ for (i = c_num(slen, self) - 1; i >= s; i--) {
cnum span = regex_run(needle_regex, h + i);
if (span >= 0)
return cons(num(i), num(span));
@@ -2867,32 +2888,44 @@ val regsub(val regex, val repl, val str)
{
val rf = from(range);
val rt = to(range);
+ val scopy = copy_str(str);
- return replace_str(str, if3(isfunc,
- funcall1(repl, sub_str(str, rf, rt)),
- repl),
+ return replace_str(scopy, if3(isfunc,
+ funcall1(repl, sub_str(scopy, rf, rt)),
+ repl),
rf, rt);
}
} else {
- list_collect_decl (out, ptail);
val pos = zero;
+ val out = mkustring(zero);
+ val slen = if2(stringp(regex), length(regex));
do {
- cons_bind (find, len, search_regex(str, regex, pos, nil));
+ val find, len;
+
+ if (slen) {
+ len = slen;
+ find = search_str(str, regex, pos, nil);
+ } else {
+ cons_bind (a, d, search_regex(str, regex, pos, nil));
+ find = a;
+ len = d;
+ }
+
if (!find) {
if (pos == zero)
return str;
- ptail = list_collect(ptail, sub_str(str, pos, nil));
- break;
+ return string_extend(out, sub_str(str, pos, nil), t);
}
- ptail = list_collect(ptail, sub_str(str, pos, find));
- ptail = list_collect(ptail, if3(isfunc,
- funcall1(repl, sub_str(str, find,
- plus(find, len))),
- repl));
+ string_extend(out, sub_str(str, pos, find), nil);
+ string_extend(out, if3(isfunc,
+ funcall1(repl, sub_str(str, find,
+ plus(find, len))),
+ repl),
+ nil);
if (len == zero && eql(find, pos)) {
if (lt(pos, length_str(str))) {
- ptail = list_collect(ptail, chr_str(str, pos));
+ string_extend(out, chr_str(str, pos), nil);
pos = plus(pos, one);
}
} else {
@@ -2900,7 +2933,7 @@ val regsub(val regex, val repl, val str)
}
} while (lt(pos, length_str(str)));
- return cat_str(out, nil);
+ return string_finish(out);
}
}
@@ -3159,7 +3192,7 @@ static val scan_until_common(val self, val regex, val stream_in,
if (!out)
out = mkstring(one, ch);
else
- string_extend(out, ch);
+ string_extend(out, ch, nil);
} else {
count++;
}
@@ -3216,6 +3249,32 @@ val count_until_match(val regex, val stream_in)
return scan_until_common(lit("count-until-match"), regex, stream_in, nil, nil);
}
+static val trim_left(val regex, val string)
+{
+ if (regexp(regex)) {
+ val pos = match_regex(string, regex, nil);
+ if (pos)
+ return sub_str(string, pos, t);
+ } else if (starts_with(regex, string, nil, nil)) {
+ return sub_str(string, length(regex), t);
+ }
+
+ return string;
+}
+
+static val trim_right(val regex, val string)
+{
+ if (regexp(regex)) {
+ val pos = match_regex_right(string, regex, nil);
+ if (pos)
+ return sub_str(string, zero, minus(length(string), pos));
+ } else if (ends_with(regex, string, nil, nil)) {
+ return sub_str(string, zero, minus(length(string), length(regex)));
+ }
+
+ return string;
+}
+
static char_set_t *create_wide_cs(void)
{
#ifdef FULL_UNICODE
@@ -3226,14 +3285,13 @@ static char_set_t *create_wide_cs(void)
char_set_t *cs = char_set_create(cst, 0, 1);
- char_set_add_range(cs, 0x1100, 0x115F);
+ char_set_add_range(cs, 0x1100, 0x11F9);
char_set_add_range(cs, 0x2329, 0x232A);
char_set_add_range(cs, 0x2E80, 0x2E99);
char_set_add_range(cs, 0x2E9B, 0x2EF3);
char_set_add_range(cs, 0x2F00, 0x2FD5);
char_set_add_range(cs, 0x2FF0, 0x2FFB);
- char_set_add_range(cs, 0x3000, 0x303E);
- char_set_add_range(cs, 0x3000, 0x303E);
+ char_set_add_range(cs, 0x3000, 0x303F);
char_set_add_range(cs, 0x3041, 0x3096);
char_set_add_range(cs, 0x3099, 0x30FF);
char_set_add_range(cs, 0x3105, 0x312D);
@@ -3242,13 +3300,13 @@ static char_set_t *create_wide_cs(void)
char_set_add_range(cs, 0x31C0, 0x31E3);
char_set_add_range(cs, 0x31F0, 0x321E);
char_set_add_range(cs, 0x3220, 0x3247);
- char_set_add_range(cs, 0x3250, 0x32FE);
- char_set_add_range(cs, 0x3300, 0x4DB5);
+ char_set_add_range(cs, 0x3250, 0x4DBF);
char_set_add_range(cs, 0x4E00, 0x9FFF);
char_set_add_range(cs, 0xA000, 0xA48C);
char_set_add_range(cs, 0xA490, 0xA4C6);
char_set_add_range(cs, 0xA960, 0xA97C);
char_set_add_range(cs, 0xAC00, 0xD7A3);
+ char_set_add_range(cs, 0xE000, 0xE757);
char_set_add_range(cs, 0xF900, 0xFAFF);
char_set_add_range(cs, 0xFE10, 0xFE19);
char_set_add_range(cs, 0xFE30, 0xFE52);
@@ -3258,12 +3316,19 @@ static char_set_t *create_wide_cs(void)
#ifdef FULL_UNICODE
char_set_add_range(cs, 0x1B000, 0x1B001);
+ char_set_add_range(cs, 0x1F004, 0x1F004);
+ char_set_add_range(cs, 0x1F0CF, 0x1F0CF);
+ char_set_add_range(cs, 0x1F170, 0x1F171);
+ char_set_add_range(cs, 0x1F17E, 0x1F17F);
+ char_set_add_range(cs, 0x1F191, 0x1F19A);
char_set_add_range(cs, 0x1F200, 0x1F202);
char_set_add_range(cs, 0x1F210, 0x1F23A);
char_set_add_range(cs, 0x1F240, 0x1F248);
char_set_add_range(cs, 0x1F250, 0x1F251);
- char_set_add_range(cs, 0x20000, 0x2FFFD);
- char_set_add_range(cs, 0x30000, 0x3FFFD);
+ char_set_add_range(cs, 0x1F300, 0x1F7FF);
+ char_set_add_range(cs, 0x1F900, 0x1FAFF);
+ char_set_add_range(cs, 0x20000, 0x2FFFF);
+ char_set_add_range(cs, 0x30000, 0x3FFFF);
#endif
return cs;
@@ -3294,22 +3359,21 @@ void regex_init(void)
cdigit_k = intern(lit("cdigit"), keyword_package);
cword_char_k = intern(lit("cword-char"), keyword_package);
+ regex_cls = cobj_register(regex_s);
+ chset_cls = cobj_register(chset_s);
+
reg_fun(intern(lit("regex-compile"), user_package), func_n2o(regex_compile, 1));
reg_fun(intern(lit("regexp"), user_package), func_n1(regexp));
reg_fun(intern(lit("regex-source"), user_package), func_n1(regex_source));
reg_fun(intern(lit("search-regex"), user_package), func_n4o(search_regex, 2));
reg_fun(intern(lit("range-regex"), user_package), func_n4o(range_regex, 2));
reg_fun(intern(lit("search-regst"), user_package), func_n4o(search_regst, 2));
- reg_fun(intern(lit("match-regex"), user_package),
- func_n3o((opt_compat && opt_compat <= 150) ?
- match_regex : match_regex_len, 2));
+ reg_fun(intern(lit("match-regex"), user_package), func_n3o(match_regex_len, 2));
reg_fun(intern(lit("match-regst"), user_package), func_n3o(match_regst, 2));
reg_fun(intern(lit("match-regex-right"), user_package),
- func_n3o((opt_compat && opt_compat <= 150) ?
- match_regex_right_old : match_regex_right, 2));
+ func_n3o(match_regex_right, 2));
reg_fun(intern(lit("match-regst-right"), user_package),
- func_n3o((opt_compat && opt_compat <= 150) ?
- match_regst_right_old : match_regst_right, 2));
+ func_n3o(match_regst_right, 2));
reg_fun(intern(lit("regex-prefix-match"), user_package),
func_n3o(regex_prefix_match, 2));
reg_fun(intern(lit("regsub"), user_package), func_n3(regsub));
@@ -3317,7 +3381,7 @@ void regex_init(void)
reg_fun(intern(lit("reg-expand-nongreedy"), system_package),
func_n1(reg_expand_nongreedy));
- reg_fun(intern(lit("reg-optimize"), system_package), func_n1(reg_optimize));
+ reg_fun(intern(lit("regex-optimize"), user_package), func_n1(regex_optimize));
reg_fun(intern(lit("read-until-match"), user_package), func_n3o(read_until_match, 1));
reg_fun(intern(lit("scan-until-match"), user_package), func_n2(scan_until_match));
reg_fun(intern(lit("count-until-match"), user_package), func_n2(count_until_match));
@@ -3336,9 +3400,22 @@ void regex_init(void)
reg_fun(intern(lit("fr^"), user_package), func_n2o(regex_range_left_fun, 1));
reg_fun(intern(lit("fr$"), user_package), func_n2o(regex_range_right_fun, 1));
reg_fun(intern(lit("frr"), user_package), func_n3o(regex_range_search_fun, 1));
+ reg_fun(intern(lit("trim-left"), user_package), func_n2(trim_left));
+ reg_fun(intern(lit("trim-right"), user_package), func_n2(trim_right));
init_special_char_sets();
}
+void regex_compat_fixup(int compat_ver)
+{
+ if (compat_ver <= 150) {
+ reg_fun(intern(lit("match-regex"), user_package), func_n3o(match_regex, 2));
+ reg_fun(intern(lit("match-regex-right"), user_package),
+ func_n3o(match_regex_right_old, 2));
+ reg_fun(intern(lit("match-regst-right"), user_package),
+ func_n3o(match_regst_right_old, 2));
+ }
+}
+
void regex_free_all(void)
{
char_set_destroy(space_cs, 1);
diff --git a/regex.h b/regex.h
index 3c60f633..4b34fc83 100644
--- a/regex.h
+++ b/regex.h
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,28 +6,31 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
extern val space_k, digit_k, word_char_k;
extern val cspace_k, cdigit_k, cword_char_k;
+extern struct cobj_class *regex_cls;
+
extern wchar_t spaces[];
val regex_compile(val regex, val error_stream);
@@ -64,4 +67,5 @@ val regex_range_right_fun(val regex, val end);
val regex_range_search_fun(val regex, val start, val from_end);
int wide_display_char_p(wchar_t ch);
void regex_init(void);
+void regex_compat_fixup(int compat_ver);
void regex_free_all(void);
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
deleted file mode 100644
index f510d892..00000000
--- a/share/txr/stdlib/compiler.tl
+++ /dev/null
@@ -1,1865 +0,0 @@
-;; Copyright 2018-2020
-;; Kaz Kylheku <kaz@kylheku.com>
-;; Vancouver, Canada
-;; All rights reserved.
-;;
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions are met:
-;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
-;;
-;; 2. Redistributions in binary form must reproduce the above copyright notice,
-;; this list of conditions and the following disclaimer in the documentation
-;; and/or other materials provided with the distribution.
-;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-(load "vm-param")
-
-(compile-only
- (load-for (struct sys:param-parser-base "param")))
-
-(defstruct (frag oreg code : fvars ffuns) nil
- oreg
- code
- fvars
- ffuns)
-
-(defstruct binding nil
- sym
- loc
- used
- sys:env)
-
-(defstruct vbinding binding)
-
-(defstruct fbinding binding)
-
-(defstruct blockinfo nil
- sym
- used
- sys:env)
-
-(defstruct sys:env nil
- vb
- fb
- bb
- up
- co
- lev
- (v-cntr 0)
-
- (:postinit (me)
- (unless me.lev
- (set me.lev (succ (or me.up.?lev 0))))
- (unless (or me.co (null me.up))
- (set me.co me.up.co))
- me.co.(new-env me))
-
- (:method lookup-var (me sym : mark-used)
- (condlet
- (((cell (assoc sym me.vb)))
- (let ((bi (cdr cell)))
- (if mark-used (set bi.used t))
- bi))
- (((up me.up)) up.(lookup-var sym mark-used))
- (t nil)))
-
- (:method lookup-fun (me sym : mark-used)
- (condlet
- (((cell (assoc sym me.fb)))
- (let ((bi (cdr cell)))
- (if mark-used (set bi.used t))
- bi))
- (((up me.up)) up.(lookup-fun sym mark-used))
- (t nil)))
-
- (:method lookup-lisp1 (me sym : mark-used)
- (condlet
- (((cell (or (assoc sym me.vb)
- (assoc sym me.fb))))
- (let ((bi (cdr cell)))
- (if mark-used (set bi.used t))
- bi))
- (((up me.up)) up.(lookup-lisp1 sym mark-used))
- (t nil)))
-
- (:method lookup-block (me sym : mark-used)
- (condlet
- (((cell (assoc sym me.bb)))
- (let ((bi (cdr cell)))
- (if mark-used (set bi.used t))
- bi))
- (((up me.up)) up.(lookup-block sym mark-used))
- (t nil)))
-
- (:method extend-var (me sym)
- (when (assoc sym me.vb)
- (compile-error me.co.last-form "duplicate variable: ~s" sym))
- (let* ((loc ^(v ,(ppred me.lev) ,(pinc me.v-cntr)))
- (bn (new vbinding sym sym loc loc env me)))
- (set me.vb (acons sym bn me.vb))))
-
- (:method extend-var* (me sym)
- (let* ((loc ^(v ,(ppred me.lev) ,(pinc me.v-cntr)))
- (bn (new vbinding sym sym loc loc env me)))
- (set me.vb (acons sym bn me.vb))))
-
- (:method extend-fun (me sym)
- (when (assoc sym me.fb)
- (compile-error me.co.last-form "duplicate function ~s" sym))
- (let* ((loc ^(v ,(ppred me.lev) ,(pinc me.v-cntr)))
- (bn (new fbinding sym sym loc loc env me)))
- (set me.fb (acons sym bn me.fb))))
-
- (:method rename-var (me from-sym to-sym)
- (iflet ((cell (assoc from-sym me.vb)))
- (rplaca cell to-sym)
- (let ((bn (cdr cell)))
- (set bn.sym to-sym))))
-
- (:method out-of-scope (me reg)
- (if (eq (car reg) 'v)
- (let ((lev (ssucc (cadr reg))))
- (< me.lev lev))))
-
- (:method extend-block (me sym)
- (let* ((bn (new blockinfo sym sym env me)))
- (set me.bb (acons sym bn me.bb)))))
-
-(compile-only
- (defstruct compiler nil
- (treg-cntr 2)
- (dreg-cntr 0)
- (sidx-cntr 0)
- (nlev 2)
- (tregs nil)
- (dreg (hash :eql-based))
- (data (hash :eql-based))
- (sidx (hash :eql-based))
- (stab (hash :eql-based))
- lt-frags
- last-form))
-
-(eval-only
- (defmacro compile-in-toplevel (comp . body)
- (with-gensyms (comp-var saved-tregs saved-treg-cntr saved-nlev)
- ^(let* ((,comp-var ,comp)
- (,saved-tregs (qref ,comp-var tregs))
- (,saved-treg-cntr (qref ,comp-var treg-cntr))
- (,saved-nlev (qref ,comp-var nlev)))
- (unwind-protect
- (progn
- (set (qref ,comp-var tregs) nil
- (qref ,comp-var treg-cntr) 2
- (qref ,comp-var nlev) 2)
- (prog1
- (progn ,*body)
- (qref ,comp-var (check-treg-leak))))
- (set (qref ,comp-var tregs) ,saved-tregs
- (qref ,comp-var treg-cntr) ,saved-treg-cntr
- (qref ,comp-var nlev) ,saved-nlev))))))
-
-(defvarl %gcall-op% (relate '(apply usr:apply call) '(gapply gapply gcall)))
-
-(defvarl %call-op% (relate '(apply usr:apply call) '(apply apply call)))
-
-(defvarl %test-funs-pos% '(eq eql))
-
-(defvarl %test-funs-neg% '(neq neql))
-
-(defvarl %test-funs-ops% '(ifq ifql))
-
-(defvarl %test-funs% (append %test-funs-pos% %test-funs-neg%))
-
-(defvarl %test-inv% (relate %test-funs-neg% %test-funs-pos%))
-
-(defvarl %test-opcode% (relate %test-funs-pos% %test-funs-ops%))
-
-(defvarl %block-using-funs% '(sys:capture-cont return* sys:abscond* match-fun
- eval load compile compile-file compile-toplevel))
-
-(defvarl %nary-ops% '(< > <= => = + - * /))
-
-(defvarl %bin-ops% '(b< b> b<= b=> b= b+ b- b* b/))
-
-(defvarl %bin-op% (relate %nary-ops% %bin-ops%))
-
-(defvarl assumed-fun)
-
-(defvar *dedup*)
-
-(defun dedup (obj)
- (cond
- ((null obj) nil)
- ((null *dedup*) obj)
- ((or (stringp obj) (bignump obj))
- (or [*dedup* obj] (set [*dedup* obj] obj)))
- (t obj)))
-
-(defun null-reg (reg)
- (equal reg '(t 0)))
-
-(defmeth compiler get-dreg (me obj)
- (let ((dobj (dedup obj)))
- (condlet
- ((((null dobj))) '(t 0))
- (((dreg [me.dreg dobj])) dreg)
- ((((< me.dreg-cntr %lev-size%)))
- (let ((dreg ^(d ,(pinc me.dreg-cntr))))
- (set [me.data (cadr dreg)] dobj)
- (set [me.dreg dobj] dreg)))
- (t (compile-error me.last-form "code too complex: too many literals")))))
-
-(defmeth compiler alloc-dreg (me)
- (if (< me.dreg-cntr %lev-size%)
- (let ((dreg ^(d ,(pinc me.dreg-cntr))))
- (set [me.data (cadr dreg)] nil)
- dreg)
- (compile-error me.last-form "code too complex: too many literals")))
-
-(defmeth compiler get-sidx (me atom)
- (iflet ((sidx [me.sidx atom]))
- sidx
- (let* ((sidx (pinc me.sidx-cntr)))
- (set [me.stab sidx] atom)
- (set [me.sidx atom] sidx))))
-
-(defmeth compiler get-datavec (me)
- (vec-list [mapcar me.data (range* 0 me.dreg-cntr)]))
-
-(defmeth compiler get-symvec (me)
- (vec-list [mapcar me.stab (range* 0 me.sidx-cntr)]))
-
-(defmeth compiler alloc-treg (me)
- (cond
- (me.tregs (pop me.tregs))
- ((< me.treg-cntr %lev-size%) ^(t ,(pinc me.treg-cntr)))
- (t (compile-error me.last-form "code too complex: out of registers"))))
-
-(defmeth compiler free-treg (me treg)
- (when (and (eq t (car treg)) (neq 0 (cadr treg)))
- (push treg me.tregs)))
-
-(defmeth compiler free-tregs (me tregs)
- (mapdo (meth me free-treg) tregs))
-
-(defmeth compiler maybe-alloc-treg (me given)
- (if (eq t (car given))
- given
- me.(alloc-treg)))
-
-(defmeth compiler maybe-free-treg (me treg given)
- (when (nequal treg given)
- me.(free-treg treg)))
-
-(defmeth compiler check-treg-leak (me)
- (let ((balance (- (ppred me.treg-cntr) (len me.tregs))))
- (unless (zerop balance)
- (error "t-register leak in compiler: ~s outstanding" balance))))
-
-(defmeth compiler new-env (me env)
- (when (>= env.lev me.nlev)
- (unless (<= env.lev %max-lev%)
- (compile-error me.last-form
- "code too complex: lexical nesting too deep"))
- (set me.nlev (succ env.lev))))
-
-(defmeth compiler compile (me oreg env form)
- (set me.last-form form)
- (cond
- ((symbolp form)
- (if (bindable form)
- me.(comp-var oreg env form)
- me.(comp-atom oreg form)))
- ((atom form) me.(comp-atom oreg form))
- (t (let ((sym (car form)))
- (cond
- ((special-operator-p sym)
- (caseq sym
- (quote me.(comp-atom oreg (cadr form)))
- (sys:setq me.(comp-setq oreg env form))
- (sys:lisp1-setq me.(comp-lisp1-setq oreg env form))
- (sys:setqf me.(comp-setqf oreg env form))
- (cond me.(comp-cond oreg env form))
- (if me.(comp-if oreg env form))
- (switch me.(comp-switch oreg env form))
- (unwind-protect me.(comp-unwind-protect oreg env form))
- ((block block*) me.(comp-block oreg env form))
- ((return-from sys:abscond-from) me.(comp-return-from oreg env form))
- (return me.(comp-return oreg env form))
- (handler-bind me.(comp-handler-bind oreg env form))
- (sys:catch me.(comp-catch oreg env form))
- ((let let*) me.(comp-let oreg env form))
- ((sys:fbind sys:lbind) me.(comp-fbind oreg env form))
- (lambda me.(comp-lambda oreg env form))
- (fun me.(comp-fun oreg env form))
- (sys:for-op me.(comp-for oreg env form))
- (sys:each-op me.(compile oreg env (expand-each form env)))
- ((progn eval-only compile-only) me.(comp-progn oreg env (cdr form)))
- (and me.(comp-and-or oreg env form))
- (or me.(comp-and-or oreg env form))
- (prog1 me.(comp-prog1 oreg env form))
- (sys:quasi me.(comp-quasi oreg env form))
- (dohash me.(compile oreg env (expand-dohash form)))
- (tree-bind me.(comp-tree-bind oreg env form))
- (mac-param-bind me.(comp-mac-param-bind oreg env form))
- (tree-case me.(comp-tree-case oreg env form))
- (sys:lisp1-value me.(comp-lisp1-value oreg env form))
- (dwim me.(comp-dwim oreg env form))
- (prof me.(comp-prof oreg env form))
- (defvarl me.(compile oreg env (expand-defvarl form)))
- (defun me.(compile oreg env (expand-defun form)))
- (defmacro me.(compile oreg env (expand-defmacro form)))
- (defsymacro me.(compile oreg env (expand-defsymacro form)))
- (sys:upenv me.(compile oreg env.up (cadr form)))
- (sys:dvbind me.(compile oreg env (caddr form)))
- (sys:load-time-lit me.(comp-load-time-lit oreg env form))
- ((macrolet symacrolet macro-time)
- (compile-error form "unexpanded ~s encountered" sym))
- ((sys:var sys:expr)
- (compile-error form "meta with no meaning: ~s " form))
- ((usr:qquote usr:unquote usr:splice
- sys:qquote sys:unquote sys:splice)
- (compile-error form "unexpanded quasiquote encountered"))
- (t
- (compile-error form "unrecognized special operator ~s" sym))))
- ((bindable sym) me.(comp-fun-form oreg env form))
- ((and (consp sym)
- (eq (car sym) 'lambda)) me.(compile oreg env ^(call ,*form)))
- (t (compile-error form "invalid operator")))))))
-
-(defmeth compiler comp-atom (me oreg form)
- (cond
- ((null form) (new (frag '(t 0) nil)))
- ((or (and (fixnump form)
- (<= (width form) (- %imm-width% 3)))
- (chrp form))
- (new (frag oreg ^((movi ,oreg ,form)))))
- (t (let ((dreg me.(get-dreg form)))
- (new (frag dreg nil))))))
-
-(defmeth compiler comp-var (me oreg env sym)
- (let ((vbin env.(lookup-var sym)))
- (cond
- (vbin (new (frag vbin.loc nil (list sym))))
- ((special-var-p sym)
- (let ((dreg me.(get-dreg sym)))
- (new (frag oreg ^((getv ,oreg ,dreg)) (list sym)))))
- (t (new (frag oreg ^((getlx ,oreg ,me.(get-sidx sym))) (list sym)))))))
-
-(defmeth compiler comp-setq (me oreg env form)
- (mac-param-bind form (op sym value) form
- (let* ((bind env.(lookup-var sym))
- (spec (special-var-p sym))
- (vloc (cond
- (bind bind.loc)
- (spec me.(get-dreg sym))
- (t me.(get-sidx sym))))
- (vfrag me.(compile (if bind vloc oreg) env value)))
- (new (frag vfrag.oreg
- ^(,*vfrag.code
- ,*(if bind
- (maybe-mov vloc vfrag.oreg)
- (if spec
- ^((setv ,vfrag.oreg ,vloc))
- ^((setlx ,vfrag.oreg ,me.(get-sidx sym))))))
- (uni (list sym) vfrag.fvars)
- vfrag.ffuns)))))
-
-(defmeth compiler comp-lisp1-setq (me oreg env form)
- (mac-param-bind form (op sym val) form
- (let ((bind env.(lookup-lisp1 sym)))
- (cond
- ((typep bind 'fbinding)
- (compile-error form "assignment to lexical function binding"))
- ((null bind)
- (let ((vfrag me.(compile oreg env val))
- (l1loc me.(get-dreg sym)))
- (new (frag vfrag.oreg
- ^(,*vfrag.code
- (setl1 ,vfrag.oreg ,l1loc))
- (uni (list sym) vfrag.fvars)
- vfrag.ffuns))))
- (t me.(compile oreg env ^(sys:setq ,sym ,val)))))))
-
-(defmeth compiler comp-setqf (me oreg env form)
- (mac-param-bind form (op sym val) form
- (if env.(lookup-fun sym)
- (compile-error form "assignment to lexical function binding")
- (let ((vfrag me.(compile oreg env val))
- (fname me.(get-dreg sym))
- (rplcd me.(get-sidx 'usr:rplacd))
- (treg me.(alloc-treg)))
- me.(free-treg treg)
- (new (frag vfrag.oreg
- ^(,*vfrag.code
- (getfb ,treg ,fname)
- (gcall ,treg ,rplcd ,treg ,vfrag.oreg))
- (uni (list sym) vfrag.fvars)
- vfrag.ffuns))))))
-
-(defmeth compiler comp-cond (me oreg env form)
- (tree-case form
- ((op) me.(comp-atom oreg nil))
- ((op (test) . more) me.(compile oreg env ^(or ,test (cond ,*more))))
- ((op (test . forms) . more) me.(compile oreg env
- ^(if ,test
- (progn ,*forms)
- (cond ,*more))))
- ((op atom . more)
- (compile-error form "atom in cond syntax; pair expected"))
- ((op . atom)
- (compile-error form "trailing atom in cond syntax"))))
-
-(defmeth compiler comp-if (me oreg env form)
- (tree-case form
- ((op test then else)
- (cond
- ((null test)
- me.(compile oreg env else))
- ((constantp test)
- me.(compile oreg env then))
- ((and (consp test) (member (car test) %test-funs%))
- me.(compile oreg env ^(ift ,(car test) ,(cadr test) ,(caddr test)
- ,then ,else)))
- (t
- (let* ((te-oreg me.(maybe-alloc-treg oreg))
- (lelse (gensym "l"))
- (lskip (gensym "l"))
- (te-frag me.(compile te-oreg env test))
- (th-frag me.(compile oreg env then))
- (el-frag me.(compile oreg env else)))
- me.(maybe-free-treg te-oreg oreg)
- (new (frag oreg
- ^(,*te-frag.code
- (if ,te-frag.oreg ,lelse)
- ,*th-frag.code
- ,*(maybe-mov oreg th-frag.oreg)
- (jmp ,lskip)
- ,lelse
- ,*el-frag.code
- ,*(maybe-mov oreg el-frag.oreg)
- ,lskip)
- (uni te-frag.fvars (uni th-frag.fvars el-frag.fvars))
- (uni te-frag.ffuns (uni th-frag.ffuns el-frag.ffuns))))))))
- ((op test then)
- (cond
- ((null test) me.(compile oreg env nil))
- ((constantp test)
- me.(compile oreg env then))
- ((and (consp test) (member (car test) %test-funs%))
- me.(compile oreg env ^(ift ,(car test) ,(cadr test) ,(caddr test)
- ,then)))
- (t (let* ((lskip (gensym "l"))
- (te-oreg me.(maybe-alloc-treg oreg))
- (te-frag me.(compile te-oreg env test))
- (th-frag me.(compile oreg env then)))
- me.(maybe-free-treg te-oreg oreg)
- (new (frag oreg
- ^(,*te-frag.code
- ,*(maybe-mov oreg te-frag.oreg)
- (if ,oreg ,lskip)
- ,*th-frag.code
- ,*(maybe-mov oreg th-frag.oreg)
- ,lskip)
- (uni te-frag.fvars th-frag.fvars)
- (uni te-frag.ffuns th-frag.ffuns)))))))
- ((op test)
- (cond
- ((constantp test) me.(compile oreg env nil))
- ((and (consp test) (member (car test) %test-funs%))
- me.(compile oreg env ^(ift ,(car test) ,(cadr test) ,(caddr test))))
- (t (let ((te-frag me.(compile oreg env test)))
- (new (frag oreg
- ^(,*te-frag.code
- (mov ,oreg nil))
- te-frag.fvars
- te-frag.ffuns))))))
- ((op) me.(compile oreg env nil))
- (form (compile-error form "excess argument forms"))))
-
-(defmeth compiler comp-ift (me oreg env form)
- (mac-param-bind form (op fun left right : then else) form
- (when (member fun %test-funs-neg%)
- (set fun [%test-inv% fun])
- (swap then else))
- (if (and (constantp left) (constantp right))
- me.(compile oreg env (if (call fun (eval left) (eval right)) then else))
- (let* ((opcode [%test-opcode% fun])
- (le-oreg me.(alloc-treg))
- (ri-oreg me.(alloc-treg))
- (lelse (gensym "l"))
- (lskip (gensym "l"))
- (le-frag me.(compile le-oreg env left))
- (ri-frag me.(compile ri-oreg env right))
- (th-frag me.(compile oreg env then))
- (el-frag me.(compile oreg env else)))
- me.(free-treg le-oreg)
- me.(free-treg ri-oreg)
- (new (frag oreg
- ^(,*le-frag.code
- ,*ri-frag.code
- (,opcode ,le-frag.oreg ,ri-frag.oreg ,lelse)
- ,*th-frag.code
- ,*(maybe-mov oreg th-frag.oreg)
- (jmp ,lskip)
- ,lelse
- ,*el-frag.code
- ,*(maybe-mov oreg el-frag.oreg)
- ,lskip)
- (uni (uni le-frag.fvars ri-frag.fvars)
- (uni th-frag.fvars el-frag.fvars))
- (uni (uni le-frag.ffuns ri-frag.ffuns)
- (uni th-frag.ffuns el-frag.ffuns))))))))
-
-(defmeth compiler comp-switch (me oreg env form)
- (mac-param-bind form (op idx-form cases-vec) form
- (let* ((ncases (len cases-vec))
- (cs (and (plusp ncases) (conses [cases-vec 0])))
- (shared (and cs
- (let ((c cs)
- (d (cdr (list-vec cases-vec))))
- (whilet ((m (if d (memq (pop d) c))))
- (set c m))
- (null d))))
- (cases (if shared
- (let ((cs-nil ^(,*cs nil)))
- [mapcar ldiff cs-nil (cdr cs-nil)])
- cases-vec))
- (lend (gensym "l"))
- (clabels (mapcar (ret (gensym "l")) cases))
- (treg me.(maybe-alloc-treg oreg))
- (ifrag me.(compile treg env idx-form))
- (seen (unless shared (hash :eql-based)))
- last-cfrag
- (cfrags (collect-each ((cs cases)
- (lb clabels)
- (i (range 1)))
- (iflet ((seen-lb (and seen [seen cs])))
- (progn
- (set [clabels (pred i)] seen-lb)
- (new (frag oreg nil)))
- (let ((cfrag me.(comp-progn oreg env cs)))
- (when (eq i ncases)
- (set last-cfrag cfrag))
- (unless shared
- (set [seen cs] lb))
- (new (frag oreg
- ^(,lb
- ,*cfrag.code
- ,*(unless shared
- ^(,*(maybe-mov oreg cfrag.oreg)
- ,*(unless (= i ncases)
- ^((jmp ,lend))))))
- cfrag.fvars cfrag.ffuns)))))))
- me.(maybe-free-treg treg oreg)
- (new (frag oreg
- ^(,*ifrag.code
- (swtch ,ifrag.oreg ,*clabels)
- ,*(mappend .code cfrags)
- ,*(when (and shared last-cfrag)
- (maybe-mov oreg last-cfrag.oreg))
- ,lend)
- (uni ifrag.fvars [reduce-left uni cfrags nil .fvars])
- (uni ifrag.ffuns [reduce-left uni cfrags nil .ffuns]))))))
-
-(defmeth compiler comp-unwind-protect (me oreg env form)
- (mac-param-bind form (op prot-form . cleanup-body) form
- (let* ((treg me.(alloc-treg))
- (pfrag me.(compile oreg env prot-form))
- (cfrag me.(comp-progn treg env cleanup-body))
- (lclean (gensym "l")))
- me.(free-treg treg)
- (cond
- ((null pfrag.code)
- (new (frag cfrag.oreg
- cfrag.code
- cfrag.fvars
- cfrag.ffuns)))
- ((null cfrag.code) pfrag)
- (t (new (frag pfrag.oreg
- ^((uwprot ,lclean)
- ,*pfrag.code
- (end nil)
- ,lclean
- ,*cfrag.code
- (end nil))
- (uni pfrag.fvars pfrag.fvars)
- (uni cfrag.fvars cfrag.fvars))))))))
-
-(defmeth compiler comp-block (me oreg env form)
- (mac-param-bind form (op name . body) form
- (let* ((star (and name (eq op 'block*)))
- (nenv (unless star
- (new env up env lev env.lev co me)))
- (binfo (unless star
- (cdar nenv.(extend-block name))))
- (treg (if star me.(maybe-alloc-treg oreg)))
- (nfrag (if star me.(compile treg env name)))
- (nreg (if star nfrag.oreg me.(get-dreg name)))
- (bfrag me.(comp-progn oreg (or nenv env) body))
- (lskip (gensym "l")))
- (when treg
- me.(maybe-free-treg treg oreg))
- (if (and (not star)
- (not binfo.used)
- [all bfrag.ffuns system-symbol-p]
- [none bfrag.ffuns (op member @1 %block-using-funs%)])
- bfrag
- (new (frag oreg
- ^(,*(if nfrag nfrag.code)
- (block ,oreg ,nreg ,lskip)
- ,*bfrag.code
- ,*(maybe-mov oreg bfrag.oreg)
- (end ,oreg)
- ,lskip)
- bfrag.fvars
- bfrag.ffuns))))))
-
-(defmeth compiler comp-return-from (me oreg env form)
- (mac-param-bind form (op name : value) form
- (let* ((nreg (if (null name)
- nil
- me.(get-dreg name)))
- (opcode (if (eq op 'return-from) 'ret 'abscsr))
- (vfrag me.(compile oreg env value))
- (binfo env.(lookup-block name t)))
- (new (frag oreg
- ^(,*vfrag.code
- (,opcode ,nreg ,vfrag.oreg))
- vfrag.fvars
- vfrag.ffuns)))))
-
-(defmeth compiler comp-return (me oreg env form)
- (mac-param-bind form (op : value) form
- me.(comp-return-from oreg env ^(return-from nil ,value))))
-
-(defmeth compiler comp-handler-bind (me oreg env form)
- (mac-param-bind form (op func-form ex-syms . body) form
- (let* ((freg me.(maybe-alloc-treg oreg))
- (ffrag me.(compile freg env func-form))
- (sreg me.(get-dreg ex-syms))
- (bfrag me.(comp-progn oreg env body)))
- me.(maybe-free-treg freg oreg)
- (new (frag bfrag.oreg
- ^(,*ffrag.code
- (handle ,ffrag.oreg ,sreg)
- ,*bfrag.code
- (end ,bfrag.oreg))
- (uni ffrag.fvars bfrag.fvars)
- (uni ffrag.ffuns bfrag.ffuns))))))
-
-(defmeth compiler comp-catch (me oreg env form)
- (mac-param-bind form (op symbols try-expr desc-expr . clauses) form
- (with-gensyms (ex-sym-var ex-args-var)
- (let* ((nenv (new env up env co me))
- (esvb (cdar nenv.(extend-var ex-sym-var)))
- (eavb (cdar nenv.(extend-var ex-args-var)))
- (tfrag me.(compile oreg nenv try-expr))
- (dfrag me.(compile oreg nenv desc-expr))
- (lhand (gensym "l"))
- (lhend (gensym "l"))
- (treg me.(alloc-treg))
- (nclauses (len clauses))
- (cfrags (collect-each ((cl clauses)
- (i (range 1)))
- (mac-param-bind form (sym params . body) cl
- (let* ((cl-src ^(apply (lambda ,params ,*body)
- ,ex-sym-var ,ex-args-var))
- (cfrag me.(compile oreg nenv (expand cl-src)))
- (lskip (gensym "l")))
- (new (frag oreg
- ^((gcall ,treg
- ,me.(get-sidx 'exception-subtype-p)
- ,esvb.loc
- ,me.(get-dreg sym))
- (if ,treg ,lskip)
- ,*cfrag.code
- ,*(maybe-mov tfrag.oreg cfrag.oreg)
- ,*(unless (eql i nclauses)
- ^((jmp ,lhend)))
- ,lskip)
- cfrag.fvars
- cfrag.ffuns)))))))
- me.(free-treg treg)
- (new (frag tfrag.oreg
- ^((frame ,nenv.lev ,nenv.v-cntr)
- ,*dfrag.code
- (catch ,esvb.loc ,eavb.loc
- ,me.(get-dreg symbols) ,dfrag.oreg ,lhand)
- ,*tfrag.code
- (jmp ,lhend)
- ,lhand
- ,*(mappend .code cfrags)
- ,lhend
- (end ,tfrag.oreg)
- (end ,tfrag.oreg))
- (uni tfrag.fvars [reduce-left uni cfrags nil .fvars])
- (uni tfrag.ffuns [reduce-left uni cfrags nil .ffuns])))))))
-
-(defmeth compiler comp-let (me oreg env form)
- (mac-param-bind form (sym raw-vis . body) form
- (let* ((vis (mapcar [iffi atom list] raw-vis))
- (specials [keep-if special-var-p vis car])
- (lexsyms [remove-if special-var-p [mapcar car vis]])
- allsyms
- (specials-occur [find-if special-var-p vis car])
- (treg (if specials-occur me.(alloc-treg)))
- (frsize (len lexsyms))
- (seq (eq sym 'let*))
- (nenv (new env up env co me))
- (eenv (unless seq (new env up env co me)))
- (fenv (if seq nenv eenv)))
- (unless seq
- (each ((lsym lexsyms))
- nenv.(extend-var lsym)))
- (let* (ffuns fvars
- (code (build
- (add ^(,(if specials-occur 'dframe 'frame)
- ,nenv.lev ,frsize))
- (each ((vi vis))
- (tree-bind (sym : form) vi
- (push sym allsyms)
- (cond
- ((special-var-p sym)
- (let ((frag me.(compile treg fenv form))
- (dreg me.(get-dreg sym)))
- (pend frag.code)
- (add ^(bindv ,frag.oreg ,dreg))
- (set ffuns (uni ffuns frag.ffuns)
- fvars (uni fvars
- (if seq
- (diff frag.fvars
- (cdr allsyms))
- frag.fvars)))))
- (form
- (let* ((tmp (if seq (gensym)))
- (bind (if seq
- (cdar nenv.(extend-var tmp))
- nenv.(lookup-var sym)))
- (frag me.(compile bind.loc fenv form)))
- (when seq
- fenv.(rename-var tmp sym))
- (pend frag.code)
- (unless (null-reg frag.oreg)
- (pend (maybe-mov bind.loc frag.oreg)))
- (set ffuns (uni ffuns frag.ffuns)
- fvars (uni fvars
- (if seq
- (diff frag.fvars
- (cdr allsyms))
- frag.fvars)))))
- (t (if seq nenv.(extend-var* sym))))))))
- (bfrag me.(comp-progn oreg nenv body))
- (boreg (if env.(out-of-scope bfrag.oreg) oreg bfrag.oreg)))
- (when treg
- me.(free-treg treg))
- (new (frag boreg
- (append code bfrag.code
- (maybe-mov boreg bfrag.oreg)
- ^((end ,boreg)))
- (uni (diff bfrag.fvars allsyms) fvars)
- (uni ffuns bfrag.ffuns)))))))
-
-(defmeth compiler comp-fbind (me oreg env form)
- (mac-param-bind form (sym raw-fis . body) form
- (let* ((fis (mapcar [iffi atom list] raw-fis))
- (lexfuns [mapcar car fis])
- (frsize (len lexfuns))
- (rec (eq sym 'sys:lbind))
- (eenv (unless rec (new env up env co me)))
- (nenv (new env up env co me)))
- (each ((lfun lexfuns))
- nenv.(extend-fun lfun))
- (let* (ffuns fvars
- (ffrags (collect-each ((fi fis))
- (tree-bind (sym : form) fi
- (let* ((bind nenv.(lookup-fun sym))
- (frag me.(compile bind.loc
- (if rec nenv eenv)
- form)))
- (list bind
- (new (frag frag.oreg
- (append frag.code
- (maybe-mov bind.loc frag.oreg))
- frag.fvars
- frag.ffuns)))))))
- (bfrag me.(comp-progn oreg nenv body))
- (boreg (if env.(out-of-scope bfrag.oreg) oreg bfrag.oreg)))
- (set ffrags (append-each ((bf ffrags))
- (tree-bind (bind ff) bf
- (when bind.used
- (set ffuns (uni ffuns ff.ffuns)
- fvars (uni fvars ff.fvars))
- (list ff)))))
- (new (frag boreg
- (append ^((frame ,nenv.lev ,frsize))
- (mappend .code ffrags)
- bfrag.code
- (maybe-mov boreg bfrag.oreg)
- ^((end ,boreg)))
- (uni fvars bfrag.fvars)
- (uni (diff bfrag.ffuns lexfuns)
- (if rec (diff ffuns lexfuns) ffuns))))))))
-
-(defmeth compiler comp-lambda (me oreg env form)
- (mac-param-bind form (op par-syntax . body) form
- (let* ((pars (new (fun-param-parser par-syntax form)))
- (need-frame (or (plusp pars.nfix) pars.rest))
- (nenv (if need-frame (new env up env co me) env))
- lexsyms fvars specials need-dframe)
- (when (> pars.nfix %max-lambda-fixed-args%)
- (compile-warning form "~s arguments in a lambda (max is ~s)"
- pars.nfix %max-lambda-fixed-args%))
- (flet ((spec-sub (sym)
- (cond
- ((special-var-p sym)
- (let ((sub (gensym)))
- (push (cons sym sub) specials)
- (set need-dframe t)
- nenv.(extend-var sub)
- sub))
- (t
- (push sym lexsyms)
- nenv.(extend-var sym)
- sym))))
- (let* ((req-pars (collect-each ((rp pars.req))
- (spec-sub rp)))
- (opt-pars (collect-each ((op pars.opt))
- (tree-bind (var-sym : init-form have-sym) op
- (list (spec-sub var-sym)
- init-form
- (if have-sym (spec-sub have-sym))))))
- (rest-par (when pars.rest (spec-sub pars.rest)))
- (allsyms req-pars))
- (upd specials nreverse)
- (let* ((col-reg (if opt-pars me.(get-dreg :)))
- (tee-reg (if opt-pars me.(get-dreg t)))
- (ifrags (collect-each ((op opt-pars))
- (tree-bind (var-sym init-form have-sym) op
- (let* ((vbind nenv.(lookup-var var-sym))
- (ifrag me.(compile vbind.loc nenv init-form)))
- (set fvars (uni fvars
- (diff ifrag.fvars allsyms)))
- (push var-sym allsyms)
- (push have-sym allsyms)
- ifrag))))
- (opt-code (append-each ((op opt-pars)
- (ifrg ifrags))
- (tree-bind (var-sym init-form have-sym) op
- (let ((vbind nenv.(lookup-var var-sym))
- (have-bind nenv.(lookup-var have-sym))
- (lskip (gensym "l")))
- ^(,*(if have-sym
- ^((mov ,have-bind.loc ,tee-reg)))
- (ifq ,vbind.loc ,col-reg ,lskip)
- ,*(if have-sym
- ^((mov ,have-bind.loc nil)))
- ,*ifrg.code
- ,*(maybe-mov vbind.loc ifrg.oreg)
- ,lskip
- ,*(whenlet ((spec-sub [find var-sym specials : cdr]))
- (set specials [remq var-sym specials cdr])
- ^((bindv ,vbind.loc ,me.(get-dreg (car spec-sub)))))
- ,*(whenlet ((spec-sub [find have-sym specials : cdr]))
- (set specials [remq have-sym specials cdr])
- ^((bindv ,have-bind.loc ,me.(get-dreg (car spec-sub))))))))))
- (benv (if need-dframe (new env up nenv co me) nenv))
- (btreg me.(alloc-treg))
- (bfrag me.(comp-progn btreg benv body))
- (boreg (if env.(out-of-scope bfrag.oreg) btreg bfrag.oreg))
- (lskip (gensym "l-"))
- (frsize (if need-frame nenv.v-cntr 0)))
- me.(free-treg btreg)
- (new (frag oreg
- ^((close ,oreg ,frsize ,lskip ,pars.nfix ,pars.nreq
- ,(if rest-par t nil)
- ,*(collect-each ((rp req-pars))
- nenv.(lookup-var rp).loc)
- ,*(collect-each ((op opt-pars))
- nenv.(lookup-var (car op)).loc)
- ,*(if rest-par
- (list nenv.(lookup-var rest-par).loc)))
- ,*(if need-dframe
- ^((dframe ,benv.lev 0)))
- ,*(if specials
- (collect-each ((vs specials))
- (tree-bind (special . gensym) vs
- (let ((sub-bind nenv.(lookup-var gensym))
- (dreg me.(get-dreg special)))
- ^(bindv ,sub-bind.loc ,dreg)))))
- ,*opt-code
- ,*bfrag.code
- ,*(if need-dframe
- ^((end ,boreg)))
- ,*(maybe-mov boreg bfrag.oreg)
- (end ,boreg)
- ,lskip)
- (uni fvars (diff bfrag.fvars lexsyms))
- (uni [reduce-left uni ifrags nil .ffuns]
- bfrag.ffuns)))))))))
-
-(defmeth compiler comp-fun (me oreg env form)
- (mac-param-bind form (op arg) form
- (let ((fbin env.(lookup-fun arg t)))
- (cond
- (fbin (new (frag fbin.loc nil nil (list arg))))
- ((and (consp arg) (eq (car arg) 'lambda))
- me.(compile oreg env arg))
- (t (new (frag oreg ^((getf ,oreg ,me.(get-sidx arg)))
- nil (list arg))))))))
-
-(defmeth compiler comp-progn (me oreg env args)
- (let* (ffuns fvars
- (lead-forms (butlastn 1 args))
- (last-form (nthlast 1 args))
- (eff-lead-forms (remove-if [orf constantp symbolp] lead-forms))
- (forms (append eff-lead-forms last-form))
- (nargs (len forms))
- lastfrag
- (oreg-discard me.(alloc-treg))
- (code (build
- (each ((form forms)
- (n (range 1)))
- (let ((islast (eql n nargs)))
- (let ((frag me.(compile (if islast oreg oreg-discard)
- env form)))
- (when islast
- (set lastfrag frag))
- (set fvars (uni fvars frag.fvars))
- (set ffuns (uni ffuns frag.ffuns))
- (pend frag.code)))))))
- me.(free-treg oreg-discard)
- (new (frag (if lastfrag lastfrag.oreg ^(t 0)) code fvars ffuns))))
-
-(defmeth compiler comp-and-or (me oreg env form)
- (tree-case form
- ((op) me.(compile oreg env (if (eq op 'and) t)))
- ((op arg) me.(compile oreg env arg))
- ((op . args)
- (let* (ffuns fvars
- (nargs (len args))
- lastfrag
- (is-and (eq op 'and))
- (lout (gensym "l"))
- (treg me.(maybe-alloc-treg oreg))
- (code (build
- (each ((form args)
- (n (range 1)))
- (let ((islast (eql n nargs)))
- (let ((frag me.(compile treg env form)))
- (when islast
- (set lastfrag frag))
- (pend frag.code
- (maybe-mov treg frag.oreg))
- (unless islast
- (add (if is-and
- ^(if ,treg ,lout)
- ^(ifq ,treg ,nil ,lout))))
- (set fvars (uni fvars frag.fvars))
- (set ffuns (uni ffuns frag.ffuns))))))))
- me.(maybe-free-treg treg oreg)
- (new (frag oreg
- (append code ^(,lout
- ,*(maybe-mov oreg treg)))
- fvars ffuns))))))
-
-(defmeth compiler comp-prog1 (me oreg env form)
- (tree-case form
- ((prog1 fi . re) (let* ((igreg me.(alloc-treg))
- (fireg me.(maybe-alloc-treg oreg))
- (fi-frag me.(compile fireg env fi))
- (re-frag me.(comp-progn igreg env
- (append re '(nil)))))
- me.(maybe-free-treg fireg oreg)
- me.(free-treg igreg)
- (new (frag fireg
- (append fi-frag.code
- (maybe-mov fireg fi-frag.oreg)
- re-frag.code)
- (uni fi-frag.fvars re-frag.fvars)
- (uni fi-frag.ffuns re-frag.ffuns)))))
- ((prog1 fi) me.(compile oreg env fi))
- ((prog1) me.(compile oreg env nil))))
-
-(defmeth compiler comp-quasi (me oreg env form)
- (let ((qexp (expand-quasi form)))
- me.(compile oreg env (expand qexp))))
-
-(defmeth compiler comp-fun-form (me oreg env form)
- (tree-bind (sym . args) form
- (cond
- ((= (len args) 2)
- (iflet ((bin [%bin-op% sym]))
- (set sym bin
- form (cons sym args))))
- ((= (len args) 1)
- (caseq sym
- (- (set sym 'neg
- form (cons sym args)))
- ((identity + * min max) (return-from comp-fun-form
- me.(compile oreg env (car args)))))))
- (caseql sym
- ((call apply usr:apply)
- (let ((gopcode [%gcall-op% sym])
- (opcode [%call-op% sym]))
- (tree-case (car args)
- ((op arg . more)
- (caseq op
- (fun (cond
- (more (compile-error form "excess args in fun form"))
- ((bindable arg)
- (let ((fbind env.(lookup-fun arg t)))
- me.(comp-call-impl oreg env (if fbind opcode gopcode)
- (if fbind fbind.loc me.(get-sidx arg))
- (cdr args))))
- ((and (consp arg) (eq (car arg) 'lambda))
- me.(comp-fun-form oreg env ^(,sym ,arg ,*(cdr args))))
- (t :)))
- (lambda me.(comp-inline-lambda oreg env opcode
- (car args) (cdr args)))
- (t :)))
- (arg me.(comp-call oreg env
- (if (eq sym 'usr:apply) 'apply sym) args)))))
- (ift me.(comp-ift oreg env form))
- (t (let* ((fbind env.(lookup-fun sym t))
- (cfrag me.(comp-call-impl oreg env (if fbind 'call 'gcall)
- (if fbind fbind.loc me.(get-sidx sym))
- args)))
- (pushnew sym cfrag.ffuns)
- cfrag)))))
-
-(defmeth compiler comp-call (me oreg env opcode args)
- (tree-bind (fform . fargs) args
- (let* ((foreg me.(maybe-alloc-treg oreg))
- (ffrag me.(compile foreg env fform))
- (cfrag me.(comp-call-impl oreg env opcode ffrag.oreg fargs)))
- me.(maybe-free-treg foreg oreg)
- (new (frag cfrag.oreg
- (append ffrag.code
- cfrag.code)
- (uni ffrag.fvars cfrag.fvars)
- (uni ffrag.ffuns cfrag.ffuns))))))
-
-(defmeth compiler comp-call-impl (me oreg env opcode freg args)
- (let* ((aoregs nil)
- (afrags (collect-each ((arg args))
- (let* ((aoreg me.(alloc-treg))
- (afrag me.(compile aoreg env arg)))
- (if (nequal afrag.oreg aoreg)
- me.(free-treg aoreg)
- (push aoreg aoregs))
- afrag))))
- me.(free-tregs aoregs)
- (new (frag oreg
- ^(,*(mappend .code afrags)
- (,opcode ,oreg ,freg ,*(mapcar .oreg afrags)))
- [reduce-left uni afrags nil .fvars]
- [reduce-left uni afrags nil .ffuns]))))
-
-(defmeth compiler comp-inline-lambda (me oreg env opcode lambda args)
- (let ((reg-args args) apply-list-arg)
- (when (eql opcode 'apply)
- (unless args
- (compile-error lambda "apply requires arguments"))
- (set reg-args (butlast args)
- apply-list-arg (car (last args))))
- me.(compile oreg env (expand (lambda-apply-transform lambda
- reg-args
- apply-list-arg
- nil)))))
-
-(defmeth compiler comp-for (me oreg env form)
- (mac-param-bind form (op inits (: (test nil test-p) . rets) incs . body) form
- (let* ((treg me.(alloc-treg))
- (ifrag me.(comp-progn treg env inits))
- (tfrag (if test-p me.(compile oreg env test)))
- (rfrag me.(comp-progn oreg env rets))
- (nfrag me.(comp-progn treg env incs))
- (bfrag me.(comp-progn treg env body))
- (lback (gensym "l"))
- (lskip (gensym "l"))
- (frags (build
- (add ifrag)
- (if test-p (add tfrag))
- (add rfrag nfrag bfrag))))
- me.(free-treg treg)
- (new (frag rfrag.oreg
- ^(,*ifrag.code
- ,lback
- ,*(if test-p
- ^(,*tfrag.code
- (if ,tfrag.oreg ,lskip)))
- ,*bfrag.code
- ,*nfrag.code
- (jmp ,lback)
- ,*(if test-p
- ^(,lskip
- ,*rfrag.code)))
- [reduce-left uni frags nil .fvars]
- [reduce-left uni frags nil .ffuns])))))
-
-(defmeth compiler comp-tree-bind (me oreg env form)
- (tree-bind (op params obj . body) form
- (with-gensyms (obj-var)
- (let ((expn (expand ^(let ((,obj-var ,obj))
- ,(expand-bind-mac-params ^',form
- ^',(rlcp ^(,(car form))
- form)
- params nil
- obj-var t nil body)))))
- me.(compile oreg env expn)))))
-
-(defmeth compiler comp-mac-param-bind (me oreg env form)
- (mac-param-bind form (op context params obj . body) form
- (with-gensyms (obj-var form-var)
- (let ((expn (expand ^(let* ((,obj-var ,obj)
- (,form-var ,context))
- ,(expand-bind-mac-params form-var
- form-var
- params nil
- obj-var t nil body)))))
- me.(compile oreg env expn)))))
-
-(defmeth compiler comp-tree-case (me oreg env form)
- (mac-param-bind form (op obj . cases) form
- (let* ((ncases (len cases))
- (nenv (new env up env co me))
- (obj-immut-var (cdar nenv.(extend-var (gensym))))
- (obj-var (cdar nenv.(extend-var (gensym))))
- (err-blk (gensym))
- (lout (gensym "l"))
- (ctx-form ^',form)
- (err-form ^',(rlcp ^(,(car form)) form))
- (treg me.(maybe-alloc-treg oreg))
- (objfrag me.(compile treg env obj))
- (cfrags (collect-each ((c cases)
- (i (range 1)))
- (mac-param-bind form (params . body) c
- (let* ((src (expand ^(block ,err-blk
- (set ,obj-var.sym
- ,obj-immut-var.sym)
- ,(expand-bind-mac-params
- ctx-form err-form
- params nil obj-var.sym :
- err-blk
- body))))
- (lerrtest (gensym "l"))
- (lnext (gensym "l"))
- (cfrag me.(compile treg nenv src)))
- (new (frag treg
- ^(,*cfrag.code
- ,*(maybe-mov treg cfrag.oreg)
- (ifq ,treg ,me.(get-dreg :) ,lout))
- cfrag.fvars
- cfrag.ffuns))))))
- (allfrags (cons objfrag cfrags)))
- me.(maybe-free-treg treg oreg)
- (new (frag oreg
- ^(,*objfrag.code
- (frame ,nenv.lev ,nenv.v-cntr)
- ,*(maybe-mov obj-immut-var.loc objfrag.oreg)
- ,*(mappend .code cfrags)
- (mov ,treg nil)
- ,lout
- ,*(maybe-mov oreg treg)
- (end ,oreg))
- [reduce-left uni allfrags nil .fvars]
- [reduce-left uni allfrags nil .ffuns])))))
-
-(defmeth compiler comp-lisp1-value (me oreg env form)
- (mac-param-bind form (op arg) form
- (cond
- ((bindable arg)
- (let ((bind env.(lookup-lisp1 arg t)))
- (cond
- (bind
- (new (frag bind.loc
- nil
- (if (typep bind 'vbinding) (list arg))
- (if (typep bind 'fbinding) (list arg)))))
- ((not (boundp arg))
- (pushnew arg assumed-fun)
- (new (frag oreg
- ^((getf ,oreg ,me.(get-sidx arg)))
- nil
- (list arg))))
- ((special-var-p arg)
- (new (frag oreg
- ^((getv ,oreg ,me.(get-dreg arg)))
- (list arg)
- nil)))
- (t (new (frag oreg
- ^((getlx ,oreg ,me.(get-sidx arg)))
- (list arg)
- nil))))))
- (t me.(compile oreg env arg)))))
-
-(defmeth compiler comp-dwim (me oreg env form)
- (mac-param-bind form (op obj . args) form
- (let* ((l1-exprs (cdr form))
- (fun (car l1-exprs))
- (bind env.(lookup-lisp1 fun nil)))
- me.(compile oreg env
- (if (and (symbolp fun)
- (not bind)
- (not (boundp fun)))
- (progn
- (pushnew fun assumed-fun)
- ^(,fun ,*(mapcar (op list 'sys:lisp1-value) (cdr l1-exprs))))
- ^(call ,*(mapcar (op list 'sys:lisp1-value) l1-exprs)))))))
-
-(defmeth compiler comp-prof (me oreg env form)
- (mac-param-bind form (op . forms) form
- (let ((bfrag me.(comp-progn oreg env forms)))
- (new (frag oreg
- ^((prof ,oreg)
- ,*bfrag.code
- (end ,bfrag.oreg))
- bfrag.fvars bfrag.ffuns)))))
-
-(defun misleading-ref-check (frag env form)
- (each ((v frag.fvars))
- (when env.(lookup-var v)
- (compile-warning form "cannot refer to lexical variable ~s" v)))
- (each ((f frag.ffuns))
- (when env.(lookup-fun f)
- (compile-warning form "cannot refer to lexical function ~s" f))))
-
-(defmeth compiler comp-load-time-lit (me oreg env form)
- (mac-param-bind form (op loaded-p exp) form
- (if loaded-p
- me.(compile oreg env ^(quote ,exp))
- (compile-in-toplevel me
- (let* ((oreg me.(alloc-treg))
- (dreg me.(alloc-dreg))
- (exp me.(compile oreg (new env co me) exp))
- (lt-frag (new (frag dreg
- ^(,*exp.code
- (mov ,dreg ,exp.oreg))
- exp.fvars
- exp.ffuns))))
- (misleading-ref-check exp env form)
- me.(free-treg oreg)
- (push lt-frag me.lt-frags)
- (new (frag dreg nil)))))))
-
-(defun maybe-mov (to-reg from-reg)
- (if (nequal to-reg from-reg)
- ^((mov ,to-reg ,from-reg))))
-
-(defun expand-quasi-mods (obj mods : form)
- (let (plist num sep rng-ix scalar-ix-p flex gens)
- (flet ((get-sym (exp)
- (let ((gen (gensym)))
- (push (list gen exp) gens)
- gen)))
- (for () (mods) ((pop mods))
- (let ((mel (car mods)))
- (cond
- ((keywordp mel)
- (set plist mods)
- (return))
- ((integerp mel)
- (when num
- (compile-error form "duplicate modifier (width/alignment): ~s"
- num))
- (set num mel))
- ((stringp mel)
- (when sep
- (compile-error form "duplicate modifier (separator): ~s"
- num))
- (set sep mel))
- ((atom mel)
- (push (get-sym mel) flex))
- (t
- (caseq (car mel)
- (dwim
- (when rng-ix
- (compile-error form "duplicate modifier (range/index): ~s"
- mel))
- (unless (consp (cdr mel))
- (compile-error form "missing argument in range/index: ~s"
- mel))
- (unless (null (cddr mel))
- (compile-error form "excess args in range/index: ~s"
- num))
- (let ((arg (cadr mel)))
- (cond
- ((and (consp arg) (eq (car arg) 'range))
- (set rng-ix (get-sym ^(rcons ,(cadr arg) ,(caddr arg)))))
- (t
- (set rng-ix (get-sym arg))
- (set scalar-ix-p t)))))
- (sys:expr (push (get-sym flex) (cadr mel)))
- (t (push (get-sym mel) flex)))))))
- (let ((mcount (+ (if num 1 0)
- (if sep 1 0)
- (if rng-ix 1 0)
- (len flex))))
- (when (> mcount 3)
- (compile-error form "too many formatting modifiers"))
- ^(alet ,(nreverse gens)
- ,(if flex
- ^(sys:fmt-flex ,obj ',plist
- ,*(remq nil (list* num sep
- (if scalar-ix-p
- ^(rcons ,rng-ix nil)
- rng-ix)
- (nreverse flex))))
- (cond
- (plist ^(sys:fmt-simple ,obj ,num ,sep, rng-ix ',plist))
- (rng-ix ^(sys:fmt-simple ,obj ,num ,sep, rng-ix))
- (sep ^(sys:fmt-simple ,obj ,num ,sep))
- (num ^(sys:fmt-simple ,obj ,num))
- (t ^(sys:fmt-simple ,obj ,num)))))))))
-
-(defun expand-quasi-args (form)
- (append-each ((el (cdr form)))
- (cond
- ((consp el)
- (caseq (car el)
- (sys:var (mac-param-bind form (sym exp : mods) el
- (list (expand-quasi-mods exp mods))))
- (sys:quasi (expand-quasi-mods el))
- (t (list ^(sys:fmt-simple ,el)))))
- ((bindable el)
- (list ^(sys:fmt-simple ,el)))
- (t
- (list el)))))
-
-(defun expand-quasi (form)
- (let ((qa (expand-quasi-args form)))
- ^(sys:fmt-join ,*qa)))
-
-(defun expand-dohash (form)
- (mac-param-bind form (op (key-var val-var hash-form : res-form) . body) form
- (with-gensyms (iter-var cell-var)
- ^(let (,key-var ,val-var (,iter-var (hash-begin ,hash-form)) ,cell-var)
- (sys:for-op ((sys:setq ,cell-var (hash-next ,iter-var)))
- (,cell-var ,res-form)
- ((sys:setq ,cell-var (hash-next ,iter-var)))
- (sys:setq ,key-var (car ,cell-var))
- (sys:setq ,val-var (cdr ,cell-var))
- ,*body)))))
-
-(defun expand-each (form env)
- (mac-param-bind form (op each-type vars . body) form
- (unless vars
- (set vars [mapcar car env.vb]))
- (let* ((gens (mapcar (ret (gensym)) vars))
- (out (if (member each-type '(collect-each append-each))
- (gensym)))
- (accum (if out (gensym))))
- ^(let* (,*(zip gens vars) ,*(if accum ^((,out (cons nil nil)) (,accum ,out))))
- (sys:for-op ()
- ((and ,*gens) ,*(if accum ^((cdr ,out))))
- (,*(mapcar (ret ^(sys:setq ,@1 (cdr ,@1))) gens))
- ,*(mapcar (ret ^(sys:setq ,@1 (car ,@2))) vars gens)
- ,*(caseq each-type
- (collect-each ^((rplacd ,accum (cons (progn ,*body) nil))
- (sys:setq ,accum (cdr ,accum))))
- (append-each ^((rplacd ,accum (append (cdr ,accum) (progn ,*body)))
- (sys:setq ,accum (last ,accum))))
- (t body)))))))
-
-(defun expand-bind-mac-params (ctx-form err-form params menv-var
- obj-var strict err-block body)
- (let (gen-stk stmt vars)
- (labels ((get-gen ()
- (or (pop gen-stk) (gensym)))
- (put-gen (g)
- (push g gen-stk))
- (expand-rec (par-syntax obj-var check-var)
- (labels ((emit-stmt (form)
- (when form
- (if check-var
- (push ^(when ,check-var ,form) stmt)
- (push form stmt))))
- (emit-var (sym init-form)
- (push (if stmt
- (prog1
- ^(,sym (progn ,*(nreverse stmt)
- ,(if check-var
- ^(when ,check-var ,init-form)
- init-form)))
- (set stmt nil))
- ^(,sym ,(if check-var
- ^(when ,check-var ,init-form)
- init-form)))
- vars)))
- (let ((pars (new (mac-param-parser par-syntax ctx-form))))
- (progn
- (cond
- ((eq strict t)
- (emit-stmt
- ^(sys:bind-mac-check ,err-form ',par-syntax
- ,obj-var ,pars.nreq
- ,(unless pars.rest
- pars.nfix))))
- ((null strict))
- ((symbolp strict)
- (emit-stmt
- (let ((len-expr ^(if (consp ,obj-var)
- (len ,obj-var) 0)))
- (if pars.rest
- ^(unless (<= ,pars.nreq ,len-expr)
- (return-from ,err-block ',strict))
- ^(unless (<= ,pars.nreq ,len-expr ,pars.nfix)
- (return-from ,err-block ',strict)))))))
- (each ((k pars.key))
- (tree-bind (key . sym) k
- (caseq key
- (:whole (emit-var sym obj-var))
- (:form (emit-var sym ctx-form))
- (:env (emit-var sym menv-var)))))
- (each ((p pars.req))
- (cond
- ((listp p)
- (let ((curs (get-gen)))
- (emit-stmt ^(set ,curs (car ,obj-var)))
- (emit-stmt ^(set ,obj-var (cdr ,obj-var)))
- (expand-rec p curs check-var)
- (put-gen curs)))
- (t
- (emit-var p ^(car ,obj-var))
- (emit-stmt ^(set ,obj-var (cdr ,obj-var))))))
- (each ((o pars.opt))
- (tree-bind (p : init-form pres-p) o
- (cond
- ((listp p)
- (let* ((curs (get-gen))
- (stmt ^(cond
- (,obj-var
- (set ,curs (car ,obj-var))
- (set ,obj-var (cdr ,obj-var))
- ,*(if pres-p '(t)))
- (t
- (set ,curs ,init-form)
- ,*(if pres-p '(nil))))))
- (if pres-p
- (emit-var pres-p stmt)
- (emit-stmt stmt))
- (let ((cv (gensym)))
- (emit-var cv curs)
- (expand-rec p curs cv)
- (put-gen curs))))
- (t
- (cond
- (pres-p
- (emit-var p nil)
- (emit-var pres-p
- ^(cond
- (,obj-var
- (set ,p (car ,obj-var))
- (set ,obj-var (cdr ,obj-var))
- ,(if pres-p t))
- (t
- ,(if init-form
- ^(set ,p ,init-form))
- ,(if pres-p nil)))))
- (t
- (emit-var p ^(if ,obj-var
- (prog1
- (car ,obj-var)
- (set ,obj-var (cdr ,obj-var)))
- (if ,init-form ,init-form)))))))))
- (when pars.rest
- (emit-var pars.rest obj-var)))))))
- (expand-rec params obj-var nil)
- (when stmt
- (push ^(,(gensym) (progn ,*(nreverse stmt))) vars))
- ^(let* (,*gen-stk ,*(nreverse vars))
- ,*body))))
-
-(defun expand-defvarl (form)
- (mac-param-bind form (op sym : value) form
- (with-gensyms (cell)
- ^(let ((,cell (sys:rt-defvarl ',sym)))
- (if ,cell
- (usr:rplacd ,cell (cons ',sym ,value)))
- ',sym))))
-
-(defun expand-defun (form)
- (mac-param-bind form (op name args . body) form
- (flet ((mklambda (block-name)
- ^(lambda ,args (block ,block-name ,*body))))
- (cond
- ((bindable name)
- ^(sys:rt-defun ',name ,(mklambda name)))
- ((consp name)
- (caseq (car name)
- (meth
- (mac-param-bind form (meth type slot) name
- ^(sys:define-method ',type ',slot ,(mklambda slot))))
- (macro
- (mac-param-bind form (macro sym) name
- ^(sys:rt-defmacro ',sym ',name ,(mklambda sym))))
- (t (compile-error form "~s isn't a valid compound function name"
- name))))
- (t (compile-error form "~s isn't a valid function name" name))))))
-
-(defun expand-defmacro (form)
- (mac-param-bind form (op name mac-args . body) form
- (with-gensyms (form menv spine-iter)
- (let ((exp-lam ^(lambda (,form ,menv)
- (let ((,spine-iter (cdr ,form)))
- ,(expand (expand-bind-mac-params form form mac-args
- menv spine-iter
- t nil
- ^((sys:set-macro-ancestor
- (block ,name ,*body)
- ,form))))))))
- ^(progn
- (sys:rt-defmacro ',name '(macro ,name) ,exp-lam)
- ',name)))))
-
-(defun expand-defsymacro (form)
- (mac-param-bind form (op name def) form
- ^(sys:rt-defsymacro ',name ',def)))
-
-(defun lambda-apply-transform (lm-expr fix-arg-exprs apply-list-expr recursed)
- (if (and (not recursed)
- apply-list-expr
- (constantp apply-list-expr))
- (let* ((apply-list-val (eval apply-list-expr))
- (apply-atom (nthlast 0 apply-list-val))
- (apply-fixed (butlastn 0 apply-list-val)))
- (lambda-apply-transform lm-expr (append fix-arg-exprs
- (mapcar (ret ^',@1) apply-fixed))
- ^',apply-atom t))
- (mac-param-bind lm-expr (lambda lm-args . lm-body) lm-expr
- (let* ((pars (new (fun-param-parser lm-args lm-expr)))
- (fix-vals (mapcar (ret (gensym)) fix-arg-exprs))
- (ign-sym (gensym))
- (al-val (gensym))
- (shadow-p (let ((all-vars (append pars.req pars.(opt-syms)
- (if pars.rest (list pars.rest)))))
- (or (isec all-vars fix-arg-exprs)
- (member apply-list-expr all-vars)))))
- ^(,(if shadow-p 'let 'alet) ,(zip fix-vals fix-arg-exprs)
- (let* ,(build
- (if apply-list-expr
- (add ^(,al-val ,apply-list-expr)))
- (while (and fix-vals pars.req)
- (add ^(,(pop pars.req) ,(pop fix-vals))))
- (while (and fix-vals pars.opt)
- (tree-bind (var-sym : init-form have-sym) (pop pars.opt)
- (add ^(,var-sym ,(pop fix-vals)))
- (if have-sym
- (add ^(,have-sym t)))))
- (cond
- ((and (null pars.req)
- (null pars.opt))
- (if fix-vals
- (if pars.rest
- (add ^(,pars.rest (list* ,*fix-arg-exprs ,apply-list-expr)))
- (lambda-too-many-args lm-expr))
- (when (or pars.rest apply-list-expr)
- (add ^(,(or pars.rest ign-sym) ,apply-list-expr)))))
- ((and fix-vals apply-list-expr)
- (lambda-too-many-args lm-expr))
- (apply-list-expr
- (when pars.req
- (add ^(,ign-sym (if (< (len ,al-val) ,(len pars.req))
- (lambda-short-apply-list)))))
- (while pars.req
- (add ^(,(pop pars.req) (pop ,al-val))))
- (while pars.opt
- (tree-bind (var-sym : init-form have-sym) (pop pars.opt)
- (cond
- (have-sym
- (add ^(,var-sym (if ,al-val
- (car ,al-val)
- ,init-form)))
- (add ^(,have-sym (when ,al-val
- (pop ,al-val)
- t))))
- (t (add ^(,var-sym (if ,al-val
- (pop ,al-val)
- ,init-form)))))))
- (when pars.rest
- (add ^(,pars.rest ,al-val))))
- (pars.req
- (lambda-too-few-args lm-expr))
- (pars.opt
- (while pars.opt
- (tree-bind (var-sym : init-form have-sym) (pop pars.opt)
- (add ^(,var-sym ,init-form))
- (if have-sym
- (add ^(,have-sym)))))
- (when pars.rest
- (add ^(,pars.rest))))))
- ,*lm-body))))))
-
-(defun system-symbol-p (sym)
- (member (symbol-package sym)
- (load-time (list user-package system-package))))
-
-(defun usr:compile-toplevel (exp : (expanded-p nil))
- (let ((co (new compiler))
- (as (new assembler))
- (*dedup* (or *dedup* (hash))))
- (let* ((oreg co.(alloc-treg))
- (xexp (if expanded-p
- exp
- (unwind-protect
- (expand* exp)
- (unless *load-recursive*
- (release-deferred-warnings)))))
- (frag co.(compile oreg (new env co co) xexp)))
- co.(free-treg oreg)
- co.(check-treg-leak)
- as.(asm ^(,*(mappend .code (nreverse co.lt-frags)) ,*frag.code (end ,frag.oreg)))
- (vm-make-desc co.nlev (succ as.max-treg) as.buf co.(get-datavec) co.(get-symvec)))))
-
-(defun compiler-emit-warnings ()
- (let ((warn-fun [keep-if boundp (zap assumed-fun)]))
- (when warn-fun
- (usr:catch
- (throw 'warning
- `uses of @{warn-fun ", "} compiled as functions,\
- \ then defined as vars`)
- (continue ())))))
-
-(defvarl %file-suff-rx% #/[.][^\\\/.]+/)
-
-(defvar *emit*)
-
-(defvar *eval*)
-
-(defvarl %big-endian% (equal (ffi-put 1 (ffi uint32)) #b'00000001'))
-
-(defvarl %tlo-ver% ^(5 0 ,%big-endian%))
-
-(defvarl %package-manip% '(make-package delete-package
- use-package unuse-package
- set-package-fallback-list
- intern unintern rehome-sym
- use-sym unuse-sym))
-
-(defun open-compile-streams (in-path out-path test-fn)
- (let* ((parent (or *load-path* ""))
- (sep [path-sep-chars 0])
- (in-path (if (pure-rel-path-p in-path)
- `@(dir-name parent)@sep@{in-path}`
- in-path))
- (rsuff (r$ %file-suff-rx% in-path))
- (suff (if rsuff [in-path rsuff]))
- (ip-nosuff (if rsuff [in-path 0..(from rsuff)] in-path))
- in-stream out-stream)
- (cond
- ((ends-with ".txr" in-path)
- (error "~s: cannot compile TXR files" 'compile-file))
- ((ends-with ".tl" in-path)
- (set in-stream (ignerr (open-file in-path))
- out-path (or out-path `@{in-path [0..-3]}.tlo`)))
- (t
- (set in-stream (or (ignerr (open-file `@{in-path}.tl`))
- (ignerr (open-file in-path)))
- out-path (or out-path `@{in-path}.tlo`))))
-
- (unless in-stream
- (error "~s: unable to open input file ~s" 'compile-file in-path))
-
- (unless [test-fn in-stream out-path]
- (close-stream in-stream)
- (return-from open-compile-streams nil))
-
- (set out-stream (ignerr (open-file out-path "w")))
-
- (unless out-stream
- (close-stream in-stream)
- (error "~s: unable to open output file ~s" 'compile-file in-stream))
-
- (list in-stream out-stream out-path)))
-
-(defun list-from-vm-desc (vd)
- (list (sys:vm-desc-nlevels vd)
- (sys:vm-desc-nregs vd)
- (sys:vm-desc-bytecode vd)
- (copy (sys:vm-desc-datavec vd))
- (sys:vm-desc-symvec vd)))
-
-(defmacro usr:with-compilation-unit (. body)
- (with-gensyms (rec)
- ^(let* ((,rec sys:*load-recursive*)
- (sys:*load-recursive* t)
- (*dedup* (or *dedup* (hash))))
- (unwind-protect
- (progn ,*body)
- (unless ,rec
- (release-deferred-warnings)
- (compiler-emit-warnings))))))
-
-(defun dump-to-tlo (out-stream out)
- (let* ((*print-circle* t)
- (*package* (sys:make-anon-package))
- (out-forms (split* out.(get) (op where (op eq :fence)))))
- (prinl %tlo-ver% out-stream)
- [mapdo (op prinl @1 out-stream) out-forms]
- (delete-package *package*)))
-
-(defun propagate-perms (in-stream out-stream)
- (let ((sti (stat in-stream)))
- (when (plusp (logand sti.mode s-ixusr))
- (let ((mode "+x")
- (suid (if (plusp (logand sti.mode s-isuid)) ",u+s"))
- (sgid (if (and (plusp (logand sti.mode s-isgid))
- (plusp (logand sti.mode s-ixgrp))) ",g+s")))
- (when (or suid sgid)
- (let ((sto (stat out-stream)))
- (set mode (append mode
- (if (eql sti.uid sto.uid) suid)
- (if (eql sti.gid sto.gid) sgid)))))
- (chmod out-stream mode)))))
-
-(defun compile-file-conditionally (in-path out-path test-fn)
- (whenlet ((success nil)
- (perms nil)
- (streams (open-compile-streams in-path out-path test-fn)))
- (with-resources ((in-stream (car streams) (close-stream in-stream))
- (out-stream (cadr streams) (progn
- (when perms
- (propagate-perms in-stream
- out-stream))
- (close-stream out-stream)
- (unless success
- (remove-path (caddr streams))))))
- (let* ((err-ret (gensym))
- (*package* *package*)
- (*emit* t)
- (*eval* t)
- (*load-path* (stream-get-prop (car streams) :name))
- (*rec-source-loc* t)
- (out (new list-builder)))
- (with-compilation-unit
- (iflet ((line (get-line in-stream))
- ((starts-with "#!" line)))
- (progn
- (set line `@line `)
- (upd line (regsub #/--lisp[^\-]/ (ret `--compiled@[@1 -1]`)))
- (put-line (butlast line) out-stream)
- (set perms t))
- (seek-stream in-stream 0 :from-start))
- (labels ((compile-form (unex-form)
- (let* ((form (macroexpand unex-form))
- (sym (if (consp form) (car form))))
- (caseq sym
- (progn [mapdo compile-form (cdr form)])
- (compile-only (let ((*eval* nil))
- [mapdo compile-form (cdr form)]))
- (eval-only (let ((*emit* nil))
- [mapdo compile-form (cdr form)]))
- (sys:load-time-lit
- (if (cadr form)
- (compile-form ^(quote ,(caddr form)))
- (compile-form (caddr form))))
- (t (when (and (or *eval* *emit*)
- (not (constantp form)))
- (let* ((vm-desc (compile-toplevel form))
- (flat-vd (list-from-vm-desc vm-desc))
- (fence (member sym %package-manip%)))
- (when *eval*
- (let ((pa *package-alist*))
- (sys:vm-execute-toplevel vm-desc)
- (when (neq pa *package-alist*)
- (set fence t))))
- (when (and *emit* (consp form))
- out.(add flat-vd)
- (when fence
- out.(add :fence))))))))))
- (unwind-protect
- (whilet ((obj (read in-stream *stderr* err-ret))
- ((neq obj err-ret)))
- (compile-form obj))
- (dump-to-tlo out-stream out))
-
- (let ((parser (sys:get-parser in-stream)))
- (when (> (sys:parser-errors parser) 0)
- (error "~s: compilation of ~s failed" 'compile-file
- (stream-get-prop in-stream :name)))))
- (flush-stream out-stream)
- (set success t))))))
-
-(defun usr:compile-file (in-path : out-path)
- [compile-file-conditionally in-path out-path tf])
-
-(defun usr:compile-update-file (in-path : out-path)
- [compile-file-conditionally in-path out-path [mapf path-newer fstat identity]])
-
-(defun usr:dump-compiled-objects (out-stream . compiled-objs)
- (symacrolet ((self 'dump-compiled-objects))
- (let ((out (new list-builder)))
- (flet ((vm-from-fun (fun)
- (unless (vm-fun-p fun)
- (error "~s: not a vm function: ~s" self fun))
- (sys:vm-closure-desc (func-get-env fun))))
- (each ((obj compiled-objs))
- (let* ((vm-desc (typecase obj
- (vm-desc obj)
- (fun (vm-from-fun obj))
- (t (iflet ((fun (symbol-function obj)))
- (vm-from-fun fun)
- (error "~s: not a compiled object: ~s"
- self obj)))))
- (symvec (sys:vm-desc-symvec vm-desc)))
- out.(add (list-from-vm-desc vm-desc))
- (when (isec symvec %package-manip%)
- out.(add :fence)))))
- (dump-to-tlo out-stream out))))
-
-(defun sys:env-to-let (env form)
- (when env
- (let ((vb (env-vbindings env))
- (fb (env-fbindings env))
- (up (env-next env)))
- (when vb
- (set form ^(let ,(mapcar (tb ((a . d)) ^(,a ',d)) vb) ,form)))
- (when fb
- (let (lbind fbind)
- (each ((pair fb))
- (tree-bind (a . d) pair
- (let* ((fun-p (interp-fun-p d))
- (fe (if fun-p (func-get-env d)))
- (lb-p (and fe (eq fe env)))
- (fb-p (and fe (eq fe up))))
- (cond
- (lb-p (push ^(,a ,(func-get-form d)) lbind))
- (fb-p (push ^(,a ,(func-get-form d)) fbind))
- (t (push ^(,a ',d) fbind))))))
- (when lbind
- (set form ^(sys:lbind ,(nreverse lbind) ,form)))
- (when fbind
- (set form ^(sys:fbind ,(nreverse fbind) ,form)))))
- (if up
- (set form (sys:env-to-let up form)))))
- form)
-
-(defun usr:compile (obj)
- (typecase obj
- (fun (tree-bind (indicator args . body) (func-get-form obj)
- (let* ((form (sys:env-to-let (func-get-env obj)
- ^(lambda ,args ,*body)))
- (vm-desc (compile-toplevel form)))
- (vm-execute-toplevel vm-desc))))
- (t (condlet
- (((fun (symbol-function obj)))
- (tree-bind (indicator args . body) (func-get-form fun)
- (let* ((form (sys:env-to-let (func-get-env fun)
- ^(lambda ,args ,*body)))
- (vm-desc (compile-toplevel form))
- (comp-fun (vm-execute-toplevel vm-desc)))
- (set (symbol-function obj) comp-fun))))
- (t (error "~s: cannot compile ~s" 'compile obj))))))
diff --git a/share/txr/stdlib/getput.tl b/share/txr/stdlib/getput.tl
deleted file mode 100644
index daf08b1e..00000000
--- a/share/txr/stdlib/getput.tl
+++ /dev/null
@@ -1,132 +0,0 @@
-;; Copyright 2016-2020
-;; Kaz Kylheku <kaz@kylheku.com>
-;; Vancouver, Canada
-;; All rights reserved.
-;;
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions are met:
-;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
-;;
-;; 2. Redistributions in binary form must reproduce the above copyright notice,
-;; this list of conditions and the following disclaimer in the documentation
-;; and/or other materials provided with the distribution.
-;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-(defun sys:get-buf-common (s bytes seek)
- (let ((b (make-buf 0 0 (min bytes 4096)))
- (o 0))
- (when (plusp seek)
- (unless (ignerr (seek-stream s seek :from-current))
- (let ((b (make-buf (min seek 4096)))
- (c 0))
- (while (< c seek)
- (let ((p (fill-buf b 0 s)))
- (if (zerop p)
- (return))
- (inc c p))))))
- (while (or (null bytes) (< (len b) bytes))
- (let ((p (fill-buf-adjust b o s)))
- (when (= p o)
- (return))
- (set o p)
- (when (eql p (buf-alloc-size b))
- (buf-set-length b (min (+ p p) bytes)))))
- b))
-
-(defun file-get (name)
- (with-stream (s (open-file name))
- (read s)))
-
-(defun file-put (name obj)
- (with-stream (s (open-file name "w"))
- (prinl obj s)))
-
-(defun file-append (name obj)
- (with-stream (s (open-file name "a"))
- (prinl obj s)))
-
-(defun file-get-string (name)
- (with-stream (s (open-file name))
- (get-string s)))
-
-(defun file-put-string (name string)
- (with-stream (s (open-file name "w"))
- (put-string string s)))
-
-(defun file-append-string (name string)
- (with-stream (s (open-file name "a"))
- (put-string string s)))
-
-(defun file-get-lines (name)
- (get-lines (open-file name)))
-
-(defun file-put-lines (name lines)
- (with-stream (s (open-file name "w"))
- (put-lines lines s)))
-
-(defun file-append-lines (name lines)
- (with-stream (s (open-file name "a"))
- (put-lines lines s)))
-
-(defun file-get-buf (name : bytes (seek 0))
- (with-stream (s (open-file name "rb"))
- (sys:get-buf-common s bytes seek)))
-
-(defun file-put-buf (name buf : (seek 0))
- (with-stream (s (open-file name "wb"))
- (unless (zerop seek)
- (seek-stream s seek :from-current))
- (put-buf buf 0 s)))
-
-(defun file-place-buf (name buf : (seek 0))
- (with-stream (s (open-file name "mb"))
- (unless (zerop seek)
- (seek-stream s seek :from-current))
- (put-buf buf 0 s)))
-
-(defun file-append-buf (name buf)
- (with-stream (s (open-file name "ab"))
- (put-buf buf 0 s)))
-
-(defun command-get (cmd)
- (with-stream (s (open-command cmd))
- (read s)))
-
-(defun command-put (cmd obj)
- (with-stream (s (open-command cmd "w"))
- (prinl obj s)))
-
-(defun command-get-string (cmd)
- (with-stream (s (open-command cmd))
- (get-string s)))
-
-(defun command-put-string (cmd string)
- (with-stream (s (open-command cmd "w"))
- (put-string string s)))
-
-(defun command-get-lines (cmd)
- (get-lines (open-command cmd)))
-
-(defun command-put-lines (cmd lines)
- (with-stream (s (open-command cmd "w"))
- (put-lines lines s)))
-
-(defun command-get-buf (cmd : bytes (skip 0))
- (with-stream (s (open-command cmd "rb"))
- (sys:get-buf-common s bytes skip)))
-
-(defun command-put-buf (cmd buf)
- (with-stream (s (open-command cmd "wb"))
- (put-buf buf 0 s)))
diff --git a/share/txr/stdlib/keyparams.tl b/share/txr/stdlib/keyparams.tl
deleted file mode 100644
index 7dd38de2..00000000
--- a/share/txr/stdlib/keyparams.tl
+++ /dev/null
@@ -1,90 +0,0 @@
-;; Copyright 2017-2020
-;; Kaz Kylheku <kaz@kylheku.com>
-;; Vancouver, Canada
-;; All rights reserved.
-;;
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions are met:
-;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
-;;
-;; 2. Redistributions in binary form must reproduce the above copyright notice,
-;; this list of conditions and the following disclaimer in the documentation
-;; and/or other materials provided with the distribution.
-;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-(defun sys:extract-keys (keys args)
- (build
- (each ((k keys))
- (iflet ((f (memp (car k) args)))
- (add (cadr f))
- (add (cdr k))))))
-
-(defun sys:extract-keys-p (keys args)
- (build
- (each ((k keys))
- (add (if (memp k args) t)))))
-
-(defun sys:build-key-list-expr (key-params menv)
- (let ((exprs (collect-each ((kp key-params))
- (let ((kw (intern (symbol-name (first kp)) 'keyword))
- (ex (second kp)))
- (if (constantp ex menv)
- ^(quote (,kw . ,(second kp)))
- ^(cons ,kw ,(second kp)))))))
- (if [all exprs (op eq 'quote) car]
- ^(quote ,[mapcar cadr exprs])
- ^(list ,*exprs))))
-
-(define-param-expander :key (param body menv form)
- (let* ((excluding-rest (butlastn 0 param))
- (key-start (memq '-- excluding-rest))
- (rest-param (or (nthlast 0 param) (gensym)))
- (before-key (ldiff excluding-rest key-start))
- (key-params-raw (butlastn 0 (cdr key-start)))
- (key-params [mapcar [iffi atom (op list @1)] key-params-raw])
- (eff-param (append before-key rest-param)))
- (each ((key-spec key-params))
- (tree-case key-spec
- ((sym init var-p . junk)
- (when (consp junk)
- (compile-error form "superfluous forms in ~s" key-spec))
- (when junk
- (compile-error form "invalid dotted form ~s" key-spec))
- (unless (bindable var-p)
- (compile-error form "~s isn't a bindable symbol" var-p))
- :)
- ((sym init . more)
- (unless (listp more)
- (compile-error form "invalid dotted form ~s" key-spec))
- :)
- ((sym . more)
- (unless (listp more)
- (compile-error form "invalid dotted form ~s" key-spec))
- (unless (bindable sym)
- (compile-error form "~s isn't a bindable symbol" sym)))))
- (let* ((key-params-p [keep-if third key-params])
- (key-vars [mapcar first key-params])
- (key-vars-p [mapcar third key-params-p])
- (keys (sys:build-key-list-expr key-params menv))
- (keys-p (mapcar (op intern (symbol-name (first @1)) 'keyword)
- key-params-p)))
- (list eff-param
- ^(tree-bind ,key-vars
- (sys:extract-keys ,keys ,rest-param)
- ,*(if keys-p
- ^((tree-bind ,key-vars-p
- (sys:extract-keys-p ',keys-p ,rest-param)
- ,*body))
- body))))))
diff --git a/share/txr/stdlib/op.tl b/share/txr/stdlib/op.tl
deleted file mode 100644
index 9b3cf346..00000000
--- a/share/txr/stdlib/op.tl
+++ /dev/null
@@ -1,198 +0,0 @@
-;; Copyright 2017-2020
-;; Kaz Kylheku <kaz@kylheku.com>
-;; Vancouver, Canada
-;; All rights reserved.
-;;
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions are met:
-;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
-;;
-;; 2. Redistributions in binary form must reproduce the above copyright notice,
-;; this list of conditions and the following disclaimer in the documentation
-;; and/or other materials provided with the distribution.
-;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-(defvar sys:*op-ctx*)
-
-(sys:make-struct-type
- 'sys:op-ctx nil nil '(form gens up meta rec recvar) nil
- (lambda (me)
- (slotset me 'up sys:*op-ctx*)
- (slotset me 'meta (gensym "meta-")))
- nil nil)
-
-(defun sys:ensure-op-arg (ctx n)
- (let ((ag (slot ctx 'gens)))
- (when (> n 1024)
- ['compile-error (slot ctx 'form)
- "@~a calls for function with too many arguments" n])
- (for ((i (len ag)) (l))
- ((<= i n)
- (sys:setq ag (append ag (nreverse l)))
- (slotset ctx 'gens ag)
- [ag n])
- ((sys:setq i (succ i)))
- (sys:setq l (cons (gensym `arg-@(if (plusp i) i "rest")-`) l)))))
-
-(defun sys:op-meta-p (expr)
- (tree-case expr
- ((x y . r) (and (null r)
- (cond
- ((eq x 'sys:expr) (sys:op-meta-p y))
- ((eq x 'sys:var) (or (integerp y)
- (eq y 'rest))))))))
-
-(defun sys:op-rec-p (expr)
- (tree-case expr
- ((x (y . r)) (and (eq x 'sys:expr) (eq y 'usr:rec)))))
-
-(defun sys:op-ensure-rec (ctx : recvar)
- (when recvar
- (slotset ctx 'recvar t))
- (or (slot ctx 'rec) (slotset ctx 'rec (gensym "rec-"))))
-
-(defun sys:op-alpha-rename (f e op-args do-nested-metas)
- (let* ((ctx sys:*op-ctx*)
- (code ^(macrolet ((sys:expr (:form f arg)
- (let ((ctx ,ctx))
- (cond
- ((and (slot ctx 'up)
- (or (sys:op-meta-p arg)
- (sys:op-rec-p arg)
- (equal arg '(sys:var usr:rec))))
- ^(,(slot (slot ctx 'up) 'meta) (quote ,arg)))
- ((sys:op-rec-p f)
- ^(,(sys:op-ensure-rec ctx) ,*(rest arg)))
- (t f))))
- (sys:var (:form f arg . mods)
- (cond
- ((sys:op-meta-p f)
- (unless (integerp arg)
- (sys:setq arg 0))
- (sys:ensure-op-arg ,ctx arg))
- ((equal f '(sys:var usr:rec))
- (sys:op-ensure-rec ,ctx t))
- (t f)))
- ,*(if do-nested-metas
- ^((,(slot ctx 'meta) ((quote arg)) arg))))
- ,op-args)))
- (expand code e)))
-
-(eval-only
- (defmacro op-ignerr (x)
- ^(sys:catch (error) ,x () (error (. args)))))
-
-(defun sys:op-expand (f e args)
- (unless args
- ['compile-error f "arguments required"])
- (let* ((compat (and (plusp sys:compat) (<= sys:compat 225)))
- (ctx (make-struct 'sys:op-ctx ^(form ,f)))
- (do-gen)
- (sys:*op-ctx* ctx)
- (sym (car f))
- (syntax-0 (if (eq sym 'do) args ^[,*args]))
- (syntax-1 (if (or (null syntax-0) (neq sym 'do) compat)
- (sys:op-alpha-rename f e syntax-0 nil)
- (or (op-ignerr (sys:op-alpha-rename f e syntax-0 nil))
- (let ((syn (sys:op-alpha-rename
- f e (append syntax-0
- (list (sys:setq do-gen
- (gensym))))
- nil)))
- (when (slot ctx 'gens)
- (sys:op-alpha-rename f e syntax-0 nil))
- syn))))
- (syntax-2 (sys:op-alpha-rename f e syntax-1 t))
- (metas (slot ctx 'gens))
- (rec (slot ctx 'rec))
- (recvar (slot ctx 'recvar))
- (rest-sym (sys:ensure-op-arg ctx 0))
- (lambda-interior (let ((fargs (cdr (cdr syntax-2))))
- (cond
- ((and (eq sym 'lop) fargs)
- (let ((fargs-l1 (mapcar (lambda (farg)
- ^(sys:l1-val ,farg))
- fargs)))
- ^[sys:apply ,(car (cdr syntax-2))
- (append ,rest-sym (list ,*fargs-l1))]))
- (metas syntax-2)
- ((eq sym 'do)
- (cond
- (compat syntax-2)
- (do-gen
- (let ((arg1 (sys:ensure-op-arg ctx 1)))
- ^(symacrolet ((,do-gen ,arg1))
- ,syntax-2)))
- (t (let ((arg1 (sys:ensure-op-arg ctx 1)))
- (append syntax-2 (list arg1))))))
- (t (append syntax-2 rest-sym))))))
- (let ((metas (slot ctx 'gens)))
- (cond
- (recvar ^(sys:lbind ((,rec (lambda (,*(cdr metas) . ,rest-sym)
- (let ((,rec (fun ,rec)))
- ,lambda-interior))))
- (fun ,rec)))
- (rec ^(sys:lbind ((,rec (lambda (,*(cdr metas) . ,rest-sym)
- ,lambda-interior)))
- (fun ,rec)))
- (t ^(lambda (,*(cdr metas) . ,rest-sym)
- ,lambda-interior))))))
-
-(defmacro op (:form f :env e . args)
- (sys:op-expand f e args))
-
-(defmacro do (:form f :env e . args)
- (sys:op-expand f e args))
-
-(defmacro lop (:form f :env e . args)
- (sys:op-expand f e args))
-
-(defmacro ldo (op . args)
- ^(do ,op @1 ,*args))
-
-(defmacro ap (. args)
- ^(apf (op ,*args)))
-
-(defmacro ip (. args)
- ^(ipf (op ,*args)))
-
-(defmacro ado (. args)
- ^(apf (do ,*args)))
-
-(defmacro ido (. args)
- ^(ipf (do ,*args)))
-
-(defmacro ret (. args)
- ^(op identity (progn @rest ,*args)))
-
-(defmacro aret (. args)
- ^(ap identity (progn @rest ,*args)))
-
-(defun sys:opip-expand (e clauses)
- (collect-each ((c clauses))
- (if (atom c)
- c
- (let ((sym (car c)))
- (if (member sym '(dwim uref qref))
- c
- (let ((opdo (if (or (special-operator-p (car c))
- (macro-form-p c e)) 'do 'op)))
- ^(,opdo ,*c)))))))
-
-(defmacro opip (:env e . clauses)
- ^[chain ,*(sys:opip-expand e clauses)])
-
-(defmacro oand (:env e . clauses)
- ^[chand ,*(sys:opip-expand e clauses)])
diff --git a/share/txr/stdlib/path-test.tl b/share/txr/stdlib/path-test.tl
deleted file mode 100644
index d550352b..00000000
--- a/share/txr/stdlib/path-test.tl
+++ /dev/null
@@ -1,185 +0,0 @@
-;; Copyright 2015-2020
-;; Kaz Kylheku <kaz@kylheku.com>
-;; Vancouver, Canada
-;; All rights reserved.
-;;
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions are met:
-;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
-;;
-;; 2. Redistributions in binary form must reproduce the above copyright notice,
-;; this list of conditions and the following disclaimer in the documentation
-;; and/or other materials provided with the distribution.
-;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-(defun sys:do-path-test (statfun path testfun)
- [testfun (if (stringp path) (ignerr [statfun path]) path)])
-
-(eval-only
- (defmacro sys:path-test ((sym statfun path) . body)
- ^[sys:do-path-test ,statfun ,path
- (lambda (,sym) (when ,sym ,*body))]))
-
-(defun sys:path-test-type (statfun path code)
- (sys:path-test (s statfun path)
- (eql (logand s.mode s-ifmt) code)))
-
-(defun sys:path-test-mode (statfun path mask)
- (sys:path-test (s statfun path)
- (plusp (logand s.mode mask))))
-
-(defun path-exists-p (path)
- (sys:path-test (s stat path) t))
-
-(defun path-file-p (path)
- [sys:path-test-type stat path s-ifreg])
-
-(defun path-dir-p (path)
- [sys:path-test-type stat path s-ifdir])
-
-(defun path-symlink-p (path)
- [sys:path-test-type lstat path s-iflnk])
-
-(defun path-blkdev-p (path)
- [sys:path-test-type stat path s-ifblk])
-
-(defun path-chrdev-p (path)
- [sys:path-test-type stat path s-ifchr])
-
-(defun path-sock-p (path)
- [sys:path-test-type stat path s-ifsock])
-
-(defun path-pipe-p (path)
- [sys:path-test-type stat path s-ififo])
-
-(defun path-setgid-p (path)
- [sys:path-test-mode stat path s-isgid])
-
-(defun path-setuid-p (path)
- [sys:path-test-mode stat path s-isuid])
-
-(defun path-sticky-p (path)
- [sys:path-test-mode stat path s-isvtx])
-
-(defun path-mine-p (path)
- (sys:path-test (s stat path)
- (= s.uid (geteuid))))
-
-(defun path-my-group-p (path)
- (sys:path-test (s stat path)
- (let ((g s.gid))
- (or (= g (getegid))
- (find g (getgroups))))))
-
-;; umask, gmask and omask must test identical permissions
-;; multiple permissions may be tested, but not a combination
-;; of x with any other permission.
-(defun sys:path-access (path umask gmask omask)
- (sys:path-test (s stat path)
- (let ((m s.mode)
- (euid (geteuid)))
- (cond
- ((zerop euid) (or (zerop (logand umask s-ixusr))
- (plusp (logand m (logior umask gmask omask)))))
- ((= euid s.uid) (= umask (logand m umask)))
- ((let ((g s.gid))
- (or (= g (getegid))
- (find g (getgroups))))
- (= gmask (logand m gmask)))
- (t (= omask (logand m omask)))))))
-
-(defun path-executable-to-me-p (path)
- (sys:path-access path s-ixusr s-ixgrp s-ixoth))
-
-(defun path-writable-to-me-p (path)
- (sys:path-access path s-iwusr s-iwgrp s-iwoth))
-
-(defun path-readable-to-me-p (path)
- (sys:path-access path s-irusr s-irgrp s-iroth))
-
-(defun path-read-writable-to-me-p (path)
- (sys:path-access path
- (logior s-irusr s-iwusr)
- (logior s-irgrp s-iwgrp)
- (logior s-iroth s-iwoth)))
-
-(defun path-private-to-me-p (path)
- (sys:path-test (s stat path)
- (let ((m s.mode)
- (euid (geteuid)))
- (mlet ((g (getgrgid s.gid))
- (name (let ((pw (getpwuid euid)))
- (if pw pw.name)))
- (suname (let ((pw (getpwuid 0)))
- (if pw pw.name))))
- (and (or (zerop s.uid)
- (eql euid s.uid))
- (zerop (logand m s-iwoth))
- (or (zerop (logand m s-iwgrp))
- (null g.mem)
- (and (all g.mem (orf (op equal name)
- (op equal suname))))))))))
-
-(defun path-strictly-private-to-me-p (path)
- (sys:path-test (s stat path)
- (let ((m s.mode)
- (euid (geteuid)))
- (mlet ((g (getgrgid s.gid))
- (name (let ((pw (getpwuid euid)))
- (if pw pw.name)))
- (suname (let ((pw (getpwuid 0)))
- (if pw pw.name))))
- (and (or (zerop s.uid)
- (eql euid s.uid))
- (zerop (logand m (logior s-iroth s-iwoth)))
- (or (zerop (logand m (logior s-irgrp s-iwgrp)))
- (null g.mem)
- (and (all g.mem (orf (op equal name)
- (op equal suname))))))))))
-
-
-(defmacro sys:path-examine ((sym statfun path) . body)
- ^[sys:do-path-test ,statfun ,path
- (lambda (,sym) ,*body)])
-
-(defun path-newer (path-0 path-1)
- (sys:path-examine (s0 stat path-0)
- (sys:path-examine (s1 stat path-1)
- (if s0
- (or (null s1)
- (let ((mt0 s0.mtime)
- (mt1 s1.mtime))
- (or (> mt0 mt1)
- (and (= mt0 mt1)
- (> s0.mtime-nsec s1.mtime-nsec)))))))))
-
-(defun path-older (path-0 path-1)
- (path-newer path-1 path-0))
-
-(defun path-same-object (path-0 path-1)
- (sys:path-examine (s0 stat path-0)
- (sys:path-examine (s1 stat path-1)
- (and s0 s1
- (eql s0.dev s1.dev)
- (eql s0.ino s1.ino)))))
-
-(defun path-dir-empty (path)
- (when (path-dir-p path)
- (let ((name (if (stringp path) path path.path)))
- (with-stream (ds (open-directory name))
- (for (ent) ((set ent (get-line ds)) t) ()
- (casequal ent
- (("." ".."))
- (t (return nil))))))))
diff --git a/share/txr/stdlib/pmac.tl b/share/txr/stdlib/pmac.tl
deleted file mode 100644
index 48bb3386..00000000
--- a/share/txr/stdlib/pmac.tl
+++ /dev/null
@@ -1,34 +0,0 @@
-;; Copyright 2017-2020
-;; Kaz Kylheku <kaz@kylheku.com>
-;; Vancouver, Canada
-;; All rights reserved.
-;;
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions are met:
-;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
-;;
-;; 2. Redistributions in binary form must reproduce the above copyright notice,
-;; this list of conditions and the following disclaimer in the documentation
-;; and/or other materials provided with the distribution.
-;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-(defmacro define-param-expander (keyword
- (parms body : (env (gensym)) (form (gensym)))
- . forms)
- ^(progn
- (set [*param-macro* ,keyword]
- (lambda (,parms ,body ,env ,form)
- ,*forms))
- ,keyword))
diff --git a/share/txr/stdlib/socket.tl b/share/txr/stdlib/socket.tl
deleted file mode 100644
index 5f9d3d7c..00000000
--- a/share/txr/stdlib/socket.tl
+++ /dev/null
@@ -1,158 +0,0 @@
-;; Copyright 2016-2020
-;; Kaz Kylheku <kaz@kylheku.com>
-;; Vancouver, Canada
-;; All rights reserved.
-;;
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions are met:
-;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
-;;
-;; 2. Redistributions in binary form must reproduce the above copyright notice,
-;; this list of conditions and the following disclaimer in the documentation
-;; and/or other materials provided with the distribution.
-;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-(defstruct sockaddr nil
- (:static family nil))
-
-(defstruct sockaddr-in sockaddr
- (addr 0) (port 0)
- (:static family af-inet))
-
-(defstruct sockaddr-in6 sockaddr
- (addr 0) (port 0) (flow-info 0) (scope-id 0)
- (:static family af-inet6))
-
-(defstruct sockaddr-un sockaddr
- path
- (:static family af-unix))
-
-(defstruct addrinfo nil
- (flags 0)
- (family 0)
- (socktype 0)
- (protocol 0)
- (canonname 0))
-
-(defvarl shut-rd 0)
-(defvarl shut-wr 1)
-(defvarl shut-rdwr 2)
-
-(defun str-inaddr (addr : port)
- (let ((d (logand addr #xFF))
- (c (logand (ash addr -8) #xFF))
- (b (logand (ash addr -16) #xFF))
- (a (ash addr -24))
- (p (if port `:@port` "")))
- (if (or (> a 255) (minusp a))
- (throwf 'eval-error "~s: ~a out of range for IPv4 address"
- 'str-inaddr addr)
- `@a.@b.@c.@d@p`)))
-
-(defun sys:in6addr-condensed-text (numeric-pieces)
- (let* ((notyet t)
- (texts (window-mappend
- 1 nil
- (lambda (pre chunk post)
- (cond
- ((and notyet (zerop (car chunk)) (cdr chunk))
- (zap notyet)
- (if (and post pre) '("") '(":")))
- (t (mapcar (op format nil "~x") chunk))))
- [partition-by zerop numeric-pieces])))
- `@{texts ":"}`))
-
-(defun str-in6addr (addr : port)
- (let ((str (if (and (<= (width addr) 48)
- (= (ash addr -32) #xFFFF))
- `::ffff:@(str-inaddr (logtrunc addr 32))`
- (let* ((pieces (let ((count 8))
- (nexpand-left (lambda (val)
- (if (minusp (dec count))
- (unless (zerop val)
- (throwf 'eval-error
- "~s: \
- \ ~a out of range \
- \ for IPv6 address"
- 'str-in6addr
- addr))
- (cons (logand val #xFFFF)
- (ash val -16))))
- addr))))
- (sys:in6addr-condensed-text pieces)))))
- (if port
- `[@str]:@port`
- str)))
-
-(defun sys:str-inaddr-net-impl (addr wextra : weff)
- (let ((mask addr))
- (set mask (logior mask (ash mask 1)))
- (set mask (logior mask (ash mask 2)))
- (set mask (logior mask (ash mask 4)))
- (set mask (logior mask (ash mask 8)))
- (set mask (logior mask (ash mask 16)))
- (let* ((w (- 32 (width (lognot mask 32))))
- (d (logand addr #xFF))
- (c (logand (ash addr -8) #xFF))
- (b (logand (ash addr -16) #xFF))
- (a (ash addr -24))
- (we (or weff (+ w wextra))))
- (cond
- ((or (> a 255) (minusp a))
- (throwf 'eval-error "~s: ~a out of range for IPv4 address"
- 'str-inaddr-net addr))
- ((> w 24) `@a.@b.@c.@d/@we`)
- ((> w 16) `@a.@b.@c/@we`)
- ((> w 8) `@a.@b/@we`)
- (t `@a/@we`)))))
-
-(defun str-inaddr-net (addr : width)
- (sys:str-inaddr-net-impl addr 0 width))
-
-(defun str-in6addr-net (addr : width)
- (if (and (<= (width addr) 48)
- (= (ash addr -32) #xFFFF))
- `::ffff:@(sys:str-inaddr-net-impl (logtrunc addr 32) 96 width)`
- (let ((mask addr))
- (set mask (logior mask (ash mask 1)))
- (set mask (logior mask (ash mask 2)))
- (set mask (logior mask (ash mask 4)))
- (set mask (logior mask (ash mask 8)))
- (set mask (logior mask (ash mask 16)))
- (set mask (logior mask (ash mask 32)))
- (set mask (logior mask (ash mask 64)))
- (let* ((w (- 128 (width (lognot mask 128))))
- (pieces (let ((count 8))
- (nexpand-left (lambda (val)
- (if (minusp (dec count))
- (unless (zerop val)
- (throwf 'eval-error
- "~s: \
- \ ~a out of range \
- \ for IPv6 address"
- 'str-in6addr-net
- addr))
- (cons (logand val #xFFFF)
- (ash val -16))))
- addr)))
- (cand-prefix [pieces 0..(trunc (+ w 15) 16)])
- (prefix (if (search cand-prefix '(0 0)) pieces cand-prefix)))
- `@(sys:in6addr-condensed-text prefix)/@(or width w)`))))
-
-(defplace (sock-peer sock) body
- (getter setter
- ^(macrolet ((,getter () ^(sock-peer ',',sock))
- (,setter (val) ^(sock-set-peer ,',sock ,val)))
- ,body)))
diff --git a/share/txr/stdlib/struct.tl b/share/txr/stdlib/struct.tl
deleted file mode 100644
index aa518444..00000000
--- a/share/txr/stdlib/struct.tl
+++ /dev/null
@@ -1,367 +0,0 @@
-;; Copyright 2015-2020
-;; Kaz Kylheku <kaz@kylheku.com>
-;; Vancouver, Canada
-;; All rights reserved.
-;;
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions are met:
-;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
-;;
-;; 2. Redistributions in binary form must reproduce the above copyright notice,
-;; this list of conditions and the following disclaimer in the documentation
-;; and/or other materials provided with the distribution.
-;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-(defun sys:bad-slot-syntax (form arg)
- (compile-error form "bad slot syntax ~s" arg))
-
-(defun sys:prune-missing-inits (slot-init-forms)
- (remove-if (tb ((kind name : (init-form nil init-form-present)))
- (and (member kind '(:static :instance :function))
- (not init-form-present)))
- slot-init-forms))
-
-(defmacro defstruct (:form form name-spec super-spec . slot-specs)
- (tree-bind (name args) (tree-case name-spec
- ((atom . args) (list atom args))
- (atom (list atom nil)))
- (unless (bindable name)
- (compile-error form "~s isn't a bindable symbol" name))
- (unless (proper-listp slot-specs)
- (compile-error form "bad syntax: dotted form"))
- (let* ((instance-init-form nil)
- (instance-postinit-form nil)
- (instance-fini-form nil)
- (slot-init-forms (collect-each ((slot slot-specs))
- (tree-case slot
- ((word name args . body)
- (caseq word
- (:method
- (when (not args)
- (compile-error form
- "method ~s needs \
- \ at least one parameter"
- name))
- ^(:function ,name
- (lambda ,args
- (block ,name ,*body))))
- (:function ^(,word ,name
- (lambda ,args
- (block ,name
- ,*body))))
- ((:static :instance)
- (when body
- (sys:bad-slot-syntax form slot))
- ^(,word ,name ,args))
- (t :)))
- ((word (arg) . body)
- (caseq word
- (:init
- (unless (bindable arg)
- (sys:bad-slot-syntax form slot))
- (when instance-init-form
- (compile-error form
- "duplicate :init"))
- (set instance-init-form
- (cons arg body))
- ^(,word nil nil))
- (:postinit
- (unless (bindable arg)
- (sys:bad-slot-syntax form slot))
- (when instance-postinit-form
- (compile-error form
- "duplicate :postinit"))
- (set instance-postinit-form
- (cons arg body))
- ^(,word nil nil))
- (:fini
- (unless (bindable arg)
- (sys:bad-slot-syntax form slot))
- (when instance-fini-form
- (compile-error form
- "duplicate :fini"))
- (set instance-fini-form
- (cons arg body))
- ^(,word nil nil))
- (t (when body
- (sys:bad-slot-syntax form slot))
- :)))
- ((word name)
- (caseq word
- ((:static)
- ^(,word ,name))
- ((:instance)
- ^(,word ,name nil))
- ((:method :function)
- (sys:bad-slot-syntax form slot))
- (t ^(:instance ,word ,name))))
- ((name)
- ^(:instance ,name nil))
- (name
- ^(:instance ,name nil)))))
- (supers (if (and super-spec (atom super-spec))
- (list super-spec)
- super-spec))
- (stat-si-forms [keep-if (op member @1 '(:static :function))
- slot-init-forms car])
- (pruned-si-forms (sys:prune-missing-inits stat-si-forms))
- (func-si-forms [keep-if (op eq :function) pruned-si-forms car])
- (val-si-forms [keep-if (op eq :static) pruned-si-forms car])
- (inst-si-forms [keep-if (op eq :instance) slot-init-forms car])
- (stat-slots [mapcar second stat-si-forms])
- (inst-slots [mapcar second inst-si-forms]))
- (whenlet ((bad [find-if [notf bindable]
- (append stat-slots inst-slots)]))
- (compile-error form
- (if (symbolp bad)
- "slot name ~s isn't a bindable symbol"
- "invalid slot specifier syntax: ~s")
- bad))
- (each ((s supers))
- (or (find-struct-type s)
- (compile-defr-warning form ^(struct-type . ,s)
- "inheritance base ~s \
- \ does not name a struct type"
- s)))
- (let ((arg-sym (gensym))
- (type-sym (gensym)))
- (register-tentative-def ^(struct-type . ,name))
- (each ((s stat-slots))
- (register-tentative-def ^(slot . ,s)))
- (each ((s inst-slots))
- (register-tentative-def ^(slot . ,s)))
- ^(sys:make-struct-type
- ',name ',supers ',stat-slots ',inst-slots
- ,(if (or func-si-forms val-si-forms)
- ^(lambda (,arg-sym)
- ,*(mapcar (aret ^(when (static-slot-p ,arg-sym ',@2)
- (static-slot-set ,arg-sym ',@2 ,@3)))
- (append func-si-forms val-si-forms))))
- ,(if (or inst-si-forms instance-init-form instance-fini-form)
- ^(lambda (,arg-sym)
- ,*(if (cdr instance-fini-form)
- ^((finalize ,arg-sym (lambda (,(car instance-fini-form))
- ,*(cdr instance-fini-form))
- t)))
- ,*(if inst-si-forms
- ^((let ((,type-sym (struct-type ,arg-sym)))
- ,*(mapcar (aret ^(unless (static-slot-p ,type-sym ',@2)
- (slotset ,arg-sym ',@2 ,@3)))
- inst-si-forms))))
- ,*(if (cdr instance-init-form)
- ^((let ((,(car instance-init-form) ,arg-sym))
- ,*(cdr instance-init-form))))))
- ,(when args
- (when (> (countql : args) 1)
- (compile-error form
- "multiple colons in boa syntax"))
- (let ((col-pos (posq : args)))
- (let ((req-args [args 0..col-pos])
- (opt-args (if col-pos [args (succ col-pos)..:])))
- (let ((r-gens (mapcar (ret (gensym)) req-args))
- (o-gens (mapcar (ret (gensym)) opt-args))
- (p-gens (mapcar (ret (gensym)) opt-args)))
- ^(lambda (,arg-sym ,*r-gens
- ,*(if opt-args '(:))
- ,*(if opt-args
- (mapcar (ret ^(,@1 nil ,@2))
- o-gens p-gens)))
- ,*(mapcar (ret ^(slotset ,arg-sym ',@1 ,@2))
- req-args r-gens)
- ,*(mapcar (ret ^(if ,@3
- (slotset ,arg-sym ',@1 ,@2)))
- opt-args o-gens p-gens))))))
- ,(if instance-postinit-form
- ^(lambda (,arg-sym)
- ,*(if (cdr instance-postinit-form)
- ^((let ((,(car instance-postinit-form) ,arg-sym))
- ,*(cdr instance-postinit-form)))))))))))
-
-(defmacro sys:struct-lit (name . plist)
- ^(sys:make-struct-lit ',name ',plist))
-
-(defun sys:check-slot (form slot)
- (unless (or (sys:slot-types slot)
- (sys:static-slot-types slot))
- (compile-defr-warning form ^(slot . ,slot)
- "symbol ~s isn't the name of a struct slot"
- slot))
- slot)
-
-(defun sys:check-struct (form stype)
- (unless (find-struct-type stype)
- (compile-defr-warning form ^(struct-type . ,stype)
- "~s does not name a struct type"
- stype)))
-
-(defmacro qref (:form form obj . refs)
- (when (null refs)
- (throwf 'eval-error "~s: bad syntax" 'qref))
- (tree-case obj
- ((a b) (if (eq a 't)
- ^(if ,b (qref ,b ,*refs))
- :))
- (x (tree-case refs
- (() ())
- (((pref sym) . more)
- (if (eq pref t)
- (let ((s (gensym)))
- ^(let ((,s (slot ,obj ',sym)))
- (if ,s (qref ,s ,*more))))
- :))
- (((dw sym . args))
- (if (eq dw 'dwim)
- ^[(slot ,obj ',(sys:check-slot form sym)) ,*args]
- :))
- (((dw sym . args) . more)
- (if (eq dw 'dwim)
- ^(qref [(slot ,obj ',(sys:check-slot form sym)) ,*args] ,*more)
- :))
- (((sym . args))
- (let ((osym (gensym)))
- (sys:check-slot form sym)
- ^(slet ((,osym ,obj))
- (call (slot ,osym ',sym) ,osym ,*args))))
- (((sym . args) . more)
- (let ((osym (gensym)))
- (sys:check-slot form sym)
- ^(qref (slet ((,osym ,obj))
- (call (slot ,osym ',sym) ,osym ,*args)) ,*more)))
- ((sym)
- (sys:check-slot form sym)
- ^(slot ,obj ',sym))
- ((sym . more)
- (sys:check-slot form sym)
- ^(qref (slot ,obj ',sym) ,*more))
- (obj (throwf 'eval-error "~s: bad syntax: ~s" 'qref refs))))))
-
-(defmacro uref (. args)
- (cond
- ((null args) (throwf 'eval-error "~s: bad syntax" 'uref))
- ((null (cdr args))
- (if (consp (car args))
- ^(umeth ,*(car args))
- ^(usl ,(car args))))
- ((eq t (car args))
- (with-gensyms (ovar)
- ^(lambda (,ovar) (qref (t ,ovar) ,*(cdr args)))))
- (t (with-gensyms (ovar)
- ^(lambda (,ovar) (qref ,ovar ,*args))))))
-
-(defun sys:new-type (op form type)
- (caseq op
- ((new lnew) (sys:check-struct form type) ^',type)
- (t type)))
-
-(defun sys:new-expander (op form spec pairs)
- (when (oddp (length pairs))
- (compile-error form
- "~s: slot initform arguments must occur pairwise" op))
- (let ((qpairs (mappend (aret ^(',@1 ,@2)) (tuples 2 pairs))))
- (tree-case spec
- ((texpr . args)
- (let ((type (sys:new-type op form texpr)))
- (caseq op
- ((new new*) (if qpairs
- ^(make-struct ,type (list ,*qpairs) ,*args)
- ^(struct-from-args ,type ,*args)))
- ((lnew lnew*) ^(make-lazy-struct ,type
- (lambda ()
- (cons (list ,*qpairs)
- (list ,*args))))))))
- (texpr
- (let ((type (sys:new-type op form texpr)))
- (caseq op
- ((new new*) ^(struct-from-plist ,type ,*qpairs))
- ((lnew lnew*) ^(make-lazy-struct ,type
- (lambda ()
- (list (list ,*qpairs)))))))))))
-
-(defmacro new (:form form spec . pairs)
- (sys:new-expander (car form) form spec pairs))
-
-(defmacro new* (:form form spec . pairs)
- (sys:new-expander (car form) form spec pairs))
-
-(defmacro lnew (:form form spec . pairs)
- (sys:new-expander (car form) form spec pairs))
-
-(defmacro lnew* (:form form spec . pairs)
- (sys:new-expander (car form) form spec pairs))
-
-(defmacro meth (obj slot . bound-args)
- ^[(fun method) ,obj ',slot ,*bound-args])
-
-(defmacro usl (:form form slot)
- (sys:check-slot form slot)
- ^(uslot ',slot))
-
-(defmacro umeth (:form form slot . bound-args)
- (sys:check-slot form slot)
- ^[(fun umethod) ',slot ,*bound-args])
-
-(defun sys:define-method (type-sym name fun)
- (caseq name
- (:init (struct-set-initfun type-sym fun))
- (:postinit (struct-set-postinitfun type-sym fun))
- (t (static-slot-ensure type-sym name fun)))
- ^(meth ,type-sym ,name))
-
-(defmacro defmeth (:form form type-sym name arglist . body)
- (cond
- ((not (bindable type-sym))
- (compile-error form "~s isn't a valid struct name" type-sym))
- ((not (find-struct-type type-sym))
- (compile-defr-warning form ^(struct-type . ,type-sym)
- "definition of struct ~s not seen here" type-sym)))
- (register-tentative-def ^(slot . ,name))
- ^(sys:define-method ',type-sym ',name (lambda ,arglist
- (block ,name ,*body))))
-
-(defmacro with-slots ((. slot-specs) obj-expr . body)
- (with-gensyms (obj-sym)
- ^(let ((,obj-sym ,obj-expr))
- (symacrolet (,*(mapcar [iff consp
- (aret ^(,@1 (slot ,obj-sym ',@2)))
- (ret ^(,@1 (slot ,obj-sym ',@1)))]
- slot-specs))
- ,*body))))
-
-(defun sys:rslotset (struct sym meth-sym val)
- (prog1
- (slotset struct sym val)
- (call (umethod meth-sym) struct)))
-
-(defmacro usr:rslot (struct sym meth-sym)
- ^(slot ,struct ,sym))
-
-(define-place-macro usr:rslot (struct sym meth-sym)
- ^(sys:rslot ,struct ,sym ,meth-sym))
-
-(defplace (sys:rslot struct sym meth-sym) body
- (getter setter
- (with-gensyms (struct-sym slot-sym meth-slot-sym)
- ^(slet ((,struct-sym ,struct)
- (,slot-sym ,sym)
- (,meth-slot-sym ,meth-sym))
- (macrolet ((,getter () ^(slot ,',struct-sym ,',slot-sym))
- (,setter (val) ^(sys:rslotset ,',struct-sym ,',slot-sym
- ,',meth-slot-sym ,val)))
- ,body))))
- (ssetter
- ^(macrolet ((,ssetter (val) ^(progn
- (sys:rslotset ,',struct ,',sym
- ,',meth-sym ,val))))
- ,body)))
diff --git a/share/txr/stdlib/type.tl b/share/txr/stdlib/type.tl
deleted file mode 100644
index d784b893..00000000
--- a/share/txr/stdlib/type.tl
+++ /dev/null
@@ -1,39 +0,0 @@
-;; Copyright 2015-2020
-;; Kaz Kylheku <kaz@kylheku.com>
-;; Vancouver, Canada
-;; All rights reserved.
-;;
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions are met:
-;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
-;;
-;; 2. Redistributions in binary form must reproduce the above copyright notice,
-;; this list of conditions and the following disclaimer in the documentation
-;; and/or other materials provided with the distribution.
-;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-(defmacro typecase (form . clauses)
- (let* ((val (gensym))
- (cond-pairs (collect-each ((cl clauses))
- (tree-case cl
- ((type . body)
- (if (symbolp type)
- ^((typep ,val ',type) ,*body)
- :))
- (else (throwf 'eval-error
- "~s: bad clause syntax: ~s"
- 'typecase cl))))))
- ^(let ((,val ,form))
- (cond ,*cond-pairs))))
diff --git a/share/txr/stdlib/vm-param.tl b/share/txr/stdlib/vm-param.tl
deleted file mode 100644
index 1198831b..00000000
--- a/share/txr/stdlib/vm-param.tl
+++ /dev/null
@@ -1,37 +0,0 @@
-;; Copyright 2018-2020
-;; Kaz Kylheku <kaz@kylheku.com>
-;; Vancouver, Canada
-;; All rights reserved.
-;;
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions are met:
-;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
-;;
-;; 2. Redistributions in binary form must reproduce the above copyright notice,
-;; this list of conditions and the following disclaimer in the documentation
-;; and/or other materials provided with the distribution.
-;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-(defsymacro %lev-size% 1024)
-(defsymacro %max-lev-idx% (macro-time (pred %lev-size%)))
-(defsymacro %lev-bits% 10)
-(defsymacro %max-lev% 63)
-(defsymacro %max-v-lev% (macro-time (ppred %max-lev%)))
-(defsymacro %imm-width% 32)
-(defsymacro %sm-lev-size% 64)
-(defsymacro %max-sm-lev-idx% (macro-time (pred %sm-lev-size%)))
-(defsymacro %max-sm-lev% 15)
-(defsymacro %sm-lev-bits% 6)
-(defsymacro %max-lambda-fixed-args% 127)
diff --git a/signal.c b/signal.c
index 900844e6..50c95a0e 100644
--- a/signal.c
+++ b/signal.c
@@ -1,4 +1,4 @@
-/* Copyright 2013-2020
+/* Copyright 2013-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,28 +6,28 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stdlib.h>
#include <string.h>
-#include <stdarg.h>
#include <errno.h>
#include <wchar.h>
#include <signal.h>
@@ -82,11 +82,14 @@ static void sig_handler(int sig)
int exc = is_cpu_exception(sig);
int ic = interrupt_count++;
int in_interrupt = ic > 0;
+ val *stack_lim = 0;
if (exc) {
gc = gc_state(0);
+ stack_lim = gc_stack_limit;
as = async_sig_enabled;
async_sig_enabled = 1;
+ gc_stack_limit = 0;
}
sig_reload_cache();
@@ -110,6 +113,7 @@ static void sig_handler(int sig)
}
if (exc) {
+ gc_stack_limit = stack_lim;
async_sig_enabled = as;
gc_state(gc);
}
@@ -119,7 +123,8 @@ static void sig_handler(int sig)
static val kill_wrap(val pid, val sig)
{
- cnum p = c_num(pid), s = c_num(default_arg(sig, num_fast(SIGTERM)));
+ val self = lit("kill");
+ cnum p = c_num(pid, self), s = c_num(default_arg(sig, num_fast(SIGTERM)), self);
int res = kill(p, s);
if (opt_compat && opt_compat <= 114)
return num(res);
@@ -128,7 +133,8 @@ static val kill_wrap(val pid, val sig)
static val raise_wrap(val sig)
{
- int res = raise(c_num(sig));
+ val self = lit("raise");
+ int res = raise(c_num(sig, self));
return tnil(res == 0);
}
@@ -195,7 +201,7 @@ void sig_init(void)
#if HAVE_ITIMER
reg_varl(intern(lit("itimer-real"), user_package), num_fast(ITIMER_REAL));
reg_varl(intern(lit("itimer-virtual"), user_package), num_fast(ITIMER_VIRTUAL));
- reg_varl(intern(lit("itimer-prov"), user_package), num_fast(ITIMER_PROF));
+ reg_varl(intern(lit("itimer-prof"), user_package), num_fast(ITIMER_PROF));
reg_fun(intern(lit("getitimer"), user_package), func_n1(getitimer_wrap));
reg_fun(intern(lit("setitimer"), user_package), func_n3(setitimer_wrap));
#endif
@@ -212,40 +218,42 @@ void sig_init(void)
#if HAVE_SIGALTSTACK
static mem_t *stack;
+static int stack_refcount;
-static void setup_alt_stack(void)
+static void addref_alt_stack(void)
{
- stack_t ss;
-
- if (!stack)
+ if (stack_refcount++ == 0) {
+ stack_t ss;
stack = chk_malloc(SIGSTKSZ);
+ ss.ss_sp = stack;
+ ss.ss_size = SIGSTKSZ;
+ ss.ss_flags = 0;
- ss.ss_sp = stack;
- ss.ss_size = SIGSTKSZ;
- ss.ss_flags = 0;
-
- if (sigaltstack(&ss, NULL) == -1) {
- free(stack);
- stack = 0;
+ if (sigaltstack(&ss, NULL) == -1) {
+ free(stack);
+ stack = 0;
+ }
}
}
-static void teardown_alt_stack(void)
+static void release_alt_stack(void)
{
- stack_t ss;
+ if (--stack_refcount == 0) {
+ stack_t ss;
- if (!stack)
- return;
+ if (!stack)
+ return;
- ss.ss_sp = stack;
- ss.ss_size = SIGSTKSZ;
- ss.ss_flags = SS_DISABLE;
+ ss.ss_sp = stack;
+ ss.ss_size = SIGSTKSZ;
+ ss.ss_flags = SS_DISABLE;
- if (sigaltstack(&ss, NULL) == -1)
- return;
+ if (sigaltstack(&ss, NULL) == -1)
+ return;
- free(stack);
- stack = 0;
+ free(stack);
+ stack = 0;
+ }
}
#endif
@@ -259,8 +267,8 @@ val set_sig_handler(val signo, val lambda)
{
static struct sigaction blank;
val self = lit("set-sig-handler");
- cnum sig = c_num(signo);
- val old_lambda;
+ cnum sig = c_num(signo, self);
+ val old;
small_sigset_t block, saved;
small_sigfillset(&block);
@@ -269,17 +277,18 @@ val set_sig_handler(val signo, val lambda)
if (sig < 0 || sig >= MAX_SIG)
uw_throwf(error_s, lit("~a: signal ~s out of range"), self, sig, nao);
- old_lambda = sig_lambda[sig];
+ old = sig_lambda[sig];
- if (lambda != old_lambda) {
+ if (lambda != old) {
unsigned long mask = 1UL << sig;
- if (lambda == nil) {
- signal(sig, SIG_IGN);
- sig_deferred &= ~mask;
- } else if (lambda == t) {
- signal(sig, SIG_DFL);
+ if (lambda == nil || lambda == t) {
+ signal(sig, if3(lambda, SIG_DFL, SIG_IGN));
sig_deferred &= ~mask;
+#if HAVE_SIGALTSTACK
+ if ((sig == SIGSEGV || sig == SIGBUS) && old != t && old != nil)
+ release_alt_stack();
+#endif
} else {
struct sigaction sa = blank;
@@ -289,33 +298,29 @@ val set_sig_handler(val signo, val lambda)
sa.sa_handler = sig_handler;
sigfillset(&sa.sa_mask);
#if HAVE_SIGALTSTACK
- if (sig == SIGSEGV || sig == SIGBUS) {
- setup_alt_stack();
+ if ((sig == SIGSEGV || sig == SIGBUS) && (old == t || old == nil)) {
+ addref_alt_stack();
sa.sa_flags |= SA_ONSTACK;
}
#endif
sigaction(sig, &sa, 0);
}
-#if HAVE_SIGALTSTACK
- if ((sig == SIGSEGV || sig == SIGBUS) && (lambda == nil || lambda == t))
- teardown_alt_stack();
-#endif
-
sig_lambda[sig] = lambda;
}
sig_mask(SIG_SETMASK, &saved, 0);
- return old_lambda;
+ return old;
}
val get_sig_handler(val signo)
{
- cnum sig = c_num(signo);
+ val self = lit("get-sig-handler");
+ cnum sig = c_num(signo, self);
if (sig < 0 || sig >= MAX_SIG)
- uw_throwf(error_s, lit("get-sig-handler: signal ~s out of range"), sig, nao);
+ uw_throwf(error_s, lit("~a: signal ~s out of range"), self, sig, nao);
return sig_lambda[sig];
}
@@ -365,8 +370,8 @@ int sig_mask(int how, const small_sigset_t *set, small_sigset_t *oldset)
if (sig_blocked_cache.set != pnew->set) {
static sigset_t blank;
sigset_t real_newset = blank, real_oldset;
- sig_blocked_cache = *pnew;
int ret;
+ sig_blocked_cache = *pnew;
#if HAVE_VALGRIND
VALGRIND_MAKE_MEM_DEFINED(&real_oldset, sizeof real_oldset);
#endif
@@ -392,9 +397,10 @@ static val tv_to_usec(val sec, val usec)
val getitimer_wrap(val which)
{
+ val self = lit("getitimer");
struct itimerval itv;
- if (getitimer(c_num(which), &itv) < 0)
+ if (getitimer(c_num(which, self), &itv) < 0)
return nil;
return list(tv_to_usec(num_time(itv.it_interval.tv_sec), num(itv.it_interval.tv_usec)),
@@ -404,15 +410,16 @@ val getitimer_wrap(val which)
val setitimer_wrap(val which, val interval, val currval)
{
+ val self = lit("setitimer");
struct itimerval itn, itv;
const val meg = num_fast(1000000);
- itn.it_interval.tv_sec = c_time(trunc(interval, meg));
- itn.it_interval.tv_usec = c_num(mod(interval, meg));
- itn.it_value.tv_sec = c_time(trunc(currval, meg));
- itn.it_value.tv_usec = c_num(mod(currval, meg));
+ itn.it_interval.tv_sec = c_time(trunc(interval, meg), self);
+ itn.it_interval.tv_usec = c_num(mod(interval, meg), self);
+ itn.it_value.tv_sec = c_time(trunc(currval, meg), self);
+ itn.it_value.tv_usec = c_num(mod(currval, meg), self);
- if (setitimer(c_num(which), &itn, &itv) < 0)
+ if (setitimer(c_num(which, self), &itn, &itv) < 0)
return nil;
return list(tv_to_usec(num_time(itv.it_interval.tv_sec), num(itv.it_interval.tv_usec)),
diff --git a/signal.h b/signal.h
index c3e5375f..7462f12c 100644
--- a/signal.h
+++ b/signal.h
@@ -1,4 +1,4 @@
-/* Copyright 2013-2020
+/* Copyright 2013-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#if HAVE_POSIX_SIGS
@@ -40,7 +41,7 @@ extern small_sigset_t sig_blocked_cache;
sig_check(); \
async_sig_enabled = 1; \
{ \
- do ; while (0)
+ do { } while (0)
#define sig_restore_enable \
} \
@@ -52,7 +53,7 @@ extern small_sigset_t sig_blocked_cache;
int sig_save = async_sig_enabled; \
async_sig_enabled = 0; \
{ \
- do ; while (0)
+ do { } while (0)
#define sig_restore_disable \
} \
diff --git a/socket.c b/socket.c
index c9da9a19..55584944 100644
--- a/socket.c
+++ b/socket.c
@@ -1,4 +1,4 @@
-/* Copyright 2016-2020
+/* Copyright 2016-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stddef.h>
@@ -35,13 +36,21 @@
#include <errno.h>
#include <unistd.h>
#include <fcntl.h>
+#include <sys/socket.h>
#include <sys/un.h>
#include <netdb.h>
#include "config.h"
#include "alloca.h"
-#if HAVE_SYS_SELECT_H
+#if HAVE_POLL
+#include <poll.h>
+#elif HAVE_SELECT
#include <sys/select.h>
#endif
+#if HAVE_SYS_TIME
+#include <sys/time.h>
+#endif
+#include <netinet/in.h>
+#include <netinet/tcp.h>
#include "lib.h"
#include "stream.h"
#include "signal.h"
@@ -53,6 +62,10 @@
#include "struct.h"
#include "arith.h"
#include "sysif.h"
+#include "itypes.h"
+#include "ffi.h"
+#include "txr.h"
+#include "autoload.h"
#include "socket.h"
#define MIN(A, B) ((A) < (B) ? (A) : (B))
@@ -121,7 +134,7 @@ static void ipv6_scope_id_from_num(struct sockaddr_in6 *dst, val scope)
static val sockaddr_in_unpack(struct sockaddr_in *src)
{
- args_decl(args, ARGS_MIN);
+ args_decl_constsize(args, ARGS_MIN);
val out = make_struct(sockaddr_in_s, nil, args);
slotset(out, addr_s, ipv4_addr_to_num(&src->sin_addr));
slotset(out, port_s, num_fast(ntohs(src->sin_port)));
@@ -130,7 +143,7 @@ static val sockaddr_in_unpack(struct sockaddr_in *src)
static val sockaddr_in6_unpack(struct sockaddr_in6 *src)
{
- args_decl(args, ARGS_MIN);
+ args_decl_constsize(args, ARGS_MIN);
val out = make_struct(sockaddr_in6_s, nil, args);
slotset(out, addr_s, ipv6_addr_to_num(&src->sin6_addr));
slotset(out, port_s, num_fast(ntohs(src->sin6_port)));
@@ -139,7 +152,7 @@ static val sockaddr_in6_unpack(struct sockaddr_in6 *src)
static val sockaddr_un_unpack(struct sockaddr_un *src)
{
- args_decl(args, ARGS_MIN);
+ args_decl_constsize(args, ARGS_MIN);
val out = make_struct(sockaddr_un_s, nil, args);
slotset(out, path_s, string_utf8(src->sun_path));
return out;
@@ -161,22 +174,23 @@ static val sockaddr_unpack(int family, struct sockaddr_storage *src)
#if HAVE_GETADDRINFO
-static void addrinfo_in(struct addrinfo *dest, val src)
+static void addrinfo_in(struct addrinfo *dest, val src, val self)
{
- dest->ai_flags = c_num(default_arg(slot(src, flags_s), zero));
- dest->ai_family = c_num(default_arg(slot(src, family_s), zero));
- dest->ai_socktype = c_num(default_arg(slot(src, socktype_s), zero));
- dest->ai_protocol = c_num(default_arg(slot(src, protocol_s), zero));
+ dest->ai_flags = c_num(default_arg(slot(src, flags_s), zero), self);
+ dest->ai_family = c_num(default_arg(slot(src, family_s), zero), self);
+ dest->ai_socktype = c_num(default_arg(slot(src, socktype_s), zero), self);
+ dest->ai_protocol = c_num(default_arg(slot(src, protocol_s), zero), self);
}
static val getaddrinfo_wrap(val node_in, val service_in, val hints_in)
{
+ val self = lit("getaddrinfo");
val node = default_arg(node_in, nil);
val service = default_arg(service_in, nil);
val hints = default_arg(hints_in, nil);
struct addrinfo hints_ai, *phints = hints ? &hints_ai : 0, *alist = 0, *aiter;
- char *node_u8 = stringp(node) ? utf8_dup_to(c_str(node)) : 0;
- char *service_u8 = stringp(service) ? utf8_dup_to(c_str(service)) : 0;
+ char *node_u8 = stringp(node) ? utf8_dup_to(c_str(node, self)) : 0;
+ char *service_u8 = stringp(service) ? utf8_dup_to(c_str(service, self)) : 0;
val node_num_p = integerp(node);
val svc_num_p = integerp(service);
int res = 0;
@@ -186,7 +200,7 @@ static val getaddrinfo_wrap(val node_in, val service_in, val hints_in)
if (hints) {
memset(&hints_ai, 0, sizeof hints_ai);
- addrinfo_in(&hints_ai, hints);
+ addrinfo_in(&hints_ai, hints, self);
}
res = getaddrinfo(node_u8, service_u8, phints, &alist);
@@ -199,7 +213,9 @@ static val getaddrinfo_wrap(val node_in, val service_in, val hints_in)
uw_catch_end;
if (res == 0) {
+ val canonname = nil;
for (aiter = alist; aiter; aiter = aiter->ai_next) {
+ val addr = nil;
switch (aiter->ai_family) {
case AF_INET:
{
@@ -207,8 +223,8 @@ static val getaddrinfo_wrap(val node_in, val service_in, val hints_in)
if (node_num_p)
ipv4_addr_from_num(&sa->sin_addr, node);
if (svc_num_p)
- sa->sin_port = htons(c_num(service));
- ptail = list_collect(ptail, sockaddr_in_unpack(sa));
+ sa->sin_port = htons(c_num(service, self));
+ addr = sockaddr_in_unpack(sa);
}
break;
case AF_INET6:
@@ -217,11 +233,19 @@ static val getaddrinfo_wrap(val node_in, val service_in, val hints_in)
if (node_num_p)
ipv6_addr_from_num(&sa->sin6_addr, node);
if (svc_num_p)
- sa->sin6_port = ntohs(c_num(service));
- ptail = list_collect(ptail, sockaddr_in6_unpack(sa));
+ sa->sin6_port = ntohs(c_num(service, self));
+ addr = sockaddr_in6_unpack(sa);
}
break;
}
+ if (addr) {
+ if (aiter == alist && (hints_ai.ai_flags & AI_CANONNAME) != 0
+ && aiter->ai_canonname)
+ canonname = string_utf8(aiter->ai_canonname);
+ if (canonname)
+ slotset(addr, canonname_s, canonname);
+ ptail = list_collect(ptail, addr);
+ }
}
}
@@ -241,7 +265,8 @@ static void addr_mismatch(val addr, val family)
}
static void sockaddr_pack(val sockaddr, val family,
- struct sockaddr_storage *buf, socklen_t *len)
+ struct sockaddr_storage *buf, socklen_t *len,
+ val self)
{
val addr_type = typeof(sockaddr);
@@ -254,7 +279,7 @@ static void sockaddr_pack(val sockaddr, val family,
memset(sa, 0, sizeof *sa);
sa->sin_family = AF_INET;
ipv4_addr_from_num(&sa->sin_addr, addr);
- sa->sin_port = ntohs(c_num(port));
+ sa->sin_port = ntohs(c_num(port, self));
*len = sizeof *sa;
} else if (addr_type == sockaddr_in6_s) {
val addr = slot(sockaddr, addr_s);
@@ -269,13 +294,13 @@ static void sockaddr_pack(val sockaddr, val family,
ipv6_addr_from_num(&sa->sin6_addr, addr);
ipv6_flow_info_from_num(sa, flow);
ipv6_scope_id_from_num(sa, scope);
- sa->sin6_port = ntohs(c_num(port));
+ sa->sin6_port = ntohs(c_num(port, self));
*len = sizeof *sa;
} else if (addr_type == sockaddr_un_s) {
val path = slot(sockaddr, path_s);
struct sockaddr_un *sa = coerce(struct sockaddr_un *, buf);
size_t size;
- unsigned char *path_u8 = utf8_dup_to_buf(c_str(path), &size, 0);
+ unsigned char *path_u8 = utf8_dup_to_buf(c_str(path, self), &size, 0);
memset(sa, 0, sizeof *sa);
sa->sun_family = AF_UNIX;
memcpy(sa->sun_path, path_u8, MIN(size, sizeof sa->sun_path));
@@ -315,7 +340,7 @@ static val make_dgram_sock_stream(int fd, val family, val peer,
if (peer_addr != 0)
memcpy(&d->peer_addr, peer_addr, pa_len);
d->pa_len = pa_len;
- stream = cobj(coerce(mem_t *, d), stream_s, &dgram_strm_ops.cobj_ops);
+ stream = cobj(coerce(mem_t *, d), stream_cls, &dgram_strm_ops.cobj_ops);
d->stream = stream;
d->family = family;
d->peer = peer;
@@ -362,8 +387,8 @@ static void dgram_overflow(val stream)
* increasing the datagram size.
*/
struct dgram_stream *d = coerce(struct dgram_stream *, stream->co.handle);
- d->err = ENOBUFS;
- uw_throwf(socket_error_s, lit("dgram write overflow on ~s"), stream, nao);
+ errno = d->err = ENOBUFS;
+ uw_ethrowf(socket_error_s, lit("dgram write overflow on ~s"), stream, nao);
}
static int dgram_put_byte_callback(int b, mem_t *ctx)
@@ -376,8 +401,9 @@ static int dgram_put_byte_callback(int b, mem_t *ctx)
static val dgram_put_string(val stream, val str)
{
+ val self = lit("put-string");
struct dgram_stream *d = coerce(struct dgram_stream *, stream->co.handle);
- const wchar_t *s = c_str(str);
+ const wchar_t *s = c_str(str, self);
while (*s) {
if (!utf8_encode(*s++, dgram_put_byte_callback, coerce(mem_t *, d)))
@@ -423,9 +449,9 @@ static int dgram_get_byte_callback(mem_t *ctx)
if (nbytes == -1) {
d->err = errno;
- uw_throwf(socket_error_s,
- lit("get-byte: recv on ~s failed: ~d/~s"),
- d->stream, num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(socket_error_s,
+ lit("get-byte: recv on ~s failed: ~d/~s"),
+ d->stream, num(errno), errno_to_str(errno), nao);
}
uw_unwind {
@@ -510,21 +536,21 @@ static val dgram_flush(val stream)
if (nwrit != d->tx_pos) {
d->err = (nwrit < 0) ? errno : ENOBUFS;
- uw_throwf(socket_error_s,
- lit("flush-stream: sendto on ~s ~a: ~d/~s"),
- stream,
- (nwrit < 0) ? lit("failed") : lit("truncated"),
- num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(socket_error_s,
+ lit("flush-stream: sendto on ~s ~a: ~d/~s"),
+ stream,
+ (nwrit < 0) ? lit("failed") : lit("truncated"),
+ num(errno), errno_to_str(errno), nao);
}
free(d->tx_buf);
d->tx_buf = 0;
d->tx_pos = 0;
} else {
- d->err = ENOTCONN;
- uw_throwf(socket_error_s,
- lit("flush-stream: cannot transmit on ~s: peer not set"),
- stream, nao);
+ errno = d->err = ENOTCONN;
+ uw_ethrowf(socket_error_s,
+ lit("flush-stream: cannot transmit on ~s: peer not set"),
+ stream, nao);
}
}
return t;
@@ -533,23 +559,24 @@ static val dgram_flush(val stream)
static val dgram_close(val stream, val throw_on_error)
{
struct dgram_stream *d = coerce(struct dgram_stream *, stream->co.handle);
+
+ (void) throw_on_error;
+
if (d->fd != -1) {
dgram_flush(stream);
close(d->fd);
d->fd = -1;
d->err = 0;
+ return t;
}
- return t;
+ return nil;
}
static val dgram_get_prop(val stream, val ind)
{
struct dgram_stream *d = coerce(struct dgram_stream *, stream->co.handle);
- if (ind == fd_k)
- return num(d->fd);
-
if (ind == name_k) {
if (d->fd == -1)
return lit("closed");
@@ -640,8 +667,9 @@ static val dgram_get_sock_peer(val stream)
static val dgram_set_sock_peer(val stream, val peer)
{
+ val self = lit("sock-set-peer");
struct dgram_stream *d = coerce(struct dgram_stream *, stream->co.handle);
- sockaddr_pack(peer, d->family, &d->peer_addr, &d->pa_len);
+ sockaddr_pack(peer, d->family, &d->peer_addr, &d->pa_len, self);
return set(mkloc(d->peer, stream), peer);
}
@@ -675,10 +703,11 @@ static_def(struct strm_ops dgram_strm_ops =
static val sock_bind(val sock, val sockaddr)
{
+ val self = lit("sock-bind");
val sfd = stream_fd(sock);
if (sfd) {
- int fd = c_num(sfd);
+ int fd = c_num(sfd, self);
val family = sock_family(sock);
struct sockaddr_storage sa;
socklen_t salen;
@@ -686,38 +715,81 @@ static val sock_bind(val sock, val sockaddr)
(void) setsockopt(fd, SOL_SOCKET, SO_REUSEADDR, &reuse, sizeof(reuse));
- sockaddr_pack(sockaddr, family, &sa, &salen);
+ sockaddr_pack(sockaddr, family, &sa, &salen, self);
if (bind(fd, coerce(struct sockaddr *, &sa), salen) != 0)
- uw_throwf(socket_error_s, lit("sock-bind failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(socket_error_s, lit("~a failed: ~d/~s"),
+ self, num(errno), errno_to_str(errno), nao);
stream_set_prop(sock, addr_k, sockaddr);
return t;
}
- uw_throwf(socket_error_s, lit("sock-bind: cannot bind ~s"), sock, nao);
+ uw_throwf(socket_error_s, lit("~a: cannot bind ~s"), self, sock, nao);
}
-static int to_connect(int fd, struct sockaddr *addr, socklen_t len,
- val sock, val sockaddr, val timeout)
+#if HAVE_POLL
+
+static int fd_timeout(int fd, val timeout, int write, val self)
{
- if (!timeout) {
+ cnum ms = c_num(timeout, self) / 1000;
+ int pollms = (ms > INT_MAX) ? INT_MAX : ms;
+ struct pollfd pfd;
int res;
+ if (write)
+ pfd.events = POLLOUT;
+ else
+ pfd.events = POLLIN;
+
+ pfd.fd = fd;
+
sig_save_enable;
- res = connect(fd, addr, len);
+ res = poll(&pfd, 1, pollms);
sig_restore_enable;
return res;
- } else {
- cnum u = c_num(timeout);
+}
+
+#elif HAVE_SELECT
+
+static int fd_timeout(int fd, val timeout, int write, val self)
+{
+ cnum us = c_num(timeout, self);
struct timeval tv;
+ fd_set fds;
+
+ tv.tv_sec = us / 1000000;
+ tv.tv_usec = us % 1000000;
+
+ FD_ZERO(&fds);
+ FD_SET(fd, &fds);
+
+ sig_save_enable;
+
+ if (write)
+ res = select(fd + 1, 0 ,&rfds, 0, &tv);
+ else
+ res = select(fd + 1, &rfds, 0, 0, &tv);
+
+
+ sig_restore_enable;
+
+ return res;
+}
+
+#endif
+
+static int to_connect(int fd, struct sockaddr *addr, socklen_t len,
+ val sock, val sockaddr, val timeout, val self)
+{
+ int res;
+
+#if HAVE_POLL || HAVE_SELECT
+ if (timeout) {
int flags = fcntl(fd, F_GETFL);
- int res;
- fd_set rfds;
if (fcntl(fd, F_SETFL, flags | O_NONBLOCK) == -1)
return -1;
@@ -735,54 +807,58 @@ static int to_connect(int fd, struct sockaddr *addr, socklen_t len,
break;
}
- tv.tv_sec = u / 1000000;
- tv.tv_usec = u % 1000000;
-
- FD_ZERO(&rfds);
- FD_SET(fd, &rfds);
-
- sig_save_enable;
-
- res = select(fd + 1, &rfds, 0, 0, &tv);
-
- sig_restore_enable;
+ res = fd_timeout(fd, timeout, 1, self);
switch (res) {
case -1:
return -1;
case 0:
- uw_throwf(timeout_error_s, lit("sock-connect ~s: timeout on ~s"),
- sock, sockaddr, nao);
+ uw_ethrowf(timeout_error_s, lit("~a: ~s: timeout on ~s"),
+ self, sock, sockaddr, nao);
default:
return 0;
}
}
+#else
+ (void) timeout;
+#endif
+
+ sig_save_enable;
+
+ res = connect(fd, addr, len);
+
+ sig_restore_enable;
+
+ return res;
}
-static val open_sockfd(val fd, val family, val type, val mode_str)
+static val open_sockfd(val fd, val family, val type, val mode_str, val self)
{
struct stdio_mode m, m_rpb = stdio_mode_init_rpb;
if (type == num_fast(SOCK_DGRAM)) {
- return make_dgram_sock_stream(c_num(fd), family, nil, 0, 0, 0, 0,
- parse_mode(mode_str, m_rpb), 0);
+ return make_dgram_sock_stream(c_num(fd, self), family, nil, 0, 0, 0, 0,
+ parse_mode(mode_str, m_rpb, self), 0);
} else {
- FILE *f = (errno = 0, w_fdopen(c_num(fd), c_str(normalize_mode(&m, mode_str, m_rpb))));
+ FILE *f = (errno = 0, w_fdopen(c_num(fd, self),
+ c_str(normalize_mode(&m, mode_str,
+ m_rpb, self),
+ self)));
if (!f) {
int eno = errno;
- close(c_num(fd));
- uw_throwf(errno_to_file_error(eno), lit("error creating stream for socket ~a: ~d/~s"),
- fd, num(eno), string_utf8(strerror(eno)), nao);
+ close(c_num(fd, self));
+ uw_ethrowf(errno_to_file_error(eno), lit("error creating stream for socket ~a: ~d/~s"),
+ fd, num(eno), errno_to_str(eno), nao);
}
return set_mode_props(m, make_sock_stream(f, family, type));
}
}
-
static val sock_connect(val sock, val sockaddr, val timeout)
{
+ val self = lit("sock-connect");
val sfd = stream_fd(sock);
if (sfd) {
@@ -790,12 +866,12 @@ static val sock_connect(val sock, val sockaddr, val timeout)
struct sockaddr_storage sa;
socklen_t salen;
- sockaddr_pack(sockaddr, family, &sa, &salen);
+ sockaddr_pack(sockaddr, family, &sa, &salen, self);
- if (to_connect(c_num(sfd), coerce(struct sockaddr *, &sa), salen,
- sock, sockaddr, default_null_arg(timeout)) != 0)
- uw_throwf(socket_error_s, lit("sock-connect ~s to addr ~s: ~d/~s"),
- sock, sockaddr, num(errno), string_utf8(strerror(errno)), nao);
+ if (to_connect(c_num(sfd, self), coerce(struct sockaddr *, &sa), salen,
+ sock, sockaddr, default_null_arg(timeout), self) != 0)
+ uw_ethrowf(socket_error_s, lit("~a: ~s to addr ~s: ~d/~s"),
+ self, sock, sockaddr, num(errno), errno_to_str(errno), nao);
sock_set_peer(sock, sockaddr);
@@ -807,21 +883,21 @@ static val sock_connect(val sock, val sockaddr, val timeout)
return sock;
}
- uw_throwf(socket_error_s, lit("sock-connect: cannot connect ~s"), sock, nao);
+ uw_throwf(socket_error_s, lit("~a: cannot connect ~s"), self, sock, nao);
}
-static val sock_mark_connected(val sock)
+static val sock_mark_connected(val sock, val self)
{
val sfd = stream_fd(sock);
if (sfd) {
val family = sock_family(sock);
- struct sockaddr_storage sa = { 0 };
+ struct sockaddr_storage sa = all_zero_init;
socklen_t salen = sizeof sa;
- (void) getpeername(c_num(sfd), coerce(struct sockaddr *, &sa), &salen);
+ (void) getpeername(c_num(sfd, self), coerce(struct sockaddr *, &sa), &salen);
- sock_set_peer(sock, sockaddr_unpack(c_num(family), &sa));
+ sock_set_peer(sock, sockaddr_unpack(c_num(family, self), &sa));
if (sock_type(sock) == num_fast(SOCK_DGRAM)) {
struct dgram_stream *d = coerce(struct dgram_stream *, sock->co.handle);
@@ -836,11 +912,12 @@ static val sock_mark_connected(val sock)
static val sock_listen(val sock, val backlog)
{
+ val self = lit("sock-listen");
val sfd = stream_fd(sock);
if (!sfd)
- uw_throwf(socket_error_s, lit("sock-listen: cannot listen on ~s"),
- sock, nao);
+ uw_throwf(socket_error_s, lit("~a: cannot listen on ~s"),
+ self, sock, nao);
if (sock_type(sock) == num_fast(SOCK_DGRAM)) {
if (sock_peer(sock)) {
@@ -848,20 +925,21 @@ static val sock_listen(val sock, val backlog)
goto failed;
}
} else {
- if (listen(c_num(sfd), c_num(default_arg(backlog, num_fast(16)))))
+ if (listen(c_num(sfd, self), c_num(default_arg(backlog, num_fast(16)), self)))
goto failed;
}
return t;
failed:
- uw_throwf(socket_error_s, lit("sock-listen failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(socket_error_s, lit("~a failed: ~d/~s"),
+ self, num(errno), errno_to_str(errno), nao);
}
static val sock_accept(val sock, val mode_str, val timeout_in)
{
+ val self = lit("sock-accept");
val sfd = stream_fd(sock);
- int fd = sfd ? c_num(sfd) : -1;
+ int fd = sfd ? c_num(sfd, self) : -1;
val family = sock_family(sock);
val type = sock_type(sock);
struct sockaddr_storage sa;
@@ -872,32 +950,22 @@ static val sock_accept(val sock, val mode_str, val timeout_in)
if (!sfd)
goto badfd;
+#if HAVE_POLL || HAVE_SELECT
if (timeout) {
- struct timeval tv;
- cnum u = c_num(timeout);
- fd_set rfds;
- int res;
-
- tv.tv_sec = u / 1000000;
- tv.tv_usec = u % 1000000;
- FD_ZERO(&rfds);
- FD_SET(fd, &rfds);
-
- sig_save_enable;
-
- res = select(fd + 1, &rfds, 0, 0, &tv);
-
- sig_restore_enable;
+ int res = fd_timeout(fd, timeout, 0, self);
switch (res) {
case -1:
goto badfd;
case 0:
- uw_throwf(timeout_error_s, lit("sock-accept ~s: timeout"), sock, nao);
+ uw_ethrowf(timeout_error_s, lit("~a: ~s: timeout"), self, sock, nao);
default:
break;
}
}
+#else
+ (void) timeout;
+#endif
if (type == num_fast(SOCK_DGRAM)) {
struct dgram_stream *d = coerce(struct dgram_stream *, sock->co.handle);
@@ -930,10 +998,10 @@ static val sock_accept(val sock, val mode_str, val timeout_in)
if (nbytes == -1)
goto failed;
- if (nilp(peer = sockaddr_unpack(c_num(family), &sa))) {
+ if (nilp(peer = sockaddr_unpack(c_num(family, self), &sa))) {
free(dgram);
- uw_throwf(socket_error_s, lit("sock-accept: ~s isn't a supported socket family"),
- family, nao);
+ uw_throwf(socket_error_s, lit("~a: ~s isn't a supported socket family"),
+ self, family, nao);
}
{
@@ -951,7 +1019,7 @@ static val sock_accept(val sock, val mode_str, val timeout_in)
}
return make_dgram_sock_stream(afd, family, peer, dgram, nbytes,
coerce(struct sockaddr *, &sa), salen,
- parse_mode(mode_str, mode_rpb), d);
+ parse_mode(mode_str, mode_rpb, self), d);
}
} else {
int afd = -1;
@@ -964,99 +1032,126 @@ static val sock_accept(val sock, val mode_str, val timeout_in)
if (afd < 0)
goto failed;
- if (nilp(peer = sockaddr_unpack(c_num(family), &sa)))
- uw_throwf(socket_error_s, lit("accept: ~s isn't a supported socket family"),
- family, nao);
+ if (nilp(peer = sockaddr_unpack(c_num(family, self), &sa)))
+ uw_throwf(socket_error_s, lit("~a: ~s isn't a supported socket family"),
+ self, family, nao);
{
- val stream = open_sockfd(num(afd), family, num_fast(SOCK_STREAM), mode_str);
+ val stream = open_sockfd(num(afd), family, num_fast(SOCK_STREAM),
+ mode_str, self);
sock_set_peer(stream, peer);
return stream;
}
}
failed:
- uw_throwf(socket_error_s, lit("accept failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(socket_error_s, lit("~a failed: ~d/~s"),
+ self, num(errno), errno_to_str(errno), nao);
badfd:
- uw_throwf(socket_error_s, lit("sock-accept: cannot accept on ~s"),
- sock, nao);
+ uw_ethrowf(socket_error_s, lit("~a: cannot accept on ~s"),
+ self, sock, nao);
}
static val sock_shutdown(val sock, val how)
{
+ val self = lit("sock-shutdown");
val sfd = stream_fd(sock);
flush_stream(sock);
- if (shutdown(c_num(sfd), c_num(default_arg(how, num_fast(SHUT_WR)))))
- uw_throwf(socket_error_s, lit("shutdown failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ if (shutdown(c_num(sfd, self), c_num(default_arg(how, num_fast(SHUT_WR)), self)))
+ uw_ethrowf(socket_error_s, lit("~a failed: ~d/~s"),
+ self, num(errno), errno_to_str(errno), nao);
return t;
}
-#if defined SO_SNDTIMEO && defined SO_RCVTIMEO
-static val sock_timeout(val sock, val usec, val name, int which)
+#if HAVE_SYS_TIME && defined SO_SNDTIMEO && defined SO_RCVTIMEO
+static val sock_timeout(val sock, val usec, val name, int which, val self)
{
- cnum fd = c_num(stream_fd(sock));
- cnum u = c_num(usec);
+ cnum fd = c_num(stream_fd(sock), self);
+ cnum u = c_num(usec, self);
struct timeval tv;
tv.tv_sec = u / 1000000;
tv.tv_usec = u % 1000000;
if (setsockopt(fd, SOL_SOCKET, which, &tv, sizeof tv) != 0)
- uw_throwf(socket_error_s, lit("~a failed on ~s: ~d/~s"),
- name, sock, num(errno),
- string_utf8(strerror(errno)), nao);
+ uw_ethrowf(socket_error_s, lit("~a failed on ~s: ~d/~s"),
+ name, sock, num(errno),
+ errno_to_str(errno), nao);
return sock;
}
static val sock_send_timeout(val sock, val usec)
{
- return sock_timeout(sock, usec, lit("sock-send-timeout"), SO_SNDTIMEO);
+ val self = lit("sock-send-timeout");
+ return sock_timeout(sock, usec, self, SO_SNDTIMEO, self);
}
static val sock_recv_timeout(val sock, val usec)
{
- return sock_timeout(sock, usec, lit("sock-recv-timeout"), SO_RCVTIMEO);
+ val self = lit("sock-recv-timeout");
+ return sock_timeout(sock, usec, self, SO_RCVTIMEO, self);
}
#endif
+#ifndef SOCK_NONBLOCK
+#define SOCK_NONBLOCK 0
+#endif
+
+#ifndef SOCK_CLOEXEC
+#define SOCK_CLOEXEC 0
+#endif
+
static val open_socket(val family, val type, val mode_str)
{
- int fd = socket(c_num(family), c_num(type), 0);
- return open_sockfd(num(fd), family, type, mode_str);
+ val self = lit("open-socket");
+ int fd = socket(c_num(family, self), c_num(type, self), 0);
+
+ if (fd < 0)
+ uw_ethrowf(socket_error_s, lit("~a failed: ~d/~s"),
+ self, num(errno), errno_to_str(errno), nao);
+
+ if (SOCK_NONBLOCK | SOCK_CLOEXEC)
+ type = num_fast(c_num(type, self) & ~(SOCK_NONBLOCK | SOCK_CLOEXEC));
+
+ return open_sockfd(num(fd), family, type, mode_str, self);
}
static val socketpair_wrap(val family, val type, val mode_str)
{
+ val self = lit("open-socket-pair");
int sv[2] = { -1, -1 };
- int res = socketpair(c_num(family), c_num(type), 0, sv);
+ int res = socketpair(c_num(family, self), c_num(type, self), 0, sv);
val out = nil;
uw_simple_catch_begin;
if (res < 0)
- uw_throwf(socket_error_s, lit("sock-pair failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(socket_error_s, lit("~a failed: ~d/~s"),
+ self, num(errno), errno_to_str(errno), nao);
+
+ if (SOCK_NONBLOCK | SOCK_CLOEXEC)
+ type = num_fast(c_num(type, self) & ~(SOCK_NONBLOCK | SOCK_CLOEXEC));
{
- val s0 = open_sockfd(num(sv[0]), family, type, mode_str);
- val s1 = open_sockfd(num(sv[1]), family, type, mode_str);
+ val s0 = open_sockfd(num(sv[0]), family, type, mode_str, self);
+ val s1 = open_sockfd(num(sv[1]), family, type, mode_str, self);
- sock_mark_connected(s0);
- sock_mark_connected(s1);
+ sock_mark_connected(s0, self);
+ sock_mark_connected(s1, self);
out = list(s0, s1, nao);
}
uw_unwind {
- if (sv[0] != -1)
- close(sv[0]);
- if (sv[1] != -1)
- close(sv[1]);
+ if (!out) {
+ if (sv[0] != -1)
+ close(sv[0]);
+ if (sv[1] != -1)
+ close(sv[1]);
+ }
}
uw_catch_end;
@@ -1064,7 +1159,117 @@ static val socketpair_wrap(val family, val type, val mode_str)
return out;
}
-void sock_load_init(void)
+static val sock_opt(val sock, val level, val option, val type_opt)
+{
+ val self = lit("sock-opt");
+ val sfd = stream_fd(sock);
+ int lvl = c_int(level, self);
+ int opt = c_int(option, self);
+ val type = default_arg(type_opt, ffi_type_lookup(int_s));
+ struct txr_ffi_type *tft = ffi_type_struct_checked(self, type);
+
+ if (!sfd) {
+ uw_throwf(socket_error_s, lit("~a: cannot get option on ~s"),
+ self, sock, nao);
+ } else {
+ socklen_t typesize = convert(socklen_t, ffi_type_size(tft));
+ socklen_t size = typesize;
+ mem_t *data = coerce(mem_t *, zalloca(size));
+ if (getsockopt(c_num(sfd, self), lvl, opt, data, &size) != 0)
+ uw_ethrowf(socket_error_s, lit("~a failed on ~s: ~d/~s"),
+ self, sock, num(errno), errno_to_str(errno), nao);
+ /* TODO: Add a separate function to handle options with
+ * variable-size values, for example the platform-specific
+ * SO_BINDTODEVICE.
+ * (Or perhaps add an optional argument following type_opt
+ * specifying the requested length of the value, presumably of type
+ * carray.) */
+ if (size != typesize)
+ uw_throwf(socket_error_s, lit("~a: variable-size option on ~s"),
+ self, sock, nao);
+ return ffi_type_get(tft, data, self);
+ }
+}
+
+static val sock_set_opt(val sock, val level, val option, val value,
+ val type_opt)
+{
+ val self = lit("sock-set-opt");
+ val sfd = stream_fd(sock);
+ int lvl = c_int(level, self);
+ int opt = c_int(option, self);
+ val type = default_arg(type_opt, ffi_type_lookup(int_s));
+ struct txr_ffi_type *tft = ffi_type_struct_checked(self, type);
+
+ if (!sfd) {
+ uw_throwf(socket_error_s, lit("~a: cannot set option on ~s"),
+ self, sock, nao);
+ } else {
+ socklen_t size = convert(socklen_t, ffi_type_size(tft));
+ mem_t *data = coerce(mem_t *, zalloca(size));
+ ffi_type_put(tft, value, data, self);
+ if (setsockopt(c_num(sfd, self), lvl, opt, data, size) != 0)
+ uw_ethrowf(socket_error_s, lit("~a failed on ~s: ~d/~s"),
+ self, sock, num(errno), errno_to_str(errno), nao);
+ return value;
+ }
+}
+
+static val sock_set_entries(val fun)
+{
+ val sname[] = {
+ lit("sockaddr"), lit("sockaddr-in"), lit("sockaddr-in6"),
+ lit("sockaddr-un"), lit("addrinfo"),
+ nil
+ };
+ val vname[] = {
+ lit("af-unspec"), lit("af-unix"), lit("af-inet"), lit("af-inet6"),
+ lit("sock-stream"), lit("sock-dgram"),
+ lit("inaddr-any"), lit("inaddr-loopback"),
+ lit("in6addr-any"), lit("in6addr-loopback"),
+ lit("sock-nonblock"), lit("sock-cloexec"),
+ lit("ai-passive"), lit("ai-canonname"), lit("ai-numerichost"),
+ lit("ai-v4mapped"), lit("ai-all"), lit("ai-addrconfig"),
+ lit("ai-numericserv"), lit("sol-socket"), lit("ipproto-ip"),
+ lit("ipproto-ipv6"), lit("ipproto-tcp"), lit("ipproto-udp"),
+ lit("so-acceptconn"), lit("so-broadcast"), lit("so-debug"),
+ lit("so-dontroute"), lit("so-error"), lit("so-keepalive"),
+ lit("so-linger"), lit("so-oobinline"), lit("so-rcvbuf"),
+ lit("so-rcvlowat"), lit("so-rcvtimeo"), lit("so-reuseaddr"),
+ lit("so-sndbuf"), lit("so-sndlowat"), lit("so-sndtimeo"),
+ lit("so-type"), lit("ipv6-join-group"), lit("ipv6-leave-group"),
+ lit("ipv6-multicast-hops"), lit("ipv6-multicast-if"),
+ lit("ipv6-multicast-loop"), lit("ipv6-unicast-hops"),
+ lit("ipv6-v6only"), lit("tcp-nodelay"),
+ nil
+ };
+ val name[] = {
+ lit("getaddrinfo"),
+ lit("str-inaddr"), lit("str-in6addr"),
+ lit("str-inaddr-net"), lit("str-in6addr-net"),
+ lit("inaddr-str"), lit("in6addr-str"),
+ lit("shut-rd"), lit("shut-wr"), lit("shut-rdwr"),
+ lit("open-socket"), lit("open-socket-pair"),
+ lit("sock-bind"), lit("sock-connect"), lit("sock-listen"),
+ lit("sock-accept"), lit("sock-shutdown"), lit("open-socket"),
+ lit("open-socket-pair"), lit("sock-send-timeout"), lit("sock-recv-timeout"),
+ lit("sock-opt"), lit("sock-set-opt"),
+ lit("sockaddr-str"),
+ nil
+ };
+ val name_noload[] = {
+ lit("family"), lit("addr"), lit("port"), lit("flow-info"),
+ lit("scope-id"), lit("prefix"), lit("path"), lit("flags"), lit("socktype"),
+ lit("protocol"), lit("canonname"), lit("str-addr"), nil
+ };
+ autoload_set(al_struct, sname, fun);
+ autoload_set(al_var, vname, fun);
+ autoload_set(al_fun, name, fun);
+ autoload_intern(name_noload);
+ return nil;
+}
+
+static val sock_instantiate(void)
{
sockaddr_in_s = intern(lit("sockaddr-in"), user_package);
sockaddr_in6_s = intern(lit("sockaddr-in6"), user_package);
@@ -1104,11 +1309,18 @@ void sock_load_init(void)
reg_varl(intern(lit("ai-passive"), user_package), num_fast(AI_PASSIVE));
reg_varl(intern(lit("ai-canonname"), user_package), num_fast(AI_CANONNAME));
reg_varl(intern(lit("ai-numerichost"), user_package), num_fast(AI_NUMERICHOST));
+#ifdef AI_V4MAPPED
reg_varl(intern(lit("ai-v4mapped"), user_package), num_fast(AI_V4MAPPED));
+#endif
+#ifdef AI_ALL
reg_varl(intern(lit("ai-all"), user_package), num_fast(AI_ALL));
+#endif
reg_varl(intern(lit("ai-addrconfig"), user_package), num_fast(AI_ADDRCONFIG));
reg_varl(intern(lit("ai-numericserv"), user_package), num_fast(AI_NUMERICSERV));
#endif
+ reg_varl(intern(lit("shut-rd"), user_package), num_fast(SHUT_RD));
+ reg_varl(intern(lit("shut-wr"), user_package), num_fast(SHUT_WR));
+ reg_varl(intern(lit("shut-rdwr"), user_package), num_fast(SHUT_RDWR));
reg_fun(intern(lit("sock-bind"), user_package), func_n2(sock_bind));
reg_fun(intern(lit("sock-connect"), user_package), func_n3o(sock_connect, 2));
@@ -1117,14 +1329,56 @@ void sock_load_init(void)
reg_fun(intern(lit("sock-shutdown"), user_package), func_n2o(sock_shutdown, 1));
reg_fun(intern(lit("open-socket"), user_package), func_n3o(open_socket, 2));
reg_fun(intern(lit("open-socket-pair"), user_package), func_n3o(socketpair_wrap, 2));
-#if defined SO_SNDTIMEO && defined SO_RCVTIMEO
+#if HAVE_SYS_TIME && defined SO_SNDTIMEO && defined SO_RCVTIMEO
reg_fun(intern(lit("sock-send-timeout"), user_package), func_n2(sock_send_timeout));
reg_fun(intern(lit("sock-recv-timeout"), user_package), func_n2(sock_recv_timeout));
#endif
+ reg_fun(intern(lit("sock-opt"), user_package), func_n4o(sock_opt, 3));
+ reg_fun(intern(lit("sock-set-opt"), user_package), func_n5o(sock_set_opt, 4));
+ reg_varl(intern(lit("sol-socket"), user_package), num_fast(SOL_SOCKET));
+ reg_varl(intern(lit("ipproto-ip"), user_package), num_fast(IPPROTO_IP));
+ reg_varl(intern(lit("ipproto-ipv6"), user_package), num_fast(IPPROTO_IPV6));
+ reg_varl(intern(lit("ipproto-tcp"), user_package), num_fast(IPPROTO_TCP));
+ reg_varl(intern(lit("ipproto-udp"), user_package), num_fast(IPPROTO_UDP));
+ reg_varl(intern(lit("so-acceptconn"), user_package), num_fast(SO_ACCEPTCONN));
+ reg_varl(intern(lit("so-broadcast"), user_package), num_fast(SO_BROADCAST));
+ reg_varl(intern(lit("so-debug"), user_package), num_fast(SO_DEBUG));
+ reg_varl(intern(lit("so-dontroute"), user_package), num_fast(SO_DONTROUTE));
+ reg_varl(intern(lit("so-error"), user_package), num_fast(SO_ERROR));
+ reg_varl(intern(lit("so-keepalive"), user_package), num_fast(SO_KEEPALIVE));
+ reg_varl(intern(lit("so-linger"), user_package), num_fast(SO_LINGER));
+ reg_varl(intern(lit("so-oobinline"), user_package), num_fast(SO_OOBINLINE));
+ reg_varl(intern(lit("so-rcvbuf"), user_package), num_fast(SO_RCVBUF));
+ reg_varl(intern(lit("so-rcvlowat"), user_package), num_fast(SO_RCVLOWAT));
+ reg_varl(intern(lit("so-rcvtimeo"), user_package), num_fast(SO_RCVTIMEO));
+ reg_varl(intern(lit("so-reuseaddr"), user_package), num_fast(SO_REUSEADDR));
+ reg_varl(intern(lit("so-sndbuf"), user_package), num_fast(SO_SNDBUF));
+ reg_varl(intern(lit("so-sndlowat"), user_package), num_fast(SO_SNDLOWAT));
+ reg_varl(intern(lit("so-sndtimeo"), user_package), num_fast(SO_SNDTIMEO));
+ reg_varl(intern(lit("so-type"), user_package), num_fast(SO_TYPE));
+ reg_varl(intern(lit("ipv6-join-group"), user_package), num_fast(IPV6_JOIN_GROUP));
+ reg_varl(intern(lit("ipv6-leave-group"), user_package), num_fast(IPV6_LEAVE_GROUP));
+ reg_varl(intern(lit("ipv6-multicast-hops"), user_package), num_fast(IPV6_MULTICAST_HOPS));
+ reg_varl(intern(lit("ipv6-multicast-if"), user_package), num_fast(IPV6_MULTICAST_IF));
+ reg_varl(intern(lit("ipv6-multicast-loop"), user_package), num_fast(IPV6_MULTICAST_LOOP));
+ reg_varl(intern(lit("ipv6-unicast-hops"), user_package), num_fast(IPV6_UNICAST_HOPS));
+ reg_varl(intern(lit("ipv6-v6only"), user_package), num_fast(IPV6_V6ONLY));
+ reg_varl(intern(lit("tcp-nodelay"), user_package), num_fast(TCP_NODELAY));
fill_stream_ops(&dgram_strm_ops);
+
dgram_strm_ops.get_sock_family = dgram_get_sock_family;
dgram_strm_ops.get_sock_type = dgram_get_sock_type;
dgram_strm_ops.get_sock_peer = dgram_get_sock_peer;
dgram_strm_ops.set_sock_peer = dgram_set_sock_peer;
+
+ load(scat2(stdlib_path, lit("socket")));
+ return nil;
+}
+
+void sock_init(void)
+{
+ ffi_typedef(intern(lit("socklen-t"), user_package),
+ ffi_type_by_size(convert(socklen_t, -1) > 0, sizeof (socklen_t)));
+ autoload_reg(sock_instantiate, sock_set_entries);
}
diff --git a/socket.h b/socket.h
index 0e803eef..45d51f2e 100644
--- a/socket.h
+++ b/socket.h
@@ -1,4 +1,4 @@
-/* Copyright 2016-2020
+/* Copyright 2016-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,24 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
void sock_init(void);
-void sock_load_init(void);
diff --git a/stdlib/arith-each.tl b/stdlib/arith-each.tl
new file mode 100644
index 00000000..142e02a6
--- /dev/null
+++ b/stdlib/arith-each.tl
@@ -0,0 +1,103 @@
+;; Copyright 2021-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defun sys:vars-check (form vars)
+ (unless (listp vars)
+ (compile-error form "~s is expected to be variable binding syntax" vars))
+ (whenlet ((bad (find-if [notf consp] vars)))
+ (compile-error form "~s isn't a var-initform pair" bad)))
+
+(defmacro sys:arith-each (fn iv short-circ vars . body)
+ (let* ((gens (mapcar (ret (gensym)) vars))
+ (syms [mapcar car vars])
+ (accum (gensym)))
+ (if (null vars)
+ iv
+ ^(let* (,*(mapcar (ret ^(,@1 (iter-begin ,@2))) gens syms)
+ (,accum ,iv))
+ (block nil
+ (sys:for-op ()
+ ((and ,*(mapcar (op list 'iter-more) gens)
+ ,*(cond
+ ((eq t short-circ) ^(,accum))
+ ((null short-circ) ^((null ,accum)))
+ ((eq '+ short-circ) ^((nzerop ,accum)))))
+ ,accum)
+ (,*(mapcar (ret ^(sys:setq ,@1 (iter-step ,@1))) gens))
+ ,*(mapcar (ret ^(sys:setq ,@1 (iter-item ,@2))) syms gens)
+ (set ,accum ,(cond
+ ((consp fn) ^(,(car fn) ,accum (progn ,*body)))
+ (fn ^(,fn (progn ,*body)))
+ (t ^(progn ,*body))))))))))
+
+(defmacro sum-each (:form f vars . body)
+ (sys:vars-check f vars)
+ ^(let ,vars
+ (block nil
+ (sys:arith-each (+) 0 : ,vars ,*body))))
+
+(defmacro sum-each* (:form f vars . body)
+ (sys:vars-check f vars)
+ ^(let* ,vars
+ (block nil
+ (sys:arith-each (+) 0 : ,vars ,*body))))
+
+(defmacro mul-each (:form f vars . body)
+ (sys:vars-check f vars)
+ ^(let ,vars
+ (block nil
+ (sys:arith-each (*) 1 + ,vars ,*body))))
+
+(defmacro mul-each* (:form f vars . body)
+ (sys:vars-check f vars)
+ ^(let* ,vars
+ (block nil
+ (sys:arith-each (*) 1 + ,vars ,*body))))
+
+(defmacro each-true (:form f vars . body)
+ (sys:vars-check f vars)
+ ^(let* ,vars
+ (block nil
+ (sys:arith-each nil t t ,vars ,*body))))
+
+(defmacro some-true (:form f vars . body)
+ (sys:vars-check f vars)
+ ^(let* ,vars
+ (block nil
+ (sys:arith-each nil nil nil ,vars ,*body))))
+
+(defmacro each-false (:form f vars . body)
+ (sys:vars-check f vars)
+ ^(let* ,vars
+ (block nil
+ (sys:arith-each not t t ,vars ,*body))))
+
+(defmacro some-false (:form f vars . body)
+ (sys:vars-check f vars)
+ ^(let* ,vars
+ (block nil
+ (sys:arith-each not nil nil ,vars ,*body))))
diff --git a/share/txr/stdlib/asm.tl b/stdlib/asm.tl
index 8dd64ec4..2ff28721 100644
--- a/share/txr/stdlib/asm.tl
+++ b/stdlib/asm.tl
@@ -1,4 +1,4 @@
-;; Copyright 2018-2020
+;; Copyright 2018-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,27 +6,29 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(load "vm-param")
(defstruct oc-base nil
+ (:static deprecated nil)
(:method synerr (me fmt . args)
(error `opcode @{me.symbol}: @fmt` . args))
@@ -41,6 +43,7 @@
n syntax)))
(:method backpatch (me asm at offs)
+ (ignore asm at offs)
(asm-error `@{me.symbol} doesn't backpatch`)))
(compile-only
@@ -215,9 +218,9 @@
(q me.(cur-pos)))
(inc c)
me.(set-pos p)
- (format t "~,5d: ~,08X ~a\n" (trunc p 4) me.(get-word) dis-txt)
+ (format stream "~,5d: ~,08X ~a\n" (trunc p 4) me.(get-word) dis-txt)
(while (< (inc p 4) q)
- (format t "~,5d: ~,08X\n" (trunc p 4) me.(get-word)))
+ (format stream "~,5d: ~,08X\n" (trunc p 4) me.(get-word)))
me.(set-pos q)
(set p q)))
c))
@@ -269,7 +272,7 @@
(defmacro with-lev-idx ((lev-var idx-var) val-expr . body)
(with-gensyms (val-var)
^(let* ((,val-var ,val-expr)
- (,lev-var (ash ,val-var (macro-time (- %lev-bits%))))
+ (,lev-var (ash ,val-var (- %lev-bits%)))
(,idx-var (logtrunc ,val-var %lev-bits%)))
,*body))))
@@ -315,13 +318,15 @@
(defstruct backpatch-low16 nil
(:method backpatch (me asm at offs)
- (tree-bind (hi lo) asm.(get-pair)
+ (ignore me)
+ (tree-bind (hi t) asm.(get-pair)
asm.(set-pos at)
asm.(put-pair hi offs))))
(defstruct backpatch-high16 nil
(:method backpatch (me asm at offs)
- (tree-bind (hi lo) asm.(get-pair)
+ (ignore me)
+ (tree-bind (t lo) asm.(get-pair)
asm.(set-pos at)
asm.(put-pair offs lo))))
@@ -342,15 +347,21 @@
(defstruct ,class ,orig-class
(:static symbol ',symbol)
(:static code ,code))
- (register-opcode (new ,class)))))
+ (register-opcode (new ,class))))
+
+ (defmacro defopcode-alias (alias-symbol orig-symbol)
+ ^(let ((oc [%oc-hash% ',orig-symbol]))
+ (set [%oc-hash% ',alias-symbol] oc))))
(defopcode op-label label nil
(:method asm (me asm syntax)
+ (ignore me)
(unless (is-label syntax)
asm.(synerr "label must be keyword or gensym"))
asm.(define-label syntax))
- (:method dis (me asm extension operand)))
+ (:method dis (me asm extension operand)
+ (ignore me asm extension operand)))
(defopcode op-noop noop auto
(:method asm (me asm syntax)
@@ -358,6 +369,7 @@
asm.(put-insn me.code 0 0))
(:method dis (me asm extension operand)
+ (ignore asm extension operand)
^(,me.symbol)))
(defopcode op-frame frame auto
@@ -372,6 +384,7 @@
%lev-size%))
asm.(put-insn me.code lev size)))
(:method dis (me asm lev size)
+ (ignore asm)
^(,me.symbol ,lev ,size)))
(defopcode-derived op-sframe sframe auto op-frame)
@@ -384,11 +397,14 @@
(let ((res (car asm.(parse-args me syntax '(r)))))
asm.(put-insn me.code 0 res)))
(:method dis (me asm extension res)
+ (ignore asm extension)
^(,me.symbol ,(operand-to-sym res))))
-(defopcode-derived op-fin fin auto op-end)
+(defopcode-alias jend end)
-(defopcode-derived op-prof prof auto op-fin)
+(defopcode-alias xend end)
+
+(defopcode-derived op-prof prof auto op-end)
(defopcode op-call call auto
(:method asm (me asm syntax)
@@ -452,6 +468,7 @@
asm.(put-insn me.code (enc-small-op src) dst)))
(:method dis (me asm src dst)
+ (ignore asm)
^(,me.symbol ,(operand-to-sym dst) ,(small-op-to-sym src))))
(defopcode op-movsr movsr auto
@@ -461,6 +478,7 @@
asm.(put-insn me.code (enc-small-op dst) src)))
(:method dis (me asm dst src)
+ (ignore asm)
^(,me.symbol ,(small-op-to-sym dst) ,(operand-to-sym src))))
(defopcode op-movrr movrr auto
@@ -471,6 +489,7 @@
asm.(put-pair 0 src)))
(:method dis (me asm extension dst)
+ (ignore asm extension)
(let ((src (cadr asm.(get-pair))))
^(,me.symbol ,(operand-to-sym dst) ,(operand-to-sym src)))))
@@ -483,46 +502,6 @@
(t 'movrr))]))
real.(asm asm syntax)))))
-(defopcode op-movrsi movrsi auto
- (:method asm (me asm syntax)
- me.(chk-arg-count 2 syntax)
- (tree-bind (dst imm) asm.(parse-args me syntax '(d si))
- asm.(put-insn me.code (logtrunc (sys:bits imm) 10) dst)))
-
- (:method dis (me asm imm dst)
- ^(,me.symbol ,(operand-to-sym dst) ,(bits-to-obj imm 10))))
-
-(defopcode op-movsmi movsmi auto
- (:method asm (me asm syntax)
- me.(chk-arg-count 2 syntax)
- (tree-bind (dst imm) asm.(parse-args me syntax '(ds mi))
- asm.(put-insn me.code (enc-small-op dst)
- (logtrunc (sys:bits imm) 16))))
-
- (:method dis (me asm dst imm )
- ^(,me.symbol ,(small-op-to-sym dst) ,(bits-to-obj imm 16))))
-
-(defopcode op-movrbi movrbi auto
- (:method asm (me asm syntax)
- me.(chk-arg-count 2 syntax)
- (tree-bind (dst imm) asm.(parse-args me syntax '(d bi))
- asm.(put-insn me.code 0 dst)
- asm.(put-word (logtrunc (sys:bits imm) 32))))
-
- (:method dis (me asm extension dst)
- (let ((imm asm.(get-word)))
- ^(,me.symbol ,(operand-to-sym dst) ,(bits-to-obj imm 32)))))
-
-(defopcode op-movi-pseudo movi nil
- (:method asm (me asm syntax)
- (tree-bind (dst src) asm.(parse-args me syntax '(d bi))
- (let ((real [%oc-hash% (cond
- (asm.(immediate-fits-type src 'si) 'movrsi)
- ((and asm.(immediate-fits-type src 'si)
- (small-op-p dst)) 'movsmi)
- (t 'movrbi))]))
- real.(asm asm syntax)))))
-
(defopcode op-jmp jmp auto
(:method asm (me asm syntax)
me.(chk-arg-count 1 syntax)
@@ -530,9 +509,11 @@
asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))))
(:method backpatch (me asm at dst)
+ (ignore at)
asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)))
(:method dis (me asm high16 low16)
+ (ignore asm)
^(,me.symbol ,(logior (ash high16 16) low16))))
(defopcode op-if if auto
@@ -543,9 +524,11 @@
asm.(put-pair 0 reg)))
(:method backpatch (me asm at dst)
+ (ignore at)
asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)))
(:method dis (me asm high16 low16)
+ (ignore asm)
(let ((dst (logior (ash high16 16) low16))
(reg (cadr asm.(get-pair))))
^(,me.symbol ,(operand-to-sym reg) ,dst))))
@@ -558,6 +541,7 @@
asm.(put-pair lreg rreg)))
(:method backpatch (me asm at dst)
+ (ignore at)
asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)))
(:method dis (me asm high16 low16)
@@ -602,6 +586,7 @@
asm.(put-pair outreg blname)))
(:method backpatch (me asm at exitpt)
+ (ignore at)
asm.(put-insn me.code (ash exitpt -16) (logtrunc exitpt 16)))
(:method dis (me asm high16 low16)
@@ -617,6 +602,7 @@
asm.(put-insn me.code (enc-small-op name) reg)))
(:method dis (me asm name reg)
+ (ignore asm)
^(,me.symbol ,(small-op-to-sym name) ,(operand-to-sym reg))))
(defopcode op-retrs retrs auto
@@ -626,6 +612,7 @@
asm.(put-insn me.code (enc-small-op reg) name)))
(:method dis (me asm reg name)
+ (ignore asm)
^(,me.symbol ,(operand-to-sym name) ,(small-op-to-sym reg))))
(defopcode op-retrr retrr auto
@@ -636,6 +623,7 @@
asm.(put-pair 0 name)))
(:method dis (me asm extension reg)
+ (ignore asm extension)
(let ((name (cadr asm.(get-pair))))
^(,me.symbol ,(operand-to-sym name) ,(operand-to-sym reg)))))
@@ -661,9 +649,11 @@
asm.(put-pair desc catch-syms)))
(:method backpatch (me asm at dst)
+ (ignore at)
asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)))
(:method dis (me asm high16 low16)
+ (ignore asm)
(let ((dst (logior (ash high16 16) low16)))
(tree-bind (sym args) asm.(get-pair)
(tree-bind (desc catch-syms) asm.(get-pair)
@@ -679,8 +669,9 @@
asm.(put-pair fun handle-syms)))
(:method dis (me asm extension fun)
- (let ((handle-syms (cadr asm.(get-pair))))
- ^(,me.symbol ,(operand-to-sym fun) ,(operand-to-sym handle-syms)))))
+ (ignore asm extension)
+ (let ((handle-syms (cadr asm.(get-pair))))
+ ^(,me.symbol ,(operand-to-sym fun) ,(operand-to-sym handle-syms)))))
(defopcode op-getv getv auto
(:method asm (me asm syntax)
@@ -691,6 +682,7 @@
(set name 1))
asm.(put-insn me.code (enc-small-op name) reg)))
(:method dis (me asm name reg)
+ (ignore asm)
^(,me.symbol ,(operand-to-sym reg) ,(small-op-to-sym name))))
(defopcode-derived op-oldgetf oldgetf auto op-getv)
@@ -712,6 +704,7 @@
(set name 1))
asm.(put-insn me.code (enc-small-op name) reg)))
(:method dis (me asm name reg)
+ (ignore asm)
^(,me.symbol ,(operand-to-sym reg) ,(small-op-to-sym name))))
(defopcode-derived op-setl1 setl1 auto op-setv)
@@ -722,13 +715,14 @@
(:method asm (me asm syntax)
me.(chk-arg-count-min 6 syntax)
(let* ((syn-pat (repeat '(d) (- (length syntax) 7))))
- (tree-bind (reg frsize dst fix req vari . regs)
- asm.(parse-args me syntax ^(d n l n n o ,*syn-pat))
+ (tree-bind (reg frsize ntreg dst fix req vari . regs)
+ asm.(parse-args me syntax ^(d n n l n n o,*syn-pat))
(unless (<= 0 frsize %lev-size%)
me.(synerr "frame size must be 0 to ~a" %lev-size%))
asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))
asm.(put-pair (logior (ash (if vari 1 0) %lev-bits%) frsize) reg)
asm.(put-pair req fix)
+ asm.(put-pair 0 ntreg)
(unless (eql fix (- (len regs) (if vari 1 0)))
me.(synerr "wrong number of registers"))
(while regs
@@ -737,25 +731,28 @@
asm.(put-pair y x))))))
(:method backpatch (me asm at dst)
+ (ignore at)
asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)))
(:method dis (me asm high16 low16)
+ (ignore asm)
(let ((dst (logior (ash high16 16) low16)))
(tree-bind (vari-frsize reg) asm.(get-pair)
(let ((vari (bit vari-frsize %lev-bits%)))
(tree-bind (req fix) asm.(get-pair)
- (build
- (add me.symbol (operand-to-sym reg)
- (logtrunc vari-frsize %lev-bits%)
- dst fix req vari)
- (when vari
- (inc fix))
- (while (> fix 0)
- (dec fix 2)
- (tree-bind (y x) asm.(get-pair)
- (add (operand-to-sym x))
- (unless (minusp fix)
- (add (operand-to-sym y))))))))))))
+ (tree-bind (t ntreg) asm.(get-pair)
+ (build
+ (add me.symbol (operand-to-sym reg)
+ (logtrunc vari-frsize %lev-bits%)
+ ntreg dst fix req vari)
+ (when vari
+ (inc fix))
+ (while (> fix 0)
+ (dec fix 2)
+ (tree-bind (y x) asm.(get-pair)
+ (add (operand-to-sym x))
+ (unless (minusp fix)
+ (add (operand-to-sym y)))))))))))))
(defopcode op-getlx getlx auto
(:method asm (me asm syntax)
@@ -767,6 +764,7 @@
(t asm.(put-insn me.code (enc-small-op 1) idx)
asm.(asm-one ^(mov ,(operand-to-exp dst) t1))))))
(:method dis (me asm dst idx)
+ (ignore asm)
^(,me.symbol ,(small-op-to-sym dst) ,idx)))
(defopcode op-setlx setlx auto
@@ -779,6 +777,7 @@
(t asm.(asm-one ^(mov t1 ,(operand-to-exp src)))
asm.(put-insn me.code (enc-small-op 1) idx)))))
(:method dis (me asm src idx)
+ (ignore asm)
^(,me.symbol ,(small-op-to-sym src) ,idx)))
(defopcode-derived op-getf getf auto op-getlx)
diff --git a/share/txr/stdlib/awk.tl b/stdlib/awk.tl
index 33776a1c..61b6d484 100644
--- a/share/txr/stdlib/awk.tl
+++ b/stdlib/awk.tl
@@ -1,4 +1,4 @@
-;; Copyright 2016-2020
+;; Copyright 2016-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,25 +6,26 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
-(load "conv.tl")
+(load "conv")
(defstruct sys:awk-state ()
(rs "\n") krs
@@ -43,7 +44,7 @@
par-mode par-mode-fs par-mode-prev-fs
(streams (hash :equal-based))
(:fini (self)
- (dohash (k v self.streams)
+ (dohash (#:k v self.streams)
(close-stream v)))
(:postinit (self)
(set self.inputs (or self.inputs (zap *args*) (list *stdin*)))
@@ -55,10 +56,11 @@
self.output stream)))))
(defstruct sys:awk-compile-time ()
- inputs output name lets
+ inputs output name lets funs
begin-file-actions end-file-actions
begin-actions end-actions
cond-actions
+ field-name-conv
(nranges 0)
(rng-rec-temp (gensym))
(rng-vec-temp (gensym))
@@ -162,11 +164,11 @@
(t r))))))
(t
(set aws.par-mode nil)
- (let ((rin (record-adapter (if (regexp aws.rs)
- aws.rs
- (regex-compile aws.rs))
- *stdin*
- aws.krs)))
+ (let ((rin (record-adapter
+ (if (regexp aws.rs) aws.rs
+ (regex-compile ^(compound, aws.rs)))
+ *stdin*
+ aws.krs)))
(lambda () (get-line rin))))))))))
(set aws.file-rec-num 0)
(unwind-protect
@@ -186,13 +188,14 @@
(put-string `@(car a)`)
(put-string (if (set next (cdr a)) self.ofs self.ors))))
(t (put-string self.rec)
- (put-string self.ors))))
+ (put-string self.ors)
+ nil)))
(defmeth sys:awk-state ensure-stream (self kind path mode)
(hash-update-1 self.streams
^(,kind ,path)
(do or @1 (caseq kind
- ((:inf :outf) (open-file path mode))
+ ((:inf :outf :apf) (open-file path mode))
((:inp :outp) (open-command path mode))))
nil))
@@ -287,8 +290,8 @@
(defmacro sys:awk-redir (aws-sym stream-var kind mode path body)
(with-gensyms (res-sym)
- ^(let ((,res-sym ,path)
- (,stream-var (qref ,aws-sym (ensure-stream ,kind ,res-sym ,mode))))
+ ^(let* ((,res-sym ,path)
+ (,stream-var (qref ,aws-sym (ensure-stream ,kind ,res-sym ,mode))))
,(if body
^(qref ,aws-sym (close-or-flush ,stream-var ,kind ,res-sym
(progn ,*body)))
@@ -314,24 +317,41 @@
(awk-error "duplicate :name clauses"))
(when (or (atom actions) (cdr actions))
(awk-error "bad :name syntax"))
- (unless (car actions)
- (awk-error "null :name not permitted"))
- (unless (symbolp (car actions))
- (awk-error ":name must be a symbol"))
(set awc.name (car actions)))
(:let (push actions awc.lets))
+ (:fun (push actions awc.funs))
(:begin (push actions awc.begin-actions))
(:set (push ^((set ,*actions)) awc.begin-actions))
(:end (push actions awc.end-actions))
(:begin-file (push actions awc.begin-file-actions))
(:set-file (push ^((set ,*actions)) awc.begin-actions))
(:end-file (push actions awc.end-file-actions))
+ (:fields
+ (when awc.field-name-conv
+ (awk-error "duplicate :fields clauses"))
+ (let ((fnames
+ (collect-each ((fn actions))
+ (match-case fn
+ (@(bindable @sym) (list sym))
+ ((@(bindable @sym) @(bindable))
+ (if (eq sym '-)
+ (awk-error "type given for unnamed field"))
+ fn)
+ ((@(bindable) @type)
+ (awk-error "bad fconv function: ~s" type))
+ (@else (awk-error "bad :fields item: ~s"
+ else))))))
+ (let ((nodash [remq '- fnames car]))
+ (unless (equal nodash [unique nodash car])
+ (awk-error "duplicate field names")))
+ (set awc.field-name-conv fnames)))
(t (push (if actions
cl
^(,pattern (prn)))
awc.cond-actions))))
(junk (awk-error "bad clause syntax ~s" junk))))
(set awc.lets [apply append (nreverse awc.lets)]
+ awc.funs [apply append (nreverse awc.funs)]
awc.begin-actions [apply append (nreverse awc.begin-actions)]
awc.end-actions [apply append (nreverse awc.end-actions)]
awc.begin-file-actions [apply append (nreverse awc.begin-file-actions)]
@@ -339,8 +359,7 @@
awc.cond-actions (nreverse awc.cond-actions))
awc))
-(defun sys:awk-code-move-check (awc aws-sym mainform subform
- suspicious-vars kind)
+(defun sys:awk-code-move-check (mainform subform suspicious-vars kind)
(when suspicious-vars
(compile-warning mainform "~!form ~s\n\
is moved out of the apparent scope\n\
@@ -396,20 +415,16 @@
(expand-with-free-refs from-expr e ,awc.outer-env)
(expand-with-free-refs to-expr e ,awc.outer-env)
(list (cadr form) (caddr form)))
- (sys:awk-code-move-check ,awc ',aws-sym
- form from-expr-orig
+ (sys:awk-code-move-check form from-expr-orig
(diff fe-ev fe-fv)
'variables)
- (sys:awk-code-move-check ,awc ',aws-sym
- form from-expr-orig
+ (sys:awk-code-move-check form from-expr-orig
(diff fe-ef fe-ff)
'functions)
- (sys:awk-code-move-check ,awc ',aws-sym
- form to-expr-orig
+ (sys:awk-code-move-check form to-expr-orig
(diff te-ev te-fv)
'variables)
- (sys:awk-code-move-check ,awc ',aws-sym
- form to-expr-orig
+ (sys:awk-code-move-check form to-expr-orig
(diff te-ef te-ff)
'functions)
(push rng-temp (qref ,awc rng-expr-temps))
@@ -450,73 +465,118 @@
^(symacrolet ((f (usr:rslot ,',aws-sym 'fields 'f-to-rec)))
(set f (mapcar (opip ,*opip-args) f))))
(fconv (. conv-args)
- ^(set f (sys:conv (,*conv-args) f)))
- (-> (path . body)
+ ^(set f (sys:conv (,*conv-args) f))))
+ ,*body)))
+
+(defmacro sys:awk-mac-let-outer (aws-sym . body)
+ ^(macrolet ((-> (path . body)
^(sys:awk-redir ,',aws-sym *stdout* :outf "w" ,path ,body))
- (->> (path . body)
- ^(sys:awk-redir ,',aws-sym *stdout* :apf "a" ,path ,body))
- (<- (path . body)
+ (->> (path . body)
+ ^(sys:awk-redir ,',aws-sym *stdout* :apf "a" ,path ,body))
+ (<- (path . body)
^(sys:awk-redir ,',aws-sym *stdin* :inf "r" ,path ,body))
- (!> (path . body)
+ (!> (path . body)
^(sys:awk-redir ,',aws-sym *stdout* :outp "w" ,path ,body))
- (<! (path . body)
+ (<! (path . body)
^(sys:awk-redir ,',aws-sym *stdin* :inp "r" ,path ,body)))
- ,*body)))
+ ,*body))
(defmacro sys:awk-fun-let (aws-sym . body)
^(flet ((prn (. args)
(qref ,aws-sym (prn . args))))
,*body))
+(defmacro sys:awk-symac-let (awc . body)
+ ^(symacrolet ,(append-each ((fn awc.field-name-conv)
+ (ix 0))
+ (if (neq (car fn) '-)
+ (list ^(,(car fn) [f ,ix]))))
+ ,*body))
+
+(defun sys:awk-field-name-code (awc aws-sym)
+ (with-gensyms (fiter)
+ (let* ((nf 0)
+ (code (append-each ((fnc awc.field-name-conv)
+ (i 0))
+ (set nf (succ i))
+ (if (cadr fnc)
+ ^((rplaca ,fiter
+ (sys:conv-expand-sym ,(cadr fnc)
+ (car ,fiter)))
+ (set ,fiter (cdr ,fiter)))
+ ^((set ,fiter (cdr ,fiter)))))))
+ (while-match @(end ((set . @nil))) code
+ (upd code butlast))
+ ^(let ((,fiter (qref ,aws-sym fields)))
+ (if (< (len ,fiter) ,nf)
+ (set ,fiter (take ,nf (append ,fiter (repeat '(""))))
+ (qref ,aws-sym fields) ,fiter
+ (qref ,aws-sym nf) ,nf))
+ ,*code
+ (qref ,aws-sym (f-to-rec))))))
+
(defun sys:awk-fun-shadowing-env (up-env)
(make-env nil '((prn . sys:special)) up-env))
(defmacro awk (:env outer-env . clauses)
(let ((awc (sys:awk-expander outer-env clauses)))
(with-gensyms (aws-sym awk-begf-fun awk-fun awk-endf-fun awk-retval)
- (let* ((p-actions-xform-unex (mapcar (aret ^(when (sys:awk-test ,@1 rec)
- ,*@rest))
+ (let* ((p-actions-xform-unex (mapcar (aret
+ ^(whenlet ((res (sys:awk-test ,@1
+ rec)))
+ ,*@rest))
awc.cond-actions))
(p-actions-xform (expand
^(sys:awk-mac-let ,awc ,aws-sym
,*p-actions-xform-unex)
(sys:awk-fun-shadowing-env outer-env))))
+ (if awc.rng-exprs
+ (set p-actions-xform
+ ^(let* ((,awc.rng-rec-temp rec)
+ (,awc.rng-vec-temp (qref ,aws-sym rng-vec))
+ ,*(nreverse
+ (zip awc.rng-expr-temps
+ awc.rng-exprs)))
+ ,p-actions-xform)))
+ (if (and awc.field-name-conv
+ [some awc.field-name-conv cdr])
+ (set p-actions-xform
+ ^(progn
+ ,(sys:awk-field-name-code awc aws-sym)
+ ,p-actions-xform)))
^(block ,(or awc.name 'awk)
- (let* (,*awc.lets ,awk-retval
- (,aws-sym (new sys:awk-state
- ,*(if awc.inputs ^(inputs (list ,*awc.inputs)))
- ,*(if awc.output ^(output ,awc.output))
- rng-n (macro-time (qref ,awc nranges)))))
- (sys:awk-mac-let ,awc ,aws-sym
- (sys:awk-fun-let ,aws-sym
- (let* (,*(if awc.output
- ^((*stdout* (qref ,aws-sym output))))
- ,*(if (and awc.cond-actions awc.begin-file-actions)
- ^((,awk-begf-fun (lambda (,aws-sym)
- ,*awc.begin-file-actions))))
- ,*(if (and awc.cond-actions awc.end-file-actions)
- ^((,awk-endf-fun (lambda (,aws-sym)
- ,*awc.end-file-actions))))
- ,*(if (or awc.cond-actions awc.begin-file-actions
- awc.end-file-actions awc.end-actions)
- ^((,awk-fun (lambda (,aws-sym)
- ,(if awc.rng-exprs
- ^(let* ((,awc.rng-rec-temp rec)
- (,awc.rng-vec-temp (qref ,aws-sym rng-vec))
- ,*(nreverse
- (zip awc.rng-expr-temps
- awc.rng-exprs)))
- ,p-actions-xform)
- p-actions-xform))))))
- ,*awc.begin-actions
- (unwind-protect
- ,(if (or awc.cond-actions awc.begin-file-actions
- awc.end-file-actions awc.end-actions)
- ^(qref ,aws-sym (loop ,awk-fun
- ,(if awc.begin-file-actions
- awk-begf-fun)
- ,(if awc.end-file-actions
- awk-endf-fun))))
- (set ,awk-retval (progn ,*awc.end-actions))
- (call-finalizers ,aws-sym))
- ,awk-retval)))))))))
+ (let (,awk-retval
+ (,aws-sym (new sys:awk-state
+ ,*(if awc.inputs ^(inputs (list ,*awc.inputs)))
+ ,*(if awc.output ^(output ,awc.output))
+ rng-n (macro-time (qref ,awc nranges)))))
+ (sys:awk-mac-let-outer ,aws-sym
+ (let* ,awc.lets
+ (sys:awk-mac-let ,awc ,aws-sym
+ (sys:awk-fun-let ,aws-sym
+ (sys:awk-symac-let ,awc
+ (labels ,awc.funs
+ (let* (,*(if awc.output
+ ^((*stdout* (qref ,aws-sym output))))
+ ,*(if (and awc.cond-actions awc.begin-file-actions)
+ ^((,awk-begf-fun (lambda (,aws-sym)
+ ,*awc.begin-file-actions))))
+ ,*(if (and awc.cond-actions awc.end-file-actions)
+ ^((,awk-endf-fun (lambda (,aws-sym)
+ ,*awc.end-file-actions))))
+ ,*(if (or awc.cond-actions awc.begin-file-actions
+ awc.end-file-actions awc.end-actions)
+ ^((,awk-fun (lambda (,aws-sym)
+ ,p-actions-xform)))))
+ ,*awc.begin-actions
+ (unwind-protect
+ ,(if (or awc.cond-actions awc.begin-file-actions
+ awc.end-file-actions awc.end-actions)
+ ^(qref ,aws-sym (loop ,awk-fun
+ ,(if awc.begin-file-actions
+ awk-begf-fun)
+ ,(if awc.end-file-actions
+ awk-endf-fun))))
+ (set ,awk-retval (progn ,*awc.end-actions))
+ (call-finalizers ,aws-sym))
+ ,awk-retval)))))))))))))
diff --git a/share/txr/stdlib/build.tl b/stdlib/build.tl
index 527460be..35f71a7c 100644
--- a/share/txr/stdlib/build.tl
+++ b/stdlib/build.tl
@@ -1,4 +1,4 @@
-;; Copyright 2016-2020
+;; Copyright 2016-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,30 +6,66 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defun sys:list-builder-flets (lb-form)
+ (nconc
+ (collect-each ((op '(add add* pend pend* ncon ncon* oust)))
+ ^(,op (. args)
+ (qref ,lb-form (,op . args))
+ nil))
+ ^((get ()
+ (qref ,lb-form (get)))
+ (del* ()
+ (qref ,lb-form (del*)))
+ (do-del ()
+ (qref ,lb-form (del))))))
+
+(defun sys:build-expander (forms return-get)
+ (with-gensyms (name)
+ ^(let ((,name (new list-builder)))
+ (flet ,(sys:list-builder-flets name)
+ (macrolet ((del (:form f : (expr nil expr-p))
+ (if expr-p f '(do-del))))
+ ,*forms
+ ,*(if return-get ^((qref ,name (get)))))))))
+
+(defmacro build (. forms)
+ (sys:build-expander forms t))
+
+(defmacro buildn (. forms)
+ (sys:build-expander forms nil))
(defstruct list-builder ()
head tail
- (:postinit (bc)
- (set bc.head (cons nil bc.head)
- bc.tail bc.head))
+ (:postinit (self)
+ (set self.head (cons nil self.head)
+ self.tail self.head))
+
+ (:method oust (self . lists)
+ (if lists
+ (let ((nl [apply append lists]))
+ (set self.tail (usr:rplacd self.head nl)))
+ (set self.tail (usr:rplacd self.head nil)))
+ self)
(:method add (self . items)
(let ((st self.tail))
@@ -37,12 +73,12 @@
(let ((tl (last st)))
(usr:rplacd tl (append (cdr tl) items))
(set self.tail tl)))
- nil)
+ self)
(:method add* (self . items)
(let ((h self.head))
(usr:rplacd h (append items (cdr h))))
- nil)
+ self)
(:method pend (self . lists)
(when lists
@@ -53,14 +89,14 @@
(nl [apply append lists]))
(usr:rplacd tl (append (cdr tl) (if cp (copy-list nl) nl)))
(set self.tail tl)))
- nil))
+ self))
(:method pend* (self . lists)
(let* ((h self.head)
(pf [apply append (append lists (list (cdr h)))]))
(usr:rplacd h pf)
(set self.tail h))
- nil)
+ self)
(:method ncon (self . lists)
(when lists
@@ -68,7 +104,7 @@
(nl [apply nconc lists]))
(usr:rplacd tl (nconc (cdr tl) nl))
(set self.tail tl))
- nil))
+ self))
(:method ncon* (self . lists)
(let* ((h self.head)
@@ -76,7 +112,7 @@
(usr:rplacd h pf)
(if (eq self.tail h)
(set self.tail pf)))
- nil)
+ self)
(:method get (self)
(cdr self.head))
@@ -109,32 +145,5 @@
(usr:rplacd hd nil)
(set self.tail hd))))))
-(defun sys:list-builder-flets (lb-form)
- (nconc
- (collect-each ((op '(add add* pend pend* ncon ncon*)))
- ^(,op (. args)
- (qref ,lb-form (,op . args))))
- ^((get ()
- (qref ,lb-form (get)))
- (del* ()
- (qref ,lb-form (del*)))
- (do-del ()
- (qref ,lb-form (del))))))
-
(defun build-list (: init)
(new list-builder head init))
-
-(defun sys:build-expander (forms return-get)
- (with-gensyms (name)
- ^(let ((,name (new list-builder)))
- (flet ,(sys:list-builder-flets name)
- (macrolet ((del (:form f : (expr nil expr-p))
- (if expr-p f '(do-del))))
- ,*forms
- ,*(if return-get ^((qref ,name (get)))))))))
-
-(defmacro build (. forms)
- (sys:build-expander forms t))
-
-(defmacro buildn (. forms)
- (sys:build-expander forms nil))
diff --git a/share/txr/stdlib/cadr.tl b/stdlib/cadr.tl
index 4c334562..43286535 100644
--- a/share/txr/stdlib/cadr.tl
+++ b/stdlib/cadr.tl
@@ -1,6 +1,6 @@
;; This file is generated by gencadr.txr
-;; Copyright 2015-2020
+;; Copyright 2015-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -8,23 +8,24 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(defplace (caar cell) body
(getter setter
diff --git a/stdlib/comp-opts.tl b/stdlib/comp-opts.tl
new file mode 100644
index 00000000..9d4dd050
--- /dev/null
+++ b/stdlib/comp-opts.tl
@@ -0,0 +1,51 @@
+;; Copyright 2017-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defstruct usr:compile-opts ()
+ usr:shadow-fun
+ usr:shadow-var
+ usr:shadow-cross
+ usr:unused
+ usr:constant-throws
+ usr:log-level)
+
+(defsymacro %warning-syms% '(shadow-fun shadow-var shadow-cross
+ unused log-level constant-throws))
+
+(defvar usr:*compile-opts* (new compile-opts unused t constant-throws t))
+
+(defmacro when-opt (compile-opt . forms)
+ (with-gensyms (optval)
+ ^(whenlet ((,optval usr:*compile-opts*.,compile-opt))
+ (macrolet ((diag (. args)
+ ^(opt-controlled-diag ,',optval ,*args)))
+ ,*forms))))
+
+(defun opt-controlled-diag (optval . args)
+ (caseq optval
+ (:error (compile-error . args))
+ ((t :warn) (compile-warning . args))))
diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl
new file mode 100644
index 00000000..3585971a
--- /dev/null
+++ b/stdlib/compiler.tl
@@ -0,0 +1,2735 @@
+;; Copyright 2018-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(load "vm-param")
+(load "optimize")
+(load-for (usr:var %const-foldable% "constfun"))
+
+(compile-only
+ (load-for
+ (struct sys:param-parser-base "param")
+ (macro when-opt "comp-opts")))
+
+(defstruct (frag oreg code : fvars ffuns pars) nil
+ oreg
+ code
+ pars
+ fvars
+ ffuns
+ vbin
+ alt-oreg)
+
+(defstruct binding nil
+ sym
+ loc
+ used
+ sys:env)
+
+(defstruct vbinding binding)
+
+(defstruct fbinding binding
+ pars)
+
+(defstruct blockinfo nil
+ sym
+ used
+ sys:env)
+
+(defstruct sys:env nil
+ vb
+ fb
+ bb
+ up
+ co
+ lev
+ (v-cntr 0)
+
+ (:postinit (me)
+ (unless me.lev
+ (set me.lev (succ (or me.up.?lev 0))))
+ (unless (or me.co (null me.up))
+ (set me.co me.up.co))
+ me.co.(new-env me))
+
+ (:method lookup-var (me sym : mark-used)
+ (condlet
+ (((cell (assoc sym me.vb)))
+ (let ((bi (cdr cell)))
+ (if mark-used (set bi.used t))
+ bi))
+ (((up me.up)) up.(lookup-var sym mark-used))
+ (t nil)))
+
+ (:method lookup-fun (me sym : mark-used)
+ (condlet
+ (((cell (assoc sym me.fb)))
+ (let ((bi (cdr cell)))
+ (if mark-used (set bi.used t))
+ bi))
+ (((up me.up)) up.(lookup-fun sym mark-used))
+ (t nil)))
+
+ (:method lookup-lisp1 (me sym : mark-used)
+ (condlet
+ (((cell (or (assoc sym me.vb)
+ (assoc sym me.fb))))
+ (let ((bi (cdr cell)))
+ (if mark-used (set bi.used t))
+ bi))
+ (((up me.up)) up.(lookup-lisp1 sym mark-used))
+ (t nil)))
+
+ (:method lookup-block (me sym : mark-used)
+ (condlet
+ (((cell (assoc sym me.bb)))
+ (let ((bi (cdr cell)))
+ (if mark-used (set bi.used t))
+ bi))
+ (((up me.up)) up.(lookup-block sym mark-used))
+ (t nil)))
+
+ (:method get-loc (me)
+ (when (>= me.v-cntr %lev-size%)
+ (compile-error me.last-form
+ "code too complex: too many lexicals in one frame"))
+ ^(v ,(ppred me.lev) ,(pinc me.v-cntr)))
+
+ (:method extend-var (me sym : (loc me.(get-loc)))
+ (when (assoc sym me.vb)
+ (compile-error me.co.last-form "duplicate variable: ~s" sym))
+ me.(extend-var* sym loc))
+
+ (:method extend-var* (me sym : (loc me.(get-loc)))
+ (when-opt shadow-var
+ (cond
+ ((and me.up me.(lookup-var sym))
+ (diag me.co.last-form "variable ~s shadows local variable" sym))
+ ((boundp sym)
+ (diag me.co.last-form "variable ~s shadows global variable" sym))))
+ (when-opt shadow-cross
+ (cond
+ ((and me.up me.(lookup-fun sym))
+ (diag me.co.last-form "variable ~s shadows local function" sym))
+ ((fboundp sym)
+ (diag me.co.last-form "variable ~s shadows global function" sym))))
+ (let ((bn (new vbinding sym sym loc loc env me)))
+ (set me.vb (acons sym bn me.vb))
+ bn))
+
+ (:method extend-fun (me sym)
+ (when (assoc sym me.fb)
+ (compile-error me.co.last-form "duplicate function ~s" sym))
+ (when-opt shadow-fun
+ (cond
+ ((and me.up me.(lookup-fun sym))
+ (diag me.co.last-form "function ~s shadows local function" sym))
+ ((fboundp sym)
+ (diag me.co.last-form "function ~s shadows global function" sym))
+ ((mboundp sym)
+ (diag me.co.last-form "function ~s shadows global macro" sym))))
+ (when-opt shadow-cross
+ (cond
+ ((and me.up me.(lookup-var sym))
+ (diag me.co.last-form "function ~s shadows local variable" sym))
+ ((boundp sym)
+ (diag me.co.last-form "function ~s shadows global variable" sym))))
+ (let* ((loc ^(v ,(ppred me.lev) ,(pinc me.v-cntr)))
+ (bn (new fbinding sym sym loc loc env me)))
+ (set me.fb (acons sym bn me.fb))))
+
+ (:method out-of-scope (me reg)
+ (if (eq (car reg) 'v)
+ (let ((lev (ssucc (cadr reg))))
+ (< me.lev lev))))
+
+ (:method extend-block (me sym)
+ (let* ((bn (new blockinfo sym sym env me)))
+ (set me.bb (acons sym bn me.bb))))
+
+ (:method unused-check (me form nuance)
+ (when-opt unused
+ (each-match ((@sym . @bn) me.vb)
+ (if (and (symbol-package sym) (not bn.used))
+ (diag form "~a ~s unused" nuance sym))))))
+
+(defstruct closure-spy ()
+ env
+ cap-vars
+
+ (:method captured (me vbin sym)
+ (when (eq vbin.env me.env)
+ (pushnew sym me.cap-vars))))
+
+(defstruct access-spy ()
+ closure-spies
+
+ (:method accessed (me vbin sym)
+ (each ((spy me.closure-spies))
+ (when (neq spy me)
+ spy.(captured vbin sym))))
+
+ (:method assigned (me vbin sym)
+ (each ((spy me.closure-spies))
+ (when (neq spy me)
+ spy.(captured vbin sym)))))
+
+(defstruct simplify-var-spy ()
+ mutated-vars
+ (:method accessed (me vbin sym)
+ (ignore me vbin sym))
+
+ (:method assigned (me vbin sym)
+ (ignore sym)
+ (pushnew vbin me.mutated-vars)))
+
+(compile-only
+ (defstruct compiler nil
+ (treg-cntr 2)
+ (dreg-cntr 0)
+ (sidx-cntr 0)
+ (nlev 2)
+ (loop-nest 0)
+ (tregs nil)
+ (dreg (hash :eql-based))
+ (data (hash :eql-based))
+ (sidx (hash :eql-based))
+ (stab (hash :eql-based))
+ datavec
+ symvec
+ lt-frags
+ last-form
+ top-form
+ closure-spies
+ access-spies
+
+ (:method snapshot (me)
+ (let ((snap (copy me)))
+ (set snap.dreg (copy me.dreg)
+ snap.data (copy me.data)
+ snap.sidx (copy me.sidx)
+ snap.stab (copy me.stab))
+ snap))
+
+ (:method restore (me snap)
+ (replace-struct me snap))))
+
+(defstruct eval-cache-entry ()
+ orig-form
+ reduced-form
+ throws)
+
+(eval-only
+ (defmacro compile-in-toplevel (me . body)
+ (with-gensyms (saved-tregs saved-treg-cntr)
+ ^(let* ((,saved-tregs (qref ,me tregs))
+ (,saved-treg-cntr (qref ,me treg-cntr)))
+ (unwind-protect
+ (progn
+ (set (qref ,me tregs) nil
+ (qref ,me treg-cntr) 2)
+ (prog1
+ (progn ,*body)
+ (qref ,me (check-treg-leak))))
+ (set (qref ,me tregs) ,saved-tregs
+ (qref ,me treg-cntr) ,saved-treg-cntr)))))
+
+ (defmacro compile-with-fresh-tregs (me . body)
+ (with-gensyms (saved-tregs saved-treg-cntr)
+ ^(let* ((,saved-tregs (qref ,me tregs))
+ (,saved-treg-cntr (qref ,me treg-cntr)))
+ (unwind-protect
+ (progn
+ (set (qref ,me tregs) nil
+ (qref ,me treg-cntr) 2)
+ (prog1
+ (progn ,*body)
+ (qref ,me (check-treg-leak))))
+ (set (qref ,me tregs) ,saved-tregs
+ (qref ,me treg-cntr) ,saved-treg-cntr)))))
+
+ (defun with-spy (me flag spy spy-expr body push-meth pop-meth)
+ ^(let ((,spy (if ,flag ,spy-expr)))
+ (unwind-protect
+ (progn
+ (if ,spy (qref ,me (,push-meth ,spy)))
+ ,*body)
+ (if ,spy (qref ,me (,pop-meth ,spy))))))
+
+ (defmacro with-closure-spy (me flag spy spy-expr . body)
+ (with-spy me flag spy spy-expr body 'push-closure-spy 'pop-closure-spy))
+
+ (defmacro with-access-spy (me flag spy spy-expr . body)
+ (with-spy me flag spy spy-expr body 'push-access-spy 'pop-access-spy)))
+
+(defvarl %gcall-op% (relate '(apply usr:apply call) '(gapply gapply gcall)))
+
+(defvarl %call-op% (relate '(apply usr:apply call) '(apply apply call)))
+
+(defvarl %test-funs-pos% '(eq eql))
+
+(defvarl %test-funs-neg% '(neq neql))
+
+(defvarl %test-funs-ops% '(ifq ifql))
+
+(defvarl %test-funs% (append %test-funs-pos% %test-funs-neg%))
+
+(defvarl %test-inv% (relate %test-funs-neg% %test-funs-pos%))
+
+(defvarl %test-opcode% (relate %test-funs-pos% %test-funs-ops%))
+
+(defvarl %block-using-funs% '(sys:capture-cont return* sys:abscond* match-fun
+ eval load compile compile-file compile-toplevel))
+
+(defvarl %nary-ops% '(< > <= => = + - * /))
+
+(defvarl %bin-ops% '(b< b> b<= b=> b= b+ b- b* b/))
+
+(defvarl %bin-op% (relate %nary-ops% %bin-ops% nil))
+
+(defvarl assumed-fun)
+
+(defvar *in-compilation-unit* nil)
+
+(defvar *dedup*)
+
+(defvar *unchecked-calls*)
+
+(defvarl %param-info% (hash :eq-based :weak-keys))
+
+(defvarl %eval-cache% (hash :eql-based :weak-keys :weak-vals))
+
+(defvar *load-time*)
+
+(defvar *top-level*)
+
+;; 0 - no optimization
+;; 1 - constant folding, algebraics.
+;; 2 - block elimination, frame elimination
+;; 3 - lambda/combinator lifting
+;; 4 - control-flow: jump-threading, dead code
+;; 5 - data-flow: dead registers, useless regisers
+;; 6 - iterate on 4-5 optimizations.
+;; 7 - more expensive size or speed optimizations
+(defvar usr:*opt-level* 7)
+
+(defun dedup (obj)
+ (cond
+ ((null obj) nil)
+ ((null *dedup*) obj)
+ ((or (stringp obj) (bignump obj))
+ (or [*dedup* obj] (set [*dedup* obj] obj)))
+ (t obj)))
+
+(defun null-reg (reg)
+ (equal reg '(t 0)))
+
+(defun maybe-mov (to-reg from-reg)
+ (if (nequal to-reg from-reg)
+ ^((mov ,to-reg ,from-reg))))
+
+(defmeth compiler get-dreg (me obj)
+ (let ((dobj (dedup obj)))
+ (condlet
+ ((((null dobj))) '(t 0))
+ (((dreg [me.dreg dobj])) dreg)
+ (t
+ (let ((dreg ^(d ,(pinc me.dreg-cntr))))
+ (set me.datavec nil
+ [me.data (cadr dreg)] dobj
+ [me.dreg dobj] dreg))))))
+
+(defmeth compiler alloc-dreg (me)
+ (if (< me.dreg-cntr %lev-size%)
+ (let ((dreg ^(d ,(pinc me.dreg-cntr))))
+ (set [me.data (cadr dreg)] nil)
+ dreg)
+ (compile-error me.last-form "code too complex: too many literals")))
+
+(defmeth compiler null-dregs (me used-dreg)
+ (each ((n 0..me.dreg-cntr))
+ (unless (bit used-dreg n)
+ (set [me.data n] nil
+ me.datavec nil))))
+
+(defmeth compiler get-sidx (me atom)
+ (iflet ((sidx [me.sidx atom]))
+ sidx
+ (let* ((sidx (pinc me.sidx-cntr)))
+ (set [me.stab sidx] atom)
+ (set [me.sidx atom] sidx))))
+
+(defmeth compiler get-datavec (me)
+ (or me.datavec
+ (set me.datavec (vec-list [mapcar me.data (range* 0 me.dreg-cntr)]))))
+
+(defmeth compiler get-symvec (me)
+ (or me.symvec
+ (set me.symvec (vec-list [mapcar me.stab (range* 0 me.sidx-cntr)]))))
+
+(defmeth compiler alloc-treg (me)
+ (cond
+ (me.tregs (pop me.tregs))
+ ((< me.treg-cntr %lev-size%) ^(t ,(pinc me.treg-cntr)))
+ (t (compile-error me.last-form "code too complex: out of registers"))))
+
+(defmeth compiler alloc-new-treg (me)
+ (cond
+ ((< me.treg-cntr %lev-size%) ^(t ,(pinc me.treg-cntr)))
+ (t (compile-error me.last-form "code too complex: out of registers"))))
+
+(defmeth compiler free-treg (me treg)
+ (when (and (eq t (car treg)) (neq 0 (cadr treg)))
+ (push treg me.tregs)))
+
+(defmeth compiler free-tregs (me tregs)
+ (mapdo (meth me free-treg) tregs))
+
+(defmeth compiler unalloc-reg-count (me)
+ (- %lev-size% me.treg-cntr))
+
+(defmeth compiler maybe-alloc-treg (me given)
+ (if (eq t (car given))
+ given
+ me.(alloc-treg)))
+
+(defmeth compiler maybe-free-treg (me treg given)
+ (when (nequal treg given)
+ me.(free-treg treg)))
+
+(defmeth compiler check-treg-leak (me)
+ (let ((balance (- (ppred me.treg-cntr) (len me.tregs))))
+ (unless (zerop balance)
+ (error "t-register leak in compiler: ~s outstanding" balance))))
+
+(defmeth compiler new-env (me env)
+ (when (>= env.lev me.nlev)
+ (unless (<= env.lev %max-lev%)
+ (compile-error me.last-form
+ "code too complex: lexical nesting too deep"))
+ (set me.nlev (succ env.lev))))
+
+(defmeth compiler push-closure-spy (me spy)
+ (push spy me.closure-spies))
+
+(defmeth compiler pop-closure-spy (me spy)
+ (let ((top (pop me.closure-spies)))
+ (unless top
+ (error "closure spy stack bug in compiler"))
+ (unless (eq top spy)
+ (error "closure spy stack balance problem in compiler"))))
+
+(defmeth compiler push-access-spy (me spy)
+ (push spy me.access-spies))
+
+(defmeth compiler pop-access-spy (me spy)
+ (let ((top (pop me.access-spies)))
+ (unless top
+ (error "access spy stack bug in compiler"))
+ (unless (eq top spy)
+ (error "access spy stack balance problem in compiler"))))
+
+(defmeth compiler compile (me oreg env form)
+ (unless (atom form)
+ (set me.last-form form))
+ (cond
+ ((symbolp form)
+ (if (bindable form)
+ me.(comp-var oreg env form)
+ me.(comp-atom oreg form)))
+ ((atom form) me.(comp-atom oreg form))
+ (t (let ((sym (car form)))
+ (cond
+ ((bindable sym)
+ (caseq sym
+ (quote me.(comp-atom oreg (cadr form)))
+ (sys:setq me.(comp-setq oreg env form))
+ (sys:lisp1-setq me.(comp-lisp1-setq oreg env form))
+ (sys:setqf me.(comp-setqf oreg env form))
+ (cond me.(comp-cond oreg env form))
+ (if me.(comp-if oreg env form))
+ (switch me.(comp-switch oreg env form))
+ (unwind-protect me.(comp-unwind-protect oreg env form))
+ ((block block* sys:blk) me.(comp-block oreg env form))
+ ((return-from sys:abscond-from) me.(comp-return-from oreg env form))
+ (return me.(comp-return oreg env form))
+ (handler-bind me.(comp-handler-bind oreg env form))
+ (sys:catch me.(comp-catch oreg env form))
+ ((let let*) me.(comp-let oreg env form))
+ ((sys:fbind sys:lbind) me.(comp-fbind oreg env form))
+ (lambda me.(comp-lambda oreg env form))
+ (fun me.(comp-fun oreg env form))
+ (sys:for-op me.(comp-for oreg env form))
+ (sys:each-op me.(compile oreg env (expand-each form env)))
+ ((progn eval-only compile-only) me.(comp-progn oreg env (cdr form)))
+ (and me.(compile oreg env (expand-and form)))
+ (or me.(comp-or oreg env form))
+ (prog1 me.(comp-prog1 oreg env form))
+ (progv me.(comp-progv oreg env form))
+ (sys:quasi me.(comp-quasi oreg env form))
+ (dohash me.(compile oreg env (expand-dohash form)))
+ (tree-bind me.(comp-tree-bind oreg env form))
+ (mac-param-bind me.(comp-mac-param-bind oreg env form))
+ (mac-env-param-bind me.(comp-mac-env-param-bind oreg env form))
+ (tree-case me.(comp-tree-case oreg env form))
+ (sys:lisp1-value me.(comp-lisp1-value oreg env form))
+ (dwim me.(comp-dwim oreg env form))
+ (prof me.(comp-prof oreg env form))
+ (defvarl me.(compile oreg env (expand-defvarl form)))
+ (defun me.(compile oreg env (expand-defun form)))
+ (defmacro me.(compile oreg env (expand-defmacro form)))
+ (defsymacro me.(compile oreg env (expand-defsymacro form)))
+ (sys:upenv me.(compile oreg env.up (cadr form)))
+ (sys:dvbind me.(compile oreg env (caddr form)))
+ (sys:load-time-lit me.(comp-load-time-lit oreg env form))
+ ;; compiler-only special operators:
+ (ift me.(comp-ift oreg env form))
+ ;; specially treated functions
+ ((call apply usr:apply) me.(comp-apply-call oreg env form))
+ ;; error cases
+ ((macrolet symacrolet macro-time)
+ (compile-error form "unexpanded ~s encountered" sym))
+ ((sys:var sys:expr)
+ (compile-error form "meta with no meaning: ~s " form))
+ ((usr:qquote usr:unquote usr:splice
+ sys:qquote sys:unquote sys:splice)
+ (compile-error form "unexpanded quasiquote encountered"))
+ ;; function call
+ ((+ *) me.(comp-arith-form oreg env form))
+ ((- /) me.(comp-arith-neg-form oreg env form))
+ (typep me.(comp-typep oreg env form))
+ (compiler-let me.(comp-compiler-let oreg env form))
+ (t me.(comp-fun-form oreg env form))))
+ ((and (consp sym)
+ (eq (car sym) 'lambda)) me.(compile oreg env ^(call ,*form)))
+ (t (compile-error form "invalid operator")))))))
+
+(defmeth compiler comp-atom (me oreg form)
+ (ignore oreg)
+ (cond
+ ((null form) (new (frag '(t 0) nil)))
+ (t (let ((dreg me.(get-dreg form)))
+ (new (frag dreg nil))))))
+
+(defmeth compiler comp-var (me oreg env sym)
+ (let ((vbin env.(lookup-var sym t)))
+ (cond
+ (vbin
+ (each ((spy me.access-spies))
+ spy.(accessed vbin sym))
+ (new (frag vbin.loc nil (list sym))
+ vbin vbin
+ alt-oreg oreg))
+ ((special-var-p sym)
+ (let ((dreg me.(get-dreg sym)))
+ (new (frag oreg ^((getv ,oreg ,dreg)) (list sym)))))
+ (t (new (frag oreg ^((getlx ,oreg ,me.(get-sidx sym))) (list sym)))))))
+
+(defmeth compiler comp-setq (me oreg env form)
+ (mac-param-bind form (t sym value) form
+ (let* ((bind env.(lookup-var sym))
+ (spec (special-var-p sym))
+ (vloc (cond
+ (bind bind.loc)
+ (spec me.(get-dreg sym))
+ (t me.(get-sidx sym))))
+ (vfrag me.(compile (if bind vloc oreg) env value)))
+ (when bind
+ (set vfrag.vbin bind
+ vfrag.alt-oreg oreg)
+ (each ((spy me.access-spies))
+ spy.(assigned bind sym)))
+ (new (frag vfrag.oreg
+ ^(,*vfrag.code
+ ,*(if bind
+ (maybe-mov vloc vfrag.oreg)
+ (if spec
+ ^((setv ,vfrag.oreg ,vloc))
+ ^((setlx ,vfrag.oreg ,me.(get-sidx sym))))))
+ (uni (list sym) vfrag.fvars)
+ vfrag.ffuns)))))
+
+(defmeth compiler comp-lisp1-setq (me oreg env form)
+ (mac-param-bind form (t sym val) form
+ (let ((bind env.(lookup-lisp1 sym)))
+ (cond
+ ((typep bind 'fbinding)
+ (compile-error form "assignment to lexical function binding"))
+ ((null bind)
+ (let ((vfrag me.(compile oreg env val))
+ (l1loc me.(get-dreg sym)))
+ (new (frag vfrag.oreg
+ ^(,*vfrag.code
+ (setl1 ,vfrag.oreg ,l1loc))
+ (uni (list sym) vfrag.fvars)
+ vfrag.ffuns))))
+ (t (each ((spy me.access-spies))
+ spy.(assigned bind sym))
+ me.(compile oreg env ^(sys:setq ,sym ,val)))))))
+
+(defmeth compiler comp-setqf (me oreg env form)
+ (mac-param-bind form (t sym val) form
+ (if env.(lookup-fun sym)
+ (compile-error form "assignment to lexical function binding")
+ (let ((vfrag me.(compile oreg env val))
+ (fname me.(get-dreg sym))
+ (rplcd me.(get-sidx 'usr:rplacd))
+ (treg me.(alloc-treg)))
+ me.(free-treg treg)
+ (new (frag vfrag.oreg
+ ^(,*vfrag.code
+ (getfb ,treg ,fname)
+ (gcall ,treg ,rplcd ,treg ,vfrag.oreg))
+ vfrag.fvars
+ (uni (list sym) vfrag.ffuns)))))))
+
+(defmeth compiler comp-cond (me oreg env form)
+ (tree-case form
+ ((t) me.(comp-atom oreg nil))
+ ((t (test) . more) me.(compile oreg env ^(or ,test (cond ,*more))))
+ ((t (test . forms) . more) me.(compile oreg env
+ ^(if ,test
+ (progn ,*forms)
+ (cond ,*more))))
+ ((t t . t)
+ (compile-error form "atom in cond syntax; pair expected"))
+ ((t . t)
+ (compile-error form "trailing atom in cond syntax"))))
+
+(defmeth compiler comp-if (me oreg env form)
+ (match-case (cdr form)
+ (@(require ((@(and @(or equal nequal) @op) @a @b) . @rest)
+ (or (eql-comparable a)
+ (eql-comparable b)))
+ (let* ((pos (eq op 'equal))
+ (cf (if (or (eq-comparable a)
+ (eq-comparable b))
+ (if pos 'eq 'neq)
+ (if pos'eql 'neql))))
+ me.(compile oreg env ^(if (,cf ,a ,b) ,*rest))))
+ (((not (@(and @(or eq eql equal) @op) . @eargs)) . @args)
+ (let ((nop (caseq op (eq 'neq) (eql 'neql) (equal 'nequal))))
+ me.(comp-if oreg env ^(if (,nop ,*eargs) ,*args))))
+ ((@(safe-constantp @test) @then @else)
+ me.(compile oreg env (if (safe-const-eval test) then else)))
+ ((@(safe-constantp @test) @then)
+ me.(compile oreg env (if (safe-const-eval test) then)))
+ ((@(safe-constantp))
+ me.(compile oreg env nil))
+ (((@(member @op %test-funs%) @a @b) . @rest)
+ me.(compile oreg env ^(ift ,op ,a ,b ,*rest)))
+ ((@test @then @else)
+ (let* ((te-oreg me.(maybe-alloc-treg oreg))
+ (lelse (gensym "l"))
+ (lskip (gensym "l"))
+ (te-frag me.(compile te-oreg env test))
+ (th-frag me.(compile oreg env then))
+ (el-frag me.(compile oreg env else)))
+ me.(maybe-free-treg te-oreg oreg)
+ (new (frag oreg
+ ^(,*te-frag.code
+ (if ,te-frag.oreg ,lelse)
+ ,*th-frag.code
+ ,*(maybe-mov oreg th-frag.oreg)
+ (jmp ,lskip)
+ ,lelse
+ ,*el-frag.code
+ ,*(maybe-mov oreg el-frag.oreg)
+ ,lskip)
+ (uni te-frag.fvars (uni th-frag.fvars el-frag.fvars))
+ (uni te-frag.ffuns (uni th-frag.ffuns el-frag.ffuns))))))
+ ((@test @then)
+ (let* ((lskip (gensym "l"))
+ (te-oreg me.(maybe-alloc-treg oreg))
+ (te-frag me.(compile te-oreg env test))
+ (th-frag me.(compile oreg env then)))
+ me.(maybe-free-treg te-oreg oreg)
+ (new (frag oreg
+ ^(,*te-frag.code
+ ,*(maybe-mov oreg te-frag.oreg)
+ (if ,te-frag.oreg ,lskip)
+ ,*th-frag.code
+ ,*(maybe-mov oreg th-frag.oreg)
+ ,lskip)
+ (uni te-frag.fvars th-frag.fvars)
+ (uni te-frag.ffuns th-frag.ffuns)))))
+ ((@test)
+ (let ((te-frag me.(compile oreg env test)))
+ (new (frag oreg
+ ^(,*te-frag.code
+ (mov ,oreg nil))
+ te-frag.fvars
+ te-frag.ffuns))))
+ (() me.(compile oreg env nil))
+ (@nil (compile-error form "excess argument forms"))))
+
+(defmeth compiler comp-ift (me oreg env form)
+ (mac-param-bind form (t fun left right : then else) form
+ (when (member fun %test-funs-neg%)
+ (set fun [%test-inv% fun])
+ (swap then else))
+ (if (and (safe-constantp left) (safe-constantp right))
+ me.(compile oreg env (if (call fun
+ (safe-const-eval left)
+ (safe-const-eval right))
+ then else))
+ (let* ((opcode [%test-opcode% fun])
+ (le-oreg me.(alloc-treg))
+ (ri-oreg me.(alloc-treg))
+ (lelse (gensym "l"))
+ (lskip (gensym "l"))
+ (le-frag me.(compile le-oreg env left))
+ (ri-frag me.(compile ri-oreg env right))
+ (th-frag me.(compile oreg env then))
+ (el-frag me.(compile oreg env else)))
+ me.(free-treg le-oreg)
+ me.(free-treg ri-oreg)
+ (new (frag oreg
+ ^(,*le-frag.code
+ ,*ri-frag.code
+ (,opcode ,le-frag.oreg ,ri-frag.oreg ,lelse)
+ ,*th-frag.code
+ ,*(maybe-mov oreg th-frag.oreg)
+ (jmp ,lskip)
+ ,lelse
+ ,*el-frag.code
+ ,*(maybe-mov oreg el-frag.oreg)
+ ,lskip)
+ (uni (uni le-frag.fvars ri-frag.fvars)
+ (uni th-frag.fvars el-frag.fvars))
+ (uni (uni le-frag.ffuns ri-frag.ffuns)
+ (uni th-frag.ffuns el-frag.ffuns))))))))
+
+(defmeth compiler comp-switch (me oreg env form)
+ (mac-param-bind form (t idx-form cases-vec) form
+ (let* ((ncases (len cases-vec))
+ (cs (and (plusp ncases) (conses [cases-vec 0])))
+ (shared (and cs
+ (let ((c cs)
+ (d (cdr (list-vec cases-vec))))
+ (whilet ((m (if d (memq (pop d) c))))
+ (set c m))
+ (null d))))
+ (cases (if shared
+ (let ((cs-nil ^(,*cs nil)))
+ (vec-list [mapcar ldiff cs-nil (cdr cs-nil)]))
+ cases-vec))
+ (lend (gensym "l"))
+ (clabels (mapcar (ret (gensym "l")) cases))
+ (treg me.(maybe-alloc-treg oreg))
+ (ifrag me.(compile treg env idx-form))
+ (seen (unless shared (hash :eql-based)))
+ last-cfrag
+ (cfrags (collect-each ((cs cases)
+ (lb clabels)
+ (i (range 1)))
+ (iflet ((seen-lb (and seen [seen cs])))
+ (progn
+ (set [clabels (pred i)] seen-lb)
+ (new (frag oreg nil)))
+ (let ((cfrag me.(comp-progn oreg env cs)))
+ (when (eq i ncases)
+ (set last-cfrag cfrag))
+ (unless shared
+ (set [seen cs] lb))
+ (new (frag oreg
+ ^(,lb
+ ,*cfrag.code
+ ,*(unless shared
+ ^(,*(maybe-mov oreg cfrag.oreg)
+ ,*(unless (= i ncases)
+ ^((jmp ,lend))))))
+ cfrag.fvars cfrag.ffuns)))))))
+ me.(maybe-free-treg treg oreg)
+ (new (frag oreg
+ ^(,*ifrag.code
+ (swtch ,ifrag.oreg ,*(list-vec clabels))
+ ,*(mappend .code cfrags)
+ ,*(when (and shared last-cfrag)
+ (maybe-mov oreg last-cfrag.oreg))
+ ,lend)
+ (uni ifrag.fvars [reduce-left uni cfrags nil .fvars])
+ (uni ifrag.ffuns [reduce-left uni cfrags nil .ffuns]))))))
+
+(defmeth compiler comp-unwind-protect (me oreg env form)
+ (mac-param-bind form (t prot-form . cleanup-body) form
+ (let* ((treg me.(alloc-treg))
+ (pfrag me.(compile oreg env prot-form))
+ (cfrag me.(comp-progn treg env cleanup-body))
+ (lclean (gensym "l")))
+ me.(free-treg treg)
+ (cond
+ ((null pfrag.code)
+ (new (frag pfrag.oreg
+ cfrag.code
+ cfrag.fvars
+ cfrag.ffuns)))
+ ((null cfrag.code) pfrag)
+ (t (new (frag pfrag.oreg
+ ^((uwprot ,lclean)
+ ,*pfrag.code
+ (end nil)
+ ,lclean
+ ,*cfrag.code
+ (end nil))
+ (uni pfrag.fvars pfrag.fvars)
+ (uni cfrag.fvars cfrag.fvars))))))))
+
+(defmeth compiler comp-block (me oreg env form)
+ (mac-param-bind form (op name . body) form
+ (let* ((star (and name (eq op 'block*)))
+ (nenv (unless star
+ (new env up env lev env.lev co me)))
+ (binfo (unless star
+ (cdar nenv.(extend-block name))))
+ (treg (if star me.(maybe-alloc-treg oreg)))
+ (nfrag (if star me.(compile treg env name)))
+ (nreg (if star nfrag.oreg me.(get-dreg name)))
+ (bfrag me.(comp-progn oreg (or nenv env) body))
+ (lskip (gensym "l")))
+ (when treg
+ me.(maybe-free-treg treg oreg))
+ (if (and (>= *opt-level* 2)
+ (not star)
+ (not binfo.used)
+ (if (eq op 'sys:blk)
+ [all bfrag.ffuns [orf system-symbol-p (op eq name)]]
+ [all bfrag.ffuns system-symbol-p])
+ [none bfrag.ffuns (op member @1 %block-using-funs%)])
+ bfrag
+ (new (frag oreg
+ ^(,*(if nfrag nfrag.code)
+ (block ,oreg ,nreg ,lskip)
+ ,*bfrag.code
+ ,*(maybe-mov oreg bfrag.oreg)
+ (end ,oreg)
+ ,lskip)
+ bfrag.fvars
+ bfrag.ffuns))))))
+
+(defmeth compiler comp-return-from (me oreg env form)
+ (mac-param-bind form (op name : value) form
+ (let* ((nreg (if (null name)
+ nil
+ me.(get-dreg name)))
+ (opcode (if (eq op 'return-from) 'ret 'abscsr))
+ (vfrag me.(compile oreg env value)))
+ env.(lookup-block name t)
+ (new (frag oreg
+ ^(,*vfrag.code
+ (,opcode ,nreg ,vfrag.oreg))
+ vfrag.fvars
+ vfrag.ffuns)))))
+
+(defmeth compiler comp-return (me oreg env form)
+ (mac-param-bind form (t : value) form
+ me.(comp-return-from oreg env ^(return-from nil ,value))))
+
+(defmeth compiler comp-handler-bind (me oreg env form)
+ (mac-param-bind form (t func-form ex-syms . body) form
+ (let* ((freg me.(maybe-alloc-treg oreg))
+ (ffrag me.(compile freg env func-form))
+ (sreg me.(get-dreg ex-syms))
+ (bfrag me.(comp-progn oreg env body)))
+ me.(maybe-free-treg freg oreg)
+ (new (frag bfrag.oreg
+ ^(,*ffrag.code
+ (handle ,ffrag.oreg ,sreg)
+ ,*bfrag.code
+ (end ,bfrag.oreg))
+ (uni ffrag.fvars bfrag.fvars)
+ (uni ffrag.ffuns bfrag.ffuns))))))
+
+(defmeth compiler comp-catch (me oreg env form)
+ (mac-param-bind form (t symbols try-expr desc-expr . clauses) form
+ (if (and (plusp *opt-level*)
+ (or (null symbols)
+ (safe-constantp try-expr)))
+ me.(compile oreg env try-expr)
+ (with-gensyms (ex-sym-var ex-args-var)
+ (let* ((nenv (new env up env co me))
+ (esvb nenv.(extend-var ex-sym-var))
+ (eavb nenv.(extend-var ex-args-var))
+ (tfrag me.(compile oreg nenv try-expr))
+ (dfrag me.(compile oreg nenv desc-expr))
+ (lhand (gensym "l"))
+ (lhend (gensym "l"))
+ (treg me.(alloc-treg))
+ (nclauses (len clauses))
+ (have-one-symbol (and (plusp *opt-level*) (eql 1 (len symbols))))
+ (one-symbol (if have-one-symbol (car symbols)))
+ (cfrags (collect-each ((cl clauses)
+ (i (range 1)))
+ (mac-param-bind form (sym params . body) cl
+ (let* ((cl-src (rlcp-tree ^(apply (lambda ,params ,*body)
+ ,ex-sym-var ,ex-args-var)
+ form))
+ (cfrag me.(compile oreg nenv (expand cl-src)))
+ (lskip (gensym "l")))
+ (new (frag oreg
+ (cond
+ ((and have-one-symbol
+ (exception-subtype-p one-symbol sym))
+ ^(,*cfrag.code
+ ,*(maybe-mov oreg cfrag.oreg)
+ ,*(unless (eql i nclauses)
+ ^((jmp ,lhend)))))
+ (have-one-symbol
+ (set cfrag.fvars nil
+ cfrag.ffuns nil)
+ nil)
+ (t ^((gcall ,treg
+ ,me.(get-sidx 'exception-subtype-p)
+ ,esvb.loc
+ ,me.(get-dreg sym))
+ (if ,treg ,lskip)
+ ,*cfrag.code
+ ,*(maybe-mov oreg cfrag.oreg)
+ ,*(unless (eql i nclauses)
+ ^((jmp ,lhend)))
+ ,lskip)))
+ cfrag.fvars
+ cfrag.ffuns)))))))
+ me.(free-treg treg)
+ (new (frag oreg
+ ^((frame ,nenv.lev ,nenv.v-cntr)
+ ,*dfrag.code
+ (catch ,esvb.loc ,eavb.loc
+ ,me.(get-dreg symbols) ,dfrag.oreg ,lhand)
+ ,*tfrag.code
+ ,*(maybe-mov oreg tfrag.oreg)
+ (jmp ,lhend)
+ ,lhand
+ ,*(mappend .code cfrags)
+ ,lhend
+ (end ,oreg)
+ (end ,oreg))
+ (uni tfrag.fvars [reduce-left uni cfrags nil .fvars])
+ (uni tfrag.ffuns [reduce-left uni cfrags nil .ffuns]))))))))
+
+(defmeth compiler eliminate-frame (me code env)
+ (if (>= me.(unalloc-reg-count) (len env.vb))
+ (let ((trhash (hash))
+ (vbhash (hash))
+ (vlev (ppred env.lev))
+ (tregs nil))
+ (each ((cell env.vb))
+ (tree-bind (t . vbind) cell
+ (let ((treg me.(alloc-new-treg)))
+ (set [trhash vbind.loc] treg)
+ (set [vbhash vbind.loc] vbind)
+ (push treg tregs))))
+ (let ((ncode (append-each ((insns (conses code)))
+ (match-case insns
+ (((frame @lev @size) . @nil)
+ ^((frame ,(pred lev) ,size)))
+ (((dframe @lev @size) . @nil)
+ ^((dframe ,(pred lev) ,size)))
+ (((@op . @args) . @nil)
+ (let ((nargs (mapcar (lambda-match
+ ((@(as arg (v @lev @idx)))
+ (or [trhash arg]
+ (if (> lev vlev)
+ ^(v ,(pred lev) ,idx)
+ arg)))
+ ((@arg) arg))
+ args)))
+ ^((,op ,*nargs))))
+ ((@else . @nil) (list else))))))
+ (dohash (loc treg trhash)
+ (let ((vb [vbhash loc]))
+ (set vb.loc treg)))
+ me.(free-tregs tregs)
+ (if (plusp me.loop-nest)
+ (append (mapcar (ret ^(mov ,@1 (t 0))) (nreverse tregs)) ncode)
+ ncode)))
+ code))
+
+(defmeth compiler comp-let (me oreg env form)
+ (mac-param-bind form (sym raw-vis . body) form
+ (let* ((vis (mapcar [iffi atom list] raw-vis))
+ (lexsyms [remove-if special-var-p [mapcar car vis]])
+ allsyms
+ (specials-occur [find-if special-var-p vis car])
+ (treg (if specials-occur me.(alloc-treg)))
+ (frsize (len lexsyms))
+ (seq (eq sym 'let*))
+ (nenv (new env up env co me))
+ (fenv (if seq nenv (new env up env co me))))
+ (with-closure-spy me (and (not specials-occur)
+ (>= *opt-level* 2))
+ cspy (new closure-spy env nenv)
+ (unless seq
+ (each ((lsym lexsyms))
+ nenv.(extend-var lsym)))
+ (let* (ffuns fvars
+ (code (build
+ (add ^(,(if specials-occur 'dframe 'frame)
+ ,nenv.lev ,frsize))
+ (each ((vi vis))
+ (tree-bind (sym : form) vi
+ (push sym allsyms)
+ (cond
+ ((special-var-p sym)
+ (let ((frag me.(compile treg fenv form))
+ (dreg me.(get-dreg sym)))
+ (pend frag.code)
+ (add ^(bindv ,frag.oreg ,dreg))
+ (set ffuns (uni ffuns frag.ffuns)
+ fvars (uni fvars
+ (if seq
+ (diff frag.fvars
+ (cdr allsyms))
+ frag.fvars)))))
+ (form
+ (let* ((loc (if seq
+ nenv.(get-loc)
+ nenv.(lookup-var sym).loc))
+ (frag me.(compile loc fenv form)))
+ (when seq
+ nenv.(extend-var* sym loc))
+ (pend frag.code)
+ (unless (null-reg frag.oreg)
+ (pend (maybe-mov loc frag.oreg)))
+ (set ffuns (uni ffuns frag.ffuns)
+ fvars (uni fvars
+ (if seq
+ (diff frag.fvars
+ (cdr allsyms))
+ frag.fvars)))))
+ (t (if seq nenv.(extend-var* sym))))))))
+ (bfrag me.(comp-progn oreg nenv body))
+ (boreg (if env.(out-of-scope bfrag.oreg) oreg bfrag.oreg))
+ (code (append code bfrag.code
+ (maybe-mov boreg bfrag.oreg)
+ ^((end ,boreg)))))
+ (when (and cspy (null cspy.cap-vars))
+ (set code me.(eliminate-frame [code 1..-1] nenv)))
+ (when treg
+ me.(free-treg treg))
+ nenv.(unused-check form "variable")
+ (new (frag boreg
+ code
+ (uni (diff bfrag.fvars allsyms) fvars)
+ (uni ffuns bfrag.ffuns))))))))
+
+(defmeth compiler comp-fbind (me oreg env form)
+ (mac-param-bind form (sym raw-fis . body) form
+ (let* ((fis (mapcar [iffi atom list] raw-fis))
+ (lexfuns [mapcar car fis])
+ (frsize (len lexfuns))
+ (rec (eq sym 'sys:lbind))
+ (eenv (unless rec (new env up env co me)))
+ (nenv (new env up env co me)))
+ (each ((lfun lexfuns))
+ nenv.(extend-fun lfun))
+ (let* (ffuns fvars
+ (ffrags (collect-each ((fi fis))
+ (tree-bind (sym : form) fi
+ (let* ((bind nenv.(lookup-fun sym))
+ (frag me.(compile bind.loc
+ (if rec nenv eenv)
+ form)))
+ (set bind.pars frag.pars)
+ (list bind
+ (new (frag frag.oreg
+ (append frag.code
+ (maybe-mov bind.loc frag.oreg))
+ frag.fvars
+ frag.ffuns)))))))
+ (bfrag me.(comp-progn oreg nenv body))
+ (boreg (if env.(out-of-scope bfrag.oreg) oreg bfrag.oreg)))
+ (set ffrags (append-each ((bf ffrags))
+ (tree-bind (bind ff) bf
+ (when bind.used
+ (set ffuns (uni ffuns ff.ffuns)
+ fvars (uni fvars ff.fvars))
+ (list ff)))))
+ (if ffrags
+ (new (frag boreg
+ (append ^((frame ,nenv.lev ,frsize))
+ (mappend .code ffrags)
+ bfrag.code
+ (maybe-mov boreg bfrag.oreg)
+ ^((end ,boreg)))
+ (uni fvars bfrag.fvars)
+ (uni (diff bfrag.ffuns lexfuns)
+ (if rec (diff ffuns lexfuns) ffuns))))
+ (new (frag boreg
+ (append me.(eliminate-frame bfrag.code nenv)
+ (maybe-mov boreg bfrag.oreg))
+ bfrag.fvars
+ bfrag.ffuns)))))))
+
+(defmeth compiler comp-lambda-impl (me oreg env form)
+ (mac-param-bind form (t par-syntax . body) form
+ (with-access-spy me me.closure-spies
+ spy (new access-spy
+ closure-spies me.closure-spies)
+ (compile-with-fresh-tregs me
+ (let* ((*load-time* nil)
+ (*top-level* nil)
+ (pars (new (fun-param-parser par-syntax form)))
+ (need-frame (or (plusp pars.nfix) pars.rest))
+ (nenv (if need-frame (new env up env co me) env))
+ lexsyms fvars specials need-dframe)
+ (when (> pars.nfix %max-lambda-fixed-args%)
+ (compile-warning form "~s arguments in a lambda (max is ~s)"
+ pars.nfix %max-lambda-fixed-args%))
+ (flet ((spec-sub (sym : (loc :))
+ (cond
+ ((special-var-p sym)
+ (let ((sub (gensym)))
+ (push (cons sym sub) specials)
+ (set need-dframe t)
+ nenv.(extend-var sub loc)
+ sub))
+ (t
+ (push sym lexsyms)
+ nenv.(extend-var sym loc)
+ sym))))
+ (let* ((req-pars (collect-each ((rp pars.req))
+ (spec-sub rp)))
+ (allsyms req-pars)
+ (opt-pars (collect-each ((op pars.opt))
+ (tree-bind (var-sym : init-form have-sym) op
+ (let* ((loc nenv.(get-loc))
+ (ifrag me.(compile loc nenv init-form)))
+ (set fvars (uni fvars
+ (diff ifrag.fvars allsyms)))
+ (push var-sym allsyms)
+ (push have-sym allsyms)
+ (list (spec-sub var-sym loc)
+ ifrag
+ (if have-sym (spec-sub have-sym)))))))
+ (rest-par (when pars.rest (spec-sub pars.rest))))
+ (upd specials nreverse)
+ (with-closure-spy me (and (not specials)
+ (>= *opt-level* 2))
+ cspy (new closure-spy env nenv)
+ (let* ((col-reg (if opt-pars me.(get-dreg :)))
+ (tee-reg (if opt-pars me.(get-dreg t)))
+ (ifrags [mapcar cadr opt-pars])
+ (opt-code (append-each ((op opt-pars)
+ (ifrg ifrags))
+ (tree-bind (var-sym t have-sym) op
+ (let ((vbind nenv.(lookup-var var-sym))
+ (have-bind nenv.(lookup-var have-sym))
+ (lskip (gensym "l")))
+ ^(,*(if have-sym
+ ^((mov ,have-bind.loc ,tee-reg)))
+ (ifq ,vbind.loc ,col-reg ,lskip)
+ ,*(if have-sym
+ ^((mov ,have-bind.loc nil)))
+ ,*ifrg.code
+ ,*(maybe-mov vbind.loc ifrg.oreg)
+ ,lskip
+ ,*(whenlet ((spec-sub [find var-sym specials : cdr]))
+ (set specials [remq var-sym specials cdr])
+ ^((bindv ,vbind.loc ,me.(get-dreg (car spec-sub)))))
+ ,*(whenlet ((spec-sub [find have-sym specials : cdr]))
+ (set specials [remq have-sym specials cdr])
+ ^((bindv ,have-bind.loc ,me.(get-dreg (car spec-sub))))))))))
+ (benv (if need-dframe (new env up nenv co me) nenv))
+ (btreg me.(alloc-treg))
+ (bfrag me.(comp-progn btreg benv body))
+ (boreg (if env.(out-of-scope bfrag.oreg) btreg bfrag.oreg))
+ (lskip (gensym "l"))
+ (frsize (if need-frame nenv.v-cntr 0))
+ (code ^((close ,oreg ,frsize ,me.treg-cntr ,lskip
+ ,pars.nfix ,pars.nreq ,(if rest-par t nil)
+ ,*(collect-each ((rp req-pars))
+ nenv.(lookup-var rp).loc)
+ ,*(collect-each ((op opt-pars))
+ nenv.(lookup-var (car op)).loc)
+ ,*(if rest-par
+ (list nenv.(lookup-var rest-par).loc)))
+ ,*(if need-dframe
+ ^((dframe ,benv.lev 0)))
+ ,*(if specials
+ (collect-each ((vs specials))
+ (tree-bind (special . gensym) vs
+ (let ((sub-bind nenv.(lookup-var gensym))
+ (dreg me.(get-dreg special)))
+ ^(bindv ,sub-bind.loc ,dreg)))))
+ ,*opt-code
+ ,*bfrag.code
+ ,*(if need-dframe
+ ^((end ,boreg)))
+ ,*(maybe-mov boreg bfrag.oreg)
+ (jend ,boreg)
+ ,lskip)))
+ me.(free-treg btreg)
+ (when (and cspy (plusp frsize) (null cspy.cap-vars))
+ (when-match ((close @reg @frsize @nil . @irest) . @crest)
+ me.(eliminate-frame code nenv)
+ (set code ^((close ,reg 0 ,me.treg-cntr ,*irest)
+ ,*crest))))
+ nenv.(unused-check form "parameter")
+ (new (frag oreg code
+ (uni fvars (diff bfrag.fvars lexsyms))
+ (uni [reduce-left uni ifrags nil .ffuns]
+ bfrag.ffuns)
+ pars)))))))))))
+
+(defmeth compiler comp-lambda (me oreg env form)
+ (if (or *load-time* *top-level* (< *opt-level* 3))
+ me.(comp-lambda-impl oreg env form)
+ (let* ((snap me.(snapshot))
+ (lambda-frag me.(comp-lambda-impl oreg env form))
+ (ok-lift-var-pov (all lambda-frag.fvars
+ (lambda (sym)
+ (not env.(lookup-var sym)))))
+ (ok-lift-fun-pov (all lambda-frag.ffuns
+ (lambda (sym)
+ (not env.(lookup-fun sym))))))
+ (cond
+ ((and ok-lift-var-pov ok-lift-fun-pov)
+ me.(restore snap)
+ me.(compile oreg env ^(sys:load-time-lit nil ,form)))
+ (t lambda-frag)))))
+
+(defmeth compiler comp-fun (me oreg env form)
+ (mac-param-bind form (t arg) form
+ (let ((fbin env.(lookup-fun arg t)))
+ (cond
+ (fbin (new (frag fbin.loc nil nil (list arg))))
+ ((and (consp arg) (eq (car arg) 'lambda))
+ me.(compile oreg env arg))
+ (t (new (frag oreg ^((getf ,oreg ,me.(get-sidx arg)))
+ nil (list arg))))))))
+
+(defmeth compiler comp-progn (me oreg env args)
+ (let* (ffuns fvars
+ (lead-forms (butlastn 1 args))
+ (last-form (nthlast 1 args))
+ (eff-lead-forms (remove-if [orf constantp symbolp] lead-forms))
+ (forms (append eff-lead-forms last-form))
+ (nargs (len forms))
+ lastfrag
+ (oreg-discard me.(alloc-treg))
+ (code (build
+ (each ((form forms)
+ (n (range 1)))
+ (let ((islast (eql n nargs)))
+ (let ((frag me.(compile (if islast oreg oreg-discard)
+ env form)))
+ (when islast
+ (set lastfrag frag))
+ (set fvars (uni fvars frag.fvars))
+ (set ffuns (uni ffuns frag.ffuns))
+ (pend frag.code)))))))
+ me.(free-treg oreg-discard)
+ (new (frag (if lastfrag lastfrag.oreg ^(t 0)) code fvars ffuns))))
+
+(defmeth compiler comp-or (me oreg env form)
+ (tree-case (simplify-or form)
+ ((t) me.(compile oreg env nil))
+ ((t arg) me.(compile oreg env arg))
+ ((t . args)
+ (let* (ffuns fvars
+ (nargs (len args))
+ (lout (gensym "l"))
+ (treg me.(maybe-alloc-treg oreg))
+ (code (build
+ (each ((form args)
+ (n (range 1)))
+ (let ((islast (eql n nargs)))
+ (let ((frag me.(compile treg env form)))
+ (pend frag.code
+ (maybe-mov treg frag.oreg))
+ (unless islast
+ (add ^(ifq ,treg (t 0) ,lout)))
+ (set fvars (uni fvars frag.fvars))
+ (set ffuns (uni ffuns frag.ffuns))))))))
+ me.(maybe-free-treg treg oreg)
+ (new (frag oreg
+ (append code ^(,lout
+ ,*(maybe-mov oreg treg)))
+ fvars ffuns))))))
+
+(defmeth compiler comp-prog1 (me oreg env form)
+ (tree-case form
+ ((t fi . re) (let* ((igreg me.(alloc-treg))
+ (fireg me.(maybe-alloc-treg oreg))
+ (fi-frag me.(compile fireg env fi))
+ (re-frag me.(comp-progn igreg env
+ (append re '(nil)))))
+ me.(maybe-free-treg fireg oreg)
+ me.(free-treg igreg)
+ (new (frag fireg
+ (append fi-frag.code
+ (maybe-mov fireg fi-frag.oreg)
+ re-frag.code)
+ (uni fi-frag.fvars re-frag.fvars)
+ (uni fi-frag.ffuns re-frag.ffuns)))))
+ ((t fi) me.(compile oreg env fi))
+ ((t) me.(compile oreg env nil))))
+
+(defmeth compiler comp-progv (me oreg env form)
+ (tree-case form
+ ((t syms vals)
+ me.(comp-progn oreg env ^(progn ,syms ,vals nil)))
+ ((t syms vals . body)
+ (let* ((denv (new env up env co me))
+ (sreg me.(alloc-treg))
+ (vreg me.(alloc-treg))
+ (sfrag me.(compile sreg env syms))
+ (vfrag me.(compile vreg env vals))
+ (bfrag me.(comp-progn oreg denv body)))
+ me.(free-treg sreg)
+ me.(free-treg vreg)
+ (new (frag bfrag.oreg
+ (append sfrag.code
+ vfrag.code
+ ^((dframe ,denv.lev 0)
+ (gcall ,oreg
+ ,me.(get-sidx 'sys:rt-progv)
+ ,sfrag.oreg
+ ,vfrag.oreg))
+ bfrag.code
+ '((end nil)))
+ (uni sfrag.fvars (uni vfrag.fvars bfrag.fvars))
+ (uni sfrag.ffuns (uni vfrag.ffuns bfrag.ffuns))))))))
+
+(defmeth compiler comp-quasi (me oreg env form)
+ (let ((qexp (expand-quasi form)))
+ me.(compile oreg env (expand qexp))))
+
+(defmeth compiler comp-arith-form (me oreg env form)
+ (if (plusp *opt-level*)
+ (tree-case form
+ ((op . args)
+ (let* ((pargs [partition-by constantp args])
+ (fargs (append-each ((pa pargs))
+ (if (and (constantp (car pa))
+ (all pa [chain safe-const-eval integerp]))
+ (list (safe-const-reduce
+ (rlcp ^(,op ,*pa) form)))
+ pa))))
+ me.(comp-fun-form oreg env (rlcp ^(,op ,*fargs) form))))
+ (form me.(compile oreg env form)))
+ me.(comp-fun-form oreg env form)))
+
+(defmeth compiler comp-arith-neg-form (me oreg env form)
+ (tree-case form
+ ((nop a1 a2 a3 . args)
+ (let* ((op (caseq nop (- '+) (/ '*)))
+ (sform (rlcp ^(,op ,a2 ,a3 ,*args) form)))
+ me.(comp-fun-form oreg env
+ (rlcp ^(,nop ,a1 ,sform) form))))
+ (form me.(comp-fun-form oreg env form))))
+
+(defmeth compiler comp-typep (me oreg env form)
+ (match-case form
+ ((typep @exp @(require @(constantp @type)
+ (eq t (safe-const-eval type))))
+ me.(compile oreg env ^(progn ,exp t)))
+ ((typep @exp @(require @(constantp @type)
+ (null (safe-const-eval type))))
+ me.(compile oreg env ^(progn ,exp nil)))
+ (@nil
+ me.(comp-fun-form oreg env form))))
+
+(defmeth compiler comp-compiler-let (me oreg env form)
+ (tree-bind (t bindings . body) form
+ (progv [mapcar car bindings]
+ [mapcar [chain cadr no-dvbind-eval] bindings]
+ me.(comp-progn oreg env body))))
+
+(defmeth compiler comp-fun-form (me oreg env form)
+ (let* ((olev *opt-level*)
+ (sym (car form))
+ (nargs (len (cdr form)))
+ (fbin env.(lookup-fun sym t))
+ (pars (or fbin.?pars
+ (get-param-info sym))))
+ (if pars
+ (param-check form nargs pars)
+ (push (cons form nargs) *unchecked-calls*))
+
+ (when (null fbin)
+ (when (plusp olev)
+ (match-case form
+ ((equal @a @b)
+ (cond
+ ((or (eq-comparable a)
+ (eq-comparable b))
+ (set form (rlcp ^(eq ,a ,b) form)))
+ ((or (eql-comparable a)
+ (eql-comparable b))
+ (set form (rlcp ^(eql ,a ,b) form)))))
+ ((not (@(and @(or eq eql equal) @op) @a @b))
+ (let ((nop (caseq op (eq 'neq) (eql 'neql) (equal 'nequal))))
+ (return-from comp-fun-form me.(compile oreg env ^(,nop ,a ,b)))))
+ ((@(or append cons list list*) . @nil)
+ (set form (reduce-lisp form)))
+ ((@(@bin [%bin-op% @sym]) @a @b)
+ (set form (rlcp ^(,bin ,a ,b) form)))
+ ((- @a)
+ (set form (rlcp ^(neg ,a) form)))
+ ((subtypep (typeof @a) @b)
+ (set form (rlcp ^(typep ,a ,b) form)))
+ ((@(or ignore nilf) . @args)
+ (if (eql sym 'ignore)
+ (each ((a args))
+ (if (bindable a)
+ env.(lookup-var a t))))
+ (return-from comp-fun-form me.(compile oreg env
+ ^(progn ,*args nil))))
+ ((@(or identity use + * min max logior logand) @a)
+ (return-from comp-fun-form me.(compile oreg env a)))
+ (@(require (chain . @nil)
+ (> olev 5)
+ (can-inline-chain form))
+ (return-from comp-fun-form me.(compile oreg env
+ (inline-chain form))))))
+
+ (when (plusp olev)
+ (tree-case form
+ ((t . t)
+ (set form (reduce-constant env form)))))
+
+ (when (or (atom form) (special-operator-p (car form)))
+ (return-from comp-fun-form me.(compile oreg env form))))
+
+ (tree-bind (sym . args) form
+ (let* ((fbind env.(lookup-fun sym t)))
+ (macrolet ((comp-fun ()
+ 'me.(comp-call-impl oreg env (if fbind 'call 'gcall)
+ (if fbind fbind.loc me.(get-sidx sym))
+ args sym)))
+ (if (and (>= olev 3)
+ (not fbind)
+ (not *load-time*)
+ [%functional% sym])
+ (let* ((snap me.(snapshot))
+ (cfrag (comp-fun))
+ (ok-lift-var-pov (null cfrag.fvars))
+ (ok-lift-fun-pov (all cfrag.ffuns
+ (lambda (sym)
+ (and (not env.(lookup-fun sym))
+ (eq (symbol-package sym)
+ user-package))))))
+ (cond
+ ((and ok-lift-var-pov ok-lift-fun-pov)
+ me.(restore snap)
+ me.(compile oreg env ^(sys:load-time-lit nil ,form)))
+ (t (pushnew sym cfrag.ffuns)
+ cfrag)))
+ (let ((cfrag (comp-fun)))
+ (pushnew sym cfrag.ffuns)
+ cfrag)))))))
+
+(defmeth compiler comp-apply-call (me oreg env form)
+ (let ((olev *opt-level*))
+ (tree-bind (sym . oargs) form
+ (let ((args (if (plusp olev)
+ [mapcar (op reduce-constant env) oargs]
+ oargs)))
+ (let ((gopcode [%gcall-op% sym])
+ (opcode [%call-op% sym]))
+ (cond
+ ((and (plusp olev)
+ (eq sym 'call)
+ [all args constantp]
+ (let ((op (safe-const-eval (car args))))
+ (or [%const-foldable% op]
+ (not (bindable op)))))
+ (let ((crform (safe-const-reduce form)))
+ (if (eq crform form)
+ me.(comp-fun-form oreg env crform)
+ me.(compile oreg env crform))))
+ (t (tree-case (car args)
+ ((op arg . more)
+ (caseq op
+ (fun (cond
+ (more (compile-error form "excess args in fun form"))
+ ((bindable arg)
+ (let ((fbind env.(lookup-fun arg t)))
+ me.(comp-call-impl oreg env (if fbind opcode gopcode)
+ (if fbind fbind.loc me.(get-sidx arg))
+ (cdr args) arg)))
+ ((and (consp arg) (eq (car arg) 'lambda))
+ me.(comp-fun-form oreg env ^(,sym ,arg ,*(cdr args))))
+ (t :)))
+ (lambda me.(comp-inline-lambda oreg env opcode
+ (car args) (cdr args)))
+ (t :)))
+ (t me.(comp-call oreg env
+ (if (eq sym 'usr:apply) 'apply sym) args))))))))))
+
+(defmeth compiler comp-call (me oreg env opcode args)
+ (tree-bind (fform . fargs) args
+ (let* ((foreg me.(maybe-alloc-treg oreg))
+ (ffrag me.(compile foreg env fform))
+ (cfrag me.(comp-call-impl oreg env opcode ffrag.oreg fargs)))
+ me.(maybe-free-treg foreg oreg)
+ (new (frag cfrag.oreg
+ (append ffrag.code
+ cfrag.code)
+ (uni ffrag.fvars cfrag.fvars)
+ (uni ffrag.ffuns cfrag.ffuns))))))
+
+(defmeth compiler comp-call-impl (me oreg env opcode freg args : extra-ffun)
+ (with-access-spy me t spy (new simplify-var-spy)
+ (let* ((aoregs nil)
+ (afrags0 (collect-each ((arg args))
+ (let* ((aoreg me.(alloc-treg))
+ (afrag me.(compile aoreg env arg)))
+ (push aoreg aoregs)
+ afrag)))
+ (afrags (handle-mutated-var-args afrags0 spy.mutated-vars))
+ (fvars [reduce-left uni afrags nil .fvars])
+ (ffuns [reduce-left uni afrags nil .ffuns]))
+ me.(free-tregs aoregs)
+ (when extra-ffun
+ (pushnew extra-ffun ffuns))
+ (new (frag oreg
+ ^(,*(mappend .code afrags)
+ (,opcode ,oreg ,freg ,*(mapcar .oreg afrags)))
+ fvars ffuns)))))
+
+(defmeth compiler comp-inline-lambda (me oreg env opcode lambda args)
+ (let ((reg-args args) apply-list-arg)
+ (when (eql opcode 'apply)
+ (unless args
+ (compile-error lambda "apply requires arguments"))
+ (set reg-args (butlast args)
+ apply-list-arg (car (last args))))
+ me.(compile oreg env (expand (lambda-apply-transform lambda
+ reg-args
+ apply-list-arg
+ nil)))))
+
+(defmeth compiler comp-for (me oreg env form)
+ (mac-param-bind form (t inits (: (test nil test-p) . rets) incs . body) form
+ (let* ((treg me.(alloc-treg))
+ (ifrag me.(comp-progn treg env inits))
+ (*load-time* nil)
+ (tfrag (progn
+ (inc me.loop-nest)
+ (if test-p me.(compile treg env test))))
+ (rfrag me.(comp-progn oreg env rets))
+ (nfrag me.(comp-progn treg env incs))
+ (bfrag (prog1
+ me.(comp-progn treg env body)
+ (dec me.loop-nest)))
+ (lback (gensym "l"))
+ (lskip (gensym "l"))
+ (frags (build
+ (add ifrag)
+ (if test-p (add tfrag))
+ (add rfrag nfrag bfrag))))
+ me.(free-treg treg)
+ (new (frag rfrag.oreg
+ ^(,*ifrag.code
+ ,lback
+ ,*(if test-p
+ ^(,*tfrag.code
+ (if ,tfrag.oreg ,lskip)))
+ ,*bfrag.code
+ ,*nfrag.code
+ (jmp ,lback)
+ ,*(if test-p
+ ^(,lskip
+ ,*rfrag.code)))
+ [reduce-left uni frags nil .fvars]
+ [reduce-left uni frags nil .ffuns])))))
+
+(defmeth compiler comp-tree-bind (me oreg env form)
+ (tree-bind (op params obj . body) form
+ (with-gensyms (obj-var)
+ (let* ((simp-form (rlcp-tree ^'(,op) form))
+ (expn (expand ^(let ((,obj-var ,obj))
+ ,(expand-bind-mac-params simp-form form
+ params nil
+ obj-var t nil body)))))
+ me.(compile oreg env expn)))))
+
+(defmeth compiler comp-mac-param-bind (me oreg env form)
+ (mac-param-bind form (t context params obj . body) form
+ (with-gensyms (obj-var form-var)
+ (let ((expn (expand ^(let ((,obj-var ,obj)
+ (,form-var ,context))
+ ,(expand-bind-mac-params form-var form
+ params nil
+ obj-var t nil body)))))
+ me.(compile oreg env expn)))))
+
+(defmeth compiler comp-mac-env-param-bind (me oreg env form)
+ (mac-param-bind form (t context menv params obj . body) form
+ (with-gensyms (obj-var form-var)
+ (let ((expn (expand ^(let ((,obj-var ,obj)
+ (,form-var ,context))
+ ,(expand-bind-mac-params form-var form
+ params menv
+ obj-var t nil body)))))
+ me.(compile oreg env expn)))))
+
+(defmeth compiler comp-tree-case (me oreg env form)
+ (mac-param-bind form (op obj . cases) form
+ (let* ((nenv (new env up env co me))
+ (obj-immut-var nenv.(extend-var (gensym)))
+ (obj-var nenv.(extend-var (gensym)))
+ (err-blk (gensym))
+ (lout (gensym "l"))
+ (ctx-form (rlcp-tree ^'(,op) form))
+ (treg me.(maybe-alloc-treg oreg))
+ (objfrag me.(compile treg env obj))
+ (cfrags (collect-each ((c cases)
+ (i (range 1)))
+ (mac-param-bind form (params . body) c
+ (let* ((src (expand ^(block ,err-blk
+ (set ,obj-var.sym
+ ,obj-immut-var.sym)
+ ,(expand-bind-mac-params
+ ctx-form form
+ params nil obj-var.sym :
+ err-blk
+ body))))
+ (cfrag me.(compile treg nenv src)))
+ (new (frag treg
+ ^(,*cfrag.code
+ ,*(maybe-mov treg cfrag.oreg)
+ (ifq ,treg ,me.(get-dreg :) ,lout))
+ cfrag.fvars
+ cfrag.ffuns))))))
+ (allfrags (cons objfrag cfrags)))
+ me.(maybe-free-treg treg oreg)
+ (new (frag oreg
+ ^(,*objfrag.code
+ (frame ,nenv.lev ,nenv.v-cntr)
+ ,*(maybe-mov obj-immut-var.loc objfrag.oreg)
+ ,*(mappend .code cfrags)
+ (mov ,treg nil)
+ ,lout
+ ,*(maybe-mov oreg treg)
+ (end ,oreg))
+ [reduce-left uni allfrags nil .fvars]
+ [reduce-left uni allfrags nil .ffuns])))))
+
+(defmeth compiler comp-lisp1-value (me oreg env form)
+ (mac-param-bind form (t arg) form
+ (cond
+ ((bindable arg)
+ (let ((bind env.(lookup-lisp1 arg t)))
+ (cond
+ (bind
+ (each ((spy me.access-spies))
+ spy.(accessed bind arg))
+ (new (frag bind.loc
+ nil
+ (if (typep bind 'vbinding) (list arg))
+ (if (typep bind 'fbinding) (list arg)))))
+ ((not (boundp arg))
+ (pushnew arg assumed-fun)
+ (new (frag oreg
+ ^((getf ,oreg ,me.(get-sidx arg)))
+ nil
+ (list arg))))
+ ((special-var-p arg)
+ (new (frag oreg
+ ^((getv ,oreg ,me.(get-dreg arg)))
+ (list arg)
+ nil)))
+ (t (new (frag oreg
+ ^((getlx ,oreg ,me.(get-sidx arg)))
+ (list arg)
+ nil))))))
+ (t me.(compile oreg env arg)))))
+
+(defmeth compiler comp-dwim (me oreg env form)
+ (mac-param-bind form (t obj . args) form
+ (ignore obj args)
+ (let* ((l1-exprs (cdr form))
+ (fun (car l1-exprs))
+ (bind env.(lookup-lisp1 fun nil)))
+ me.(compile oreg env
+ (if (and (symbolp fun)
+ (not bind)
+ (not (boundp fun)))
+ (progn
+ (pushnew fun assumed-fun)
+ ^(,fun ,*(mapcar [iffi bindable (op list 'sys:lisp1-value)] (cdr l1-exprs))))
+ ^(call ,*(mapcar [iffi bindable (op list 'sys:lisp1-value)] l1-exprs)))))))
+
+(defmeth compiler comp-prof (me oreg env form)
+ (mac-param-bind form (t . forms) form
+ (let ((bfrag me.(comp-progn oreg env forms)))
+ (new (frag oreg
+ ^((prof ,oreg)
+ ,*bfrag.code
+ (xend ,bfrag.oreg))
+ bfrag.fvars bfrag.ffuns)))))
+
+(defun handle-mutated-var-args (frags mutated-vars)
+ (if mutated-vars
+ (build
+ (each ((frag frags))
+ (let* ((vbin frag.vbin)
+ (oreg frag.alt-oreg))
+ (add (if (and vbin (memq vbin mutated-vars))
+ (new (frag oreg (append frag.code (maybe-mov oreg vbin.loc))
+ frag.fvars frag.ffuns frag.pars))
+ frag)))))
+ frags))
+
+(defun misleading-ref-check (frag env form)
+ (each ((v frag.fvars))
+ (when env.(lookup-var v)
+ (compile-warning form "cannot refer to lexical variable ~s" v)))
+ (each ((f frag.ffuns))
+ (when env.(lookup-fun f)
+ (compile-warning form "cannot refer to lexical function ~s" f))))
+
+(defmeth compiler comp-load-time-lit (me oreg env form)
+ (mac-param-bind form (t loaded-p exp) form
+ (cond
+ (loaded-p me.(compile oreg env ^(quote ,exp)))
+ ((or *load-time* (constantp exp)) me.(compile oreg env exp))
+ (t (compile-in-toplevel me
+ (let* ((*load-time* t)
+ (dreg me.(alloc-dreg))
+ (exp me.(compile dreg (new env co me) exp))
+ (lt-frag (new (frag dreg
+ ^(,*exp.code
+ ,*(maybe-mov dreg exp.oreg))
+ exp.fvars
+ exp.ffuns
+ exp.pars))))
+ (misleading-ref-check exp env form)
+ (push lt-frag me.lt-frags)
+ (new (frag dreg nil nil nil exp.pars))))))))
+
+(defmeth compiler compact-dregs-and-syms (me insns)
+ (let ((dmap (hash))
+ (smap (vector (len me.sidx)))
+ (used-syms 0)
+ (dc 0)
+ (sc 0))
+
+ (each ((insn insns))
+ (if-match @(coll @(as dr (d @nil))) insn
+ (each ((d dr))
+ (unless (inhash dmap d)
+ (set [dmap d] ^(d ,(pinc dc))))))
+ (if-match (@(or gcall gapply getf getlx setlx) @nil @fn . @nil) insn
+ (set-mask used-syms (mask fn))))
+
+ (let ((data (hash :eql-based)))
+ (dohash (from-dreg to-dreg dmap)
+ (set [data (cadr to-dreg)] [me.data (cadr from-dreg)]))
+ (set me.data data
+ me.datavec nil
+ me.dreg-cntr dc)
+ (each ((cell me.dreg))
+ (upd (cdr cell) dmap)))
+
+ (let ((stab (hash :eql-based))
+ (sidx (hash :eql-based))
+ (nsym (width used-syms)))
+ (each ((from 0..nsym))
+ (when (bit used-syms from)
+ (let ((to (pinc sc))
+ (atom [me.stab from]))
+ (set [stab to] atom
+ [sidx atom] to
+ [smap from] to))))
+ (set me.stab stab
+ me.sidx sidx
+ me.sidx-cntr sc
+ me.symvec nil))
+
+ (mapcar [iffi consp (opip
+ (mapcar [orf dmap use])
+ (do if-match (@(as op @(or gcall gapply
+ getf getlx setlx))
+ @dest @fn . @args)
+ @1
+ ^(,op ,dest ,[smap fn] ,*args)
+ @1))]
+ insns)))
+
+(defmeth compiler optimize (me insns)
+ (let ((olev *opt-level*))
+ (if (>= olev 4)
+ (let* ((lt-dregs (mapcar .oreg me.lt-frags))
+ (bb (new (basic-blocks me insns lt-dregs me.(get-symvec)))))
+ (when (>= olev 4)
+ bb.(thread-jumps)
+ bb.(elim-dead-code))
+ (when (>= olev 5)
+ (let ((nblocks nil))
+ (while* (and (>= olev 6)
+ (neql nblocks (set nblocks bb.(num-blocks))))
+ bb.(calc-liveness)
+ bb.(peephole)
+ bb.(link-graph)
+ bb.(thread-jumps)
+ bb.(elim-dead-code))))
+ (cond
+ ((>= olev 7)
+ bb.(merge-jump-thunks)
+ bb.(compact-tregs)
+ bb.(late-peephole me.(compact-dregs-and-syms bb.(get-insns))))
+ ((>= olev 5)
+ me.(compact-dregs-and-syms bb.(get-insns)))
+ (t bb.(get-insns))))
+ insns)))
+
+(defun true-const-p (arg)
+ (and arg (constantp arg)))
+
+(defun eq-comparable (arg)
+ (and (constantp arg)
+ [[orf fixnump chrp symbolp] (eval arg)]))
+
+(defun eql-comparable (arg)
+ (and (constantp arg)
+ [[orf symbolp chrp numberp] (eval arg)]))
+
+(defun expand-and (form)
+ (match-case form
+ ((and) t)
+ ((and @a) a)
+ ((and @(true-const-p) . @rest) (expand-and ^(and ,*rest)))
+ ((and nil . @nil) nil)
+ ((and @a . @rest) ^(if ,a ,(expand-and ^(and ,*rest))))
+ (@else else)))
+
+(defun flatten-or (form)
+ (match-case form
+ ((or . @args) ^(or ,*[mappend [chain flatten-or cdr] args]))
+ (@else ^(or ,else))))
+
+(defun reduce-or (form)
+ (match-case form
+ ((or) form)
+ ((or @nil) form)
+ ((or nil . @rest) (reduce-or ^(or ,*rest)))
+ ((or @(true-const-p @c) . @nil) ^(or ,c))
+ ((or @a . @rest) ^(or ,a ,*(cdr (reduce-or ^(or ,*rest)))))
+ (@else else)))
+
+(defun simplify-or (form)
+ (reduce-or (flatten-or form)))
+
+(defmacro fixed-point (eqfn sym exp)
+ (with-gensyms (osym)
+ ^(let (,osym)
+ (while* (not (,eqfn ,osym ,sym))
+ (set ,osym ,sym
+ ,sym ,exp))
+ ,sym)))
+
+(defun reduce-lisp (form)
+ (fixed-point equal form
+ (rlcp
+ (match-case form
+ ((append (list . @largs) . @aargs)
+ ^(list* ,*largs (append ,*aargs)))
+ ((@(or append list*) @arg) arg)
+ (@(require (list* . @(listp @args))
+ (equal '(nil) (last args)))
+ ^(list ,*(butlastn 1 args)))
+ (@(with (list* . @(listp @args))
+ ((@(and @op @(or list list*)) . @largs)) (last args))
+ ^(,op ,*(butlast args) ,*largs))
+ (@(with (list* . @(listp @args))
+ ((append . @aargs)) (last args))
+ ^(list* ,*(butlast args) ,(reduce-lisp ^(append ,*aargs))))
+ ((@(or append list list*)) nil)
+ ((cons @a @b)
+ (let* ((lstar ^(list* ,a ,b))
+ (rstar (reduce-lisp lstar)))
+ (if (eq lstar rstar) form rstar)))
+ ((cons @a (cons @b @c))
+ ^(list* ,a ,b ,c))
+ ((cons @a (@(and @op @(or list list*)) . @args))
+ ^(,op ,a ,*args))
+ (@else else))
+ form)))
+
+(defun reduce-constant (env form)
+ (if (consp form)
+ (tree-bind (op . args) form
+ (if (and [%const-foldable% op]
+ (not env.(lookup-fun op)))
+ (let ((cargs [mapcar (op reduce-constant env) args]))
+ (if [all cargs constantp]
+ (safe-const-reduce (rlcp ^(,op ,*cargs) form))
+ (rlcp ^(,op ,*cargs) form)))
+ form))
+ form))
+
+(defun expand-quasi-mods (obj mods : form)
+ (let (plist num sep rng-ix scalar-ix-p flex gens)
+ (flet ((get-sym (exp)
+ (let ((gen (gensym)))
+ (push (list gen exp) gens)
+ gen)))
+ (for () (mods) ((pop mods))
+ (let ((mel (car mods)))
+ (cond
+ ((keywordp mel)
+ (set plist mods)
+ (return))
+ ((integerp mel)
+ (when num
+ (compile-error form "duplicate modifier (width/alignment): ~s"
+ num))
+ (set num mel))
+ ((stringp mel)
+ (when sep
+ (compile-error form "duplicate modifier (separator): ~s"
+ num))
+ (set sep mel))
+ ((atom mel)
+ (push (get-sym mel) flex))
+ (t
+ (caseq (car mel)
+ (dwim
+ (when rng-ix
+ (compile-error form "duplicate modifier (range/index): ~s"
+ mel))
+ (unless (consp (cdr mel))
+ (compile-error form "missing argument in range/index: ~s"
+ mel))
+ (unless (null (cddr mel))
+ (compile-error form "excess args in range/index: ~s"
+ num))
+ (let ((arg (cadr mel)))
+ (cond
+ ((and (consp arg) (eq (car arg) 'range))
+ (set rng-ix (get-sym ^(rcons ,(cadr arg) ,(caddr arg)))))
+ (t
+ (set rng-ix (get-sym arg))
+ (set scalar-ix-p t)))))
+ (sys:expr (push (get-sym flex) (cadr mel)))
+ (t (push (get-sym mel) flex)))))))
+ (let ((mcount (+ (if num 1 0)
+ (if sep 1 0)
+ (if rng-ix 1 0)
+ (len flex))))
+ (when (> mcount 3)
+ (compile-error form "too many formatting modifiers"))
+ ^(alet ,(nreverse gens)
+ ,(if flex
+ ^(sys:fmt-flex ,obj ',plist
+ ,*(remq nil (list* num sep
+ (if scalar-ix-p
+ ^(rcons ,rng-ix nil)
+ rng-ix)
+ (nreverse flex))))
+ (cond
+ (plist ^(sys:fmt-simple ,obj ,num ,sep, rng-ix ',plist))
+ (rng-ix ^(sys:fmt-simple ,obj ,num ,sep, rng-ix))
+ (sep ^(sys:fmt-simple ,obj ,num ,sep))
+ (num ^(sys:fmt-simple ,obj ,num))
+ (t ^(sys:fmt-simple ,obj ,num)))))))))
+
+(defun expand-quasi-args (form)
+ (append-each ((el (cdr form)))
+ (cond
+ ((consp el)
+ (caseq (car el)
+ (sys:var (mac-param-bind form (t exp : mods) el
+ (list (expand-quasi-mods exp mods))))
+ (sys:quasi (expand-quasi-args el))
+ (t (list ^(sys:fmt-simple ,el)))))
+ ((bindable el)
+ (list ^(sys:fmt-simple ,el)))
+ (t
+ (list el)))))
+
+(defun expand-quasi (form)
+ (let ((qa (expand-quasi-args form)))
+ (cond
+ ((cdr qa) ^(sys:fmt-join ,*qa))
+ (qa (car qa))
+ (t '(mkstring 0)))))
+
+(defun expand-dohash (form)
+ (mac-param-bind form (t (key-var val-var hash-form : res-form) . body) form
+ (with-gensyms (iter-var cell-var)
+ (rlcp
+ ^(let (,key-var ,val-var (,iter-var (hash-begin ,hash-form)) ,cell-var)
+ (block nil
+ (sys:for-op ((sys:setq ,cell-var (hash-next ,iter-var)))
+ (,cell-var ,res-form)
+ ((sys:setq ,cell-var (hash-next ,iter-var)))
+ (sys:setq ,key-var (car ,cell-var))
+ (sys:setq ,val-var (cdr ,cell-var))
+ ,*body)))
+ form))))
+
+(defun expand-each (form env)
+ (mac-param-bind form (t each-type vars . body) form
+ (when (eq vars t)
+ (set vars [mapcar car env.vb]))
+ (let* ((gens (mapcar (ret (gensym)) vars))
+ (out (if (member each-type '(collect-each append-each))
+ (gensym)))
+ (accum (if out (gensym))))
+ ^(let* (,*(mapcar (ret ^(,@1 (iter-begin ,@2))) gens vars)
+ ,*(if accum ^((,out (cons nil nil)) (,accum ,out))))
+ (block nil
+ (sys:for-op ()
+ ((and ,*(mapcar (op list 'iter-more) gens))
+ ,*(if accum (if (eq each-type 'collect-each)
+ ^((cdr ,out))
+ ^((sys:apply (fun append) ,out)))))
+ (,*(mapcar (ret ^(sys:setq ,@1 (iter-step ,@1))) gens))
+ ,*(mapcar (ret ^(sys:setq ,@1 (iter-item ,@2))) vars gens)
+ ,*(caseq each-type
+ ((collect-each append-each)
+ ^((rplacd ,accum (cons (progn ,*body) nil))
+ (sys:setq ,accum (cdr ,accum))))
+ (t body))))))))
+
+(defun expand-bind-mac-params (ctx-form rlcp-form params menv-var
+ obj-var strict err-block body)
+ (let (gen-stk stmt vars)
+ (labels ((get-gen ()
+ (or (pop gen-stk) (gensym)))
+ (put-gen (g)
+ (push g gen-stk))
+ (expand-rec (par-syntax obj-var check-var)
+ (labels ((emit-stmt (form)
+ (when form
+ (if check-var
+ (push ^(when ,check-var ,form) stmt)
+ (push form stmt))))
+ (emit-var (sym init-form)
+ (if (eq sym t)
+ (emit-stmt init-form)
+ (push (if stmt
+ (prog1
+ ^(,sym (progn ,*(nreverse stmt)
+ ,(if check-var
+ ^(when ,check-var ,init-form)
+ init-form)))
+ (set stmt nil))
+ ^(,sym ,(if check-var
+ ^(when ,check-var ,init-form)
+ init-form)))
+ vars))))
+ (let ((pars (new (mac-param-parser par-syntax rlcp-form))))
+ (progn
+ (cond
+ ((eq strict t)
+ (emit-stmt
+ ^(sys:bind-mac-check ,ctx-form ',par-syntax
+ ,obj-var ,pars.nreq
+ ,(unless pars.rest
+ pars.nfix))))
+ ((null strict))
+ ((symbolp strict)
+ (emit-stmt
+ (let ((len-expr ^(if (consp ,obj-var)
+ (len ,obj-var) 0)))
+ (if pars.rest
+ ^(unless (<= ,pars.nreq ,len-expr)
+ (return-from ,err-block ',strict))
+ ^(unless (<= ,pars.nreq ,len-expr ,pars.nfix)
+ (return-from ,err-block ',strict)))))))
+ (each ((k pars.key))
+ (tree-bind (key . sym) k
+ (caseq key
+ (:whole (emit-var sym obj-var))
+ (:form (emit-var sym ctx-form))
+ (:env (emit-var sym menv-var)))))
+ (each ((p pars.req))
+ (cond
+ ((listp p)
+ (let ((curs (get-gen)))
+ (emit-stmt ^(set ,curs (car ,obj-var)))
+ (emit-stmt ^(set ,obj-var (cdr ,obj-var)))
+ (expand-rec p curs check-var)
+ (put-gen curs)))
+ (t (if (neq p t)
+ (emit-var p ^(car ,obj-var)))
+ (emit-stmt ^(set ,obj-var (cdr ,obj-var))))))
+ (each ((o pars.opt))
+ (tree-bind (p : init-form pres-p) o
+ (cond
+ ((listp p)
+ (let* ((curs (get-gen))
+ (stmt ^(cond
+ (,obj-var
+ (set ,curs (car ,obj-var))
+ (set ,obj-var (cdr ,obj-var))
+ ,*(if pres-p '(t)))
+ (t
+ (set ,curs ,init-form)
+ ,*(if pres-p '(nil))))))
+ (if pres-p
+ (emit-var pres-p stmt)
+ (emit-stmt stmt))
+ (let ((cv (gensym)))
+ (emit-var cv curs)
+ (expand-rec p curs cv)
+ (put-gen curs))))
+ (t
+ (cond
+ (pres-p
+ (emit-var p nil)
+ (emit-var pres-p
+ ^(cond
+ (,obj-var
+ ,(if (neq p t)
+ ^(set ,p (car ,obj-var)))
+ (set ,obj-var (cdr ,obj-var))
+ t)
+ (t
+ ,(cond
+ ((and (neq p t) init-form)
+ ^(set ,p ,init-form))
+ (init-form))
+ nil))))
+ (t
+ (emit-var p ^(if ,obj-var
+ (prog1
+ (car ,obj-var)
+ (set ,obj-var (cdr ,obj-var)))
+ (if ,init-form ,init-form)))))))))
+ (when pars.rest
+ (emit-var pars.rest obj-var)))))))
+ (expand-rec params obj-var nil)
+ (when stmt
+ (push ^(,(gensym) (progn ,*(nreverse stmt))) vars))
+ (rlcp ^(let* (,*gen-stk ,*(nreverse vars))
+ ,*body)
+ rlcp-form))))
+
+(defun expand-defvarl (form)
+ (mac-param-bind form (t sym : value) form
+ (with-gensyms (cell)
+ (if value
+ ^(let ((,cell (sys:rt-defv ',sym)))
+ (if ,cell
+ (usr:rplacd ,cell ,value))
+ ',sym)
+ ^(progn (sys:rt-defv ',sym) ',sym)))))
+
+(defun expand-defun (form)
+ (mac-param-bind form (t name args . body) form
+ (flet ((mklambda (block-name block-sym)
+ (rlcp ^(lambda ,args (,block-sym ,block-name ,*body)) form)))
+ (cond
+ ((bindable name)
+ ^(sys:rt-defun ',name ,(mklambda name 'sys:blk)))
+ ((consp name)
+ (caseq (car name)
+ (meth
+ (mac-param-bind form (t type slot) name
+ (rlcp ^(sys:define-method ',type ',slot ,(mklambda slot 'block))
+ form)))
+ (macro
+ (mac-param-bind form (t sym) name
+ ^(sys:rt-defmacro ',sym ',name ,(mklambda sym 'sys:blk))))
+ (t (compile-error form "~s isn't a valid compound function name"
+ name))))
+ (t (compile-error form "~s isn't a valid function name" name))))))
+
+(defun expand-defmacro (form)
+ (mac-param-bind form (t name mac-args . body) form
+ (with-gensyms (mform menv spine-iter)
+ (let ((exp-lam (rlcp ^(lambda (,mform ,menv)
+ (let ((,spine-iter (cdr ,mform)))
+ ,(expand (expand-bind-mac-params mform
+ form
+ mac-args
+ menv spine-iter
+ t nil
+ ^((sys:set-macro-ancestor
+ (block ,name ,*body)
+ ,mform))))))
+ form)))
+ ^(progn
+ (sys:rt-defmacro ',name '(macro ,name) ,exp-lam)
+ ',name)))))
+
+(defun expand-defsymacro (form)
+ (mac-param-bind form (t name def) form
+ ^(sys:rt-defsymacro ',name ',def)))
+
+(defun lambda-apply-transform (lm-expr fix-arg-exprs apply-list-expr recursed)
+ (if (and (not recursed)
+ apply-list-expr
+ (safe-constantp apply-list-expr))
+ (let* ((apply-list-val (safe-const-eval apply-list-expr))
+ (apply-atom (nthlast 0 apply-list-val))
+ (apply-fixed (butlastn 0 apply-list-val)))
+ (lambda-apply-transform lm-expr (append fix-arg-exprs
+ (mapcar (ret ^',@1) apply-fixed))
+ ^',apply-atom t))
+ (mac-param-bind lm-expr (t lm-args . lm-body) lm-expr
+ (let* ((pars (new (fun-param-parser lm-args lm-expr)))
+ (fix-vals (mapcar (ret (gensym)) fix-arg-exprs))
+ (fix-arg-iter fix-arg-exprs)
+ (check-opts)
+ (ign-1 (gensym))
+ (ign-2 (gensym))
+ (al-val (gensym))
+ (shadow-p (let ((all-vars (append pars.req pars.(opt-syms)
+ (if pars.rest (list pars.rest)))))
+ (or (isecp all-vars fix-arg-iter)
+ (member apply-list-expr all-vars)))))
+ (rlcp ^(,(if shadow-p 'let 'alet) ,(zip fix-vals fix-arg-iter)
+ (let* ,(build
+ (if apply-list-expr
+ (add ^(,al-val ,apply-list-expr)))
+ (while (and fix-vals pars.req)
+ (add ^(,(pop pars.req) ,(pop fix-vals)))
+ (pop fix-arg-iter))
+ (while (and fix-vals pars.opt)
+ (tree-bind (var-sym : init-form have-sym) (pop pars.opt)
+ (add ^(,var-sym ,(car fix-vals)))
+ (if have-sym
+ (add ^(,have-sym t)))
+ (unless (and (safe-constantp (car fix-arg-iter))
+ (neq (safe-const-eval (car fix-arg-iter))
+ :))
+ (push (list* var-sym have-sym init-form) check-opts)))
+ (pop fix-vals)
+ (pop fix-arg-iter))
+ (cond
+ ((and (null pars.req)
+ (null pars.opt))
+ (if fix-vals
+ (if pars.rest
+ (add ^(,pars.rest
+ (list*
+ ,*(nthcdr pars.nfix
+ ^(,*fix-arg-exprs ,apply-list-expr)))))
+ (lambda-too-many-args lm-expr))
+ (cond
+ ((and pars.rest apply-list-expr)
+ (add ^(,pars.rest ,al-val)))
+ (pars.rest
+ (add ^(,pars.rest nil)))
+ (apply-list-expr
+ (add ^(,ign-2 (if ,al-val
+ (lambda-excess-apply-list))))))))
+ ((and fix-vals apply-list-expr)
+ (lambda-too-many-args lm-expr))
+ (apply-list-expr
+ (when pars.req
+ (add ^(,ign-1 (if (< (len ,al-val) ,(len pars.req))
+ (lambda-short-apply-list)))))
+ (while pars.req
+ (add ^(,(pop pars.req) (pop ,al-val))))
+ (while pars.opt
+ (tree-bind (var-sym : init-form have-sym) (pop pars.opt)
+ (cond
+ (have-sym
+ (add ^(,var-sym (if ,al-val
+ (car ,al-val)
+ ,init-form)))
+ (add ^(,have-sym (when ,al-val
+ (pop ,al-val)
+ t))))
+ (t (add ^(,var-sym (if ,al-val
+ (pop ,al-val)
+ ,init-form)))))
+ (push (list* var-sym have-sym init-form) check-opts)))
+ (if pars.rest
+ (add ^(,pars.rest ,al-val))
+ (add ^(,ign-2 (if ,al-val
+ (lambda-excess-apply-list))))))
+ (pars.req
+ (lambda-too-few-args lm-expr))
+ (pars.opt
+ (while pars.opt
+ (tree-bind (var-sym : init-form have-sym) (pop pars.opt)
+ (add ^(,var-sym ,init-form))
+ (if have-sym
+ (add ^(,have-sym)))))
+ (when pars.rest
+ (add ^(,pars.rest))))))
+ ,*(mapcar (tb ((var-sym have-sym . init-form))
+ ^(when (eq ,var-sym :)
+ (set ,var-sym ,init-form)
+ ,*(if have-sym
+ ^((set ,have-sym nil)))))
+ (nreverse check-opts))
+ ,*lm-body))
+ lm-expr)))))
+
+(defun simplify-variadic-lambda (form)
+ (if-match @(require (lambda @(and @params @(end @rest))
+ [sys:apply . @args])
+ rest
+ (eq 1 [cons-count rest args eq])
+ (eq [args -1] rest))
+ form
+ ^(lambda (,*(butlastn 0 params) ,rest)
+ [call ,*(butlastn 1 args) ,rest])
+ form))
+
+(defun inline-chain-rec (form arg)
+ (match-ecase form
+ ((chain @fun)
+ ^(call ,(simplify-variadic-lambda fun) ,arg))
+ ((chain @fun . @rest)
+ (inline-chain-rec ^(chain ,*rest)
+ ^(call ,(simplify-variadic-lambda fun) ,arg)))))
+
+(defun can-inline-chain (form)
+ (let (yes)
+ (each ((f (cdr form)))
+ (if-match @(or @(symbolp)
+ (sys:lisp1-value @(symbolp))
+ (lambda . @lam))
+ f
+ (if lam (set yes t))
+ (return-from can-inline-chain nil)))
+ yes))
+
+(defun inline-chain (form)
+ (match-case form
+ ((chain @fun) fun)
+ ((chain @fun . @rest)
+ (with-gensyms (args)
+ ^(lambda ,args
+ ,(inline-chain-rec ^(chain ,*rest)
+ ^(apply ,fun ,args)))))
+ ((chain) form)))
+
+(defun orig-form (form)
+ (whilet ((anc (macro-ancestor form)))
+ (set form anc))
+ form)
+
+(defun safe-const-reduce (form)
+ (condlet
+ ((((atom form))) form)
+ (((ece [%eval-cache% form]))
+ ece.reduced-form)
+ (t
+ (let* ((throws nil)
+ (reduced-form (usr:catch (let ((result (eval form)))
+ (if (or (consp result)
+ (bindable result))
+ ^(quote ,result)
+ result))
+ (t (exc)
+ (ignore exc)
+ (set throws t)
+ form)))
+ (ece (new eval-cache-entry
+ orig-form (orig-form form)
+ reduced-form reduced-form
+ throws throws)))
+ (set [%eval-cache% form] ece)
+ reduced-form))))
+
+(defun safe-const-eval (form)
+ (unless [%eval-cache% form].?throws
+ (eval form)))
+
+(defun safe-constantp (form)
+ (if (constantp form)
+ (or (atom form)
+ (progn (safe-const-reduce form)
+ (not [%eval-cache% form].?throws)))))
+
+(defun eval-cache-emit-warnings ()
+ (dohash (form ece %eval-cache%)
+ (when ece.throws
+ (del [%eval-cache% form])
+ (let ((of ece.orig-form))
+ (when-opt constant-throws
+ (when (or (source-loc of)
+ (and (consp of)
+ (neq system-package (symbol-package (car of)))))
+ (unless *compile-opts*.usr:constant-throws
+ (diag ece.orig-form "constant expression ~s throws"
+ ece.orig-form))))))))
+
+(defun system-symbol-p (sym)
+ (member (symbol-package sym)
+ (load-time (list user-package system-package))))
+
+(defun no-dvbind-eval (form)
+ (eval (if-match (sys:dvbind @nil @exp) form exp form)))
+
+(defun usr:compile-toplevel (exp : (expanded-p nil))
+ (let ((co (new compiler top-form exp))
+ (as (new assembler))
+ (*dedup* (or *dedup* (hash)))
+ (*load-time* nil)
+ (*top-level* t)
+ (*opt-level* (or *opt-level* 0)))
+ (let* ((oreg co.(alloc-treg))
+ (xexp (if expanded-p
+ exp
+ (unwind-protect
+ (expand* exp)
+ (unless *load-recursive*
+ (release-deferred-warnings)))))
+ (frag co.(compile oreg (new env co co) xexp)))
+ (unless *load-recursive*
+ (eval-cache-emit-warnings))
+ co.(free-treg oreg)
+ co.(check-treg-leak)
+ (let ((insns co.(optimize ^(,*(mappend .code (nreverse co.lt-frags))
+ ,*frag.code
+ (jend ,frag.oreg)))))
+ (unless (< co.dreg-cntr %lev-size%)
+ (compile-error co.last-form "code too complex: too many literals"))
+ as.(asm insns))
+ (vm-make-desc co.nlev (succ as.max-treg) as.buf co.(get-datavec) co.(get-symvec)))))
+
+(defun get-param-info (sym)
+ (whenlet ((fun (symbol-function sym)))
+ (or [%param-info% fun]
+ (set [%param-info% fun]
+ (new param-info fun fun)))))
+
+(defun param-check (form nargs pars)
+ (cond
+ ((< nargs pars.nreq)
+ (compile-warning form "too few arguments: needs ~s, given ~s"
+ pars.nreq nargs))
+ (pars.rest)
+ ((> nargs pars.nfix)
+ (compile-warning form "too many arguments: max ~s, given ~s"
+ pars.nfix nargs))))
+
+(defun compiler-emit-warnings ()
+ (let ((warn-fun [keep-if boundp (zap assumed-fun)]))
+ (when warn-fun
+ (usr:catch
+ (throw 'warning
+ `uses of @{warn-fun ", "} compiled as functions,\
+ \ then defined as vars`)
+ (continue ()))))
+ (each ((uc (zap *unchecked-calls*)))
+ (when-match (@(as form (@sym . @nil)) . @nargs) uc
+ (whenlet ((fun (symbol-function sym)))
+ (param-check form nargs (get-param-info sym))))))
+
+(defvar *emit*)
+
+(defvar *eval*)
+
+(defvarl %big-endian% (equal (ffi-put 1 (ffi uint32)) #b'00000001'))
+
+(defvarl %tlo-ver% ^(7 0 ,%big-endian%))
+
+(defvarl %package-manip% '(make-package delete-package
+ use-package unuse-package
+ set-package-fallback-list
+ intern unintern rehome-sym
+ use-sym unuse-sym))
+
+(defmacro ign-notfound (form)
+ ^(usr:catch ,form (path-not-found (. rest) (ignore rest))))
+
+(defun open-compile-streams (in-path out-path test-fn)
+ (if (and (nullify in-path)
+ (find [in-path -1] path-sep-chars))
+ (error "~s: invalid input pathname ~s" 'compile-file in-path))
+ (let* ((parent (or *load-path* ""))
+ (in-path (if (and (pure-rel-path-p in-path) (not (empty parent)))
+ (path-cat (dir-name parent) in-path)
+ in-path))
+ (suff (short-suffix in-path))
+ (ip-nosuff (trim-right suff in-path))
+ in-stream out-stream)
+ (casequal suff
+ (".txr" (error "~s: cannot compile TXR files" 'compile-file))
+ (".tl" (set in-stream (ign-notfound (open-file in-path))
+ out-path (or out-path `@{ip-nosuff}.tlo`)))
+ (t (set in-stream (or (ign-notfound (open-file in-path))
+ (ign-notfound (open-file `@{in-path}.tl`)))
+ out-path (or out-path `@{in-path}.tlo`))))
+
+ (unless in-stream
+ (error "~s: unable to open input file ~s" 'compile-file in-path))
+
+ (unless [test-fn in-stream out-path]
+ (close-stream in-stream)
+ (return-from open-compile-streams nil))
+
+ (unwind-protect
+ (set out-stream (open-file out-path "w"))
+ (unless out-stream
+ (close-stream in-stream)))
+
+ (list in-stream out-stream out-path)))
+
+(defun clean-file (path)
+ (let* ((lev (or *compile-opts*.log-level 0))
+ (parent *load-path*)
+ (path (if (and parent (pure-rel-path-p path))
+ (path-cat (dir-name parent) path)
+ path)))
+ (flet ((try-clean (try-path)
+ (if (remove-path try-path nil)
+ (if (> lev 0)
+ (put-line `cleaned @{try-path}`)))))
+ (match-case path
+ (@(or `@base.tlo`
+ `@base.tlo.gz`)
+ (ignore base)
+ (try-clean path))
+ (@(or `@base.txr`
+ `@base.tl`
+ `@base`)
+ (or (try-clean `@base.tlo`)
+ (try-clean `@base.tlo.gz`)))))))
+
+(defun list-from-vm-desc (vd)
+ (list (sys:vm-desc-nlevels vd)
+ (sys:vm-desc-nregs vd)
+ (sys:vm-desc-bytecode vd)
+ (copy (sys:vm-desc-datavec vd))
+ (sys:vm-desc-symvec vd)))
+
+(defmacro usr:with-compilation-unit (. body)
+ (with-gensyms (rec)
+ ^(let* ((,rec *in-compilation-unit*)
+ (*in-compilation-unit* t)
+ (sys:*load-recursive* t)
+ (*dedup* (or *dedup* (hash))))
+ (unwind-protect
+ (progn ,*body)
+ (unless ,rec
+ (eval-cache-emit-warnings)
+ (release-deferred-warnings)
+ (compiler-emit-warnings))))))
+
+(defun dump-to-tlo (out-stream out)
+ (let* ((*print-circle* t)
+ (*print-base* 10)
+ (*print-flo-format* "~s")
+ (*print-flo-precision* flo-max-dig)
+ (*package* (sys:make-anon-package))
+ (out-forms (partition* out.(get) (op where (op eq :fence)))))
+ (prinl %tlo-ver% out-stream)
+ [mapdo (op prinl @1 out-stream) out-forms]
+ (delete-package *package*)))
+
+(defun propagate-perms (in-stream out-stream)
+ (let ((sti (stat in-stream)))
+ (when (plusp (logand sti.mode s-ixusr))
+ (let ((mode "+x")
+ (suid (if (plusp (logand sti.mode s-isuid)) ",u+s"))
+ (sgid (if (and (plusp (logand sti.mode s-isgid))
+ (plusp (logand sti.mode s-ixgrp))) ",g+s")))
+ (when (or suid sgid)
+ (let ((sto (stat out-stream)))
+ (set mode (append mode
+ (if (eql sti.uid sto.uid) suid)
+ (if (eql sti.gid sto.gid) sgid)))))
+ (chmod out-stream mode)))))
+
+(defun translate-hash-bang (hbline)
+ (flow hbline
+ (spl " ")
+ (subst "--lisp" "--compiled")
+ (mapcar [iffi (op ends-with "txrlisp")
+ (opip (trim-right "lisp") (join @1 "vm"))])
+ (ap join-with " ")))
+
+(defun compile-file-conditionally (in-path out-path test-fn)
+ (whenlet ((success nil)
+ (perms nil)
+ (streams (open-compile-streams in-path out-path test-fn)))
+ (with-resources ((in-stream (car streams) (close-stream in-stream))
+ (out-stream (cadr streams) (progn
+ (when perms
+ (propagate-perms in-stream
+ out-stream))
+ (close-stream out-stream)
+ (unless success
+ (remove-path (caddr streams))))))
+ (let* ((err-ret (gensym))
+ (*package* *package*)
+ (*emit* t)
+ (*eval* t)
+ (*load-path* (stream-get-prop (car streams) :name))
+ (*rec-source-loc* t)
+ (lev (or *compile-opts*.log-level 0))
+ (out (new list-builder)))
+ (if (> lev 0)
+ (put-line `compiling @{*load-path*}`))
+ (with-compilation-unit
+ (iflet ((line (get-line in-stream))
+ ((starts-with "#!" line)))
+ (let ((cline (translate-hash-bang line)))
+ (set perms t)
+ (put-line cline out-stream))
+ (seek-stream in-stream 0 :from-start))
+ (labels ((compile-form (unex-form)
+ (let* ((form (macroexpand unex-form))
+ (sym (if (consp form) (car form))))
+ (when (and sym (> lev 1))
+ (let* ((loc (source-loc form))
+ (line (or (car loc) "unknown")))
+ (if-match @(or @(with (@(symbolp @a) @(symbolp @b) . @nil)
+ print-form ^(,a ,b))
+ @(with (@(symbolp @a) . @nil)
+ print-form a)) form
+ (format t "~a: ~a\n" line print-form))))
+ (caseq sym
+ (progn [mapdo compile-form (cdr form)])
+ (compile-only (let ((*eval* nil))
+ [mapdo compile-form (cdr form)]))
+ (eval-only (let ((*emit* nil))
+ [mapdo compile-form (cdr form)]))
+ (sys:load-time-lit
+ (if (cadr form)
+ (compile-form ^(quote ,(caddr form)))
+ (compile-form (caddr form))))
+ (t (when (and (or *eval* *emit*)
+ (not (constantp form)))
+ (let* ((vm-desc (compile-toplevel form))
+ (flat-vd (list-from-vm-desc vm-desc))
+ (symvec (sys:vm-desc-symvec vm-desc))
+ (fence (isecp symvec %package-manip%)))
+ (when *eval*
+ (let ((pa *package-alist*))
+ (block* err-ret
+ (unwind-protect
+ (sys:vm-execute-toplevel vm-desc)
+ (return* err-ret)))
+ (when (neq pa *package-alist*)
+ (set fence t))))
+ (when (and *emit* (consp form))
+ out.(add flat-vd)
+ (when fence
+ out.(add :fence))))))))))
+ (unwind-protect
+ (whilet ((obj (read in-stream *stderr* err-ret))
+ ((neq obj err-ret)))
+ (compile-form obj))
+ (dump-to-tlo out-stream out))
+
+ (when (parse-errors in-stream)
+ (error "~s: compilation of ~s failed" 'compile-file
+ (stream-get-prop in-stream :name))))
+ (flush-stream out-stream)
+ (set success t))))))
+
+(defun usr:compile-file (in-path : out-path)
+ [compile-file-conditionally in-path out-path tf])
+
+(defun usr:compile-update-file (in-path : out-path)
+ (let ((test-newer [mapf path-newer fstat identity]))
+ (if (> (or *compile-opts*.log-level 0) 0)
+ (set test-newer [orf test-newer
+ (do progn
+ (put-line `skipping up-to-date @2`)
+ nil)]))
+ [compile-file-conditionally in-path out-path test-newer]))
+
+(defun usr:dump-compiled-objects (out-stream . compiled-objs)
+ (symacrolet ((self 'dump-compiled-objects))
+ (let ((out (new list-builder)))
+ (flet ((vm-from-fun (fun)
+ (unless (vm-fun-p fun)
+ (error "~s: not a vm function: ~s" self fun))
+ (sys:vm-closure-desc (func-get-env fun))))
+ (each ((obj compiled-objs))
+ (let* ((vm-desc (typecase obj
+ (vm-desc obj)
+ (fun (vm-from-fun obj))
+ (t (iflet ((fun (symbol-function obj)))
+ (vm-from-fun fun)
+ (error "~s: not a compiled object: ~s"
+ self obj)))))
+ (symvec (sys:vm-desc-symvec vm-desc)))
+ out.(add (list-from-vm-desc vm-desc))
+ (when (isecp symvec %package-manip%)
+ out.(add :fence)))))
+ (dump-to-tlo out-stream out))))
+
+(defun sys:env-to-let (env form)
+ (when env
+ (let ((vb (env-vbindings env))
+ (fb (env-fbindings env))
+ (up (env-next env)))
+ (when vb
+ (set form ^(let ,(mapcar (tb ((a . d)) ^(,a ',d)) vb) ,form)))
+ (when fb
+ (let (lbind fbind)
+ (each ((pair fb))
+ (tree-bind (a . d) pair
+ (let* ((fun-p (interp-fun-p d))
+ (fe (if fun-p (func-get-env d)))
+ (lb-p (and fe (eq fe env)))
+ (fb-p (and fe (eq fe up))))
+ (cond
+ (lb-p (push ^(,a ,(func-get-form d)) lbind))
+ (fb-p (push ^(,a ,(func-get-form d)) fbind))
+ (t (push ^(,a ',d) fbind))))))
+ (when lbind
+ (set form ^(sys:lbind ,(nreverse lbind) ,form)))
+ (when fbind
+ (set form ^(sys:fbind ,(nreverse fbind) ,form)))))
+ (if up
+ (set form (sys:env-to-let up form)))))
+ form)
+
+(defun usr:compile (obj)
+ (match-case obj
+ (@(functionp)
+ (tree-bind (t args . body) (func-get-form obj)
+ (let* ((form (sys:env-to-let (func-get-env obj)
+ ^(lambda ,args ,*body)))
+ (vm-desc (compile-toplevel form t)))
+ (vm-execute-toplevel vm-desc))))
+ ((lambda . @nil)
+ [(compile-toplevel obj nil)])
+ (@(@fun (symbol-function))
+ (tree-bind (t args . body) (func-get-form fun)
+ (let* ((form (sys:env-to-let (func-get-env fun)
+ ^(lambda ,args ,*body)))
+ (vm-desc (compile-toplevel form t))
+ (comp-fun (vm-execute-toplevel vm-desc)))
+ (set (symbol-function obj) comp-fun))))
+ (@else (error "~s: cannot compile ~s" 'compile else))))
+
+(defmacro usr:with-compile-opts (:form form . clauses)
+ (match-case clauses
+ (() ())
+ (((@(as op @(or nil t :warn :error @(integerp))) . @syms) . @rest)
+ (each ((s syms))
+ (unless (member s %warning-syms%)
+ (compile-error form
+ "~s isn't a recognized warning option" s)))
+ ^(compiler-let ((*compile-opts* (let ((co (copy *compile-opts*)))
+ (set ,*(mappend (ret ^(co.,@1 ,op))
+ syms))
+ co)))
+ ,*(if rest ^((with-compile-opts ,*rest)))))
+ ((@first . @rest)
+ ^(progn ,first ,*(if rest ^((with-compile-opts ,*rest)))))))
diff --git a/stdlib/constfun.tl b/stdlib/constfun.tl
new file mode 100644
index 00000000..de2c87f5
--- /dev/null
+++ b/stdlib/constfun.tl
@@ -0,0 +1,93 @@
+;; Copyright 2021-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defvarl %const-foldable-funs%
+ '(+ - * / sum prod abs trunc mod zerop nzerop plusp minusp evenp oddp
+ > < >= <= = /= wrap wrap* expt exptmod isqrt square gcd lcm floor ceil
+ round trunc-rem floor-rem ceil-rem round-rem sin cos tan asin acos atan
+ atan2 sinh cosh tanh asinh acosh atanh log log10 log2 exp sqrt
+ logand logior logxor logtest lognot logtrunc sign-extend ash bit mask
+ width logcount bitset cum-norm-dist inv-cum-norm n-choose-k n-perm-k
+ fixnump bignump floatp integerp numberp signum bignum-len divides sys:bits
+ digpow digits poly rpoly b< b> b<= b=> b= b+ b- b* b/ neg
+ pred ppred ppred pppred succ ssucc ssucc sssucc
+ car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr
+ cdadar cdaddr cddaar cddadr cdddar cddddr caaaaar caaaadr caaadar caaaddr
+ caadaar caadadr caaddar caadddr cadaaar cadaadr cadadar cadaddr caddaar
+ caddadr cadddar caddddr cdaaaar cdaaadr cdaadar cdaaddr cdadaar cdadadr
+ cdaddar cdadddr cddaaar cddaadr cddadar cddaddr cdddaar cdddadr cddddar
+ cdddddr first rest identity use typeof atom null false true have
+ consp listp endp proper-listp length-list second third fourth fifth
+ sixth seventh eighth ninth tenth nthcdr nth tailp
+ memq memql memqual rmemq rmemql rmemqual countq countql countqual
+ posq posql posqual rposq rposql rposqual eq eql equal meq meql mequal
+ neq neql nequal max min clamp bracket take drop if or and progn
+ prog1 prog2 nilf ignore tf display-width sys:fmt-simple
+ sys:fmt-flex sys:fmt-join packagep
+ symbolp keywordp bindable stringp length-str
+ coded-length cmp-str string-lt str= str< str> str<= str>= int-str
+ flo-str num-str int-flo flo-int tofloat toint tointz less greater
+ lequal gequal chrp chr-isalnum chr-isalnum chr-isalpha chr-isascii
+ chr-iscntrl chr-isdigit chr-digit chr-isgraph chr-islower chr-isprint
+ chr-ispunct chr-isspace chr-isblank chr-isunisp chr-isupper chr-isxdigit
+ chr-xdigit chr-toupper chr-tolower num-chr int-chr chr-num chr-int
+ chr-str span-str compl-span-str break-str vectorp length-vec size-vec
+ assq assql assoc rassq rassql rassoc prop memp length len empty ref
+ rangep from to in-range in-range* nullify))
+
+(defvarl %const-foldable% (hash-list %const-foldable-funs% :eq-based))
+
+(defvarl %effect-free-funs%
+ '(append append* revappend list list* zip interpose copy-list reverse
+ flatten flatten* flatcar flatcar* tuples remq remql remqual
+ keepq keepq keepqual remq* remql* remq* make-sym gensym
+ mkstring copy-str upcase-str downcase-str cat-str split-str spl
+ split-str-set sspl tok-str tok tok-where list-str trim-str
+ get-lines lazy-str length-str-> length-str->= length-str-<
+ length-str-<= vector vec vector-list list-vector list-vec
+ copy-vec sub-vec cat-vec acons acons-new aconsql-new alist-remove
+ copy-cons copy-tree copy-alist plist-to-alist improper-plist-to-alist
+ merge sort shuffle list-seq vec-seq str-seq copy sub seq-begin
+ iter-begin rcons make-like nullify symbol-value symbol-function
+ symbol-macro boundp fboundp mboundp special-operator-p special-var-p
+ copy-fun func-get-form func-get-name func-get-env functionp
+ interp-fun-p vm-fun-p fun-fixparam-count fun-optparam-count
+ fun-variadic sys:ctx-form sys:ctx-name range range* rlist rlist*
+ repeat pad weave promisep rperm perm comb rcomb source-loc
+ source-loc-str macro-ancestor cptr-int cptr-obj cptr-buf
+ int-cptr cptrp cptr-type cptr-size-hint))
+
+(defvarl %effect-free% (hash-uni %const-foldable%
+ (hash-list %effect-free-funs% :eq-based)))
+
+(defvarl %functional-funs%
+ '(chain chand juxt andf orf notf iff iffi dup flipargs if or and
+ progn prog1 prog2 retf apf ipf callf mapf tf umethod uslot))
+
+(defvarl %functional% (hash-list %functional-funs% :eq-based))
+
diff --git a/share/txr/stdlib/conv.tl b/stdlib/conv.tl
index 7a3551f9..b0975967 100644
--- a/share/txr/stdlib/conv.tl
+++ b/stdlib/conv.tl
@@ -1,4 +1,4 @@
-;; Copyright 2016-2020
+;; Copyright 2016-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,49 +6,46 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defmacro sys:conv-expand-sym (sym arg-expr)
+ (caseq sym
+ (usr:i ^(toint ,arg-expr))
+ (usr:o ^(toint ,arg-expr 8))
+ (usr:x ^(toint ,arg-expr 16))
+ (usr:b ^(toint ,arg-expr 2))
+ (usr:c ^(toint ,arg-expr #\c))
+ (usr:r ^(tofloat ,arg-expr))
+ (usr:iz ^(tointz ,arg-expr))
+ (usr:oz ^(tointz ,arg-expr 8))
+ (usr:xz ^(tointz ,arg-expr 16))
+ (usr:bz ^(tointz ,arg-expr 2))
+ (usr:cz ^(tointz ,arg-expr #\c))
+ (usr:rz ^(tofloatz ,arg-expr))
+ (t ^(,sym ,arg-expr))))
(defun sys:conv-let (. body)
- ^(flet ((i (arg : radix)
- (toint arg radix))
- (o (arg)
- (toint arg 8))
- (x (arg)
- (toint arg 16))
- (b (arg)
- (toint arg 2))
- (c (arg)
- (toint arg #\c))
- (r (arg)
- (tofloat arg))
- (iz (arg : radix)
- (tointz arg radix))
- (oz (arg)
- (tointz arg 8))
- (xz (arg)
- (tointz arg 16))
- (bz (arg)
- (tointz arg 2))
- (cz (arg)
- (tointz arg #\c))
- (rz (arg)
- (tofloatz arg)))
+ ^(flet ,(collect-each ((sym '(usr:i usr:o usr:x usr:b usr:c
+ usr:r usr:iz usr:oz usr:xz
+ usr:bz usr:cz usr:rz)))
+ ^(,sym (arg) (sys:conv-expand-sym ,sym arg)))
,*body))
(defun sys:do-conv (lfl mfl tfl nm list)
@@ -79,7 +76,7 @@
(op where (op eq :)))
(let ((nl (length lead))
(nt (length trail)))
- (with-gensyms (i nm lfl mfl tfl)
+ (with-gensyms (nm lfl mfl tfl)
(sys:conv-let
^(let* ((,nm (- (length ,list-sym) ,(+ nl nt)))
(,lfl (list ,*lead))
diff --git a/share/txr/stdlib/copy-file.tl b/stdlib/copy-file.tl
index 52125fd4..babf334f 100644
--- a/share/txr/stdlib/copy-file.tl
+++ b/stdlib/copy-file.tl
@@ -1,4 +1,4 @@
-;; Copyright 2018-2020
+;; Copyright 2018-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,32 +6,27 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(eval-only
- (defsymacro copy-size 65536)
-
- (defpackage copy-file
- (:fallback usr sys)
- (:use-syms usr:perms usr:times usr:owner usr:symlinks))
-
- (in-package copy-file))
+ (defsymacro copy-size 65536))
(defstruct copy-path-opts ()
perms times owner symlinks (euid (geteuid)))
@@ -89,8 +84,24 @@
(catch**
(return (copy-file path (path-cat dest-dir (base-name path))
preserve-perms preserve-times))
- (skip `skip copying @path` (exc . args) (return))
- (retry `retry copying @path` (exc . args))))))
+ (skip `skip copying @path` (exc . args)
+ (ignore args exc)
+ (return))
+ (retry `retry copying @path` (exc . args)
+ (ignore args exc))))))
+
+(defun cat-files (to-path . from-paths)
+ (let ((buf (make-buf copy-size)))
+ (with-stream (ost (open-file to-path "wb"))
+ (each ((from-path from-paths))
+ (with-stream (ist (open-file from-path "b"))
+ (while (eql (len buf) copy-size)
+ (fill-buf-adjust buf 0 ist)
+ (put-buf buf 0 ost)))
+ (buf-set-length buf copy-size)))
+ (buf-set-length buf 0)
+ (buf-trim buf)
+ nil))
(defun do-tweak-obj (to-path st opts link-p)
(when (and opts.perms (not link-p))
@@ -135,13 +146,11 @@
(unwind-protect
(ftw from-dir
(lambda (path type stat . rest)
+ (ignore rest)
(while t
(catch**
- (let* ((rel-path (let ((p [path (len from-dir)..:]))
- (if (pure-rel-path-p p) p [p 1..:])))
+ (let* ((rel-path (rel-path from-dir path))
(tgt-path (path-cat to-dir rel-path)))
- (unless (starts-with from-dir path)
- (error "~s: problem with directory traversal" 'copy-path))
(caseql* type
((ftw-dnr ftw-ns) (error "~s: unable to access ~s"
'copy-path path))
@@ -162,15 +171,19 @@
(remove-path tgt-path)))
(do-copy-obj path tgt-path stat opts)))
(return))
- (skip `skip copying @path` (exc . args) (return))
- (retry `retry copying @path` (exc . args)))))
+ (skip `skip copying @path` (exc . args)
+ (ignore exc args)
+ (return))
+ (retry `retry copying @path` (exc . args)
+ (ignore exc args)))))
ftw-phys)
(whilet ((top (pop dir-stack)))
(do-tweak-obj top.path top.stat opts nil)))))
(defun remove-path-rec (path)
(ftw path
- (lambda (path type stat . rest)
+ (lambda (path type . rest)
+ (ignore rest)
(while t
(catch**
(return
@@ -179,13 +192,17 @@
'remove-rec path))
(ftw-dp (rmdir path))
(t (remove-path path))))
- (skip `skip removing @path` (exc . args) (return))
- (retry `retry copying @path` (exc . args)))))
+ (skip `skip removing @path` (exc . args)
+ (ignore exc args)
+ (return))
+ (retry `retry copying @path` (exc . args)
+ (ignore exc args)))))
(logior ftw-phys ftw-depth)))
(defun chmod-rec (path perm)
(ftw path
- (lambda (path type stat . rest)
+ (lambda (path type . rest)
+ (ignore rest)
(while t
(catch**
(return
@@ -194,13 +211,17 @@
'remove-rec path))
(ftw-sl)
(t (chmod path perm))))
- (skip `skip chmod @path` (exc . args) (return))
- (retry `retry chmod @path` (exc . args)))))
+ (skip `skip chmod @path` (exc . args)
+ (ignore exc args)
+ (return))
+ (retry `retry chmod @path` (exc . args)
+ (ignore exc args)))))
(logior ftw-phys)))
(defun chown-rec (path uid gid)
(ftw path
- (lambda (path type stat . rest)
+ (lambda (path type . rest)
+ (ignore rest)
(while t
(catch**
(return
@@ -208,9 +229,16 @@
((ftw-dnr ftw-ns) (error "~s: unable to access ~s"
'remove-rec path))
(t (lchown path uid gid))))
- (skip `skip chown @path` (exc . args) (return))
- (retry `retry chown @path` (exc . args)))))
+ (skip `skip chown @path` (exc . args)
+ (ignore exc args)
+ (return))
+ (retry `retry chown @path` (exc . args)
+ (ignore exc args)))))
(logior ftw-phys)))
-(eval-only
- (merge-delete-package 'sys))
+(defun touch (path : ref-path)
+ (with-stream (s (or (ignerr (open-file path "mn")) (open-file path "n")))
+ (if ref-path
+ (let ((rst (stat ref-path)))
+ (utimes s 0 nil rst.mtime rst.mtime-nsec))
+ (utimes s 0 nil 0 t))))
diff --git a/stdlib/csort.tl b/stdlib/csort.tl
new file mode 100644
index 00000000..4a92e1f1
--- /dev/null
+++ b/stdlib/csort.tl
@@ -0,0 +1,46 @@
+;; Copyright 2023-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defmacro cached-sort-body (sort-fn)
+ ^(if (eq key-fun :)
+ (,sort-fn seq less-fun key-fun)
+ (,sort-fn seq less-fun (hash-map key-fun seq :eq-based))))
+
+(defun csort (seq : (less-fun :) (key-fun :))
+ (cached-sort-body sort))
+
+(defun cnsort (seq : (less-fun :) (key-fun :))
+ (cached-sort-body nsort))
+
+(defun cssort (seq : (less-fun :) (key-fun :))
+ (cached-sort-body ssort))
+
+(defun csnsort (seq : (less-fun :) (key-fun :))
+ (cached-sort-body snsort))
+
+(defun csort-group (seq : (key-fun :) (less-fun :))
+ (partition-by key-fun (csort seq less-fun key-fun)))
diff --git a/share/txr/stdlib/debugger.tl b/stdlib/debugger.tl
index 225d8207..54f0fc60 100644
--- a/share/txr/stdlib/debugger.tl
+++ b/stdlib/debugger.tl
@@ -1,4 +1,4 @@
-;; Copyright 2019-2020
+;; Copyright 2019-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,23 +6,24 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(defmacro with-disabled-debugging (. forms)
(let ((state (gensym)))
@@ -44,9 +45,11 @@
(defun debugger-help ()
(mapdo (ap pprinl `@{@1 15} @3`) %dbg-commands%))
-(defmeth fcall-frame loc (fr))
+(defmeth fcall-frame loc (fr)
+ (ignore fr))
(defmeth fcall-frame print-trace (fr pr-fr nx-fr prefix)
+ (ignore pr-fr)
(let* ((fun fr.fun)
(args fr.args)
(name (if (functionp fun)
@@ -79,6 +82,7 @@
^(,sym)))))))
(defmeth expand-frame print-trace (fr pr-fr nx-fr prefix)
+ (ignore pr-fr nx-fr)
(let* ((form fr.form)
(loc (source-loc-str form)))
(put-string `@prefix X:@(if loc `(@loc):`)`)
diff --git a/share/txr/stdlib/defset.tl b/stdlib/defset.tl
index 009a9ef8..4d90617a 100644
--- a/share/txr/stdlib/defset.tl
+++ b/stdlib/defset.tl
@@ -1,4 +1,4 @@
-;; Copyright 2019-2020
+;; Copyright 2019-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,24 +6,24 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(compile-only
(load-for (struct sys:param-parser-base "param")))
@@ -45,7 +45,8 @@
(syms (mac-env-flatten (symbol-value env))))
(list (cadr explam) syms)))
-(defun defset-expander-simple (macform get-fun set-fun)
+(defun defset-expander-simple (get-fun set-fun)
+ (ignore set-fun)
(with-gensyms (getter setter params)
^(defplace (,get-fun . ,params) body
(,getter ,setter
@@ -106,10 +107,11 @@
(defmacro usr:defset (:env e :form mf . args)
(tree-case args
((name (. params) newval setform)
+ (ignore name params newval setform)
(defset-expander e mf . args))
((get-fun set-fun)
- (defset-expander-simple mf get-fun set-fun))
- (x (compile-error mf "invalid syntax"))))
+ (defset-expander-simple get-fun set-fun))
+ (t (compile-error mf "invalid syntax"))))
(defset sub-list (list : (from 0) (to t)) items
^(progn (set ,list (replace-list ,list ,items ,from ,to)) ,items))
@@ -128,3 +130,11 @@
(defset key (node) nkey
^(progn (set-key ,node ,nkey) ,nkey))
+
+(defmacro set-mask (:env env place . integers)
+ (with-update-expander (getter setter) place env
+ ^(,setter (logior (,getter) ,*integers))))
+
+(defmacro clear-mask (:env env place . integers)
+ (with-update-expander (getter setter) place env
+ ^(,setter (logand (,getter) (lognot (logior ,*integers))))))
diff --git a/stdlib/doc-lookup.tl b/stdlib/doc-lookup.tl
new file mode 100644
index 00000000..c65650b8
--- /dev/null
+++ b/stdlib/doc-lookup.tl
@@ -0,0 +1,66 @@
+(defvar usr:*doc-url* "https://www.nongnu.org/txr/txr-manpage.html")
+
+(defvarl os-symbol
+ (if (ignerr (dlsym (dlopen "libandroid.so") "AAsset_close"))
+ :android
+ (let ((u (uname)))
+ [(orf (iff (f^ #/Linux/) (ret :linux))
+ (iff (f^ #/SunOS/)
+ (ret (if (<= 5 (int-str u.release))
+ :solaris10
+ :solaris)))
+ (iff (f^ #/CYGWIN/) (ret :cygwin))
+ (iff (f^ #/CYGNAL/) (ret :cygnal))
+ (iff (f^ #/Darwin/) (ret :macos))
+ (iff (f^ #/OpenBSD/) (ret :openbsd))
+ (ret :unknown))
+ u.sysname])))
+
+(defun detached-run (program args)
+ (match-case (fork)
+ (@(= 0) (if (zerop (fork))
+ (exit* (let ((*stdout* *stdnull*))
+ (run program args)))
+ (exit* 0)))
+ (@(> 0) (error "fork failed"))))
+
+(caseql os-symbol
+ ((:linux :macos :openbsd :solaris :solaris10 :android)
+ (defun open-url (url)
+ (let ((opener (caseql os-symbol
+ ((:linux :openbsd :solaris :android) "xdg-open")
+ (:solaris10 "/usr/dt/bin/sdtwebclient")
+ (:macos "open")))
+ (fallback '#"firefox iceweasel seamonkey mozilla \
+ epiphany konqueror chromium chromium-browser \
+ google-chrome"))
+ (iflet ((prog (getenv "BROWSER"))
+ (prog (or (and (plusp (len prog)) prog)
+ (if (abs-path-p opener)
+ opener
+ (path-search opener))
+ [find-true path-search fallback])))
+ (detached-run prog (list url))
+ (error "~s: no URL-opening method available" 'open-url)))))
+ ((:cygwin :cygnal)
+ (with-dyn-lib "shell32.dll"
+ (deffi shell-execute "ShellExecuteW"
+ cptr (cptr wstr wstr wstr wstr int))
+ (defun open-url (url)
+ (let ((hinst (shell-execute cptr-null "open" url nil nil 0)))
+ (if (> (int-cptr hinst) 32)
+ t
+ (error `~s: failed to open ~s` 'open-url url))))))
+ (t (defun open-url (url)
+ (ignore url)
+ (error "~s: not implemented" 'open-url))))
+
+(defun usr:doc (: sym)
+ (iflet ((str (typecase sym
+ (null sym)
+ (sym (let ((*package* (find-package "pub")))
+ (tostring sym)))
+ (t (tostringp sym))))
+ (tag (if str (fmt "S-~,08X" (crc32 str)) "")))
+ (open-url `@{*doc-url*}#@tag`)
+ (error "~s: ~s not found in symbol index" 'doc sym)))
diff --git a/share/txr/stdlib/doloop.tl b/stdlib/doloop.tl
index 5cccd861..63a4193c 100644
--- a/share/txr/stdlib/doloop.tl
+++ b/stdlib/doloop.tl
@@ -1,4 +1,4 @@
-;; Copyright 2017-2020
+;; Copyright 2017-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,27 +6,28 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(defun sys:expand-doloop (f vars cexp body)
(let ((xvars (mapcar (tc
- (((:whole w v i s . r))
+ (((:whole w t t t . r))
(if r (compile-error f "excess elements in ~s" w) w))
(((:whole w v i . r))
(if r
diff --git a/stdlib/each-prod.tl b/stdlib/each-prod.tl
new file mode 100644
index 00000000..271b87d0
--- /dev/null
+++ b/stdlib/each-prod.tl
@@ -0,0 +1,110 @@
+;; Copyright 2020-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defun sys:vars-check (form vars)
+ (unless (listp vars)
+ (compile-error form "~s is expected to be variable binding syntax" vars))
+ (whenlet ((bad (find-if [notf consp] vars)))
+ (compile-error form "~s isn't a var-initform pair" bad)))
+
+(defun sys:bindable-check (form syms)
+ (whenlet ((bad (find-if [notf bindable] syms)))
+ (compile-error form "~s isn't a bindable symbol" bad)))
+
+(defun sys:expand-each-prod (form vars body)
+ (sys:vars-check form vars)
+ (let ((syms [mapcar car vars])
+ (inits [mapcar cadr vars])
+ (gens [mapcar (ret (gensym)) vars]))
+ (sys:bindable-check form syms)
+ (let ((fun (caseq (car form)
+ (each-prod 'maprodo)
+ (collect-each-prod 'maprod)
+ (append-each-prod 'maprend))))
+ ^(let ,(zip gens inits)
+ (block nil
+ (,fun (lambda (,*syms) ,*body) ,*gens))))))
+
+(defun sys:expand-each-prod* (form vars body)
+ (sys:vars-check form vars)
+ (let* ((each-prod-op (caseq (car form)
+ (each-prod* 'each-prod)
+ (collect-each-prod* 'collect-each-prod)
+ (append-each-prod* 'append-each-prod)
+ (sum-each-prod* 'sum-each-prod)
+ (mul-each-prod* 'mul-each-prod)))
+ (syms [mapcar car vars]))
+ ^(let* ,vars
+ (,each-prod-op ,(zip syms syms) ,*body))))
+
+(defun sys:expand-arith-each-prod (form vars body)
+ (sys:vars-check form vars)
+ (let ((syms [mapcar car vars])
+ (inits [mapcar cadr vars])
+ (gens [mapcar (ret (gensym)) vars]))
+ (sys:bindable-check form syms)
+ (let ((op-iv (caseq (car form)
+ (sum-each-prod '(+ . 0))
+ (mul-each-prod '(* . 1)))))
+ (with-gensyms (acc)
+ ^(let ((,acc ,(cdr op-iv))
+ ,*(zip gens inits))
+ (block nil
+ (maprodo (lambda (,*syms)
+ (set ,acc (,(car op-iv) ,acc (progn ,*body))))
+ ,*gens)
+ ,acc))))))
+
+(defmacro each-prod (:form f vars . body)
+ (sys:expand-each-prod f vars body))
+
+(defmacro collect-each-prod (:form f vars . body)
+ (sys:expand-each-prod f vars body))
+
+(defmacro append-each-prod (:form f vars . body)
+ (sys:expand-each-prod f vars body))
+
+(defmacro sum-each-prod (:form f vars . body)
+ (sys:expand-arith-each-prod f vars body))
+
+(defmacro mul-each-prod (:form f vars . body)
+ (sys:expand-arith-each-prod f vars body))
+
+(defmacro each-prod* (:form f vars . body)
+ (sys:expand-each-prod* f vars body))
+
+(defmacro collect-each-prod* (:form f vars . body)
+ (sys:expand-each-prod* f vars body))
+
+(defmacro append-each-prod* (:form f vars . body)
+ (sys:expand-each-prod* f vars body))
+
+(defmacro sum-each-prod* (:form f vars . body)
+ (sys:expand-each-prod* f vars body))
+
+(defmacro mul-each-prod* (:form f vars . body)
+ (sys:expand-each-prod* f vars body))
diff --git a/share/txr/stdlib/error.tl b/stdlib/error.tl
index 1e946732..e41678e4 100644
--- a/share/txr/stdlib/error.tl
+++ b/stdlib/error.tl
@@ -1,4 +1,4 @@
-;; Copyright 2017-2020
+;; Copyright 2017-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,58 +6,34 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
-(defun sys:loc (ctx)
- (iflet ((loc (source-loc-str (sys:ctx-form ctx))))
- `(@loc) ` ""))
-
-(defun compile-error (ctx fmt . args)
- (let ((loc (sys:loc ctx))
- (name (sys:ctx-name ctx)))
- (dump-deferred-warnings *stderr*)
- (throwf 'eval-error `@loc~s: @fmt` name . args)))
-
-(defun compile-warning (ctx fmt . args)
- (let ((loc (sys:loc ctx))
- (name (sys:ctx-name ctx)))
- (usr:catch
- (throwf 'warning `@loc~s: @fmt` name . args)
- (continue ()))))
-
-(defun compile-defr-warning (ctx tag fmt . args)
- (let ((loc (sys:loc ctx))
- (name (sys:ctx-name ctx)))
- (usr:catch
- (throw 'defr-warning (fmt `@loc~s: @fmt` name . args) tag)
- (continue ()))))
+(defun sys:dig (ctx)
+ (whilet ((form (sys:ctx-form ctx))
+ (anc (unless (source-loc form)
+ (macro-ancestor form))))
+ (sys:setq ctx anc))
+ ctx)
-(defun sys:bind-mac-error (ctx-form params obj too-few-p)
- (cond
- ((atom obj)
- (compile-error ctx-form "extra element ~s not matched by params ~a"
- obj params))
- ((null obj)
- (compile-error ctx-form "params ~a require arguments" params))
- (t (compile-error ctx-form "too ~a elements in ~s for params ~a"
- (if too-few-p "few" "many")
- obj params))))
+(defun sys:loc (ctx)
+ (source-loc-str (sys:ctx-form ctx)))
(defun sys:bind-mac-check (ctx-form params obj req fix)
(if (and obj (atom obj))
@@ -72,11 +48,53 @@
(compile-error ctx-form "too ~a elements in ~s for params ~a"
problem obj params))))))
+(defun sys:bind-mac-error (ctx-form params obj too-few-p)
+ (cond
+ ((atom obj)
+ (compile-error ctx-form "extra element ~s not matched by params ~a"
+ obj params))
+ ((null obj)
+ (compile-error ctx-form "params ~a require arguments" params))
+ (t (compile-error ctx-form "too ~a elements in ~s for params ~a"
+ (if too-few-p "few" "many")
+ obj params))))
+
+
+(defun compile-error (ctx fmt . args)
+ (let* ((nctx (sys:dig ctx))
+ (loc (sys:loc nctx))
+ (name (sys:ctx-name nctx)))
+ (let ((msg (fmt `@loc: ~s: @fmt` name . args)))
+ (when (and *load-recursive*
+ (null (find-frame 'error 'catch-frame)))
+ (dump-deferred-warnings *stderr*)
+ (put-line msg *stderr*))
+ (throw 'eval-error msg))))
+
+(defun compile-warning (ctx fmt . args)
+ (let* ((nctx (sys:dig ctx))
+ (loc (sys:loc nctx))
+ (name (sys:ctx-name nctx)))
+ (usr:catch
+ (throwf 'warning `@loc: warning: ~s: @fmt` name . args)
+ (continue ()))))
+
+(defun compile-defr-warning (ctx tag fmt . args)
+ (let* ((nctx (sys:dig ctx))
+ (loc (sys:loc nctx))
+ (name (sys:ctx-name nctx)))
+ (usr:catch
+ (throw 'defr-warning (fmt `@loc: warning: ~s: @fmt` name . args) tag)
+ (continue ()))))
+
(defun lambda-too-many-args (form)
(compile-error form "excess arguments given"))
(defun lambda-too-few-args (form)
- (compile-error form "inufficient arguments given"))
+ (compile-error form "insufficient arguments given"))
(defun lambda-short-apply-list ()
(throwf 'eval-error "~s: applied argument list too short" 'lambda))
+
+(defun lambda-excess-apply-list ()
+ (throwf 'eval-error "~s: applied argument list too long" 'lambda))
diff --git a/share/txr/stdlib/except.tl b/stdlib/except.tl
index aa2c214a..37a7bae4 100644
--- a/share/txr/stdlib/except.tl
+++ b/stdlib/except.tl
@@ -1,4 +1,4 @@
-;; Copyright 2015-2020
+;; Copyright 2015-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,23 +6,24 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(defun sys:handle-bad-syntax (item)
(throwf 'eval-error "~s: bad clause syntax: ~s" 'handle item))
@@ -33,7 +34,8 @@
(tree-bind (args-ex . body-ex)
(sys:expand-params args body
e nil form)
- ^(,type (,(gensym) ,*args-ex) ,*body-ex)))
+ (rlcp ^(,type (,(gensym) ,*args-ex) ,*body-ex)
+ @1)))
catch-clauses)))
^(sys:catch ,catch-syms ,try-form nil ,*sys-catch-clauses)))
@@ -70,7 +72,7 @@
(<= 161 sys:compat)))
^(,exc-sym))
,exc-args)))
- (else (sys:handle-bad-syntax hc))))))
+ (else (sys:handle-bad-syntax else))))))
^(handler-bind (lambda (,exc-sym . ,exc-args)
(cond
,*(mapcar (aret ^((exception-subtype-p ,exc-sym ',@1) ,@2))
@@ -85,4 +87,4 @@
(sys:expand-handle form try-form handle-clauses))
(defmacro ignwarn (. forms)
- ^(handler-bind (lambda (exc-sym arg) (throw 'continue)) (warning) ,*forms))
+ ^(handler-bind (lambda (exc-sym . args) (throw 'continue)) (warning) ,*forms))
diff --git a/stdlib/expander-let.tl b/stdlib/expander-let.tl
new file mode 100644
index 00000000..bf82d76e
--- /dev/null
+++ b/stdlib/expander-let.tl
@@ -0,0 +1,44 @@
+;; Copyright 2023-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defmacro usr:expander-let (:form f :env e vars . body)
+ (let (syms values)
+ (each ((pair vars))
+ (tree-case pair
+ ((sym init)
+ (unless (special-var-p sym)
+ (compile-warning f "~s is required to be a special variable" sym))
+ (push sym syms)
+ (push
+ (if-match (sys:dv-bind @sym @form) init
+ (eval form)
+ (eval init))
+ values))
+ (else
+ (compile-warning f "not a var-init form: ~s" else))))
+ (progv (nreverse syms) (nreverse values)
+ (expand ^(progn ,*body) e))))
diff --git a/share/txr/stdlib/ffi.tl b/stdlib/ffi.tl
index a5748f3f..04b5fe09 100644
--- a/share/txr/stdlib/ffi.tl
+++ b/stdlib/ffi.tl
@@ -1,4 +1,4 @@
-;; Copyright 2017-2020
+;; Copyright 2017-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,23 +6,24 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(defmacro sys:dlib-expr (spec)
(typecase spec
@@ -31,14 +32,11 @@
(t spec)))
(defmacro with-dyn-lib (lib . body)
- (let ((keep-var (gensym "lib-")))
- ^(prog1
- (defvarl ,keep-var (sys:dlib-expr ,lib))
- (symacrolet ((sys:ffi-lib ,keep-var))
- ,*body))))
+ ^(let ((sys:ffi-lib (sys:dlib-expr ,lib)))
+ ,*body))
(defun sys:with-dyn-lib-check (f e ref)
- (when (eq (macroexpand 'sys:ffi-lib e) 'sys:ffi-lib)
+ (unless (lexical-var-p e 'sys:ffi-lib)
(compile-warning f "simple ref ~s requires ~s"
ref 'with-dyn-lib)))
@@ -54,31 +52,35 @@
(t exp)))
(defun sys:analyze-argtypes (form argtypes)
- (let ((p (posq : argtypes)))
- (when p
- (if (zerop p)
- (compile-error form "variadic with zero fixed arguments not allowed")
- (del [argtypes p])))
- (list* (length argtypes) p argtypes)))
+ (tree-bind (: ftypes vtypes) (split* argtypes (op where (op eq :)))
+ (when vtypes
+ (when (null ftypes)
+ (compile-error form "variadic with zero fixed arguments not allowed"))
+ (set vtypes
+ (collect-each ((vt vtypes))
+ (caseq vt
+ ((float) 'double)
+ ((be-float le-float)
+ (compile-error form "variadic argument cannot be of type ~s"
+ vt))
+ (t vt)))))
+ (list* (+ (len ftypes) (len vtypes)) (len ftypes) (append ftypes vtypes))))
(defmacro deffi (:form f :env e name fun-expr rettype argtypes)
(let ((fun-ref (sys:expand-sym-ref f e fun-expr))
- (ret-type-sym (gensym "ret-type-"))
- (arg-types-sym (gensym "arg-types-"))
- (call-desc-sym (gensym "call-desc-"))
- (fun-sym (gensym "ffi-fun-")))
- (tree-bind (nargs nvariadic . argtypes) (sys:analyze-argtypes f argtypes)
+ (fun-sym (gensym "fun-"))
+ (desc-sym (gensym "desc-")))
+ (tree-bind (nargs nfixed . argtypes) (sys:analyze-argtypes f argtypes)
(let ((arg-syms (take nargs (gun (gensym)))))
- ^(progn
- (defvarl ,ret-type-sym (ffi-type-compile ',rettype))
- (defvarl ,arg-types-sym [mapcar ffi-type-compile ',argtypes])
- (defvarl ,call-desc-sym (ffi-make-call-desc ,nargs ,nvariadic
- ,ret-type-sym
- ,arg-types-sym))
- (defvarl ,fun-sym ,fun-ref)
+ ^(let ((,fun-sym ,fun-ref)
+ (,desc-sym (ffi-make-call-desc ,nargs ,nfixed
+ (ffi-type-compile ',rettype)
+ [mapcar ffi-type-compile
+ ',argtypes]
+ ',name)))
(defun ,name ,arg-syms
- (ffi-call ,fun-sym ,call-desc-sym ,*arg-syms)))))))
+ (ffi-call ,fun-sym ,desc-sym ,*arg-syms)))))))
(defmacro deffi-type (name type-expr)
^(ffi-typedef ',name (ffi-type-compile ',type-expr)))
@@ -87,19 +89,17 @@
^(ffi-typedef ',name (ffi-type-compile ',type-expr)))
(defun sys:deffi-cb-expander (f name rettype argtypes safe-p abort-retval)
- (let ((ret-type-sym (gensym "ret-type-"))
- (arg-types-sym (gensym "arg-types-"))
- (call-desc-sym (gensym "call-desc-"))
- (fun-sym (gensym "fun-")))
+ (let ((fun-sym (gensym "fun-"))
+ (desc-sym (gensym "desc-")))
(tree-bind (nargs nvariadic . argtypes) (sys:analyze-argtypes f argtypes)
- ^(progn
- (defvarl ,ret-type-sym (ffi-type-compile ',rettype))
- (defvarl ,arg-types-sym [mapcar ffi-type-compile ',argtypes])
- (defvarl ,call-desc-sym (ffi-make-call-desc ,nargs ,nvariadic
- ,ret-type-sym
- ,arg-types-sym))
+ ^(let ((,desc-sym (ffi-make-call-desc ,nargs ,nvariadic
+ (ffi-type-compile ',rettype)
+ [mapcar ffi-type-compile
+ ',argtypes]
+ ',name)))
(defun ,name (,fun-sym)
- [ffi-make-closure ,fun-sym ,call-desc-sym ,safe-p ,abort-retval])))))
+ [ffi-make-closure ,fun-sym ,desc-sym
+ ,safe-p ,abort-retval])))))
(defmacro deffi-cb (:form f name rettype argtypes : abort-retval)
(sys:deffi-cb-expander f name rettype argtypes t abort-retval))
@@ -122,6 +122,12 @@
(defvarl ,var-sym (carray-cptr ,var-ref ,type-sym 1))
(defsymacro ,name (carray-ref ,var-sym 0)))))
+(defmacro deffi-struct (name . body)
+ ^(typedef ,name (struct ,name ,*body)))
+
+(defmacro deffi-union (name . body)
+ ^(typedef ,name (union ,name ,*body)))
+
(defmacro sizeof (type : (obj nil obj-p) :env menv)
(if obj-p
(if (constantp obj menv)
@@ -145,19 +151,15 @@
(ffi-elemsize (ffi-type-compile type)))
(defmacro ffi (type)
- ^(ffi-type-compile ',type))
+ ^(load-time (ffi-type-compile ',type)))
(define-accessor carray-ref carray-refset)
(defset carray-sub (carray : (from 0) (to t)) items
- (with-gensyms (it)
- ^(alet ((,it ,items))
- (progn (carray-replace ,carray ,it ,from ,to) ,it))))
+ ^(progn (carray-replace ,carray ,items ,from ,to) ,items))
(defset sub-buf (buf : (from 0) (to t)) items
- (with-gensyms (it)
- ^(alet ((,it ,items))
- (progn (replace-buf ,buf ,it ,from ,to) ,it))))
+ ^(progn (replace-buf ,buf ,items ,from ,to) ,items))
(defmacro znew (type . pairs)
(if (oddp (length pairs))
@@ -165,3 +167,10 @@
'znew))
(let ((qpairs (mappend (aret ^(',@1 ,@2)) (tuples 2 pairs))))
^(make-zstruct (ffi ,type) ,*qpairs)))
+
+(defmacro setjmp (:form f jmp-buf longjmp-var try-expr . longjmp-exprs)
+ (unless (bindable longjmp-var)
+ (compile-error f "~s is not a bindable symbol" longjmp-var))
+ ^(sys:rt-setjmp ,jmp-buf
+ (lambda () ,try-expr)
+ (lambda (,longjmp-var) ,*longjmp-exprs)))
diff --git a/share/txr/stdlib/getopts.tl b/stdlib/getopts.tl
index b98a76dc..e469228c 100644
--- a/share/txr/stdlib/getopts.tl
+++ b/stdlib/getopts.tl
@@ -1,4 +1,4 @@
-;; Copyright 2016-2020
+;; Copyright 2016-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,23 +6,24 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(defex opt-error error)
@@ -67,20 +68,26 @@
`@(if (> (length name) 1) "-")-@name`)
(defmeth opt-desc basic-type-p (me type)
- (or (functionp type) (fboundp type) (member type me.valid-types)))
+ (tree-case type
+ ((type name) (and (neq type :bool)
+ me.(basic-type-p type)
+ (stringp name)))
+ (type (or (functionp type) (fboundp type) (member type me.valid-types)))))
(defmeth opt-desc list-type-p (me type)
(tree-case type
((indicator btype) (and (eq indicator 'list)
+ (neq btype :bool)
me.(basic-type-p btype)))
- (x nil)))
+ (t nil)))
(defmeth opt-desc cumul-type-p (me type)
(tree-case type
((indicator btype) (and (eq indicator 'usr:cumul)
+ (neq btype :bool)
(or me.(basic-type-p btype)
me.(list-type-p btype))))
- (x nil)))
+ (t nil)))
(defmeth opt-desc check (me)
(unless (or me.(basic-type-p me.type)
@@ -105,7 +112,7 @@
(when (and (neq type :bool)
(eq me.arg :explicit-no))
(sys:opt-err "Non-Boolean option ~a explicitly specified as false" name))
- (caseql type
+ (caseql [[iffi [andf consp [chain car keywordp]] car] type]
(:bool
(set me.arg (neq me.arg :explicit-no)))
(:dec (set me.arg
@@ -123,7 +130,7 @@
(:cint (set me.arg
(cond
((r^$ #/[+\-]?0x[\da-fA-F]+/ me.arg)
- (int-str (regsub #/0x/ "" me.arg) 16))
+ (int-str (regsub "0x" "" me.arg) 16))
((r^$ #/[+\-]?0[0-7]+/ me.arg)
(int-str me.arg 8))
((r^$ #/[+\-]?0[\da-fA-F]+/ me.arg)
@@ -225,7 +232,7 @@
opts.(add-opt (new (sys:opt-parsed o arg od))))
(sys:opt-err "unrecognized option: -~a" o))))
-(defmeth sys:opt-processor parse-opts (me args)
+(defmeth sys:opt-processor parse-opts (me)
(let ((opts me.opts))
(whilet ((arg (pop opts.out-args)))
(cond
@@ -266,50 +273,61 @@
(defun getopts (opt-desc-list args)
(let* ((opts (new opts in-args args out-args args))
(opr (new sys:opt-processor od-list opt-desc-list opts opts)))
- opr.(parse-opts args)))
+ opr.(parse-opts)))
-(defun opthelp (opt-desc-list : (stream *stdout*))
- (let ((sorted [sort (copy-list (remove-if (op null @1.helptext)
- opt-desc-list)) :
- (do if @1.long @1.long @1.short)])
+(defun opthelp (opt-desc-list : (*stdout* *stdout*))
+ (let ((sorted [nsort (copy-list (remove-if (op null @1.helptext)
+ opt-desc-list)) :
+ (do if @1.long @1.long @1.short)])
(undocumented (keep-if (op null @1.helptext) opt-desc-list)))
- (put-line "\nOptions:\n")
- (each ((od sorted))
- (let* ((type (if (and (consp od.type) (eq (car od.type) 'cumul))
- (cadr od.type)
- od.type))
- (tstr (cond
- ((keywordp type) (upcase-str (symbol-name type)))
- ((and (consp type) (eq (car type) 'list))
- (let ((ts (upcase-str (symbol-name (cadr type)))))
- `@ts[,@ts...]`))
- (t "ARG")))
- (long (if od.long
- `--@{od.long}@(if od.arg-p `=@tstr`)`))
- (short (if od.short
- `-@{od.short}@(if od.arg-p ` @tstr`)`))
- (ls (cond
- ((and long short) `@{long 21} (@short)`)
- (long long)
- (short `@{"" 21} @short`)))
- (lines (if od.helptext (sys:wdwrap od.helptext 43))))
- (put-line ` @{ls 34}@(pop lines)`)
- (while lines
- (put-line ` @{"" 34}@(pop lines)`))))
(put-line)
+ (when sorted
+ (put-line "Options:\n")
+ (each ((od sorted))
+ (let* ((type (if (and (consp od.type) (eq (car od.type) 'cumul))
+ (cadr od.type)
+ od.type))
+ (tstr (cond
+ ((keywordp type) (upcase-str (symbol-name type)))
+ ((not (consp type)) "ARG")
+ ((eq (car type) 'list)
+ (let ((ts (ifa (consp (cadr type))
+ (cadr it)
+ (upcase-str (symbol-name it)))))
+ `@ts[,@ts...]`))
+ (t (cadr type))))
+ (long (if od.long
+ `--@{od.long}@(if od.arg-p `=@tstr`)`))
+ (short (if od.short
+ `-@{od.short}@(if od.arg-p ` @tstr`)`))
+ (ls (cond
+ ((and long short) `@{long 21} (@short)`)
+ (long long)
+ (short `@{"" 21} @short`)))
+ (lines (if od.helptext (sys:wdwrap od.helptext 43))))
+ (if (>= (len ls) 34)
+ (put-line ` @ls`)
+ (put-line ` @{ls 34}@(pop lines)`))
+ (while lines
+ (put-line ` @{"" 34}@(pop lines)`))))
+ (put-line))
(when undocumented
(put-line "Undocumented options:\n")
(let* ((undoc-str `@{[mapcar sys:opt-dash
(flatten (mappend (op list @1.short @1.long)
undocumented))] ", "}`))
- (each ((line (sys:wdwrap undoc-str 75)))
- (put-line ` @line`)))
- (put-line))
- (put-line "Notes:\n")
- (let* ((have-short (some sorted (usl short)))
- (have-long (some sorted (usl long)))
- (have-arg-p (some sorted (usl arg-p)))
- (have-bool (some sorted (op eq @1.type :bool)))
+ (each ((line (sys:wdwrap undoc-str 77)))
+ (put-line ` @line`)))
+ (put-line))))
+
+(defun opthelp-conventions (opt-desc-list : (*stdout* *stdout*))
+ (let ((documented (remove-if (op null @1.helptext) opt-desc-list))
+ (undocumented (keep-if (op null @1.helptext) opt-desc-list)))
+ (put-line "Option conventions:\n")
+ (let* ((have-short (some documented (usl short)))
+ (have-long (some documented (usl long)))
+ (have-arg-p (some documented (usl arg-p)))
+ (have-bool (some documented (op eq @1.type :bool)))
(texts (list (if have-short
"Short options can be invoked with long syntax: \ \
for example, --a can be used when -a exists.\ \
@@ -323,54 +341,78 @@
"All options are Boolean:")))
(if have-bool
"they are true when present, false when absent.")
- (if (and have-bool have-arg-p)
- "The --no- prefix can explicitly specify \ \
- Boolean options as false: if a Boolean option\ \
- X exists,\ \
- --no-X specifies it as false. This is useful\ \
- for making false those options which default\ \
- to true. "
- "The --no- prefix can explicitly specify \ \
- options as false: if an X option exists,\ \
- --no-X specifies it as false. This is useful\ \
- for making false those options which default\ \
- to true. ")
- (if (not have-long)
- "Note the double dash on --no.")
- (if (and have-short have-long)
- "The --no- prefix can be applied to a short\ \
- or long option name.")
- (if have-arg-p
+ (if have-bool
+ (if have-arg-p
+ "The --no- prefix can explicitly specify\ \
+ Boolean options as false: if a Boolean option\ \
+ X exists,\ \
+ --no-X specifies it as false. This is useful\ \
+ for making false those options which default\ \
+ to true."
+ "The --no- prefix can explicitly specify\ \
+ options as false: if an X option exists,\ \
+ --no-X specifies it as false. This is useful\ \
+ for making false those options which default\ \
+ to true."))
+ (if have-bool
+ (if (not have-long)
+ "Note the double dash on --no."
+ (if have-short
+ "The --no- prefix can be applied to a short\ \
+ or long option name.")))
+ (if (and have-long have-arg-p)
"The argument to a long option can be given in one\ \
argument as --option=arg or as a separate\ \
argument using --option arg.")
"The special argument -- can be used where an option\ \
- may appear. It means \"end of options\": the\ \
- arguments which follow are not treated as options\ \
- even if they look like options.")))
+ may appear. It means \"end of options\": the\ \
+ arguments which follow are not treated as options\ \
+ even if they look like options.")))
(mapdo (do put-line ` @1`)
(sys:wdwrap `@{(flatten texts)}` 77)))
- (put-line)
- (whenlet ((types (keep-if [andf keywordp (op neq :bool)]
- (uniq (mapcar (usl type) sorted)))))
- (put-line "Type legend:\n")
- (each ((ty types))
- (iflet ((ln (caseql ty
- (:dec " DEC - Decimal integer: -123, 0, 5, +73")
- (:hex " HEX - Hexadecimal integer -EF, 2D0, +9A")
- (:oct " OCT - Octal integer: -773, 5677, +326")
- (:cint " CINT - C-style integer: leading 0 octal,\
- \ leading 0x hex, else decimal;\n\
- \ leading sign allowed: -0777, 0xFDC, +123")
- (:float " FLOAT - Floating-point: -1.3e+03, +5, 3.3,\
- \ 3., .5, .12e9, 53.e-3, 3e-015")
- (:str " STR - String with embedded escapes, valid\
- \ as TXR Lisp string literals\n\
- \ syntax: foo, foo\\tbar, abc\\nxyz")
- (:text " TEXT - Unprocessed text"))))
- (put-line ln)))
- (put-line))))
+ (put-line)))
+(defun opthelp-types (opt-desc-list : (*stdout* *stdout*))
+ (whenlet ((documented (remove-if (op null @1.helptext) opt-desc-list))
+ (types (keep-if [andf keywordp (op neq :bool)]
+ (uniq (mapcar (chain (usl type)
+ (ldo match-ecase
+ ((@(or list cumul) @type)
+ @(rec type))
+ ((@type @nil) type)
+ (@type type)))
+ documented))))
+ (entries (isec
+ '((:dec " DEC - Decimal integer: -123, 0, 5, +73")
+ (:hex " HEX - Hexadecimal integer: -EF, 2D0, +9A")
+ (:oct " OCT - Octal integer: -773, 5677, +326")
+ (:cint " CINT - C-style integer: leading 0 octal,\
+ \ leading 0x hex, else decimal;\n\
+ \ leading sign allowed: -0777, 0xFDC,\
+ \ +123")
+ (:float " FLOAT - Floating-point: -1.3e+03, +5, 3.3,\
+ \ 3., .5, .12e9, 53.e-3, 3e-015")
+ (:str " STR - String with embedded escapes, valid\
+ \ as TXR Lisp string literal\n\
+ \ syntax: foo, foo\\tbar, abc\\nxyz")
+ (:text " TEXT - Unprocessed text"))
+ types : [iffi consp car])))
+ (put-line "Type legend:\n")
+ (mapdo (tb ((btype legend))
+ ;; TODO Make coherent the punctuation?
+ (put-line legend)
+ (whenlet ((names (uniq (mappend (chain (usl type)
+ (ldo match-case
+ ((@(or list cumul) @type)
+ @(rec type))
+ ((@btype @name)
+ (list name))))
+ documented))))
+ (mapdo (do put-line `@{"" 10}@1`)
+ (sys:wdwrap `Arguments of this type:\
+ \ @(cat-str names #\ )` 69))))
+ entries)
+ (put-line)))
(defstruct sys:option-base nil
in-args
@@ -386,12 +428,16 @@
(:method getopts (me args)
(set me.in-args args me.out-args args)
(let ((opr (new sys:opt-processor od-list me.opt-desc-list opts me)))
- opr.(parse-opts args)))
+ opr.(parse-opts)))
(:method opthelp (me : (stream *stdout*))
- (opthelp me.opt-desc-list stream)))
+ (opthelp me.opt-desc-list stream))
+ (:method opthelp-conventions (me : (stream *stdout*))
+ (opthelp-conventions me.opt-desc-list stream))
+ (:method opthelp-types (me : (stream *stdout*))
+ (opthelp-types me.opt-desc-list stream)))
(defmacro define-option-struct (name super-spec . opts)
- (let* ((slots (mapcar (tb ((short long . rest))
+ (let* ((slots (mapcar (tb ((short long . t))
(or long short))
opts))
(supers (if (and super-spec (atom super-spec))
diff --git a/stdlib/getput.tl b/stdlib/getput.tl
new file mode 100644
index 00000000..aa28b56d
--- /dev/null
+++ b/stdlib/getput.tl
@@ -0,0 +1,212 @@
+;; Copyright 2016-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defun sys:get-buf-common (s bytes seek)
+ (let ((b (make-buf 0 0 (min bytes 4096)))
+ (o 0))
+ (when (plusp seek)
+ (unless (ignerr (seek-stream s seek :from-current))
+ (let ((b (make-buf (min seek 4096)))
+ (c 0))
+ (while (< c seek)
+ (let ((p (fill-buf b 0 s)))
+ (if (zerop p)
+ (return))
+ (inc c p))))))
+ (while (or (null bytes) (< (len b) bytes))
+ (let ((p (fill-buf-adjust b o s)))
+ (when (= p o)
+ (return))
+ (set o p)
+ (when (eql p (buf-alloc-size b))
+ (buf-set-length b (min (+ p p) bytes)))))
+ b))
+
+(defun get-jsons (: (s *stdin*))
+ (when (stringp s)
+ (set s (make-string-byte-input-stream s)))
+ (build
+ (catch*
+ (while t
+ (add (get-json s)))
+ (syntax-error (type . args)
+ (if (parse-errors s)
+ (throw type . args))))))
+
+(defun put-jsons (list : (s *stdout*) flat-p)
+ (each ((obj list))
+ (put-jsonl obj s flat-p))
+ t)
+
+(defun put-objects (list : (s *stdout*))
+ (each ((obj list))
+ (prinl obj s)
+ t))
+
+(defun file-get (name : mopt)
+ (with-stream (s (open-file name `r@mopt`))
+ (read s)))
+
+(defun file-put (name obj : mopt)
+ (with-stream (s (open-file name `w@mopt`))
+ (prinl obj s)))
+
+(defun file-append (name obj : mopt)
+ (with-stream (s (open-file name `a@mopt`))
+ (prinl obj s)))
+
+(defun file-get-objects (name : mopt (err-stream :))
+ (with-stream (s (open-file name `r@mopt`))
+ (read-objects s err-stream)))
+
+(defun file-put-objects (name seq : mopt)
+ (with-stream (s (open-file name `w@mopt`))
+ (put-objects seq s)))
+
+(defun file-append-objects (name seq : mopt)
+ (with-stream (s (open-file name `a@mopt`))
+ (put-objects seq s)))
+
+(defun file-get-string (name : mopt)
+ (with-stream (s (open-file name `r@mopt`))
+ (get-string s)))
+
+(defun file-put-string (name string : mopt)
+ (with-stream (s (open-file name `w@mopt`))
+ (put-string string s)))
+
+(defun file-append-string (name string : mopt)
+ (with-stream (s (open-file name `a@mopt`))
+ (put-string string s)))
+
+(defun file-get-lines (name : mopt)
+ (get-lines (open-file name `r@mopt`)))
+
+(defun file-put-lines (name lines : mopt)
+ (with-stream (s (open-file name `w@mopt`))
+ (put-lines lines s)))
+
+(defun file-append-lines (name lines : mopt)
+ (with-stream (s (open-file name `a@mopt`))
+ (put-lines lines s)))
+
+(defun file-get-buf (name : bytes (seek 0) mopt)
+ (with-stream (s (open-file name `rb@(if bytes "u")@mopt`))
+ (sys:get-buf-common s bytes seek)))
+
+(defun file-put-buf (name buf : (seek 0) mopt)
+ (with-stream (s (open-file name `wb@mopt`))
+ (unless (zerop seek)
+ (seek-stream s seek :from-current))
+ (put-buf buf 0 s)))
+
+(defun file-place-buf (name buf : (seek 0) mopt)
+ (with-stream (s (open-file name `mb@mopt`))
+ (unless (zerop seek)
+ (seek-stream s seek :from-current))
+ (put-buf buf 0 s)))
+
+(defun file-append-buf (name buf : mopt)
+ (with-stream (s (open-file name `ab@mopt`))
+ (put-buf buf 0 s)))
+
+(defun file-get-json (name : mopt)
+ (with-stream (s (open-file name `r@mopt`))
+ (get-json s)))
+
+(defun file-put-json (name obj : flat-p mopt)
+ (with-stream (s (open-file name `w@mopt`))
+ (put-jsonl obj s flat-p)))
+
+(defun file-append-json (name obj : flat-p mopt)
+ (with-stream (s (open-file name `a@mopt`))
+ (put-jsonl obj s flat-p)))
+
+(defun file-get-jsons (name : mopt)
+ (with-stream (s (open-file name `r@mopt`))
+ (get-jsons s)))
+
+(defun file-put-jsons (name seq : flat-p mopt)
+ (with-stream (s (open-file name `w@mopt`))
+ (put-jsons seq s flat-p)))
+
+(defun file-append-jsons (name seq : flat-p mopt)
+ (with-stream (s (open-file name `a@mopt`))
+ (put-jsons s seq flat-p)))
+
+(defun command-get (cmd : mopt)
+ (with-stream (s (open-command cmd `r@mopt`))
+ (read s)))
+
+(defun command-put (cmd obj : mopt)
+ (with-stream (s (open-command cmd `w@mopt`))
+ (prinl obj s)))
+
+(defun command-get-string (cmd : mopt)
+ (with-stream (s (open-command cmd `r@mopt`))
+ (get-string s)))
+
+(defun command-put-string (cmd string : mopt)
+ (with-stream (s (open-command cmd `w@mopt`))
+ (put-string string s)))
+
+(defun command-get-lines (cmd : mopt)
+ (get-lines (open-command cmd `r@mopt`)))
+
+(defun command-put-lines (cmd lines : mopt)
+ (with-stream (s (open-command cmd `w@mopt`))
+ (put-lines lines s)))
+
+(defun command-get-buf (cmd : bytes (skip 0))
+ (with-stream (s (open-command cmd (if bytes "rbu" "rb")))
+ (sys:get-buf-common s bytes skip)))
+
+(defun command-put-buf (cmd buf : mopt)
+ (with-stream (s (open-command cmd `wb@mopt`))
+ (put-buf buf 0 s)))
+
+(defun command-get-json (cmd : mopt)
+ (with-stream (s (open-command cmd `r@mopt`))
+ (get-json s)))
+
+(defun command-put-json (cmd obj : flat-p mopt)
+ (with-stream (s (open-command cmd `w@mopt`))
+ (put-jsonl obj s flat-p)))
+
+(defun command-get-jsons (cmd : mopt)
+ (with-stream (s (open-command cmd `r@mopt`))
+ (get-jsons s)))
+
+(defun command-put-jsons (cmd seq : flat-p mopt)
+ (with-stream (s (open-command cmd `w@mopt`))
+ (put-jsons seq s flat-p)))
+
+(defmacro close-lazy-streams (. body)
+ ^(let ((sys:*lazy-streams*))
+ (unwind-protect
+ (progn ,*body))
+ (mapdo (fun close-stream) sys:*lazy-streams*)))
diff --git a/stdlib/glob.tl b/stdlib/glob.tl
new file mode 100644
index 00000000..af6fef2c
--- /dev/null
+++ b/stdlib/glob.tl
@@ -0,0 +1,93 @@
+;; Copyright 2023-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defun brace-expand (str)
+ (bexp-expand (bexp-parse str)))
+
+(defstruct bexp-parse-ctx ()
+ str
+ toks)
+
+(defun bexp-parse (str)
+ (let ((ctx (new bexp-parse-ctx
+ str str
+ toks (remqual "" (tok #/([{},]|{}|\\\\|\\.)/ t str)))))
+ (build
+ (whilet ((next (pop ctx.toks)))
+ (add
+ (if (equal next "{")
+ (bexp-parse-brace ctx)
+ next))))))
+
+(defun bexp-parse-brace (ctx)
+ (buildn
+ (caseq (whilet ((next (pop ctx.toks)))
+ (casequal next
+ ("{" (add (bexp-parse-brace ctx)))
+ ("}" (return :ok))
+ (t (add next))))
+ (:ok
+ (cond
+ ((memqual "," (get))
+ (flow (get)
+ (split* @1 (op where (op equal ",")))
+ (cons '/)))
+ (t
+ (add* "{")
+ (add "}")
+ (get))))
+ (nil
+ (add* "{")
+ (get)))))
+
+(defun bexp-expand (tree : (path (new list-builder)))
+ (build
+ (match-case tree
+ (() (add (cat-str path.(get))))
+ (((/ . @alt) . @rest)
+ (let ((saved-path path.(get)))
+ (each ((elem alt))
+ path.(oust saved-path)
+ (pend (bexp-expand (cons elem rest) path)))))
+ ((@(consp @succ) . @rest)
+ (pend (bexp-expand (append succ rest) path)))
+ ((@head . @rest)
+ path.(add head)
+ (pend (bexp-expand rest path))))))
+
+
+(defun glob* (pattern-or-patterns : (flags 0))
+ (let ((xflags (logior flags sys:glob-xstar))
+ (patterns (if (listp pattern-or-patterns)
+ pattern-or-patterns
+ (list pattern-or-patterns))))
+ (if (or (logtest flags glob-xnobrace)
+ (null (find-if (op find #\{) patterns)))
+ (glob patterns xflags)
+ (let ((xpatterns [mappend brace-expand patterns]))
+ (append-each ((p xpatterns))
+ (glob p xflags))))))
diff --git a/share/txr/stdlib/hash.tl b/stdlib/hash.tl
index 96d2e705..7e6d4361 100644
--- a/share/txr/stdlib/hash.tl
+++ b/stdlib/hash.tl
@@ -1,4 +1,4 @@
-;; Copyright 2015-2020
+;; Copyright 2015-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,23 +6,24 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(defmacro with-hash-iter ((name hash-form : key val) . body)
(let ((hash (gensym))
diff --git a/share/txr/stdlib/ifa.tl b/stdlib/ifa.tl
index c1c32538..e76cbd25 100644
--- a/share/txr/stdlib/ifa.tl
+++ b/stdlib/ifa.tl
@@ -1,4 +1,4 @@
-;; Copyright 2015-2020
+;; Copyright 2015-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,23 +6,24 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(defmacro ifa (:env e :form f test then : else)
(flet ((candidate-p (form)
@@ -54,7 +55,7 @@
(let* ((btemps (mapcar (ret (gensym)) before-it))
(atemps (mapcar (ret (gensym)) after-it)))
^(let (,*(zip btemps before-it))
- (placelet ((it ,it-form))
+ (placelet ((it (read-once ,it-form)))
(let (,*(zip atemps after-it))
(if (,sym ,*(if (eq 'dwim sym) ^(,(second test)))
,*btemps it ,*atemps)
@@ -68,15 +69,16 @@
(defmacro whena (test . body)
^(ifa ,test (progn ,*body)))
-(defun sys:if-to-cond (f if-oper cond-oper pairs)
- (tree-case pairs
- (((test . forms) . rest) ^(,if-oper ,test (progn ,*forms)
- (,cond-oper ,*rest)))
- (() ())
- (else (compile-error f "bad syntax: ~s" pairs))))
+(defun sys:if-to-cond (f if-oper pairs)
+ (with-gensyms (res)
+ ^(let (,res)
+ (or ,*(collect-each ((c pairs))
+ (mac-param-bind f (test . forms) c
+ ^(,if-oper ,test (progn (set ,res (progn ,*forms)) t)))))
+ ,res)))
(defmacro conda (:form f . pairs)
- (sys:if-to-cond f 'ifa 'conda pairs))
+ (sys:if-to-cond f 'ifa pairs))
(defmacro condlet (:form f . pairs)
- (sys:if-to-cond f 'iflet 'condlet pairs))
+ (sys:if-to-cond f 'iflet pairs))
diff --git a/stdlib/keyparams.tl b/stdlib/keyparams.tl
new file mode 100644
index 00000000..da9cfbc5
--- /dev/null
+++ b/stdlib/keyparams.tl
@@ -0,0 +1,78 @@
+;; Copyright 2017-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defun sys:stuff-key-params (keys args)
+ (with-gensyms (cell)
+ (collect-each ((k keys))
+ (tree-bind (sym : init sym-p) k
+ (let ((kw (intern (symbol-name sym) :keyword)))
+ ^(let ((,cell (memp ,kw ,args)))
+ ,(if init
+ ^(cond
+ (,cell
+ (set ,sym (cadr ,cell))
+ ,*(if sym-p ^((set ,sym-p t))))
+ (t
+ (set ,sym ,init)))
+ ^(when ,cell
+ (set ,sym (cadr ,cell))
+ ,*(if sym-p ^((set ,sym-p t)))))))))))
+
+(define-param-expander :key (param body menv form)
+ (ignore menv)
+ (let* ((excluding-rest (butlastn 0 param))
+ (key-start (memq '-- excluding-rest))
+ (rest-param (or (nthlast 0 param) (gensym)))
+ (before-key (ldiff excluding-rest key-start))
+ (key-params-raw (butlastn 0 (cdr key-start)))
+ (key-params [mapcar [iffi atom (op list @1)] key-params-raw])
+ (eff-param (append before-key rest-param)))
+ (each ((key-spec key-params))
+ (tree-case key-spec
+ ((t t var-p . junk)
+ (when (consp junk)
+ (compile-error form "superfluous forms in ~s" key-spec))
+ (when junk
+ (compile-error form "invalid dotted form ~s" key-spec))
+ (unless (bindable var-p)
+ (compile-error form "~s isn't a bindable symbol" var-p))
+ :)
+ ((t t . more)
+ (unless (listp more)
+ (compile-error form "invalid dotted form ~s" key-spec))
+ :)
+ ((sym . more)
+ (unless (listp more)
+ (compile-error form "invalid dotted form ~s" key-spec))
+ (unless (bindable sym)
+ (compile-error form "~s isn't a bindable symbol" sym)))))
+ (let* ((key-syms [mapcar first key-params])
+ (key-syms-p (remq nil [mapcar third key-params])))
+ (list eff-param
+ ^(let (,*key-syms ,*key-syms-p)
+ ,*(sys:stuff-key-params key-params rest-param)
+ ,*body)))))
diff --git a/stdlib/load-args.tl b/stdlib/load-args.tl
new file mode 100644
index 00000000..50b67679
--- /dev/null
+++ b/stdlib/load-args.tl
@@ -0,0 +1,49 @@
+;; Copyright 2023-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defun load-args-recurse (. files)
+ (if-match (@(listp @list)) files
+ (set files list))
+ (each ((file files))
+ (load file . *load-args*)))
+
+(defun load-args-process (. files)
+ (if-match (@(listp @list)) files
+ (set files list))
+ (match-case *load-args*
+ ((:compile)
+ (let* ((lp (base-name *load-path*))
+ (self (if-match @(or `@name.tlo`
+ `@name.tlo.gz`) lp
+ name lp)))
+ (compile-update-file self))
+ (mapdo [orf compile-update-file load] files))
+ ((:clean)
+ (clean-file (base-name *load-path*))
+ [mapdo clean-file files])
+ (@else
+ [mapdo (op load @1 . else) files])))
diff --git a/stdlib/match.tl b/stdlib/match.tl
new file mode 100644
index 00000000..12479fab
--- /dev/null
+++ b/stdlib/match.tl
@@ -0,0 +1,1161 @@
+;; Copyright 2021-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defvar *match-form*)
+
+(defvar *match-macro* (hash))
+
+(defex match-error eval-error)
+
+(defstruct match-guard ()
+ temps
+ vars
+ var-exprs
+ pure-temps
+ pure-temp-exprs
+ (guard-expr t)
+ (test-expr t)
+
+ (:method assignments (me)
+ (mapcar (op list 'set) me.vars me.var-exprs))
+
+ (:method lets (me)
+ (zip me.pure-temps me.pure-temp-exprs))
+
+ (:method wrap-expr (g exp)
+ (let ((lets g.(lets))
+ (temps g.temps))
+ (if (neq t g.test-expr)
+ (set exp ^(if ,g.test-expr ,exp)))
+ (cond
+ ((and lets temps)
+ (set exp ^(alet ,lets
+ (let ,temps
+ ,*g.(assignments)
+ ,exp))))
+ (lets
+ (set exp ^(alet ,lets
+ ,*g.(assignments)
+ ,exp)))
+ (temps
+ (set exp ^(let ,temps
+ ,*g.(assignments)
+ ,exp)))
+ (t
+ (set exp ^(progn ,*g.(assignments)
+ ,exp))))
+ (when (neq t g.guard-expr)
+ (set exp ^(if ,g.guard-expr ,exp)))
+ exp)))
+
+(defstruct guard-disjunction ()
+ guard-chains
+ sub-patterns
+ all-vars
+
+ (:method wrap-expr (g exp)
+ (let* ((vars [mapcar get-vars g.guard-chains])
+ (back-vars (cons nil
+ (reverse
+ [mapcar (ap append) (conses (reverse vars))])))
+ (branches (collect-each ((gc g.guard-chains)
+ (v vars)
+ (bv back-vars))
+ ^(progn
+ (set ,*(mappend (ret ^(,@1 nil)) (diff bv v)))
+ ,(reduce-right (umeth wrap-expr) gc t)))))
+ (set exp ^(when (or ,*branches)
+ ,exp))
+ exp)))
+
+(defstruct compiled-match ()
+ pattern
+ obj-var
+ guard-chain
+
+ (:method get-vars (me)
+ (uniq (get-vars me.guard-chain)))
+
+ (:method wrap-guards (me . forms)
+ (reduce-right (umeth wrap-expr) me.guard-chain ^(progn ,*forms)))
+
+ (:method add-guard-pre (me guard)
+ (push guard me.guard-chain))
+
+ (:method add-guards-pre (me . guards)
+ (set me.guard-chain
+ (append guards
+ me.guard-chain)))
+
+ (:method add-guards-post (me . guards)
+ (set me.guard-chain
+ (append me.guard-chain
+ guards))))
+
+(defstruct var-list ()
+ vars
+ menv
+
+ (:method exists (me sym) (or (member sym me.vars)
+ (lexical-binding-kind me.menv sym)
+ (boundp sym)))
+ (:method record (me sym) (push sym me.vars))
+ (:method merge (me copy) (each ((v copy.vars)) (pushnew v me.vars))))
+
+(defun get-vars (guard-chain)
+ (append-each ((g guard-chain))
+ (typecase g
+ (match-guard
+ g.vars)
+ (guard-disjunction
+ (append-each ((gc g.guard-chains)) (get-vars gc)))
+ (t (compile-error *match-form*
+ "internal error: bad guard ~s" g)))))
+
+(defun compile-struct-match (struct-pat obj-var var-list)
+ (mac-param-bind *match-form* (t required-type . pairs) struct-pat
+ (let* ((loose-p (not (bindable required-type)))
+ (slot-pairs (plist-to-alist pairs))
+ (required-slots [mapcar car slot-pairs])
+ (slot-gensyms [mapcar gensym required-slots])
+ (type-gensym (if loose-p
+ (gensym "type-")))
+ (slot-patterns [mapcar cdr slot-pairs])
+ (slot-matches [mapcar (lop compile-match var-list)
+ slot-patterns slot-gensyms])
+ (type-match (if loose-p
+ (compile-match required-type type-gensym var-list)))
+ (slot-val-exprs [mapcar (ret ^(slot ,obj-var ',@1)) required-slots])
+ (guard0 (if loose-p
+ (list (new match-guard
+ pure-temps (list type-gensym)
+ pure-temp-exprs (list ^(struct-type ,obj-var))
+ guard-expr ^(structp ,obj-var)))))
+ (guard1 (list (new match-guard
+ pure-temps slot-gensyms
+ pure-temp-exprs slot-val-exprs
+ guard-expr (if loose-p
+ ^(and ,*(mapcar
+ (ret ^(slotp ,type-gensym
+ ',@1))
+ required-slots))
+ ^(typep ,obj-var ',required-type))))))
+ (unless loose-p
+ (let ((type (find-struct-type required-type)))
+ (if type
+ (each ((slot required-slots))
+ (unless (slotp type slot)
+ (compile-defr-warning *match-form* ^(slot . ,slot)
+ "~s has no slot ~s"
+ required-type slot)))
+ (compile-defr-warning *match-form* ^(struct-type . ,required-type)
+ "no such struct type: ~s"
+ required-type))))
+ (new compiled-match
+ pattern struct-pat
+ obj-var obj-var
+ guard-chain (append guard0
+ type-match.?guard-chain
+ guard1
+ (mappend .guard-chain slot-matches))))))
+
+(defun compile-var-match (sym obj-var var-list)
+ (cond
+ ((null sym)
+ (new compiled-match
+ obj-var obj-var))
+ ((not (bindable sym))
+ (compile-error *match-form* "~s is not a bindable symbol" sym))
+ ((not var-list.(exists sym))
+ var-list.(record sym)
+ (new compiled-match
+ pattern sym
+ obj-var obj-var
+ guard-chain (if sym (list (new match-guard
+ vars (list sym)
+ var-exprs (list obj-var))))))
+ (t (new compiled-match
+ pattern sym
+ obj-var obj-var
+ guard-chain (list (new match-guard
+ guard-expr ^(equal ,obj-var ,sym)))))))
+
+(defun compile-new-var-match (sym obj-var var-list)
+ (cond
+ ((null sym)
+ (new compiled-match
+ obj-var obj-var))
+ ((not (bindable sym))
+ (compile-error *match-form* "~s is not a bindable symbol" sym))
+ (t var-list.(record sym)
+ (new compiled-match
+ pattern sym
+ obj-var obj-var
+ guard-chain (if sym (list (new match-guard
+ vars (list sym)
+ var-exprs (list obj-var))))))))
+
+(defun compile-vec-match (vec-pat obj-var var-list)
+ (let* ((elem-gensyms (mapcar (op gensym `elem-@1-`) (range* 0 (len vec-pat))))
+ (elem-exprs (mapcar (ret ^[,obj-var ,@1]) (range* 0 (len vec-pat))))
+ (elem-matches (list-vec [mapcar (lop compile-match var-list)
+ vec-pat elem-gensyms]))
+ (pruned-triple (multi (op keep-if .guard-chain @1 third)
+ elem-gensyms
+ elem-exprs
+ elem-matches))
+ (guard (new match-guard
+ pure-temps (first pruned-triple)
+ pure-temp-exprs (second pruned-triple)
+ guard-expr ^(and (vectorp ,obj-var)
+ (eql (len ,obj-var) ,(len vec-pat))))))
+ (new compiled-match
+ pattern vec-pat
+ obj-var obj-var
+ guard-chain (cons guard (mappend .guard-chain elem-matches)))))
+
+(defun compile-range-match (range-expr obj-var var-list)
+ (let ((from (from range-expr))
+ (to (to range-expr)))
+ (let* ((from-match (compile-match from (gensym "from") var-list))
+ (to-match (compile-match to (gensym "to") var-list))
+ (guard (new match-guard
+ guard-expr ^(rangep ,obj-var)
+ pure-temps (list from-match.obj-var to-match.obj-var)
+ pure-temp-exprs (list ^(from ,obj-var) ^(to ,obj-var)))))
+ (new compiled-match
+ pattern range-expr
+ obj-var obj-var
+ guard-chain (cons guard (append from-match.guard-chain
+ to-match.guard-chain))))))
+
+(defun compile-atom-match (atom obj-var var-list)
+ (flet ((compile-as-atom ()
+ (new compiled-match
+ pattern atom
+ obj-var obj-var
+ guard-chain (list (new match-guard
+ guard-expr ^(equal ,obj-var ',atom))))))
+ (typecase atom
+ (vec (if (non-triv-pat-p atom)
+ (compile-vec-match atom obj-var var-list)
+ (compile-as-atom)))
+ (range (if (non-triv-pat-p atom)
+ (compile-range-match atom obj-var var-list)
+ (compile-as-atom)))
+ (t (compile-as-atom)))))
+
+(defun compile-predicate-match (exp obj-var var-list)
+ (let ((head (car exp)))
+ (if (and (consp head) (eq (car head) 'sys:var))
+ (tree-case exp
+ (((t rvar) (op . args))
+ (let* ((arg-var (gensym "obj-"))
+ (avar
+ (condlet
+ (((vm (member-if [andf consp (op eq (car @1) 'sys:var)]
+ args)))
+ (let ((sym (cadar vm)))
+ (if (null sym)
+ (set sym arg-var)
+ (set arg-var sym))
+ (set args (append (ldiff args vm)
+ (list sym)
+ (cdr vm)))
+ sym))
+ (((vm (memq 'sys:var args)))
+ (let ((sym (cadr vm)))
+ (if (null sym)
+ (set sym arg-var)
+ (set arg-var sym))
+ (set args (append (ldiff args vm) sym))
+ sym))))
+ (res-var (gensym "res-")))
+ (unless avar
+ (set args (append args (list arg-var))))
+ (let* ((guard (new match-guard
+ pure-temps (list res-var)
+ pure-temp-exprs ^((alet ((,arg-var ,obj-var))
+ (,op ,*args)))
+ test-expr res-var))
+ (avar-match (compile-var-match avar obj-var var-list))
+ (rvar-match (compile-var-match rvar res-var var-list)))
+ (new compiled-match
+ pattern exp
+ obj-var obj-var
+ guard-chain (append avar-match.guard-chain
+ (list guard)
+ rvar-match.guard-chain)))))
+ (else (compile-error *match-form*
+ "invalid predicate syntax: ~s" else)))
+ (compile-predicate-match (list '@nil exp) obj-var var-list))))
+
+(defun compile-cons-structure (cons-pat obj-var var-list)
+ (mac-param-bind *match-form* (car . cdr) cons-pat
+ (let* ((car-gensym (gensym))
+ (cdr-gensym (gensym))
+ (car-match (compile-match car car-gensym var-list))
+ (cdr-match (if (consp cdr)
+ (caseq (car cdr)
+ ((sys:expr sys:var sys:quasi)
+ (compile-match cdr cdr-gensym var-list))
+ (t (compile-cons-structure cdr cdr-gensym var-list)))
+ (compile-atom-match cdr cdr-gensym var-list)))
+ (guard (new match-guard
+ pure-temps (append (if car-match.guard-chain
+ (list car-gensym))
+ (if cdr-match.guard-chain
+ (list cdr-gensym)))
+ pure-temp-exprs (append (if car-match.guard-chain
+ ^((car ,obj-var)))
+ (if cdr-match.guard-chain
+ ^((cdr ,obj-var))))
+ guard-expr ^(consp ,obj-var))))
+ (new compiled-match
+ pattern cons-pat
+ obj-var obj-var
+ guard-chain (cons guard (append car-match.guard-chain
+ cdr-match.guard-chain))))))
+
+(defun compile-require-match (exp obj-var var-list)
+ (mac-param-bind *match-form* (t match . conditions) exp
+ (let ((match (compile-match match obj-var var-list)))
+ match.(add-guards-post (new match-guard
+ guard-expr ^(and ,*conditions)))
+ match)))
+
+(defun compile-as-match (exp obj-var var-list)
+ (mac-param-bind *match-form* (t sym pat) exp
+ (let ((var-match (compile-new-var-match sym obj-var var-list))
+ (pat-match (compile-match pat obj-var var-list)))
+ (new compiled-match
+ pattern exp
+ obj-var obj-var
+ guard-chain (append var-match.guard-chain
+ pat-match.guard-chain)))))
+
+(defun compile-with-match (exp obj-var var-list)
+ (tree-case exp
+ ((t main-pat side-pat-var side-expr)
+ (let* ((side-var (gensym))
+ (side-pat (if (or (null side-pat-var) (bindable side-pat-var))
+ ^(sys:var ,side-pat-var)
+ side-pat-var))
+ (main-match (compile-match main-pat obj-var var-list))
+ (side-match (compile-match side-pat side-var var-list))
+ (guard (new match-guard
+ pure-temps (list side-var)
+ pure-temp-exprs (list side-expr))))
+ (new compiled-match
+ pattern exp
+ obj-var obj-var
+ guard-chain (append main-match.guard-chain
+ (list guard)
+ side-match.guard-chain))))
+ ((op side-pat-var side-expr)
+ (compile-with-match ^(,op @nil ,side-pat-var ,side-expr) obj-var var-list))
+ (else (compile-error *match-form* "bad syntax: ~s" else))))
+
+(defun compile-loop-match (exp obj-var var-list)
+ (mac-param-bind *match-form* (op match) exp
+ (let* ((no-vac-p (memq op '(coll usr:all*)))
+ (some-p (eq op 'some))
+ (coll-p (eq op 'coll))
+ (item-var (gensym "item-"))
+ (in-vars var-list.vars)
+ (cm (compile-match match item-var var-list))
+ (loop-success-p-var (gensym "loop-success-p-"))
+ (loop-continue-p-var (gensym "loop-terminate-p"))
+ (loop-iterated-var (if no-vac-p (gensym "loop-iterated-p")))
+ (matched-p-var (gensym "matched-p-"))
+ (iter-var (gensym "iter-"))
+ (cm-vars cm.(get-vars))
+ (collect-vars (diff cm-vars in-vars))
+ (collect-gens [mapcar gensym collect-vars])
+ (loop ^(for ((,iter-var (iter-begin ,obj-var))
+ (,loop-continue-p-var t)
+ ,*(if no-vac-p ^((,loop-iterated-var nil))))
+ ((and ,loop-continue-p-var (iter-more ,iter-var))
+ ,(cond
+ (some-p ^(not ,loop-continue-p-var))
+ (no-vac-p ^(and ,loop-iterated-var
+ ,loop-continue-p-var))
+ (t loop-continue-p-var)))
+ ((set ,iter-var (iter-step ,iter-var)))
+ (let ((,cm.obj-var (iter-item ,iter-var))
+ ,matched-p-var
+ ,*(unless some-p cm-vars))
+ ,cm.(wrap-guards
+ ^(progn
+ (set ,matched-p-var t)
+ ,*(if no-vac-p
+ ^((set ,loop-iterated-var t)))
+ ,*(unless some-p
+ (mapcar (ret ^(push ,@1 ,@2))
+ collect-vars
+ collect-gens))))
+ ,(unless coll-p ^(,(if some-p 'when 'unless)
+ ,matched-p-var
+ (set ,loop-continue-p-var nil))))))
+ (guard0 (new match-guard
+ vars cm-vars
+ temps (unless some-p collect-gens)
+ guard-expr ^(seqp ,obj-var)))
+ (guard1 (new match-guard
+ vars (list loop-success-p-var)
+ var-exprs (list loop)
+ test-expr (if some-p
+ loop-success-p-var
+ ^(when ,loop-success-p-var
+ ,*(mapcar (ret ^(set ,@1 (nreverse ,@2)))
+ collect-vars collect-gens)
+ t)))))
+ (new compiled-match
+ pattern exp
+ obj-var obj-var
+ guard-chain (list guard0 guard1)))))
+
+(defun compile-or-match (par-pat obj-var var-list)
+ (mac-param-bind *match-form* (t . pats) par-pat
+ (let* ((var-lists (mapcar (ret (copy var-list)) pats))
+ (par-matches (mapcar (op compile-match @1 obj-var @2)
+ pats var-lists))
+ (dj-guard (new guard-disjunction
+ guard-chains (mapcar .guard-chain par-matches)
+ sub-patterns par-matches)))
+ (each ((vl var-lists))
+ var-list.(merge vl))
+ (new compiled-match
+ pattern par-pat
+ obj-var obj-var
+ guard-chain (list dj-guard)))))
+
+(defun compile-and-match (and-pat obj-var var-list)
+ (mac-param-bind *match-form* (t . pats) and-pat
+ (let* ((par-matches (mapcar (lop compile-match obj-var var-list) pats)))
+ (new compiled-match
+ pattern and-pat
+ obj-var obj-var
+ guard-chain (mappend .guard-chain par-matches)))))
+
+(defun compile-not-match (pattern obj-var var-list)
+ (mac-param-bind *match-form* (t pattern) pattern
+ (let* ((pm (compile-match pattern obj-var var-list))
+ (guard (new match-guard
+ guard-expr ^(not (let ,pm.(get-vars)
+ ,pm.(wrap-guards t))))))
+ (new compiled-match
+ pattern pattern
+ obj-var obj-var
+ guard-chain (list guard)))))
+
+(defun compile-hash-match (hash-expr obj-var var-list)
+ (mac-param-bind *match-form* (t . pairs) hash-expr
+ (let* ((hash-alist-var (gensym "hash-alist-"))
+ (hash-alt-val ^',(gensym "alt"))
+ (need-alist-p nil)
+ (hash-keys-var (gensym "hash-keys-"))
+ (need-keys-p nil)
+ (hash-matches
+ (collect-each ((pair pairs))
+ (mac-param-bind *match-form* (key : (val nil val-p)) pair
+ (let ((key-pat-p (non-triv-pat-p key))
+ (val-pat-p (non-triv-pat-p val))
+ (key-var-sym (var-pat-p key)))
+ (cond
+ ((and (not val-p) key-var-sym var-list.(exists key-var-sym))
+ (let ((guard (new match-guard
+ test-expr ^(inhash ,obj-var
+ ,key-var-sym))))
+ (new compiled-match
+ guard-chain (list guard))))
+ ((and (not val-p) (not key-pat-p))
+ (let ((guard (new match-guard
+ test-expr ^(inhash ,obj-var
+ ',key))))
+ (new compiled-match
+ guard-chain (list guard))))
+ ((not val-p)
+ (set need-keys-p t)
+ (compile-match key hash-keys-var var-list))
+ ((and key-var-sym var-list.(exists key-var-sym))
+ (let ((vm (compile-match val (gensym "val") var-list)))
+ vm.(add-guards-pre
+ (new match-guard
+ vars (list vm.obj-var)
+ var-exprs ^((gethash ,obj-var ,key-var-sym
+ ,hash-alt-val))
+ test-expr ^(neq ,vm.obj-var
+ ,hash-alt-val)))
+ vm))
+ ((and key-pat-p val-pat-p)
+ (set need-alist-p t)
+ (compile-match ^@(coll (,key . ,val))
+ hash-alist-var var-list))
+ (key-pat-p
+ (let ((km (compile-match key (gensym "keys")
+ var-list)))
+ km.(add-guards-pre
+ (new match-guard
+ pure-temps (list km.obj-var)
+ pure-temp-exprs ^((hash-keys-of ,obj-var
+ ',val))))
+ km))
+ (t
+ (let ((vm (compile-match val (gensym "val") var-list)))
+ vm.(add-guards-pre
+ (new match-guard
+ pure-temps (list vm.obj-var)
+ pure-temp-exprs ^((gethash ,obj-var ',key
+ ,hash-alt-val))
+ test-expr ^(neq ,vm.obj-var ,hash-alt-val)))
+ vm)))))))
+ (guard (new match-guard
+ guard-expr ^(hashp ,obj-var)
+ vars (append
+ (if need-alist-p
+ (list hash-alist-var))
+ (if need-keys-p
+ (list hash-keys-var)))
+ var-exprs (append
+ (if need-alist-p
+ (list ^(hash-alist ,obj-var)))
+ (if need-keys-p
+ (list ^(hash-keys ,obj-var)))))))
+ (new compiled-match
+ pattern hash-expr
+ obj-var obj-var
+ guard-chain (cons guard (mappend .guard-chain hash-matches))))))
+
+(defun compile-scan-match (scan-syntax obj-var var-list)
+ (mac-param-bind *match-form* (t pattern) scan-syntax
+ (with-gensyms (iter found-p cont-p success-p)
+ (let* ((cm (compile-match pattern iter var-list))
+ (loop ^(for ((,iter ,obj-var) (,cont-p t) ,found-p)
+ (,cont-p ,found-p)
+ ((cond
+ ((null ,cont-p))
+ ((consp ,iter) (set ,iter (cdr ,iter)))
+ (t (zap ,cont-p))))
+ ,cm.(wrap-guards ^(set ,found-p t ,cont-p nil))))
+ (guard (new match-guard
+ vars (cons success-p cm.(get-vars))
+ var-exprs (list loop)
+ test-expr success-p)))
+ (new compiled-match
+ pattern scan-syntax
+ obj-var obj-var
+ guard-chain (list guard))))))
+
+(defun compile-exprs-match (exprs-syntax uexprs var-list)
+ (let ((upats (cdr exprs-syntax))
+ (utemps (mapcar (ret (gensym)) uexprs)))
+ (tree-bind (pats temps t) (multi-sort (list upats utemps uexprs)
+ [list less]
+ [list non-triv-pat-p])
+ (let* ((matches (mapcar (op compile-match @1 @2 var-list)
+ pats temps)))
+ (new compiled-match
+ pattern exprs-syntax
+ obj-var nil
+ guard-chain (cons (new match-guard
+ pure-temps utemps
+ pure-temp-exprs uexprs)
+ (mappend .guard-chain matches)))))))
+
+(defun compile-match (pat : (obj-var (gensym)) (var-list (new var-list)))
+ (cond
+ ((consp pat)
+ (caseq (car pat)
+ (sys:expr
+ (let ((exp (cadr pat)))
+ (if (consp exp)
+ (let ((op (car exp)))
+ (caseq op
+ (struct (compile-struct-match exp obj-var var-list))
+ (require (compile-require-match exp obj-var var-list))
+ (usr:as (compile-as-match exp obj-var var-list))
+ (usr:with (compile-with-match exp obj-var var-list))
+ (all (compile-loop-match exp obj-var var-list))
+ (usr:all* (compile-loop-match exp obj-var var-list))
+ (some (compile-loop-match exp obj-var var-list))
+ (coll (compile-loop-match exp obj-var var-list))
+ (or (compile-or-match exp obj-var var-list))
+ (and (compile-and-match exp obj-var var-list))
+ (not (compile-not-match exp obj-var var-list))
+ (hash (compile-hash-match exp obj-var var-list))
+ (usr:scan (compile-scan-match exp obj-var var-list))
+ (exprs (compile-exprs-match exp obj-var var-list))
+ (sys:quasi (compile-match exp obj-var var-list))
+ (t (iflet ((xfun [*match-macro* op]))
+ (let* ((var-env (make-env (mapcar (lop cons
+ 'sys:special)
+ var-list.vars)
+ nil var-list.menv))
+ (xexp [xfun exp var-env]))
+ (if (neq xexp exp)
+ (compile-match xexp obj-var var-list)
+ (compile-predicate-match exp obj-var var-list)))
+ (compile-predicate-match exp obj-var var-list)))))
+ (compile-error *match-form*
+ "unrecognized pattern syntax ~s" pat))))
+ (sys:var (compile-var-match (cadr pat) obj-var var-list))
+ (sys:quasi (compile-match (expand-quasi-match (cdr pat) var-list)
+ obj-var var-list))
+ (sys:qquote (compile-match (transform-qquote (cadr pat))
+ obj-var var-list))
+ (t (if (non-triv-pat-p pat)
+ (compile-cons-structure pat obj-var var-list)
+ (compile-atom-match pat obj-var var-list)))))
+ (t (compile-atom-match pat obj-var var-list))))
+
+(defun get-var-list (env)
+ (new var-list menv env))
+
+(defmacro when-match (:form *match-form* :env e pat obj . body)
+ (let ((cm (compile-match pat : (get-var-list e))))
+ ^(alet ((,cm.obj-var ,obj))
+ (let ,cm.(get-vars)
+ ,cm.(wrap-guards . body)))))
+
+(defmacro if-match (:form *match-form* :env e pat obj then : else)
+ (let ((cm (compile-match pat : (get-var-list e)))
+ (result (gensym "result-")))
+ ^(alet ((,cm.obj-var ,obj))
+ (let* (,result ,*cm.(get-vars))
+ (if ,cm.(wrap-guards
+ ^(set ,result ,then)
+ t)
+ ,result
+ ,else)))))
+
+(defun match-pat-error (sym pat val)
+ (throwf 'match-error "~s: ~s failed to match object ~s" sym pat val))
+
+(defun match-error (sym val)
+ (throwf 'match-error "~s: failed to match object ~s" sym val))
+
+(defmacro match (pat obj . body)
+ (with-gensyms (val)
+ ^(let ((,val ,obj))
+ (if-match ,pat ,val
+ (progn ,*body)
+ (match-pat-error 'match ',pat ,val)))))
+
+(defmacro while-match (:form *match-form* :env e pat obj . body)
+ (let ((cm (compile-match pat : (get-var-list e))))
+ ^(for ()
+ ((alet ((,cm.obj-var ,obj))
+ (let ,cm.(get-vars)
+ ,cm.(wrap-guards ^(progn ,*body t)))))
+ ())))
+
+(defun non-triv-pat-p (syntax)
+ (ignore syntax)
+ t)
+
+(defun match-case-to-casequal (obj clauses)
+ (let ((dfl-cnt 0))
+ (if (and [all clauses
+ [chain car [orf [chain non-triv-pat-p not]
+ [iff (op equal '@nil)
+ (do inc dfl-cnt)]
+ (do if-match (@(eq 'sys:var) @nil) @1
+ (inc dfl-cnt))]]]
+ (< dfl-cnt 2)
+ (or (zerop dfl-cnt)
+ (non-triv-pat-p (car (first (last clauses))))))
+ (with-gensyms (otmp)
+ ^(let ((,otmp ,obj))
+ (casequal ,otmp ,*(mapcar (tb ((f . r))
+ (or (if-match (@(eq 'sys:var) nil) f
+ ^(t ,*r))
+ (if-match (@(eq 'sys:var) @sym) f
+ ^(t (let ((,sym ,otmp)) ,*r)))
+ ^((,f) ,*r)))
+ clauses)))))))
+
+(defmacro match-case (:form *match-form* :env e obj . clauses)
+ (unless [all clauses [andf proper-listp [chain len plusp]]]
+ (compile-error *match-form* "bad clause syntax"))
+ (iflet ((cq (match-case-to-casequal obj clauses)))
+ cq
+ (let* ((result-temp (gensym "result-"))
+ (objvar (gensym "obj-"))
+ (var-list (get-var-list e))
+ (clause-matches [mapcar (op compile-match (car @1)
+ objvar (copy var-list))
+ clauses])
+ (clause-code (collect-each ((cl clauses)
+ (cm clause-matches))
+ (mac-param-bind *match-form* (t . forms) cl
+ ^(let (,*cm.(get-vars))
+ ,cm.(wrap-guards ^(set ,result-temp
+ (progn ,*forms))
+ t))))))
+ ^(alet ((,objvar ,obj))
+ (let (,result-temp)
+ (or ,*clause-code)
+ ,result-temp)))))
+
+(defmacro match-cond (:form *match-form* :env e . clauses)
+ (unless [all clauses [andf proper-listp [chain len (op < 1)]]]
+ (compile-error *match-form* "bad clause syntax"))
+ (let* ((result-temp (gensym "result-"))
+ (var-list (get-var-list e))
+ (clause-matches [mapcar (op compile-match (car @1)
+ : (copy var-list))
+ clauses])
+ (clause-code (collect-each ((cl clauses)
+ (cm clause-matches))
+ (mac-param-bind *match-form* (t obj . forms) cl
+ ^(let (,*cm.(get-vars)
+ (,cm.obj-var ,obj))
+ ,cm.(wrap-guards ^(set ,result-temp
+ (progn ,cm.obj-var ,*forms))
+ t))))))
+ ^(let (,result-temp)
+ (or ,*clause-code)
+ ,result-temp)))
+
+(defmacro match-ecase (obj . clauses)
+ (with-gensyms (else)
+ ^(match-case ,obj
+ ,*clauses
+ ((var ,else) (match-error 'match-ecase ,else)))))
+
+(defmacro while-match-case (:form *match-form* obj . clauses)
+ (unless [all clauses [andf proper-listp [chain len plusp]]]
+ (compile-error *match-form* "bad clause syntax"))
+ ^(for ()
+ ((match-case ,obj
+ ,*(mapcar (ret ^(,(car @1) ,*(cdr @1) t)) clauses)))
+ ()))
+
+(defmacro while-true-match-case (:form *match-form* obj . clauses)
+ (unless [all clauses [andf proper-listp [chain len plusp]]]
+ (compile-error *match-form* "bad clause syntax"))
+ ^(for ()
+ ((match-case ,obj
+ (nil)
+ ,*(mapcar (ret ^(,(car @1) ,*(cdr @1) t)) clauses)))
+ ()))
+
+(defmacro when-exprs-match (:form *match-form* :env e pats exprs . forms)
+ (let ((em (compile-match ^@(exprs ,*pats) exprs (get-var-list e))))
+ ^(let* (,*em.(get-vars))
+ ,em.(wrap-guards . forms))))
+
+(defstruct lambda-clause ()
+ orig-syntax
+ fixed-patterns
+ variadic-pattern
+ nfixed
+ forms
+
+ (:postinit (me)
+ (set me.nfixed (len me.fixed-patterns))))
+
+(defun parse-lambda-match-clause (clause)
+ (mac-param-bind *match-form* (args . body) clause
+ (cond
+ ((atom args) (new lambda-clause
+ orig-syntax args
+ variadic-pattern args
+ forms body))
+ ((proper-list-p args)
+ (let* ((vpos (pos-if (lop meq 'sys:expr 'sys:var 'sys:quasi) args)))
+ (tree-bind (fixed-pats . variadic-pat) (split args vpos)
+ (new lambda-clause
+ orig-syntax args
+ fixed-patterns fixed-pats
+ variadic-pattern (car variadic-pat)
+ forms body))))
+ (t (new lambda-clause
+ orig-syntax args
+ fixed-patterns (butlast args 0)
+ variadic-pattern (last args 0)
+ forms body)))))
+
+(defun expand-lambda-match (clauses)
+ (let* ((parsed-clauses [mapcar parse-lambda-match-clause clauses])
+ (max-args (or [find-max parsed-clauses : .nfixed].?nfixed 0))
+ (min-args (or [find-min parsed-clauses : .nfixed].?nfixed 0))
+ (variadic [some parsed-clauses .variadic-pattern])
+ (fix-arg-temps (mapcar (op gensym `arg-@1`)
+ (range* 0 min-args)))
+ (opt-arg-temps (mapcar (op gensym `arg-@1`)
+ (range* min-args max-args)))
+ (rest-temp (if variadic (gensym `rest`)))
+ (present-p-temps (mapcar (op gensym `have-@1`)
+ (range* min-args max-args)))
+ (arg-temps (append fix-arg-temps opt-arg-temps))
+ (present-vec (vec-list (append (repeat '(t) min-args)
+ present-p-temps)))
+ (result-temp (gensym "result"))
+ (ex-clauses (collect-each ((pc parsed-clauses))
+ (let* ((vp pc.variadic-pattern)
+ (exp ^(when-exprs-match
+ (,*pc.fixed-patterns
+ ,*(if vp (list vp)))
+ (,*[arg-temps 0..pc.nfixed]
+ ,*(if vp
+ ^((list* ,*[arg-temps pc.nfixed..:]
+ ,rest-temp))))
+ (set ,result-temp (progn ,*pc.forms))
+ t)))
+ (sys:set-macro-ancestor exp pc.orig-syntax)
+ (when (> pc.nfixed min-args)
+ (set exp ^(when ,[present-vec (pred pc.nfixed)]
+ ,exp)))
+ (when (and (not vp) (< pc.nfixed max-args))
+ (set exp ^(unless ,[present-vec pc.nfixed]
+ ,exp)))
+ (when (and variadic (not vp) (= pc.nfixed max-args))
+ (set exp ^(unless ,rest-temp
+ ,exp)))
+ exp))))
+ ^(lambda (,*fix-arg-temps
+ ,*(if opt-arg-temps
+ (cons : (mapcar (ret ^(,@1 nil ,@2))
+ opt-arg-temps present-p-temps)))
+ . ,rest-temp)
+ (let (,result-temp)
+ (or ,*ex-clauses)
+ ,result-temp))))
+
+(defmacro lambda-match (:form *match-form* . clauses)
+ (expand-lambda-match clauses))
+
+(defmacro defun-match (:form *match-form* name . clauses)
+ (tree-bind (t args . body) (expand-lambda-match clauses)
+ ^(defun ,name ,args . ,body)))
+
+(define-param-expander :match (params clauses menv form)
+ (ignore menv)
+ (let ((*match-form* form))
+ (unless (proper-list-p params)
+ (compile-error form
+ "~s is incompatible with dotted parameter lists"
+ :match))
+ (when (find : params)
+ (compile-error form
+ "~s is incompatible with optional parameters"
+ :match))
+ (tree-bind (t lparams . body) (expand-lambda-match clauses)
+ (let ((dashdash (member '-- params)))
+ (cons (append (ldiff params dashdash)
+ (butlastn 0 lparams)
+ dashdash
+ (nthlast 0 lparams))
+ body)))))
+
+(defmacro defmatch (name destructuring-args . body)
+ (with-gensyms (name-dummy args vars-env)
+ ^(progn
+ (sethash *match-macro* ',name
+ (lambda (,args ,vars-env)
+ (mac-env-param-bind *match-form* ,vars-env
+ (,name-dummy ,*destructuring-args)
+ ,args ,*body)))
+ ',name)))
+
+(defun macroexpand-match (pattern : env)
+ (iflet ((xfun (and (consp pattern) [*match-macro* (car pattern)])))
+ [xfun pattern env]
+ pattern))
+
+(defun check (f op pat)
+ (if (or (not (listp pat))
+ (meq (car pat) 'sys:expr 'sys:var 'sys:quasi))
+ (compile-error f "~s: list pattern expected, not ~s" op pat)
+ pat))
+
+(defun check-sym (f op sym : nil-ok)
+ (cond
+ ((bindable sym) sym)
+ ((and (null sym) nil-ok) sym)
+ (t (compile-error f "~s: bindable symbol expected, not ~s" op sym))))
+
+(defun loosen (pat)
+ (if (proper-list-p pat)
+ (append pat '@nil)
+ pat))
+
+(defun pat-len (pat)
+ (if (consp pat)
+ (let ((var-op-pos (pos-if (lop meq 'sys:var 'sys:expr 'sys:quasi)
+ (butlastn 0 pat))))
+ (if var-op-pos var-op-pos (len pat)))
+ 0))
+
+(defmatch sme (:form f sta mid end : (mvar (gensym)) eobj)
+ (let* ((psta (loosen (check f 'sme sta)))
+ (pmid (loosen (check f 'sme mid)))
+ (lsta (pat-len psta))
+ (lmid (pat-len pmid))
+ (lend (pat-len end))
+ (obj (gensym)))
+ ^@(as ,(check-sym f 'sme obj)
+ @(and ,psta
+ @(with @(scan @(as ,(check-sym f 'sme mvar) ,pmid))
+ (nthcdr ,lsta ,obj))
+ @(with @(as ,(check-sym f 'sme eobj t) ,end)
+ (nthlast ,lend (nthcdr ,lmid ,mvar)))))))
+
+(defmatch end (:form f end : evar)
+ (let* ((lend (pat-len end))
+ (obj (gensym)))
+ ^@(as ,(check-sym f 'end obj)
+ @(with @(as ,(check-sym f 'end evar t) ,end)
+ (nthlast ,lend ,obj)))))
+
+(defun non-triv-pat-p (syntax)
+ (match-case syntax
+ ((@(eq 'sys:expr) (@(bindable) . @nil)) t)
+ ((@(eq 'sys:var) @(or @(bindable) nil) . @nil) t)
+ ((@(eq 'sys:quasi) . @(some @(consp))) t)
+ ((@(eq 'sys:qquote) @nil) t)
+ ((@pat . @rest) (or (non-triv-pat-p pat)
+ (non-triv-pat-p rest)))
+ (#R(@from @to) (or (non-triv-pat-p from)
+ (non-triv-pat-p to)))
+ (@(some @(non-triv-pat-p)) t)))
+
+(defun var-pat-p (syntax)
+ (when-match (@(eq 'sys:var) @(bindable @sym) . @nil) syntax
+ sym))
+
+(defun expand-quasi-match (args var-list)
+ (labels ((bound-p (vlist vars sym)
+ (cond
+ ((bindable sym) (or (member sym vars) vlist.(exists sym)))
+ ((null sym) nil)
+ ((compile-error *match-form* "bindable symbol expected, not ~s"
+ sym))))
+ (normalize (args)
+ (mapcar (do if-match (@(eq 'sys:var) @sym nil) @1
+ ^(sys:var ,sym)
+ @1)
+ args))
+ (quasi-match (vlist args vars str pos)
+ (match-case args
+ ;; `text`
+ ((@(stringp @txt))
+ (list ^@(require @nil (eql (len ,str) (match-str ,str ,txt ,pos)))))
+ ;; `txt@...`
+ ((@(stringp @txt) . @rest)
+ (with-gensyms (npos)
+ (cons ^@(require @(with ,npos (+ ,pos (len ,txt)))
+ (match-str ,str ,txt ,pos))
+ (quasi-match vlist rest vars str npos))))
+ ;; `@{var #/rx/}` (existing binding)
+ (((@(eq 'sys:var) @(bound-p vlist vars @sym) (@(regexp @reg))))
+ (list ^@(require @nil (equal ,sym (m^$ ,reg (sub-str ,str ,pos t))))))
+ ;; `@{var #/rx/}@...` (existing binding)
+ (((@(eq 'sys:var) @(bound-p vlist vars @sym) (@(regexp @reg))) . @rest)
+ (with-gensyms (len npos)
+ (list* ^@(require @(with ,len (match-regex ,str ,reg ,pos))
+ ,len)
+ ^@(with ,npos (+ ,pos ,len))
+ ^@(require @nil (equal ,sym (sub-str ,str ,pos ,npos)))
+ (quasi-match vlist rest vars str npos))))
+ ;; `@var` (existing binding)
+ (((@(eq 'sys:var) @(bound-p vlist vars) . @nil))
+ (list ^@(require @nil (eql (len ,str)
+ (match-str ,str (sys:quasi ,(car args))
+ ,pos)))))
+ ;; `@var@...` (existing binding)
+ ((@(as avar (@(eq 'sys:var) @(bound-p vlist vars) . @nil))
+ . @rest)
+ (with-gensyms (txt len npos)
+ (list* ^@(with ,txt (sys:quasi ,avar))
+ ^@(with ,len (len ,txt))
+ ^@(with ,npos (+ ,pos ,len))
+ ^@(require @nil
+ (match-str ,str ,txt ,pos))
+ (quasi-match vlist rest vars str npos))))
+ ;; `@var` (new binding)
+ (((@(eq 'sys:var) @sym))
+ (list ^@(with ,sym (sub-str ,str ,pos t))))
+ ;; `@{var #/rx/}` (new binding)
+ (((@(eq 'sys:var) @sym (@(regexp @reg))))
+ (if sym
+ (list ^@(require @(with ,sym (sub-str ,str ,pos t))
+ (m^$ ,reg ,sym)))
+ (list ^@(require @nil
+ (m^$ ,reg (sub-str ,str ,pos t))))))
+ ;; `@{var #/rx/}@...` (new binding)
+ (((@(eq 'sys:var) @sym (@(regexp @reg))) . @rest)
+ (with-gensyms (len npos)
+ (list* ^@(require @(with ,len (match-regex ,str ,reg ,pos))
+ ,len)
+ ^@(with ,npos (+ ,pos ,len))
+ ^@(with ,sym (sub-str ,str ,pos ,npos))
+ (quasi-match vlist rest (cons sym vars) str npos))))
+ ;; `@{var 123}` (new binding)
+ (((@(eq 'sys:var) @sym (@(integerp @len))))
+ (unless (plusp len)
+ (compile-error *match-form*
+ "variable ~s: positive integer required,\ \
+ not ~a" sym))
+ (with-gensyms (npos)
+ (list ^@(require @(with ,npos (+ ,pos ,len))
+ (eql ,npos (len ,str)))
+ ^@(with ,sym (sub-str ,str ,pos t)))))
+ ;; `@{var 123}@...`` (new binding)
+ (((@(eq 'sys:var) @sym (@(integerp @len))) . @rest)
+ (unless (plusp len)
+ (compile-error *match-form*
+ "variable ~s: positive integer required,\ \
+ not ~a" sym len))
+ (with-gensyms (npos)
+ (list* ^@(require @(with ,npos (+ ,pos ,len))
+ (<= ,npos (len ,str)))
+ ^@(with ,sym (sub-str ,str ,pos ,npos))
+ (quasi-match vlist rest (cons sym vars) str npos))))
+ ;; `@{var}txt` (new binding)
+ (((@(eq 'sys:var) @sym) @(stringp @txt))
+ (with-gensyms (end)
+ (list ^@(require @(with ,end (search-str ,str ,txt ,pos))
+ ,end (eql (+ ,end ,(len txt)) (len ,str)))
+ ^@(with ,sym (sub-str ,str ,pos ,end)))))
+ ;; `@{var}txt...` (new binding)
+ (((@(eq 'sys:var) @sym) @(stringp @txt) . @rest)
+ (with-gensyms (end npos)
+ (list* ^@(require @(with ,end (search-str ,str ,txt ,pos))
+ ,end)
+ ^@(with ,npos (+ ,end ,(len txt)))
+ ^@(with ,sym (sub-str ,str ,pos ,end))
+ (quasi-match vlist rest (cons sym vars) str npos))))
+ ;; `@var0@var1` (unbound followed by bound)
+ (((@(eq 'sys:var) @sym)
+ @(as bvar (@(eq 'sys:var) @(bound-p vlist vars) . @mods)))
+ (ignore mods)
+ (with-gensyms (txt end)
+ (list ^@(with ,txt (sys:quasi ,bvar))
+ ^@(require @(with ,end (search-str ,str ,txt ,pos))
+ ,end (eql (+ , end (len ,txt)) (len ,str)))
+ ^@(with ,sym (sub-str ,str ,pos ,end)))))
+ ;; `@var0@var1...` (unbound followed by bound)
+ (((@(eq 'sys:var) @sym)
+ @(as bvar (@(eq 'sys:var) @(bound-p vlist vars) . @mods))
+ . @rest)
+ (ignore mods)
+ (with-gensyms (txt end npos)
+ (list* ^@(with ,txt (sys:quasi ,bvar))
+ ^@(require @(with ,end (search-str ,str ,txt ,pos))
+ ,end)
+ ^@(with ,npos (+ ,end (len ,txt)))
+ ^@(with ,sym (sub-str ,str ,pos ,end))
+ (quasi-match vlist rest (cons sym vars) str npos))))
+ ;; `@{var whatever}@...`(new binding, unsupported modifiers)
+ (((@(eq 'sys:var) @sym @mods . @nil) . @nil)
+ (compile-error *match-form*
+ "variable ~s: unsupported modifiers ~s"
+ sym mods))
+
+ ;; `@var0@var1` (unbound followed by unbound)
+ (((@(eq 'sys:var) @sym0)
+ (@(eq 'sys:var) @sym1 . @nil)
+ . @nil)
+ (compile-error *match-form*
+ "consecutive unbound variables ~s and ~s"
+ sym0 sym1))
+ ((@bad . @nil) (compile-error *match-form*
+ "unsupported syntax ~s"
+ ^(sys:quasi ,bad)))
+ (@nil (compile-error *match-form* "bad quasiliteral syntax")))))
+
+ (with-gensyms (str pos)
+ ^@(and @(require (sys:var ,str)
+ (stringp ,str))
+ @(with ,pos 0)
+ ,*(quasi-match var-list (normalize args) nil str pos)))))
+
+(defun transform-qquote (syn)
+ (match-case syn
+ ((sys:hash-lit nil . @(all (@key @val)))
+ ^@(hash ,*(zip [mapcar transform-qquote key]
+ [mapcar transform-qquote val])))
+ ((sys:hash-lit . @(eq nil))
+ '@(hash))
+ ((sys:struct-lit @type . @args)
+ ^@(struct ,(transform-qquote type)
+ ,*[mapcar transform-qquote args]))
+ ((sys:vector-lit @elems)
+ ^#(,*[mapcar transform-qquote elems]))
+ ((json quote @arg) (transform-qquote arg))
+ ((sys:unquote @pat) (if (symbolp pat)
+ ^(sys:var ,pat)
+ ^(sys:expr ,pat)))
+ ((sys:hash-lit @(have) . @nil)
+ (compile-error *match-form*
+ "only equal hash tables supported"))
+ ((@(or sys:qquote) . @nil)
+ (compile-error *match-form*
+ "pattern-matching quasiquote doesn't support nesting"))
+ ((sys:splice . @nil)
+ (compile-error *match-form*
+ "pattern-matching quasiquote doesn't support splicing"))
+ ((@ca . @cd) (cons (transform-qquote ca)
+ (transform-qquote cd)))
+ (@else else)))
+
+(defun each-match-expander (f pat-seq-list body fun)
+ (unless (and (proper-list-p pat-seq-list)
+ (evenp (len pat-seq-list)))
+ (compile-error f "pattern-sequence arguments must form pairs"))
+ (let ((pat-seq-pairs (tuples 2 pat-seq-list)))
+ (each ((pair pat-seq-pairs))
+ (unless (and (proper-list-p pair)
+ (eql 2 (length pair)))
+ (compile-error f "invalid pattern-sequence pair ~s" pair)))
+ (let* ((pats [mapcar car pat-seq-pairs])
+ (seqs [mapcar cadr pat-seq-pairs])
+ (gens [mapcar (ret (gensym)) pat-seq-pairs]))
+ ^(let ,(zip gens seqs)
+ (block nil
+ (,fun (lambda-match ((,*pats) (progn ,*body))) ,*gens))))))
+
+(defmacro each-match (:form f pat-seq-pairs . body)
+ (each-match-expander f pat-seq-pairs body 'mapdo))
+
+(defmacro append-matches (:form f pat-seq-pairs . body)
+ (each-match-expander f pat-seq-pairs body 'mappend))
+
+(defmacro keep-matches (:form f pat-seq-pairs . body)
+ (each-match-expander f pat-seq-pairs ^((list (progn ,*body))) 'mappend))
+
+(defmacro each-match-product (:form f pat-seq-pairs . body)
+ (each-match-expander f pat-seq-pairs body 'maprodo))
+
+(defmacro append-match-products (:form f pat-seq-pairs . body)
+ (each-match-expander f pat-seq-pairs body 'maprend))
+
+(defmacro keep-match-products (:form f pat-seq-pairs . body)
+ (each-match-expander f pat-seq-pairs ^((list (progn ,*body))) 'maprend))
diff --git a/stdlib/op.tl b/stdlib/op.tl
new file mode 100644
index 00000000..97ec7a6b
--- /dev/null
+++ b/stdlib/op.tl
@@ -0,0 +1,281 @@
+;; Copyright 2017-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defvar sys:*op-ctx*)
+
+(sys:make-struct-type
+ 'sys:op-ctx nil nil '(form gens up meta rec recvar nested) nil
+ (lambda (me)
+ (slotset me 'up sys:*op-ctx*)
+ (slotset me 'meta (gensym "meta-")))
+ nil nil)
+
+(defun sys:ensure-op-arg (ctx n)
+ (let ((ag (slot ctx 'gens)))
+ (when (> n 1024)
+ ['compile-error (slot ctx 'form)
+ "@~a calls for function with too many arguments" n])
+ (for ((i (len ag)) (l))
+ ((<= i n)
+ (sys:setq ag (append ag (nreverse l)))
+ (slotset ctx 'gens ag)
+ [ag n])
+ ((sys:setq i (succ i)))
+ (sys:setq l (cons (gensym `arg-@(if (plusp i) i "rest")-`) l)))))
+
+(defun sys:op-meta-p (exp)
+ (tree-case exp
+ ((x y . r) (and (null r)
+ (cond
+ ((eq x 'sys:expr) (let ((depth (sys:op-meta-p y)))
+ (if depth (succ depth))))
+ ((eq x 'sys:var) (if (or (integerp y)
+ (eq y 'rest))
+ 0)))))))
+
+(defun sys:op-rec-p (exp)
+ (or (tree-case exp
+ ((x (y . t)) (and (eq x 'sys:expr) (eq y 'usr:rec))))
+ (equal exp '(sys:var usr:rec))))
+
+(defun sys:op-ensure-rec (ctx : recvar)
+ (when recvar
+ (slotset ctx 'recvar t))
+ (or (slot ctx 'rec) (slotset ctx 'rec (gensym "rec-"))))
+
+(defun sys:find-parent (ctx depth)
+ (for ((more t)) (more ctx) ((if (minusp (sys:setq depth (pred depth)))
+ (sys:setq more nil)))
+ (sys:setq ctx (slot ctx 'up))))
+
+(defun sys:op-alpha-rename (e op-args do-nested-metas)
+ (let* ((ctx sys:*op-ctx*)
+ (code ^(macrolet ((sys:expr (:form f arg)
+ (let* ((ctx ,ctx)
+ (depth (sys:op-meta-p arg))
+ (rec (sys:op-rec-p arg))
+ (up (slot ctx 'up))
+ (par (cond
+ (depth (sys:find-parent ctx depth))
+ (rec up))))
+ (cond
+ ((and par (or depth rec))
+ (slotset par 'nested t)
+ ^(,(slot (slot ctx 'up) 'meta) (quote ,arg)))
+ ((sys:op-rec-p f)
+ ^(,(sys:op-ensure-rec ctx) ,*(rest arg)))
+ (t f))))
+ (sys:var (:form f arg . mods)
+ (cond
+ ((sys:op-meta-p f)
+ (unless (integerp arg)
+ (sys:setq arg 0))
+ (sys:ensure-op-arg ,ctx arg))
+ ((sys:op-rec-p f)
+ (sys:op-ensure-rec ,ctx t))
+ (t f)))
+ ,*(if do-nested-metas
+ ^((,(slot ctx 'meta) ((quote arg)) arg))))
+ ,op-args)))
+ (expand code e)))
+
+(eval-only
+ (defmacro op-ignerr (x)
+ ^(sys:catch (error) ,x () (error (. args) (ignore args)))))
+
+(defun sys:op-expand (f e args)
+ (unless args
+ ['compile-error f "arguments required"])
+ (let* ((compat (and (plusp sys:compat) (<= sys:compat 225)))
+ (ctx (make-struct 'sys:op-ctx ^(form ,f)))
+ (sys:*op-ctx* ctx)
+ (sym (car f))
+ (do-gen (if (eq sym 'do) (gensym)))
+ (syntax-0 (if (eq sym 'do) args ^[,*args]))
+ (syntax-1 (if (or (null syntax-0) (neq sym 'do) compat)
+ ;; Not do, or empty do syntax, or compat mode.
+ (sys:op-alpha-rename e syntax-0 nil)
+ ;; Try to expand args as-is, catching errors.
+ (let ((syn (op-ignerr (sys:op-alpha-rename e
+ syntax-0
+ nil))))
+ (if syn
+ ;; Args expanded.
+ (if (or (slot ctx 'gens) (slot ctx 'nested))
+ ;; There are metas: okay, use expansion as-is.
+ syn
+ ;; No metas: add do-gen at the end and expand
+ ;; again, without catching errors.
+ (sys:op-alpha-rename e
+ (append syntax-0
+ (list do-gen))
+ nil))
+ ;; Args didn't expand, so let's try it with
+ ;; do-gen added.
+ (let ((syn (sys:op-alpha-rename
+ e (append syntax-0
+ (list do-gen))
+ nil)))
+ ;; It didn't blow up with the do-gen. However, if
+ ;; there are metas, we must not be adding this
+ ;; gensym. Thus, this case is erroneous: it doesn't
+ ;; expand unless we add an element, which we must not.
+ ;; Thus we just expand it again without the do-gen,
+ ;; without op-ignerr, to let the error propagate.
+ (when (or (slot ctx 'gens) (slot ctx 'nested))
+ (sys:op-alpha-rename e syntax-0 nil)
+ ;; Just in case: we don't expect to reach this:
+ ['compile-error f "internal error"])
+ ;; There were no metas. Let's return the
+ ;; form augmented with do-gen.
+ syn)))))
+ (syntax-2 (sys:op-alpha-rename e syntax-1 t))
+ (metas (slot ctx 'gens))
+ (rec (slot ctx 'rec))
+ (recvar (slot ctx 'recvar))
+ (rest-sym (sys:ensure-op-arg ctx 0))
+ (lambda-interior (let ((fargs (tree-case syntax-2
+ ((t t . fa) fa))))
+ (cond
+ ((and (eq sym 'lop) fargs)
+ (let ((fargs-l1 (mapcar (lambda (farg)
+ ^(sys:l1-val ,farg))
+ fargs)))
+ ;; no cadr here to avoid circular autoload
+ ^[sys:apply ,(car (cdr syntax-2))
+ (append ,rest-sym (list ,*fargs-l1))]))
+ (metas syntax-2)
+ ((eq sym 'do)
+ (let ((arg1 (sys:ensure-op-arg ctx 1)))
+ ^(symacrolet ((,do-gen ,arg1))
+ ,syntax-2)))
+ (t (append syntax-2 rest-sym))))))
+ (let ((metas (slot ctx 'gens)))
+ (cond
+ (recvar ^(sys:lbind ((,rec (lambda (,*(cdr metas) . ,rest-sym)
+ (let ((,rec (fun ,rec)))
+ ,lambda-interior))))
+ (fun ,rec)))
+ (rec ^(sys:lbind ((,rec (lambda (,*(cdr metas) . ,rest-sym)
+ ,lambda-interior)))
+ (fun ,rec)))
+ (t ^(lambda (,*(cdr metas) . ,rest-sym)
+ ,lambda-interior))))))
+
+(defmacro op (:form f :env e . args)
+ (sys:op-expand f e args))
+
+(defmacro do (:form f :env e . args)
+ (sys:op-expand f e args))
+
+(defmacro lop (:form f :env e . args)
+ (sys:op-expand f e args))
+
+(defmacro ldo (op . args)
+ ^(do ,op @1 ,*args))
+
+(defmacro ap (. args)
+ ^(apf (op ,*args)))
+
+(defmacro ip (. args)
+ ^(ipf (op ,*args)))
+
+(defmacro ado (. args)
+ ^(apf (do ,*args)))
+
+(defmacro ido (. args)
+ ^(ipf (do ,*args)))
+
+(defmacro ret (arg)
+ ^(op identity* ,arg))
+
+(defmacro aret (arg)
+ ^(ap identity* ,arg))
+
+(defun sys:opip-single-let-p (c)
+ (tree-case c
+ ((op sym)
+ (and (eq op 'let)
+ (atom sym)))
+ (t nil)))
+
+(defun sys:opip-let-p (c)
+ (tree-case c
+ ((op (sym t) . rest)
+ (and (eq op 'let)
+ (atom sym)
+ (listp rest)))
+ (t nil)))
+
+(defun sys:opip-expand (e opsym dosym clauses)
+ (tree-case clauses
+ (nil nil)
+ ((c . rest)
+ (if (atom c)
+ (cons c (sys:opip-expand e opsym dosym rest))
+ (let ((sym (car c)))
+ (cond
+ ((memq sym '(dwim uref qref op do lop ldo ap ip ado ido ret aret))
+ (cons c (sys:opip-expand e opsym dosym rest)))
+ ((sys:opip-single-let-p c)
+ (tree-bind (t sym) c
+ (sys:opip-expand e opsym dosym ^((let (,sym @1)) ,*rest))))
+ ((sys:opip-let-p c)
+ (tree-bind (t . vars) c
+ ^((do let* ,vars
+ [(opip ,*(sys:opip-expand e opsym dosym rest)) @1]))))
+ (t (let ((opdo (if (or (special-operator-p (car c))
+ (macro-form-p c e)) dosym opsym)))
+ (cons ^(,opdo ,*c) (sys:opip-expand e opsym dosym
+ rest))))))))))
+
+(defmacro opip (:env e . clauses)
+ ^[chain ,*(sys:opip-expand e 'op 'do clauses)])
+
+(defmacro oand (:env e . clauses)
+ ^[chand ,*(sys:opip-expand e 'op 'do clauses)])
+
+(defmacro lopip (:env e . clauses)
+ ^[chain ,*(sys:opip-expand e 'lop 'ldo clauses)])
+
+(defmacro loand (:env e . clauses)
+ ^[chand ,*(sys:opip-expand e 'lop 'ldo clauses)])
+
+(defmacro opf (:env e fun . clauses)
+ ^[,fun ,*(sys:opip-expand e 'op 'do clauses)])
+
+(defmacro lopf (:env e fun . clauses)
+ ^[,fun ,*(sys:opip-expand e 'lop 'ldo clauses)])
+
+(defmacro flow (val . opip-args)
+ ^(call (opip ,*opip-args) ,val))
+
+(defmacro lflow (val . opip-args)
+ ^(call (lopip ,*opip-args) ,val))
+
+(defmacro tap (. args)
+ ^(prog1 @1 ,args))
diff --git a/stdlib/optimize.tl b/stdlib/optimize.tl
new file mode 100644
index 00000000..52e5504c
--- /dev/null
+++ b/stdlib/optimize.tl
@@ -0,0 +1,854 @@
+;; Copyright 2021-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(load-for
+ (usr:var %const-foldable% "constfun")
+ (usr:macro when-opt "comp-opts"))
+
+(compile-only
+ (defstruct live-info nil
+ (defined 0)
+ (used 0)
+ def0 def1)
+
+ (defstruct basic-block (live-info)
+ (live 0)
+ label
+ next
+ prev
+ links
+ rlinks
+ insns
+ closer
+ nojoin
+
+ (:method print (bl stream pretty-p)
+ (ignore pretty-p)
+ (put-string "#S" stream)
+ (print ^(basic-block live ,bl.live
+ label ,bl.label
+ insns ,bl.insns
+ links ,(mapcar .label bl.links)
+ rlinks ,(mapcar .label bl.rlinks)
+ next ,bl.next.?label) stream)))
+
+ (defstruct (basic-blocks compiler insns lt-dregs symvec) nil
+ compiler
+ insns
+ lt-dregs
+ symvec
+ (hash (hash))
+ (li-hash (hash :eq-based))
+ list
+ closures
+ (cl-hash (hash))
+ rescan
+ recalc
+ reelim
+ tryjoin
+ warned-insns
+ (:static start (gensym "start-"))
+ (:static jump-ops '(jmp if ifq ifql close swtch ret abscsr
+ uwprot catch block jend xend))
+
+ (:postinit (bb)
+ (let* ((insns (early-peephole (dedup-labels (cons bb.start bb.insns))))
+ (parts (partition-if (lambda (prev next)
+ (or (symbolp next)
+ (and (consp prev)
+ (memq (car prev) bb.jump-ops))))
+ insns))
+ (lparts (mapcar [iff [chain car symbolp]
+ use
+ (op cons (gensym))]
+ parts)))
+ (set bb.list (mapcar (do new basic-block
+ insns @1 label (car @1))
+ lparts))
+ (mapdo (do set [bb.hash @1.label] @1) bb.list))
+ bb.(link-graph t))
+
+ (:method num-blocks (bb)
+ (len bb.list))
+
+ (:method get-insns (bb)
+ [mappend .insns bb.list])
+
+ (:method cut-block (bb bl at insns)
+ (let* ((nlabel (gensym "nl"))
+ (ltail (cdr (memq bl bb.list)))
+ (nbl (new basic-block
+ label nlabel
+ insns (cons nlabel at))))
+ (set bb.list (append (ldiff bb.list ltail) (list nbl) ltail))
+ (set bl.insns (ldiff insns at))
+ (set [bb.hash nlabel] nbl)
+ (pushnew bl bb.rescan)
+ (pushnew nbl bb.rescan)
+ nbl))
+
+ (:method join-block (bb bl nxbl)
+ (when (eql (car nxbl.insns) nxbl.label)
+ (pop nxbl.insns))
+ (set bl.insns (append bl.insns nxbl.insns)
+ nxbl.insns nil
+ bl.next nxbl.next
+ bl.links nxbl.links
+ bl.nojoin nxbl.nojoin
+ bb.list (remq nxbl bb.list))
+ (if nxbl.next
+ (set nxbl.next.prev bl.prev))
+ (del [bb.hash nxbl.label])
+ (each ((nx bl.links))
+ (upd nx.rlinks (remq nxbl))
+ (pushnew bl nx.rlinks)))))
+
+(defmacro rewrite-case (sym list . cases)
+ ^(rewrite (lambda (,sym)
+ (match-case ,sym
+ ,*cases))
+ ,list))
+
+(defmeth basic-blocks link-graph (bb : first-time)
+ (unless first-time
+ (each ((bl bb.list))
+ (set bl.links nil
+ bl.next nil
+ bl.prev nil
+ bl.rlinks nil)))
+ (each* ((bl bb.list)
+ (nxbl (append (cdr bl) '(nil))))
+ (let* ((code bl.insns)
+ (tail (last code))
+ (linsn (car tail))
+ (link-next t))
+ (match-case linsn
+ ((jmp @jlabel)
+ (set bl.links (list [bb.hash jlabel])
+ link-next nil))
+ ((if @nil @jlabel)
+ (set bl.links (list [bb.hash jlabel])))
+ ((@(or ifq ifql) @nil @nil @jlabel)
+ (set bl.links (list [bb.hash jlabel])))
+ ((close @nil @nil @nil @jlabel . @nil)
+ (set bl.links (list [bb.hash jlabel])
+ bl.next nxbl
+ link-next nil)
+ (if nxbl
+ (set nxbl.prev bl)))
+ ((swtch @nil . @jlabels)
+ (set bl.links [mapcar bb.hash (uniq jlabels)]
+ link-next nil))
+ ((catch @nil @nil @nil @nil @hlabel)
+ (set bl.links (list [bb.hash hlabel])))
+ ((block @nil @nil @slabel)
+ (set bl.links (list [bb.hash slabel])))
+ ((uwprot @clabel)
+ (set bl.links (list [bb.hash clabel])))
+ ((@(or abscsr ret jend) . @nil)
+ (set link-next nil))
+ ((xend . @nil)
+ (set bl.nojoin t)))
+ (when (and nxbl link-next)
+ (set bl.next nxbl)
+ (if nxbl
+ (set nxbl.prev bl))
+ (pushnew nxbl bl.links))
+ (each ((nx bl.links))
+ (pushnew bl nx.rlinks)))))
+
+(defmeth basic-blocks local-liveness (bb bl)
+ (set bl.live 0)
+ (labels ((regnum (reg)
+ (when-match (t @num) reg num))
+ (regnums (regs)
+ (mappend (do when-match
+ (t @num) @1 (list num)) regs))
+ (defs (li insn def0 : def1)
+ (set [bb.li-hash insn] li)
+ (let* ((dn0 (regnum def0))
+ (dn1 (regnum def1))
+ (dmask0 (if dn0 (mask dn0) 0))
+ (dmask1 (if dn1 (mask dn1) 0))
+ (dmask (logior dmask0 dmask1)))
+ (cond
+ ((nzerop dmask)
+ (set li.def0 def0)
+ (set li.def1 def1)
+ (new live-info
+ used (logand li.used (lognot dmask))
+ defined dmask))
+ (t (prog1
+ (copy li)
+ (set li.def0 def0)
+ (set li.def1 def1))))))
+ (refs (li insn . refs)
+ (set [bb.li-hash insn] li)
+ (let* ((rn (regnums refs))
+ (rmask (mask . rn)))
+ (new live-info
+ used (logior li.used rmask))))
+ (def-ref (li insn def . refs)
+ (set li.def0 def
+ [bb.li-hash insn] li)
+ (let* ((rn (regnums refs))
+ (dn (regnum def))
+ (dmask (if dn (mask dn)))
+ (rmask (mask . rn)))
+ (cond
+ (dn (new live-info
+ used (logior (logand li.used (lognot dmask)) rmask)
+ defined dmask))
+ (t (new live-info
+ used (logior li.used rmask))))))
+ (liveness (insns)
+ (if (null insns)
+ (new live-info used 0)
+ (let* ((li (liveness (cdr insns)))
+ (insn (car insns)))
+ (match-case insn
+ ((@(or end jend xend prof) @reg)
+ (refs li insn reg))
+ ((@(or apply call) @def . @refs)
+ (def-ref li insn def . refs))
+ ((@(or gapply gcall) @def @nil . @refs)
+ (def-ref li insn def . refs))
+ ((mov @def @ref)
+ (def-ref li insn def ref))
+ ((if @reg . @nil)
+ (refs li insn reg))
+ ((@(or ifq ifql) @reg @creg . @nil)
+ (refs li insn reg creg))
+ ((swtch @reg . @nil)
+ (refs li insn reg))
+ ((block @reg @nreg . @nil)
+ (refs li insn reg nreg))
+ ((@(or ret abscsr) @nreg @reg)
+ (refs li insn reg nreg))
+ ((catch @esreg @eareg @syreg @descreg . @nil)
+ (let ((ili (defs li insn esreg eareg)))
+ (refs ili insn syreg descreg)))
+ ((handle @funreg @syreg)
+ (refs li insn funreg syreg))
+ ((@(or getv getvb getfb getl1b getlx getf) @def . @nil)
+ (defs li insn def))
+ ((@(or setv setl1 setlx bindv) @reg . @nil)
+ (refs li insn reg))
+ ((close @reg . @nil)
+ (defs li insn reg))
+ ((@(or jmp frame dframe uwprot) . @nil)
+ (set [bb.li-hash insn] li)
+ (copy li))
+ ((@nil . @nil)
+ (error `unhandled/mishandled @insn instruction`))
+ (@else
+ (set [bb.li-hash else] li)
+ (copy li)))))))
+ (let ((li (liveness bl.insns)))
+ (set bl.used li.used
+ bl.defined li.defined))))
+
+(defmeth basic-blocks calc-liveness (bb : (blist bb.list))
+ (each ((bl blist))
+ bb.(local-liveness bl))
+ (let (changed)
+ (while* changed
+ (let ((visited (hash :eq-based)))
+ (labels ((upd-used (bl insns live)
+ (tree-case insns
+ ((fi . re)
+ (let* ((live (upd-used bl re live))
+ (lif [bb.li-hash fi]))
+ (clear-mask live lif.defined)
+ (set-mask lif.used live)
+ live))
+ (t live)))
+ (visit (bl)
+ (unless [visited bl]
+ (set [visited bl] t)
+ (when bl.next
+ (visit bl.next))
+ (let ((used 0)
+ (old-live (or bl.live 0)))
+ (each ((nx bl.links))
+ (visit nx)
+ (set-mask used nx.used))
+ (when (neql (set bl.live (logior used old-live))
+ old-live)
+ (let ((live-in (logand (upd-used bl bl.insns bl.live)
+ (lognot bl.defined))))
+ (set-mask bl.used live-in))
+ (set changed t))))))
+ (set changed nil)
+ (visit (car bb.list)))))))
+
+(defmeth basic-blocks thread-jumps-block (bb code)
+ (let* ((tail (last code))
+ (oinsn (car tail))
+ (insn oinsn)
+ (ninsn oinsn))
+ (while* (nequal ninsn insn)
+ (set insn ninsn
+ ninsn (match-case insn
+ (@(require (if @(as reg (d @nil)) @nil)
+ (not (memqual reg bb.lt-dregs)))
+ nil)
+ ((if (t 0) @jlabel)
+ ^(jmp ,jlabel))
+ ((jmp @jlabel)
+ (let ((jinsns [bb.hash jlabel].insns))
+ (match-case jinsns
+ ((@jlabel
+ (jmp @(and @jjlabel @(not @jlabel))) . @nil)
+ ^(jmp ,jjlabel))
+ (@nil insn))))
+ ((if @reg @jlabel)
+ (let* ((jbl [bb.hash jlabel]))
+ (match-case jbl.insns
+ ((@jlabel
+ (if @reg
+ @(and @jjlabel @(not @jlabel))) . @nil)
+ ^(if ,reg ,jjlabel))
+ ((@jlabel
+ (jmp @(and @jjlabel @(not @jlabel))) . @nil)
+ ^(if ,reg ,jjlabel))
+ ((@nil
+ (ifq @reg (t 0) @nil) . @nil)
+ (let ((xbl jbl.next))
+ (if xbl
+ ^(if ,reg ,xbl.label)
+ insn)))
+ (@nil insn))))
+ ((ifq @reg @creg @jlabel)
+ (let ((jbl [bb.hash jlabel]))
+ (match-case jbl.insns
+ ((@jlabel
+ (ifq @reg @creg
+ @(and @jjlabel @(not @jlabel))) . @nil)
+ ^(ifq ,reg ,creg ,jjlabel))
+ ((@(require @jlabel (equal creg '(t 0)))
+ (if @reg @(not @jlabel)) . @nil)
+ (let ((xbl jbl.next))
+ (if xbl
+ ^(ifq ,reg ,creg ,xbl.label)
+ insn)))
+ ((@nil
+ (jmp @(and @jjlabel @(not @jlabel))) . @nil)
+ ^(ifq ,reg ,creg ,jjlabel))
+ (@nil insn))))
+ ((close @reg @frsize @ntregs @jlabel . @cargs)
+ (let ((jbl [bb.hash jlabel]))
+ (match-case jbl.insns
+ ((@jlabel
+ (jmp @(and @jjlabel @(not @jlabel))) . @nil)
+ ^(close ,reg ,frsize ,ntregs ,jjlabel ,*cargs))
+ (@nil insn))))
+ (@else else))))
+ (cond
+ ((null ninsn) (ldiff code tail))
+ ((nequal ninsn oinsn) (append (ldiff code tail) (list ninsn)))
+ (t code))))
+
+(defun subst-preserve (x y bb li insn)
+ (let ((sub (subst x y insn)))
+ (cond
+ ((equal sub insn) insn)
+ (t (set [bb.li-hash sub] li) sub))))
+
+(defun careful-subst-preserve (x y bb li insn)
+ (let ((sub (match-case insn
+ ((@(or apply call) @def . @refs)
+ ^(,(car insn) ,def ,*(subst x y refs)))
+ ((@(or gapply gcall) @def @fn . @refs)
+ ^(,(car insn) ,def ,fn ,*(subst x y refs)))
+ ((mov @def @x)
+ ^(mov ,def ,y))
+ ((catch @esreg @eareg . @refs)
+ ^(catch ,esreg ,eareg ,*(subst x y refs)))
+ (@else else))))
+ (cond
+ ((equal sub insn) insn)
+ (t (set [bb.li-hash sub] li) sub))))
+
+(defmeth basic-blocks rename (bb insns dst src)
+ (build
+ (let ((vreg (eq (car src) 'v)))
+ (whilet ((insn (pop insns)))
+ (let ((end (if-match (end . @nil) insn t))
+ (close (if-match (close . @nil) insn t))
+ (li [bb.li-hash insn]))
+ (cond
+ (close (add insn))
+ ((and vreg end)
+ (add (subst-preserve dst src bb li insn))
+ (pend insns)
+ (set insns nil))
+ ((or (mequal dst li.def0 li.def1)
+ (mequal src li.def0 li.def1))
+ (add (careful-subst-preserve dst src bb li insn))
+ (pend insns)
+ (set insns nil))
+ (t (add (subst-preserve dst src bb li insn)))))))))
+
+(defmeth basic-blocks peephole-block (bb bl)
+ (let ((code bb.(do-peephole-block bl bl.insns)))
+ (set bl.insns code)))
+
+(defmeth basic-blocks do-peephole-block (bb bl code)
+ (labels ((dead-treg (insn n)
+ (let ((li [bb.li-hash insn]))
+ (and li (not (bit li.used n))))))
+ (rewrite-case insns code
+ ;; dead t-reg
+ (@(require ((@(or mov getlx getv getf getfb) (t @n) . @nil) . @nil)
+ (dead-treg (car insns) n))
+ (pushnew bl bb.rescan)
+ (set bb.recalc t)
+ (cdr insns))
+ (@(require ((close (t @n) @nil @nil @jlabel . @nil) . @nil)
+ (dead-treg (car insns) n))
+ (pushnew bl bb.rescan)
+ (set bb.recalc t
+ bb.reelim t)
+ ^((jmp ,jlabel)))
+ (@(require ((@(or gcall gapply) (t @n) @idx . @nil) . @nil)
+ (dead-treg (car insns) n)
+ [%effect-free% [bb.symvec idx]])
+ (pushnew bl bb.rescan)
+ (set bb.recalc t)
+ (cdr insns))
+ ;; wasteful moves
+ (((mov @reg0 @nil) (mov @reg0 @nil) . @nil)
+ (cdr insns))
+ (((mov @reg0 @reg1) (mov @reg1 @reg0) . @rest)
+ (pushnew bl bb.rescan)
+ (set bb.recalc t)
+ ^(,(car insns) ,*rest))
+ ;; frame reduction
+ (((@(or frame dframe) @lev @nil)
+ (@(or call gcall mov)
+ . @(require @(coll (v @vlev @nil))
+ (none vlev (op eql (ppred lev)))))
+ . @rest)
+ ^(,(cadr insns) ,(car insns) ,*rest))
+ (((@(or frame dframe) . @nil)
+ (if (t @reg) @jlabel) . @nil)
+ (let* ((jbl [bb.hash jlabel])
+ (jinsns jbl.insns))
+ (match-case jinsns
+ ((@nil
+ (end (t @reg)) . @jrest)
+ (let* ((ybl bl.next)
+ (xbl (if ybl
+ (if jrest
+ bb.(cut-block jbl jrest jinsns)
+ jbl.next)))
+ (yinsns ybl.insns))
+ (cond
+ (xbl
+ (set ybl.insns ^(,ybl.label ,(car insns) ,*(cdr yinsns)))
+ (pushnew ybl bb.rescan)
+ (set bb.recalc t)
+ (set bb.links (list ybl xbl))
+ ^((if (t ,reg) ,xbl.label)))
+ (t insns))))
+ (@nil insns))))
+ (@(require ((if @(as reg (d @nil)) @nil) . @nil)
+ (not (memqual reg bb.lt-dregs)))
+ (pushnew bl bb.tryjoin)
+ (pushnew bl bb.rescan)
+ (pushnew bl.next bb.rescan)
+ (set bb.recalc t)
+ nil)
+ (@(require @(or ((@(or ifq ifql) @(as reg (d @nil)) (t 0) @jlabel) . @nil)
+ ((@(or ifq ifql) (t 0) @(as reg (d @nil)) @jlabel) . @nil))
+ (not (memqual reg bb.lt-dregs)))
+ (pushnew bl.next bb.rescan)
+ (if bl.next
+ (set bl.prev nil))
+ (set bb.recalc t
+ bl.next nil
+ bl.links (list [bb.hash jlabel]))
+ ^((jmp ,jlabel)))
+ (@(require ((@(or ifq ifql) @(as reg0 (d @n0)) @(as reg1 (d @n1)) @label)
+ . @nil)
+ (neql n0 n1)
+ (not (and (memqual reg0 bb.lt-dregs)
+ (memqual reg1 bb.lt-dregs))))
+ ^((jmp ,label)))
+ (((@(or ifq ifql) @reg @reg . @nil) . @nil)
+ (rest insns))
+ ;; wasteful move of previously tested value
+ (@(require ((ifq (t @reg) (d @n) @nil) . @nil)
+ (let* ((nxbl bl.next)
+ (nxinsns nxbl.insns))
+ (if (null (cdr nxbl.rlinks))
+ (if-match (@label (mov (t @reg) (d @n)) . @rest) nxinsns
+ (set nxbl.insns ^(,label ,*rest)
+ bb.recalc t)))))
+ insns)
+ (((jmp @jlabel) . @nil)
+ (let* ((jinsns (cdr [bb.hash jlabel].insns))
+ (oinsns (match-case jinsns
+ (((jend @nil) . @nil)
+ ^(,(car jinsns)))
+ ((@nil (jend @nil) . @nil)
+ ^(,(car jinsns) ,(cadr jinsns)))
+ (@nil insns))))
+ (when (neq insns oinsns)
+ (pushnew bl bb.rescan)
+ (if bl.next
+ (set bl.prev nil))
+ (set bb.recalc t
+ bl.next nil
+ bl.links nil))
+ oinsns))
+ ;; unnecessary copying t-reg
+ (@(require ((mov @(as dst (t @nil)) @src) . @rest)
+ (nequal dst src))
+ (let ((ren bb.(rename rest dst src)))
+ (cond
+ ((nequal rest ren)
+ (pushnew bl bb.rescan)
+ (set bb.recalc t)
+ (cons (car insns) ren))
+ (t insns))))
+ ;; constant folding
+ (@(require ((@(as op @(or gapply gcall)) @tgt @idx
+ . @(all @(or (d @dn)
+ @(with (t 0) dn nil))))
+ . @(with @rest
+ val nil))
+ [%const-foldable% [bb.symvec idx]]
+ [none dn (lop member bb.lt-dregs : cadr)]
+ (let ((err '#:err))
+ (set val (let* ((insn (car insns))
+ (co bb.compiler)
+ (dvec co.(get-datavec))
+ (fun [bb.symvec idx])
+ (args (mapcar [iffi true dvec] dn))
+ (val (usr:catch
+ (if (eq op 'gcall)
+ (apply fun args)
+ (apply fun (append [args 0..-1]
+ [args -1])))
+ (error (#:x) err))))
+ (when-opt usr:constant-throws
+ (when (and (eq val err)
+ (not (member insn bb.warned-insns)))
+ (diag co.top-form
+ "function ~s with arguments ~s throws"
+ fun args)
+ (push insn bb.warned-insns)))
+ val))
+ (neq val err)))
+ (let* ((dreg bb.compiler.(get-dreg val)))
+ ^((mov ,tgt ,dreg) ,*rest)))
+ ;; apply to gapply
+ (@(require @(with ((getf @(as treg (t @tn)) @idx) . @rest)
+ @(scan @(or @(with @(as apl ((apply @dest @treg . @args)
+ . @arest))
+ li [bb.li-hash (car apl)])
+ @(require (@insn . @nil)
+ (find treg insn))))
+ rest)
+ apl
+ (or (equal dest treg)
+ (not (bit li.used tn))))
+ (set bb.recalc t)
+ (let* ((gapl ^(gapply ,dest ,idx ,*args)))
+ (set [bb.li-hash gapl] li)
+ ^(,*(ldiff rest apl) ,gapl ,*arest)))
+ (@nil insns))))
+
+(defmeth basic-blocks peephole (bb)
+ (each ((bl bb.list))
+ bb.(peephole-block bl))
+ (whilet ((rescan (zap bb.rescan)))
+ (whilet ((bl (pop bb.tryjoin)))
+ (let ((nxbl bl.next))
+ (unless (or bl.nojoin (cdr nxbl.rlinks))
+ bb.(join-block bl nxbl)
+ (set bb.recalc t)
+ (when (memq nxbl bb.tryjoin)
+ (upd bb.tryjoin (remq nxbl))
+ (push bl bb.tryjoin))
+ (upd bb.rescan (remq nxbl)))))
+ (when (zap bb.recalc)
+ bb.(calc-liveness rescan))
+ (each ((bl rescan))
+ bb.(peephole-block bl)))
+ (when bb.reelim
+ bb.(elim-dead-code)))
+
+(defmeth basic-blocks thread-jumps (bb)
+ (each ((bl bb.list))
+ (set bl.insns bb.(thread-jumps-block bl.insns))))
+
+(defmeth basic-blocks join-blocks (bb)
+ (labels ((joinbl (list)
+ (tree-case list
+ ((bl nxbl . rest)
+ (cond
+ ((and (eq bl.next nxbl)
+ (eq (car bl.links) nxbl)
+ (null bl.nojoin)
+ (null (cdr bl.links))
+ (null (cdr nxbl.rlinks)))
+ bb.(join-block bl nxbl)
+ (joinbl (cons bl rest)))
+ (t (cons bl (joinbl (cdr list))))))
+ (else else))))
+ (set bb.list (joinbl bb.list))))
+
+(defmeth basic-blocks elim-dead-code (bb)
+ bb.(link-graph)
+ (let* ((visited (hash :eq-based)))
+ (labels ((visit (bl)
+ (when (test-set [visited bl])
+ (when bl.next
+ (visit bl.next))
+ [mapcar visit bl.links])))
+ (for ((bl (car bb.list))) (bl) ((set bl bl.next))
+ (visit bl)))
+ (upd bb.list (keep-if visited))
+ (let (flg)
+ (each ((bl bb.list)
+ (nx (cdr bb.list)))
+ (when bl.(check-bypass-empty nx)
+ (set flg t)
+ (del [visited bl])))
+ (if flg
+ (upd bb.list (keep-if visited))))
+ (while
+ (let (rep)
+ (each ((bl bb.list)
+ (nx (cdr bb.list)))
+ bl.(elim-next-jump nx)
+ (when bl.(check-bypass-empty nx)
+ (set rep t)
+ (del [visited bl])))
+ (if rep
+ (upd bb.list (keep-if visited))))))
+ bb.(join-blocks)
+ bb.(link-graph))
+
+(defmeth basic-blocks merge-jump-thunks (bb)
+ (let* ((candidates (mappend [andf [chain .links len (op eql 1)]
+ [chain .insns len (lop < 4)]
+ [chain .insns last car
+ [iff consp
+ [chain car (op eq 'jmp)]]]
+ list]
+ bb.list))
+ (hash (group-by [chain .insns cdr] candidates)))
+ (dohash (insns bls hash)
+ (let ((link (car (car bls).links)))
+ (each ((bb bb.list))
+ (if (and (not (member bb bls))
+ (null (cdr bb.links))
+ (eq bb.next link)
+ (starts-with (cdr bb.insns) insns)
+ (eql (len bb.insns) (len insns)))
+ (push bb bls))))
+ (when (cdr bls)
+ (whenlet ((keep (or (keep-if (op some @1.rlinks (op eq @@1) .next) bls)
+ (list (car bls))))
+ (leader (car keep)))
+ (whenlet ((dupes (diff bls keep)))
+ (each ((bl dupes))
+ (each ((pbl bl.rlinks))
+ (let* ((code pbl.insns)
+ (tail (last code))
+ (lins (car tail))
+ (sins (subst bl.label leader.label lins)))
+ (set pbl.insns (append (ldiff code tail) (list sins))))))
+ (set bb.list (remove-if (lop memq dupes) bb.list))))))))
+
+(defmeth basic-blocks late-peephole (bb code)
+ (rewrite-case insns code
+ (((if @reg @lab1)
+ @lab2
+ (jmp @lab3)
+ @lab1
+ . @rest)
+ (let* ((bl [bb.hash lab2]))
+ (if (cdr bl.rlinks)
+ insns
+ ^((ifq ,reg (t 0) ,lab3)
+ ,lab1
+ ,*rest))))
+ (((mov (t @tn) (d @nil))
+ (jmp @lab3)
+ @nil
+ (mov (t @tn) (t 0))
+ @(symbolp @lab3)
+ (ifq (t @tn) (t 0) @lab4)
+ . @nil)
+ ^(,(car insns)
+ (jmp ,lab4)
+ ,*(cddr insns)))
+ ((@(symbolp @lab1)
+ (mov (t @tn) (t 0))
+ @lab2
+ (ifq (t @tn) (t 0) @lab4)
+ @(symbolp)
+ (gcall (t @tn) . @nil)
+ . @nil)
+ ^(,lab2
+ (ifq (t ,tn) (t 0) ,lab4)
+ ,lab1
+ ,*(cddddr insns)))
+ (((mov (t @tx) (t @ty))
+ (if (t @ty) @lab2)
+ @(symbolp @lab1)
+ (gcall (t @tx) . @args)
+ @(symbolp @lab2)
+ (jend (t @tx))
+ . @rest)
+ ^((if (t ,ty) ,lab2)
+ ,lab1
+ (gcall (t ,ty) ,*args)
+ ,lab2
+ (jend (t ,ty))
+ ,*rest))
+ (@else else)))
+
+(defmeth basic-blocks identify-closures (bb)
+ (zap bb.closures)
+ (each ((bl bb.list))
+ (when-match @(end ((close . @nil))) bl.insns
+ (let ((nx bl.next))
+ (set nx.closer bl)
+ (push nx bb.closures))))
+ (upd bb.closures nreverse)
+ (let ((visited (hash :eq-based)))
+ (labels ((visit (bl clhead)
+ (when (test-set [visited bl])
+ (push bl [bb.cl-hash clhead])
+ [mapcar (lop visit clhead) bl.links])))
+ (each ((cb bb.closures))
+ (visit cb cb))))
+ [hash-update bb.cl-hash nreverse])
+
+(defmeth basic-block fill-treg-compacting-map (bl map)
+ (labels ((add-treg (reg)
+ (unless [map reg]
+ (if-match (t @nil) reg
+ (set [map reg] ^(t ,(len map))))))
+ (add-tregs (args)
+ [mapcar add-treg args]))
+ (iflet ((cl bl.closer))
+ (let ((cloinsn (car (last cl.insns))))
+ (add-tregs (cddr cloinsn))))
+ (each ((insn bl.insns))
+ (match-case insn
+ ((close @reg . @nil)
+ (add-treg reg))
+ ((@nil . @args)
+ (add-tregs args))))))
+
+(defmeth basic-block apply-treg-compacting-map (bl map)
+ (labels ((fix (arg) [map arg arg])
+ (fix-tregs (args) [mapcar fix args]))
+ (iflet ((cl bl.closer))
+ (match ((close @reg @frsize @nil . @rest)) (last cl.insns)
+ (set (last cl.insns)
+ ^((close ,reg ,frsize ,(len map) ,*(fix-tregs rest))))))
+ (set bl.insns (collect-each ((insn bl.insns))
+ (match-case insn
+ ((close @reg . @rest)
+ ^(close ,(fix reg) ,*rest))
+ ((@op . @args)
+ ^(,op ,*(fix-tregs args)))
+ (@else else))))))
+
+(defmeth basic-block check-bypass-empty (bl nx)
+ (unless (cdr bl.insns)
+ (upd nx.rlinks (remq bl))
+ (whenlet ((pb bl.prev))
+ (set pb.next nx)
+ (set nx.prev pb))
+ (each ((pb bl.rlinks))
+ (upd pb.links (subst bl nx))
+ (upd pb.insns (mapcar [iffi consp (op subst bl.label nx.label)]))
+ (push pb nx.rlinks))
+ bl))
+
+(defmeth basic-block elim-next-jump (bl nx)
+ (let* ((tail (last bl.insns))
+ (linsn (car tail)))
+ (match-case linsn
+ (@(or (jmp @jlabel)
+ (if @nil @jlabel)
+ (@(or ifq ifql) @nil @nil @jlabel))
+ (when (eql nx.label jlabel)
+ (set bl.insns (butlast bl.insns)))))))
+
+(defmeth basic-blocks compact-tregs (bb)
+ bb.(identify-closures)
+ (each ((bl bb.closures))
+ (let ((clist [bb.cl-hash bl]))
+ (let ((map (hash-from-pairs '(((t 0) (t 0)) ((t 1) (t 1))))))
+ (each ((cl clist))
+ cl.(fill-treg-compacting-map map))
+ (each ((cl clist))
+ cl.(apply-treg-compacting-map map))))))
+
+(defun rewrite (fun list)
+ (build
+ (while* list
+ (let ((nlist [fun list]))
+ (if (eq list nlist)
+ (if list (add (pop list)))
+ (set list nlist))))))
+
+(defun dedup-labels (insns)
+ (rewrite-case tail insns
+ ((@(symbolp @label0) @(symbolp @label1) . @rest)
+ (set insns (mapcar [iffi listp (op subst label1 label0)]
+ (remq label1 insns)))
+ (cons label0 rest))
+ (@nil tail))
+ insns)
+
+(defun early-peephole (code)
+ (rewrite-case insns code
+ (((mov (t @t1) (d @d1))
+ (jmp @lab2)
+ @(symbolp @lab1)
+ (mov (t @t1) (t 0))
+ @lab2
+ (ifq (t @t1) (t 0) @lab3)
+ . @rest)
+ ^((mov (t ,t1) (d ,d1))
+ (jmp ,lab3)
+ ,lab1
+ (mov (t ,t1) (t 0))
+ ,lab2
+ ,*rest))
+ (@else else)))
diff --git a/share/txr/stdlib/package.tl b/stdlib/package.tl
index d399dd81..58263126 100644
--- a/share/txr/stdlib/package.tl
+++ b/stdlib/package.tl
@@ -1,4 +1,4 @@
-;; Copyright 2016-2020
+;; Copyright 2016-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,23 +6,24 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(defun sys:name-str (kind sym-or-string)
(cond
@@ -60,6 +61,10 @@
(:use-syms
^((each ((s ',rest))
(use-sym s ,pkg))))
+ (:use-syms-as
+ ^((doloop ((r ',rest (cddr r)))
+ (r)
+ (use-sym-as (car r) (cadr r) ,pkg))))
(:local
^((each ((n ',(mapcar (op sys:name-str 'symbol)
rest)))
diff --git a/share/txr/stdlib/param.tl b/stdlib/param.tl
index e656eadc..f1f3768a 100644
--- a/share/txr/stdlib/param.tl
+++ b/stdlib/param.tl
@@ -1,4 +1,4 @@
-;; Copyright 2019-2020
+;; Copyright 2019-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,23 +6,24 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(compile-only
(defstruct param-parser-base nil
@@ -67,4 +68,15 @@
(mac-param-p nil))
(defstruct (mac-param-parser syntax form) param-parser-base
- (mac-param-p t)))
+ (mac-param-p t))
+
+ (defstruct (param-info fun) nil
+ fun
+ nreq nopt nfix rest
+ (:postinit (me)
+ (let* ((fix (fun-fixparam-count me.fun))
+ (opt (fun-optparam-count me.fun)))
+ (set me.nreq (- fix opt)
+ me.nopt opt
+ me.nfix fix
+ me.rest (fun-variadic me.fun))))))
diff --git a/stdlib/path-test.tl b/stdlib/path-test.tl
new file mode 100644
index 00000000..e3046c60
--- /dev/null
+++ b/stdlib/path-test.tl
@@ -0,0 +1,363 @@
+;; Copyright 2015-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defun sys:do-path-test (statfun path testfun)
+ [testfun (if (typep path 'stat)
+ path
+ (ignerr [statfun path]))])
+
+(eval-only
+ (defmacro sys:path-test ((sym statfun path) . body)
+ ^[sys:do-path-test ,statfun ,path
+ (lambda (,sym) (when ,sym ,*body))]))
+
+(defun sys:path-test-type (statfun path code)
+ (sys:path-test (s statfun path)
+ (eql (logand s.mode s-ifmt) code)))
+
+(defun sys:path-test-mode (statfun path mask)
+ (sys:path-test (s statfun path)
+ (plusp (logand s.mode mask))))
+
+(defun path-exists-p (path)
+ (sys:path-test (s stat path) t))
+
+(defun path-file-p (path)
+ [sys:path-test-type stat path s-ifreg])
+
+(defun path-dir-p (path)
+ [sys:path-test-type stat path s-ifdir])
+
+(defun path-symlink-p (path)
+ [sys:path-test-type lstat path s-iflnk])
+
+(defun path-blkdev-p (path)
+ [sys:path-test-type stat path s-ifblk])
+
+(defun path-chrdev-p (path)
+ [sys:path-test-type stat path s-ifchr])
+
+(defun path-sock-p (path)
+ [sys:path-test-type stat path s-ifsock])
+
+(defun path-pipe-p (path)
+ [sys:path-test-type stat path s-ififo])
+
+(defun path-setgid-p (path)
+ [sys:path-test-mode stat path s-isgid])
+
+(defun path-setuid-p (path)
+ [sys:path-test-mode stat path s-isuid])
+
+(defun path-sticky-p (path)
+ [sys:path-test-mode stat path s-isvtx])
+
+(defun path-mine-p (path)
+ (sys:path-test (s stat path)
+ (= s.uid (getuid))))
+
+(defun path-my-group-p (path)
+ (sys:path-test (s stat path)
+ (let ((g s.gid))
+ (or (= g (getgid))
+ (find g (getgroups))))))
+
+;; umask, gmask and omask must test identical permissions
+;; multiple permissions may be tested, but not a combination
+;; of x with any other permission.
+(defun sys:path-access (path umask gmask omask)
+ (sys:path-test (s stat path)
+ (let ((m s.mode)
+ (uid (getuid)))
+ (cond
+ ((zerop uid) (or (zerop (logand umask s-ixusr))
+ (plusp (logand m (logior umask gmask omask)))))
+ ((= uid s.uid) (= umask (logand m umask)))
+ ((let ((g s.gid))
+ (or (= g (getgid))
+ (find g (getgroups))))
+ (= gmask (logand m gmask)))
+ (t (= omask (logand m omask)))))))
+
+(defun path-executable-to-me-p (path)
+ (sys:path-access path s-ixusr s-ixgrp s-ixoth))
+
+(defun path-writable-to-me-p (path)
+ (sys:path-access path s-iwusr s-iwgrp s-iwoth))
+
+(defun path-readable-to-me-p (path)
+ (sys:path-access path s-irusr s-irgrp s-iroth))
+
+(defun path-read-writable-to-me-p (path)
+ (sys:path-access path
+ (logior s-irusr s-iwusr)
+ (logior s-irgrp s-iwgrp)
+ (logior s-iroth s-iwoth)))
+
+(defun path-private-to-me-p (path)
+ (sys:path-test (s stat path)
+ (let ((m s.mode)
+ (uid (geteuid)))
+ (mlet ((g (getgrgid s.gid))
+ (name (let ((pw (getpwuid uid)))
+ (if pw pw.name)))
+ (suname (let ((pw (getpwuid 0)))
+ (if pw pw.name))))
+ (and (or (zerop s.uid)
+ (eql uid s.uid))
+ (zerop (logand m s-iwoth))
+ (or (zerop (logand m s-iwgrp))
+ (null g.mem)
+ (and (all g.mem (orf (op equal name)
+ (op equal suname))))))))))
+
+(defun path-strictly-private-to-me-p (path)
+ (sys:path-test (s stat path)
+ (let ((m s.mode)
+ (uid (geteuid)))
+ (mlet ((g (getgrgid s.gid))
+ (name (let ((pw (getpwuid uid)))
+ (if pw pw.name)))
+ (suname (let ((pw (getpwuid 0)))
+ (if pw pw.name))))
+ (and (or (zerop s.uid)
+ (eql uid s.uid))
+ (zerop (logand m (logior s-iroth s-iwoth)))
+ (or (zerop (logand m (logior s-irgrp s-iwgrp)))
+ (null g.mem)
+ (and (all g.mem (orf (op equal name)
+ (op equal suname))))))))))
+
+(defun path-simplify (comp)
+ (let ((abs (equal (car comp) ""))
+ out)
+ (each ((c comp))
+ (casequal c
+ (".." (if (and (or out abs) (nequal (car out) ".."))
+ (pop out)
+ (push c out)))
+ (("." ""))
+ (t (push c out))))
+ (nreverse out)))
+
+(eval-only
+ (defmacro if-windows (then : else)
+ (use then)
+ (if (eql 2 (sizeof wchar))
+ then
+ else))
+
+ (defmacro if-native-windows (then : else)
+ (use then)
+ (if-windows
+ ^(if (find #\\ path-sep-chars) ,then ,else)
+ else)))
+
+(defun path-safe-sticky-dir (st)
+ (let ((sdir (logior s-ifdir s-isvtx)))
+ (and (eql (logand st.mode sdir) sdir)
+ (zerop st.uid))))
+
+(if (starts-with "Linux" (uname).sysname)
+ (defun safe-abs-path (comps)
+ (flet ((digstr (s) [all s chr-isdigit]))
+ (let ((safe t))
+ (when-match ("proc" @(or @(digstr) "self") . @rest)
+ (path-simplify comps)
+ (match-case rest
+ (@(or ("cwd" . @nil)
+ ("root" . @nil)
+ ("map_files" . @nil)
+ ("fd" @(digstr) . @nil))
+ (zap safe))
+ (("task" @(digstr) . @trest)
+ (match-case trest
+ (@(or ("cwd" . @nil)
+ ("root" . @nil)
+ ("fd" @(digstr) . @nil))
+ (zap safe))))))
+ safe)))
+ (set (symbol-function 'safe-abs-path) (fun tf)))
+
+(defun path-components-safe (path)
+ (if-native-windows
+ t
+ (let* ((abs-p (abs-path-p path))
+ (comps (remqual "" (sspl path-sep-chars path)))
+ (start (if abs-p "/" ".")))
+ (if (and
+ (nullify path)
+ (or (not abs-p) (safe-abs-path comps))
+ (let ((st (stat start)))
+ (or (path-private-to-me-p st)
+ (if (nequal start "/")
+ (path-safe-sticky-dir st)))))
+ (for ((ok t) (count 0) next (orig-start start))
+ ((and ok (set next (pop comps))) ok)
+ ()
+ (let* ((nxpath (path-cat start next))
+ (st (lstat nxpath)))
+ (cond
+ ((eql (logand st.mode s-ifmt) s-iflnk)
+ (if (> (inc count) 16)
+ (throwf 'file-error "~a: too many symbolic links"
+ 'path-components-safe))
+ (if (and (eql 1 st.nlink)
+ (or (zerop st.uid)
+ (eql st.uid (geteuid))))
+ (let* ((target (readlink nxpath))
+ (abs-p (abs-path-p target))
+ (tcomps (remqual "" (sspl path-sep-chars target))))
+ (when abs-p
+ (set start "/"
+ ok (and (safe-abs-path comps)
+ (if (nequal orig-start "/")
+ (set orig-start nil)
+ t))))
+ (when ok
+ (set comps (nconc tcomps comps))))
+ (set ok nil)))
+ ((or (path-private-to-me-p st)
+ (path-safe-sticky-dir st))
+ (set start nxpath))
+ (t (zap ok)))))))))
+
+(defmacro sys:path-examine ((sym statfun path) . body)
+ ^[sys:do-path-test ,statfun ,path
+ (lambda (,sym) ,*body)])
+
+(defun path-newer (path-0 path-1)
+ (sys:path-examine (s0 stat path-0)
+ (sys:path-examine (s1 stat path-1)
+ (if s0
+ (or (null s1)
+ (let ((mt0 s0.mtime)
+ (mt1 s1.mtime))
+ (or (> mt0 mt1)
+ (and (= mt0 mt1)
+ (> s0.mtime-nsec s1.mtime-nsec)))))))))
+
+(defun path-older (path-0 path-1)
+ (path-newer path-1 path-0))
+
+(defun path-same-object (path-0 path-1)
+ (sys:path-examine (s0 stat path-0)
+ (sys:path-examine (s1 stat path-1)
+ (and s0 s1
+ (eql s0.dev s1.dev)
+ (eql s0.ino s1.ino)))))
+
+(defun path-dir-empty (path)
+ (when (path-dir-p path)
+ (let ((name (if (stringp path) path path.path)))
+ (with-stream (ds (open-directory name))
+ (for (ent) ((set ent (get-line ds)) t) ()
+ (casequal ent
+ (("." ".."))
+ (t (return nil))))))))
+
+(defun path-split (str)
+ (let ((spl0 (sspl path-sep-chars str)))
+ (if-native-windows
+ (iflet ((head (car spl0))
+ (p (pos #\: head)))
+ (list* [head 0..(succ p)]
+ [head (succ p)..:]
+ (cdr spl0))
+ spl0)
+ spl0)))
+
+(defun path-volume (comp)
+ (let ((head (car comp)))
+ (if-native-windows
+ (let ((next (cadr comp))
+ (more (cddr comp)))
+ (cond
+ ((and (equal head "") (equal next "") more)
+ (let ((vol (car more)))
+ (cond
+ ((nequal "" vol)
+ (set (car comp) "")
+ (set (cdr comp) (cdr more))
+ vol)
+ (t :abs))))
+ ((and (m^ #/[A-Za-z0-9]+:/ head) head)
+ (set (car comp) next)
+ (set (cdr comp) more)
+ (if (and (equal "" next) more)
+ ^(:abs . ,head)
+ ^(:rel . ,head)))))
+ (if (and (equal head "") (cdr comp)) :abs))))
+
+(defun rel-path (from to)
+ (let* ((fspl (path-split from))
+ (tspl (path-split to))
+ (fvol (path-volume fspl))
+ (tvol (path-volume tspl)))
+ (when (nequal fvol tvol)
+ (if (and (meq :abs fvol tvol) (meq nil fvol tvol))
+ (error "~s: mixture of absolute and relative paths ~s ~s given"
+ 'rel-path from to))
+ (if (meq :abs fvol tvol)
+ (error "~s: mixture of absolute and volume paths ~s ~s given"
+ 'rel-path from to))
+ (if-windows
+ (progn
+ (when (and (consp fvol) (consp tvol))
+ (if (neq (car fvol) (car tvol))
+ (error "~s: mixture of volume absolute and relative paths \
+ \ ~s ~s given"
+ 'rel-path from to)))
+ (when (neq (null fvol) (null tvol))
+ (error "~s: mixture of volume and non-volume paths ~s ~s given"
+ 'rel-path from to))
+ (error "~s: paths on different volumes ~s ~s given"
+ 'rel-path from to))))
+ (let* ((fcomp (path-simplify fspl))
+ (tcomp (path-simplify tspl))
+ (ncommon (mismatch fcomp tcomp)))
+ (cond
+ ((null ncommon) ".")
+ ((find ".." (nthcdr ncommon fcomp))
+ (error "~s: from path uses .. to escape common prefix: ~s ~s"
+ 'rel-path from to))
+ (t (let ((nup (- (len fcomp) ncommon))
+ (down [tcomp ncommon..:]))
+ (cat-str (append (repeat '("..") nup) down)
+ [path-sep-chars 0])))))))
+
+(defun path-equal (left right)
+ (if (and (stringp left) (equal left right))
+ t
+ (let* ((lspl (path-split left))
+ (rspl (path-split right))
+ (lvol (path-volume lspl))
+ (rvol (path-volume rspl)))
+ (if (nequal lvol rvol)
+ nil
+ (equal (path-simplify lspl)
+ (path-simplify rspl))))))
diff --git a/stdlib/pic.tl b/stdlib/pic.tl
new file mode 100644
index 00000000..ecc437b2
--- /dev/null
+++ b/stdlib/pic.tl
@@ -0,0 +1,191 @@
+;; Copyright 2021-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defun expand-pic-num (fmt val)
+ (let* ((zero (or (starts-with "0" fmt)
+ (starts-with "+0" fmt)
+ (starts-with "-0" fmt)))
+ (plus (eql [fmt 0] #\+))
+ (minus (eql [fmt 0] #\-))
+ (exc (pos #\! fmt))
+ (dot (or exc (pos #\. fmt)))
+ (fmt (if (and exc (eq #\! [fmt -1])) [fmt 0..-1] fmt))
+ (fra (if dot [fmt (succ dot)..:] "")))
+ (let ((code (if (or minus plus (not zero))
+ ^(fmt ,`~@(len fmt),@(if plus "+")@(if zero "0")@(len fra)f`
+ ,val)
+ ^(fmt ,`~@(len fmt),-0@(len fra)f`
+ ,val))))
+ (if exc
+ (with-gensyms (str)
+ ^(let ((,str ,code))
+ (if (> (len ,str) ,(len fmt))
+ ,(let ((fill (mkstring (len fmt) #\#)))
+ (if (plusp (len fra))
+ (set [fill dot] #\.))
+ fill)
+ ,str)))
+ code))))
+
+(defun comma-positions (fmt)
+ (let* ((fmtx (regsub #/,./ #\, fmt))
+ (len (len fmtx))
+ (ppos (or (pos #\. fmtx) (pos #\! fmtx) len))
+ (out (vec)))
+ (each ((i len..0))
+ (if (meql [fmtx i] #\,)
+ (vec-push out (- ppos i))))
+ out))
+
+(defun insert-commas (num positions)
+ (let* ((len (len num))
+ (pn (len positions))
+ (ppos (or (pos #\. num) len))
+ (out (mkstring 0))
+ (j 0)
+ (comma #\,))
+ (each ((i len..0)
+ (p (- ppos len -1)))
+ (cond
+ ((meq comma #\- #\+ #\space)
+ (string-extend out comma)
+ (set comma #\space))
+ (t
+ (string-extend out [num i])))
+ (when (plusp i)
+ (when (< j pn)
+ (ifa (meq [num (pred i)] #\space #\- #\+)
+ (set comma it))
+ (let ((pj [positions j]))
+ (cond
+ ((eql pj p)
+ (string-extend out comma)
+ (if (neq comma #\,)
+ (set comma #\space))
+ (inc j))
+ ((< pj p)
+ (inc j)))))))
+ (nreverse out)))
+
+(defun add-neg-parens (width str)
+ (let ((sig (pos #\- str))
+ (w (len str)))
+ (cond
+ (sig
+ (set [str sig] #\space)
+ `(@[str 1..:])`)
+ ((> w width) str)
+ (t `@str `))))
+
+(defun expand-pic-num-commas (fmt val)
+ (let* ((fmt-nc (remq #\, fmt))
+ (exp-nc (expand-pic-num fmt-nc val)))
+ ^(insert-commas ,exp-nc ,(comma-positions fmt))))
+
+(defun expand-neg-parens (width exp-n)
+ ^(add-neg-parens ,width ,exp-n))
+
+(defun expand-pic-align (chr fmt val)
+ ^(fmt ,`~@(if chr chr)@(len fmt)a` ,val))
+
+(defun pic-join-opt (join-form)
+ (labels ((et (str) (regsub "~" "~~" str)))
+ (match-case join-form
+ ((join @(stringp @s) (fmt `@fmt` . @args) . @rest)
+ (pic-join-opt ^(join (fmt ,`@(et s)@fmt` ,*args) ,*rest)))
+ ((join (fmt `@fmt` . @args) @(stringp @s) . @rest)
+ (pic-join-opt ^(join (fmt ,`@fmt@(et s)` ,*args) ,*rest)))
+ ((join (fmt `@fmt1` . @args1) (fmt `@fmt2` . @args2) . @rest)
+ (pic-join-opt ^(join (fmt ,`@fmt1@fmt2` ,*args1 ,*args2) ,*rest)))
+ ((join @(stringp @s1) @(stringp @s2) . @rest)
+ (pic-join-opt ^(join ,`@s1@s2` ,*rest)))
+ ((join "" @item . @rest)
+ (pic-join-opt ^(join ,item ,*rest)))
+ ((join @item "" . @rest)
+ (pic-join-opt ^(join ,item ,*rest)))
+ ((join @item) item)
+ (@else else))))
+
+(defun expand-pic (f fmt val)
+ (unless (stringp fmt)
+ (compile-error f "~s is required to be a format string" fmt))
+ (cond
+ ([m^$ #/\~[~#<>\|\-+0.!,()]/ fmt] [fmt 1..2])
+ ([m^$ #/\~./ fmt] (compile-error f "unrecognized escape sequence ~a" fmt))
+ ([m^$ #/\~/ fmt] (compile-error f "incomplete ~~ escape"))
+ ([m^$ #/[+\-]?(0,?)?#+(,#+)*([.!]#+(,#+)*|!)?/ fmt]
+ (if (contains "," fmt)
+ (expand-pic-num-commas fmt val)
+ (expand-pic-num fmt val)))
+ ([m^$ #/\((0,?)?#+(,#+)*([.!]#+(,#+)*|!)?\)/ fmt]
+ (let ((fmt `-@[fmt 1..-1]`))
+ (expand-neg-parens
+ (len fmt)
+ (if (contains "," fmt)
+ (expand-pic-num-commas fmt val)
+ (expand-pic-num fmt val)))))
+ ([m^$ #/<+/ fmt] (expand-pic-align "<" fmt val))
+ ([m^$ #/>+/ fmt] (expand-pic-align nil fmt val))
+ ([m^$ #/\|+/ fmt] (expand-pic-align "^" fmt val))
+ (t (compile-error f "unrecognized format string ~s" fmt))))
+
+(defmacro pic (:form f bigfmt . args)
+ (let* ((regex #/[+\-]?(0,?)?#+(,#+)*([.!]#+(,#+)*|!)?| \
+ \((0,?)?#+(,#+)*([.!]#+(,#+)*|!)?\)| \
+ <+| \
+ >+| \
+ \|+| \
+ \~.|\~/))
+ (labels ((pic-compile-string (fmtstr)
+ (let ((items (collect-each ((piece (tok regex t fmtstr)))
+ (cond
+ ((m^$ regex piece)
+ (cond
+ ((starts-with "~" piece)
+ (expand-pic f piece nil))
+ (args
+ (expand-pic f piece (pop args)))
+ (t (compile-error
+ f "insufficient arguments for format"))))
+ (t piece)))))
+ (pic-join-opt ^(join ,*items)))))
+ (match-case bigfmt
+ (@(stringp @s)
+ (let ((out (pic-compile-string s)))
+ (if args
+ (compile-warning f "excess arguments"))
+ out))
+ ((@(or sys:quasi) . @qargs)
+ (let ((nqargs (build (each ((q qargs))
+ (if (stringp q)
+ (add (pic-compile-string q))
+ (add q))))))
+ (if args
+ (compile-warning f "excess arguments"))
+ ^(sys:quasi ,*nqargs)))
+ (@else (compile-error
+ f "~s is required to be a string or quasiliteral" else))))))
diff --git a/share/txr/stdlib/place.tl b/stdlib/place.tl
index 4e2c7904..61f86358 100644
--- a/share/txr/stdlib/place.tl
+++ b/stdlib/place.tl
@@ -1,4 +1,4 @@
-;; Copyright 2015-2020
+;; Copyright 2015-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,23 +6,24 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(defvar *place-clobber-expander* (hash))
(defvar *place-update-expander* (hash))
@@ -60,9 +61,9 @@
(defun sys:get-place-macro (sym)
(or [*place-macro* sym]
- (progn (sys:try-load sym) [*place-macro* sym])))
+ (progn (sys:autoload-try-fun sym) [*place-macro* sym])))
-(defun sys:pl-expand (unex-place env)
+(defun macroexpand-place (unex-place : env)
(while t
(let ((place unex-place)
pm-expander)
@@ -75,11 +76,19 @@
(when (or (eq place unex-place)
(null place)
(and (atom place) (not (symbolp place))))
- (return-from sys:pl-expand place))
+ (return-from macroexpand-place place))
(sys:setq unex-place place))))
+(defun macroexpand-1-place (unex-place : env)
+ (ignore env)
+ (let ((pm-expander (if (consp unex-place)
+ (sys:get-place-macro (car unex-place)))))
+ (if pm-expander
+ [pm-expander unex-place]
+ unex-place)))
+
(defun place-form-p (unex-place env)
- (let ((place (sys:pl-expand unex-place env)))
+ (let ((place (macroexpand-place unex-place env)))
(or (bindable place)
(and (consp place) [*place-update-expander* (car place)] t))))
@@ -121,13 +130,14 @@
[sys:r-s-let-expander bindings body e 'let constantp])
(defmacro slet (bindings :env e . body)
- (sys:r-s-let-expander bindings body e 'let [orf constantp bindable]))
+ (sys:r-s-let-expander bindings body e 'let [orf constantp
+ (op lexical-var-p e)]))
(defmacro alet (bindings :env e . body)
(let ((exp-bindings (mapcar (aret ^(,@1 ,(macroexpand @2 e))) bindings)))
(if [some exp-bindings constantp second]
[sys:r-s-let-expander exp-bindings body e 'alet constantp]
- ^(,(if [all exp-bindings bindable second]
+ ^(,(if [all exp-bindings (op lexical-var-p e) second]
'symacrolet 'let)
,exp-bindings ,*body))))
@@ -135,17 +145,18 @@
^(let ,(zip syms (repeat '((gensym)))) ,*body))
(defun sys:propagate-ancestor (to-tree from-form . syms)
- (tree-case to-tree
- ((a . d)
- (when (memq a syms)
- (sys:set-macro-ancestor to-tree from-form))
- (sys:propagate-ancestor a from-form . syms)
- (sys:propagate-ancestor d from-form . syms)))
+ (unless (macro-ancestor to-tree)
+ (tree-case to-tree
+ ((a . d)
+ (when (memq a syms)
+ (sys:set-macro-ancestor to-tree from-form))
+ (sys:propagate-ancestor a from-form . syms)
+ (sys:propagate-ancestor d from-form . syms))))
to-tree)
(defun call-update-expander (getter setter unex-place env body)
(sys:propagate-ancestor body unex-place getter setter)
- (let* ((place (sys:pl-expand unex-place env))
+ (let* ((place (macroexpand-place unex-place env))
(expander (get-update-expander place))
(sys:*pl-env* env)
(sys:*pl-form* unex-place)
@@ -155,7 +166,7 @@
(defun call-clobber-expander (ssetter unex-place env body)
(sys:propagate-ancestor body unex-place ssetter)
- (let* ((place (sys:pl-expand unex-place env))
+ (let* ((place (macroexpand-place unex-place env))
(expander (get-clobber-expander place))
(sys:*pl-env* env)
(sys:*pl-form* unex-place)
@@ -165,7 +176,7 @@
(defun call-delete-expander (deleter unex-place env body)
(sys:propagate-ancestor body unex-place deleter)
- (let* ((place (sys:pl-expand unex-place env))
+ (let* ((place (macroexpand-place unex-place env))
(expander (get-delete-expander place))
(sys:*pl-env* env)
(sys:*pl-form* unex-place)
@@ -205,13 +216,15 @@
(list a b (gensym) (gensym) (gensym)))
(tuples 2 place-value-pairs)))
(ls (reduce-left (tb ((lets stores) (place value temp getter setter))
- (list ^((,temp ,value) ,*lets)
- ^((,setter ,temp) ,*stores)))
+ (ignore place getter)
+ (list ^((,temp ,value) ,*lets)
+ ^((,setter ,temp) ,*stores)))
pvtgs '(nil nil)))
(lets (first ls))
(stores (second ls))
(body-form ^(rlet (,*lets) ,*stores)))
(reduce-left (tb (accum-form (place value temp getter setter))
+ (ignore place value temp)
(call-update-expander getter setter
place env accum-form))
pvtgs body-form))))))
@@ -297,7 +310,7 @@
(defmacro shift (:form f :env env . places)
(tree-case places
(() (compile-error f "need at least two arguments"))
- ((place) (compile-error f "need at least two arguments"))
+ ((t) (compile-error f "need at least two arguments"))
((place newvalue)
(with-update-expander (getter setter) place env
^(prog1 (,getter) (,setter ,newvalue))))
@@ -361,6 +374,13 @@
^(placelet ((,pl ,place))
(set ,pl (call (opip ,*opip-args) ,pl)))))
+(defmacro ensure (:env env place init-expr)
+ (with-gensyms (existing)
+ (with-update-expander (getter setter) place env
+ ^(iflet ((,existing (,getter)))
+ ,existing
+ (,setter ,init-expr)))))
+
(defmacro defplace (place-destructuring-args body-sym
(getter-sym setter-sym update-body) :
((ssetter-sym clobber-body))
@@ -520,6 +540,7 @@
(defplace (vecref vector index :whole args) body
(getter setter
(with-gensyms (vec-sym ind-sym)
+ (ignore args)
^(alet ((,vec-sym ,vector)
(,ind-sym ,index))
(macrolet ((,getter () ^(vecref ,',vec-sym ,',ind-sym))
@@ -527,9 +548,11 @@
,body))))
(ssetter
^(macrolet ((,ssetter (val) ^(refset ,*',args ,val)))
+ ,(ignore vector index)
,body))
(deleter
(with-gensyms (vec-sym ind-sym)
+ (ignore args)
^(alet ((,vec-sym ,vector)
(,ind-sym ,index))
(macrolet ((,deleter ()
@@ -541,6 +564,7 @@
(defplace (chr-str string index :whole args) body
(getter setter
(with-gensyms (str-sym ind-sym)
+ (ignore args)
^(alet ((,str-sym ,string)
(,ind-sym ,index))
(macrolet ((,getter () ^(chr-str ,',str-sym ,',ind-sym))
@@ -548,9 +572,11 @@
,body))))
(ssetter
^(macrolet ((,ssetter (val) ^(chr-str-set ,*',args ,val)))
+ ,(ignore string index)
,body))
(deleter
(with-gensyms (str-sym ind-sym)
+ (ignore args)
^(alet ((,str-sym ,string)
(,ind-sym ,index))
(macrolet ((,deleter ()
@@ -562,6 +588,7 @@
(defplace (ref seq index :whole args) body
(getter setter
(with-gensyms (seq-sym ind-sym)
+ (ignore args)
^(alet ((,seq-sym ,seq)
(,ind-sym ,index))
(macrolet ((,getter () ^(ref ,',seq-sym ,',ind-sym))
@@ -569,18 +596,22 @@
,body))))
(ssetter
^(macrolet ((,ssetter (val) ^(refset ,*',args ,val)))
+ ,(ignore seq index)
,body))
(deleter
(with-gensyms (seq-sym ind-sym)
- ^(alet ((,seq-sym ,seq)
- (,ind-sym ,index))
- (macrolet ((,deleter ()
- ^(prog1 (ref ,',seq-sym ,',ind-sym)
- (replace ,',seq-sym nil
- ,',ind-sym (succ ,',ind-sym)))))
- ,body)))))
+ (ignore args)
+ (with-clobber-expander (seq-ssetter) seq sys:*pl-env*
+ ^(alet ((,seq-sym ,seq)
+ (,ind-sym ,index))
+ (macrolet ((,deleter ()
+ ^(prog1 (ref ,',seq-sym ,',ind-sym)
+ (,',seq-ssetter (replace ,',seq-sym nil
+ ,',ind-sym
+ (succ ,',ind-sym))))))
+ ,body))))))
-(defplace (sub seq :whole args : (from 0) (to t)) body
+(defplace (sub seq : (from 0) (to t)) body
(getter setter
(with-gensyms (seq-sym from-sym to-sym v-sym)
(with-update-expander (seq-getter seq-setter) seq sys:*pl-env*
@@ -622,6 +653,7 @@
(defplace (gethash hash key : (default nil have-default-p)) body
(getter setter
(with-gensyms (entry-sym)
+ (ignore have-default-p)
^(let ((,entry-sym (inhash ,hash ,key ,default)))
(macrolet ((,getter () ^(cdr ,',entry-sym))
(,setter (val) ^(sys:rplacd ,',entry-sym ,val)))
@@ -652,9 +684,9 @@
^(set-hash-userdata ,',hash ,val)))
,body)))
-(defplace (dwim obj-place :env env . args) body
+(defplace (dwim obj-place . args) body
(getter setter
- (with-gensyms (ogetter-sym osetter-sym obj-sym newval-sym)
+ (with-gensyms (obj-sym newval-sym)
(let ((arg-syms (mapcar (ret (gensym)) args)))
(if (place-form-p obj-place sys:*pl-env*)
(with-update-expander (ogetter-sym osetter-sym)
@@ -681,7 +713,7 @@
,',newval-sym)))
,body))))))
(ssetter
- (with-gensyms (osetter-sym ogetter-sym obj-sym newval-sym)
+ (with-gensyms (obj-sym newval-sym)
(let ((arg-syms (mapcar (ret (gensym)) args)))
(if (place-form-p obj-place sys:*pl-env*)
(with-update-expander (ogetter-sym osetter-sym)
@@ -709,7 +741,7 @@
,body)))))
(deleter
- (with-gensyms (osetter-sym ogetter-sym obj-sym oldval-sym)
+ (with-gensyms (obj-sym oldval-sym)
(let ((arg-syms (mapcar (ret (gensym)) args)))
(if (place-form-p obj-place sys:*pl-env*)
(with-update-expander (ogetter-sym osetter-sym)
@@ -724,15 +756,76 @@
(sys:dwim-del t ,',obj-sym ,*',arg-syms))
,',oldval-sym)))))
,body))
- ^(macrolet ((,deleter ()
- ^(rlet ((,',obj-sym ,',obj-place)
- ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2)))
- ',arg-syms ',args))
- (let ((,',oldval-sym [,',obj-sym ,*',arg-syms]))
- (progn
- (sys:dwim-del nil ,',obj-sym ,*',arg-syms)
- ,',oldval-sym)))))
- ,body))))))
+ ^(macrolet ((,deleter ()
+ ^(rlet ((,',obj-sym ,',obj-place)
+ ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2)))
+ ',arg-syms ',args))
+ (let ((,',oldval-sym [,',obj-sym ,*',arg-syms]))
+ (progn
+ (sys:dwim-del nil ,',obj-sym ,*',arg-syms)
+ ,',oldval-sym)))))
+ ,body))))))
+
+(defplace (mref1 seq index) body
+ (getter setter
+ (with-gensyms (obj-sym ind-sym val-sym)
+ (if (place-form-p seq sys:*pl-env*)
+ (with-update-expander (seq-getter seq-setter) seq sys:*pl-env*
+ ^(alet ((,obj-sym (,seq-getter))
+ (,ind-sym ,index))
+ (macrolet ((,getter () ^(mref ,',obj-sym ,',ind-sym))
+ (,setter (val)
+ ^(alet ((,',val-sym ,val))
+ (,',seq-setter (sys:dwim-set t
+ ,',obj-sym
+ ,',ind-sym
+ ,',val-sym))
+ ,',val-sym)))
+ ,body)))
+ ^(rlet ((,obj-sym ,seq)
+ (,ind-sym ,index))
+ (macrolet ((,getter () '(mref ,obj-sym ,ind-sym))
+ (,setter (val)
+ ^(alet ((,',val-sym ,val))
+ (sys:dwim-set nil
+ ,',obj-sym
+ ,',ind-sym
+ ,',val-sym)
+ ,',val-sym)))
+ ,body)))))
+ (ssetter
+ (with-gensyms (val-sym)
+ (if (place-form-p seq sys:*pl-env*)
+ (with-update-expander (seq-getter seq-setter) seq sys:*pl-env*
+ ^(macrolet ((,ssetter (val)
+ ^(alet ((,',val-sym ,val))
+ (,',seq-setter
+ (sys:dwim-set t
+ (,',seq-getter)
+ ,',index
+ ,',val-sym))
+ ,',val-sym)))
+ ,body))
+ ^(macrolet ((,ssetter (val)
+ ^(alet ((,',val-sym ,val))
+ (sys:dwim-set nil
+ ,',seq
+ ,',index
+ ,',val-sym)
+ ,',val-sym)))
+ ,body))))
+ (deleter
+ (with-gensyms (obj-sym ind-sym)
+ (with-update-expander (seq-getter seq-setter) seq sys:*pl-env*
+ ^(alet ((,obj-sym (,seq-getter))
+ (,ind-sym ,index))
+ (macrolet ((,deleter ()
+ ^(prog1 (mref ,',obj-sym ,',ind-sym)
+ (,',seq-setter
+ (sys:dwim-del ,',(place-form-p seq sys:*pl-env*)
+ ,',obj-sym
+ ,',index)))))
+ ,body))))))
(defplace (force promise) body
(getter setter
@@ -790,20 +883,20 @@
:))
((type sym)
(if (eq type 'macro)
- (let ((cell (or (gethash sys:top-mb sym)
- (sethash sys:top-mb sym (cons sym nil)))))
+ (let ((cell (or (inhash sys:top-mb sym nil))))
(cons (op cdr)
(op sys:rplacd cell)))
:))
- ((op . rest)
+ ((op . t)
(if (eq op 'lambda)
(compile-error f "cannot assign to lambda")
(compile-error f "invalid function syntax ~s" sym)))
(else
- (let ((cell (or (gethash sys:top-fb sym)
- (sethash sys:top-fb sym (cons sym nil)))))
- (cons (op cdr)
- (op sys:rplacd cell))))))
+ (if (bindable else)
+ (let ((cell (inhash sys:top-fb sym nil)))
+ (cons (op cdr)
+ (op sys:rplacd cell)))
+ (compile-error f "~s isn't a bindable symbol" else)))))
(defplace (symbol-function sym-expr) body
(getter setter
@@ -818,7 +911,7 @@
,body)))
(defun sys:get-mb (f sym)
- (or (gethash sys:top-mb sym)
+ (or (inhash sys:top-mb sym)
(compile-error f "unbound macro ~s" sym)))
(defplace (symbol-macro sym-expr) body
@@ -834,15 +927,14 @@
,body)))
(defun sys:get-vb (sym)
- (or (gethash sys:top-vb sym)
- (sethash sys:top-vb sym (cons sym nil))))
+ (inhash sys:top-vb sym nil))
(defplace (symbol-value sym-expr) body
(getter setter
- (with-gensyms (binding-sym)
- ^(let ((,binding-sym (sys:get-vb ,sym-expr)))
- (macrolet ((,getter () ^(cdr ,',binding-sym))
- (,setter (val) ^(sys:rplacd ,',binding-sym ,val)))
+ (with-gensyms (sym)
+ ^(let ((,sym ,sym-expr))
+ (macrolet ((,getter () ^(symbol-value ,',sym))
+ (,setter (val) ^(sys:set-symbol-value ,',sym ,val)))
,body))))
nil
(deleter
@@ -861,10 +953,21 @@
^(macrolet ((,ssetter (val) ^(slotset ,',struct ,',sym ,val)))
,body)))
+(defun read-once (value) value)
+
+(defplace (read-once place) body
+ (getter setter
+ (with-gensyms (cache-var)
+ (with-update-expander (pgetter psetter) place sys:*pl-env*
+ ^(slet ((,cache-var (,pgetter)))
+ (macrolet ((,getter () ',cache-var)
+ (,setter (val) ^(,',psetter (set ,',cache-var ,val))))
+ ,body))))))
+
(defmacro define-modify-macro (name lambda-list function)
(let ((cleaned-lambda-list (mapcar [iffi consp car]
(remql : lambda-list))))
- (with-gensyms (place-sym args-sym)
+ (with-gensyms (place-sym)
^(defmacro ,name (:env env ,place-sym ,*lambda-list)
(with-update-expander (getter setter) ,place-sym env
^(,setter (,',function (,getter) ,,*cleaned-lambda-list)))))))
@@ -887,6 +990,7 @@
;; uses of sym as a place will fail due to get-foo not being a place.
(sethash *place-update-expander* tmp-place
(lambda (tmp-getter tmp-setter tmp-place tmp-body)
+ (ignore tmp-place)
^(macrolet ((,tmp-getter () ^(,',pl-getter))
(,tmp-setter (val) ^(,',pl-setter ,val)))
,tmp-body)))
@@ -919,7 +1023,7 @@
(lambda (getter setter place body)
(let* ((args (cdr place))
(temps (mapcar (ret (gensym)) args)))
- ^(let (,(zip temps args))
+ ^(let ,(zip temps args)
(macrolet ((,getter () ^(,',get-fun ,*',temps))
(,setter (val)
^(,',set-fun ,*',temps ,val)))
@@ -968,3 +1072,14 @@
(define-place-macro nth (index obj)
^(car (nthcdr ,index ,obj)))
+
+(define-place-macro mref (obj . indices)
+ (tree-case indices
+ (() obj)
+ ((x) ^(mref1 ,obj ,x))
+ ((x y) ^(mref1 (ref ,obj ,x) ,y))
+ (t (let* ((l2 (nthlast 2 indices))
+ (bl (ldiff indices l2))
+ (x (car l2))
+ (y (cadr l2)))
+ ^(mref1 (ref (mref ,obj ,*bl) ,x) ,y)))))
diff --git a/stdlib/pmac.tl b/stdlib/pmac.tl
new file mode 100644
index 00000000..a2eb4a37
--- /dev/null
+++ b/stdlib/pmac.tl
@@ -0,0 +1,41 @@
+;; Copyright 2017-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defmacro define-param-expander (keyword
+ (parms body : (env (gensym)) (form (gensym)))
+ . forms)
+ ^(progn
+ (set [*param-macro* ,keyword]
+ (lambda (,parms ,body ,env ,form)
+ ,*forms))
+ ,keyword))
+
+(defun macroexpand-params (prototype-form : env)
+ (tree-case prototype-form
+ ((name params . body)
+ (cons name (sys:expand-param-macro params body env prototype-form)))
+ (else (error "~s: invalid prototype-form argument ~s" %fun% else))))
diff --git a/stdlib/quips.tl b/stdlib/quips.tl
new file mode 100644
index 00000000..1e4a705e
--- /dev/null
+++ b/stdlib/quips.tl
@@ -0,0 +1,128 @@
+;; Copyright 2020-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defvarl sys:%quips%
+ #("TXR was taped live before a studio audience. The laughter is genuine."
+ "Exclusive of recycled stuffing, TXR contains new materials only."
+ "TXR is not a toy, but should be kept within easy reach of children."
+ "Do not remove this label until TXR is delivered to the consumer."
+ "Remove TXR any time for a complete refund of your disk space."
+ "Store TXR in a cool, dry storage device. Keep out of direct sunlight."
+ "Do not operate heavy equipment or motor vehicles while using TXR."
+ "Use full-strength TXR for tough tasks, or dilute with shell scripts."
+ "TXR causes vomiting if accidentally ingested; no need to induce such."
+ "If unwanted side effects persist, discontinue imperative programming."
+ "TXR works even if the application surface is not free of dirt and grease."
+ "TXR may be used in areas that are not necessarily well ventilated."
+ "TXR's button pops up when original seal is broken."
+ "TXR is tested on nothing but animals (so to speak)."
+ "Disclaimer: TXR has been found to cure cancer in lab mice only."
+ "Garbage collection is on Tuesdays: bring unwanted pointers to curb by 7:30."
+ "Warning: may explode if heated, cooled or maintained at room temperature."
+ "TXR is made with 75% post-consumer recycled cons cells."
+ "Poke a few holes in TXR with a fork before heating in the microwave."
+ "Caution: objects in heap are farther from reality than they appear."
+ "TXR doesn't really whip the llama's ass so much as the lambda's."
+ "TXR is recommended for either internal or external use. Whatever, y'know?"
+ "TXR is enteric coated to release over 24 hours of lasting relief."
+ "TXR contains many small parts, unsuitable for children under 12 months."
+ "TXR is packaged by the byte; contents may compress during shipping."
+ "Discontinue coding TXR if experiencing dizziness or shortness of breath."
+ "Self-assembly keeps TXR costs low; but ask about our installation service!"
+ "Some mild discoloration of syntax highlighting may occur with age."
+ "TXR is made with equipment not contaminated by peanuts ... r-r-right?"
+ "TXR is believed by fools to be free of defects in workmanship and materials."
+ "Adults using TXR should be closely supervised by children."
+ "TXR may be worn in seven different ways, in any weather."
+ "TXR is light and portable; take it camping, or to the Bahamas."
+ "Psst! The complimentary Allen key that comes with TXR is inpired by IKEA."
+ "Ethically produced using volunteer geek labor in a first world country."
+ "Program contains violence and coarse language, demanding user indiscretion."
+ "TXR is written, directed and produced by, not to mention starring, Kaz."
+ "Emergency exits are located in the standard library."
+ "Your history may used for automatic recommendations, like 'stick to Python'."
+ "Without the generosity of users like you, this program would exist just fine."
+ "TXR's no-spray organic production means every bug is carefully removed by hand."
+ "Upgrade to TXR Pro for a one-time fee of learning Lisp!"
+ "When transferring between containers, do not siphon TXR by mouth."
+ "Use TXR only as directed. Unless you are intelligent, curious and creative."
+ "Reminder: your account balance of 37 closing parentheses is past due."
+ "Check with your physician before commencing any strenuous Lisp program."
+ "Apply today for a TXR credit card, and get 1MB off your next allocation."
+ "Join TXR Rewards now, and get 15000 closing parentheses you can use anywhere."
+ "TXR's car insurance now offers cdr coverage for bumper-to-bumper protection."
+ "Please listen carefully to the following spec, as our Lisp has changed."
+ "If TXR were TV, it would require music by Mike Post and Peter Carpenter."
+ "TXR was set to appear on the cover of SI. Yeah, no. Learned about the jinx."
+ " |E|\n|V A N|\n |S|\n |T|"
+ "Lispが好き、とても好き、私はLispの...全てにいつも...夢中なの。"
+ "こんな広い分野の中、私が愛する...言語なら、やはり...Lispだけ。"
+ "This area is under 24 hour TTY surveillance."
+ "This TTY may be recorded for privacy-violating and evidence-gathering purposes."
+ "Imitation is the benignest form of forgery."
+ "This could be the year of the TXR desktop; I can feel it!"
+ "TXR's suggested retail price is $0. (More in Canada.)"
+ "All of our cores are currently busy servicing other applications."
+ "For faster service, do not time out & retry. Syscalls are answered in sequence."
+ "Pour le service en la langue Shell, appuyez sur Ctrl-D."
+ "Everything you type here can and will be used against you in comp.lang.lisp."
+ "Allow me to expand a bit more on why there is no substitute for macros."
+ "defmicro: error: expansion is larger than original form: switch to defmacro."
+ "Read-eval-disagree-downvote-insult treadmill initialized! Enter an expression:"
+ "If you get your macros hot enough, you get syntactic caramel!"
+ "Syntactic toffee recipe: melt butter over low heat, stir in Lisp macros."
+ "TXR needs money, so even abnormal exits now go through the gift shop."
+ "TXR Lisp has no protected class members; C++ refugees may face discrimination."
+ "In programming, you want rigor, but also to recognize and avoid rigor mortis."
+ "TXR Labs engaged in gain-of-function experiments as far back as 2009."
+ "TXR Lisp has dark mode now: global *dark-mode* and lexical with-dark-mode."
+ "Merry GNUsmas, dear FSF friends! ... Crap, wait. That's 'Samsung' backwards!"
+ "Truly future-proof systems are rare; future-resistant ones are everywhere."
+ "Lack of personality is not an effective defense against impersonation."
+ "TXR kind of supports IEEE 754.00000000000003 floating-point."
+ "TXR's sound system features 120 dB separation between quarreling audiophiles."
+ "Using TXR is a way of being carcdrate to the future code maintainer."
+ "TXR was there through my incarcdration; wanna show the nation my appreciation."
+ "I've almost decided to wipe my kitchen floor. I feel ever so closer to mop!"
+ "I'm confused; is this piano recital Rimsky-Korsakov or Wernicke–Korsakoff?"
+ "TXR Lisp environments use genuine Saskatchewan sealskin bindings."
+ "I'm not addicted to procrastination. I can start any time I want to!"
+ "Kant figure out it out by Pure Reason? Check the Immanuel!"
+ "Where were you last night? I found strings from another language on your shirt!"
+ "Evidence of amphoric Lisp macros was recently found in ancient clay jars."
+ "Remember, the car function does not make a copy. Thus, caring is sharing."
+ "It's lipid-based and used in fatty foods, yet called 'lecithin'. Go figure."
+ ))
+
+(defparml sys:%quip-rand-state% (make-random-state))
+
+(defvarl sys:%shuffled-quips%)
+
+(defun quip ()
+ (unless sys:%shuffled-quips%
+ (set sys:%shuffled-quips% (shuffle sys:%quips% sys:%quip-rand-state%)))
+ (pop sys:%shuffled-quips%))
diff --git a/share/txr/stdlib/save-exe.tl b/stdlib/save-exe.tl
index 4823cd4e..34d9465a 100644
--- a/share/txr/stdlib/save-exe.tl
+++ b/stdlib/save-exe.tl
@@ -1,4 +1,4 @@
-;; Copyright 2019-2020
+;; Copyright 2019-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,23 +6,24 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(defun save-exe (path string)
(let* ((fbuf (file-get-buf txr-exe-path))
diff --git a/stdlib/socket.tl b/stdlib/socket.tl
new file mode 100644
index 00000000..8072b35f
--- /dev/null
+++ b/stdlib/socket.tl
@@ -0,0 +1,320 @@
+;; Copyright 2016-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defstruct sockaddr nil
+ canonname ;; from getaddrinfo
+ (:static family nil))
+
+(defstruct sockaddr-in sockaddr
+ (addr 0) (port 0)
+ (prefix 32)
+ (:static family af-inet))
+
+(defstruct sockaddr-in6 sockaddr
+ (addr 0) (port 0) (flow-info 0) (scope-id 0)
+ (prefix 128)
+ (:static family af-inet6))
+
+(defstruct sockaddr-un sockaddr
+ path
+ (:static family af-unix))
+
+(defstruct addrinfo nil
+ (flags 0)
+ (family 0)
+ (socktype 0)
+ (protocol 0)
+ canonname)
+
+(defvarl shut-rd 0)
+(defvarl shut-wr 1)
+(defvarl shut-rdwr 2)
+
+(defun str-inaddr (addr : port)
+ (let ((d (logand addr #xFF))
+ (c (logand (ash addr -8) #xFF))
+ (b (logand (ash addr -16) #xFF))
+ (a (ash addr -24))
+ (p (if port `:@port` "")))
+ (if (or (> a 255) (minusp a))
+ (throwf 'eval-error "~s: ~a out of range for IPv4 address"
+ 'str-inaddr addr)
+ `@a.@b.@c.@d@p`)))
+
+
+(defun sys:in6addr-condensed-text (numeric-pieces)
+ (let* ((str (cat-str [mapcar [iff zerop (ret "Z") (op fmt "~x")]
+ numeric-pieces] ":"))
+ (zr (rra #/Z(:Z)+/ str))
+ (lp [pos-max zr : [callf - to from]])
+ (lr [zr lp]))
+ (when lp
+ (del [str lr]))
+ (upd str (regsub "Z" "0"))
+ (cond
+ ((equal "" str) "::")
+ ((starts-with ":" str) `:@str`)
+ ((ends-with ":" str) `@str:`)
+ (t str))))
+
+(defun str-in6addr (addr : port)
+ (let ((str (if (and (<= (width addr) 48)
+ (= (ash addr -32) #xFFFF))
+ `::ffff:@(str-inaddr (logtrunc addr 32))`
+ (let* ((pieces (let ((count 8))
+ (nexpand-left (lambda (val)
+ (if (minusp (dec count))
+ (unless (zerop val)
+ (throwf 'eval-error
+ "~s: \
+ \ ~a out of range \
+ \ for IPv6 address"
+ 'str-in6addr
+ addr))
+ (cons (logand val #xFFFF)
+ (ash val -16))))
+ addr))))
+ (sys:in6addr-condensed-text pieces)))))
+ (if port
+ `[@str]:@port`
+ str)))
+
+(defun sys:str-inaddr-net-impl (addr wextra : weff)
+ (let ((mask addr))
+ (set-mask mask (ash mask 1))
+ (set-mask mask (ash mask 2))
+ (set-mask mask (ash mask 4))
+ (set-mask mask (ash mask 8))
+ (set-mask mask (ash mask 16))
+ (let* ((w (- 32 (width (lognot mask 32))))
+ (d (logand addr #xFF))
+ (c (logand (ash addr -8) #xFF))
+ (b (logand (ash addr -16) #xFF))
+ (a (ash addr -24))
+ (we (or weff (+ w wextra))))
+ (cond
+ ((or (> a 255) (minusp a))
+ (throwf 'eval-error "~s: ~a out of range for IPv4 address"
+ 'str-inaddr-net addr))
+ ((> w 24) `@a.@b.@c.@d/@we`)
+ ((> w 16) `@a.@b.@c/@we`)
+ ((> w 8) `@a.@b/@we`)
+ (t `@a/@we`)))))
+
+(defun str-inaddr-net (addr : width)
+ (sys:str-inaddr-net-impl addr 0 width))
+
+(defun str-in6addr-net (addr : width)
+ (if (and (<= (width addr) 48)
+ (= (ash addr -32) #xFFFF))
+ `::ffff:@(sys:str-inaddr-net-impl (logtrunc addr 32) 96 width)`
+ (let ((mask addr))
+ (set-mask mask (ash mask 1))
+ (set-mask mask (ash mask 2))
+ (set-mask mask (ash mask 4))
+ (set-mask mask (ash mask 8))
+ (set-mask mask (ash mask 16))
+ (set-mask mask (ash mask 32))
+ (set-mask mask (ash mask 64))
+ (let* ((w (- 128 (width (lognot mask 128))))
+ (pieces (let ((count 8))
+ (nexpand-left (lambda (val)
+ (if (minusp (dec count))
+ (unless (zerop val)
+ (throwf 'eval-error
+ "~s: \
+ \ ~a out of range \
+ \ for IPv6 address"
+ 'str-in6addr-net
+ addr))
+ (cons (logand val #xFFFF)
+ (ash val -16))))
+ addr)))
+ (cand-prefix [pieces 0..(trunc (+ w 15) 16)])
+ (prefix (if (search cand-prefix '(0 0)) pieces cand-prefix)))
+ `@(sys:in6addr-condensed-text prefix)/@(or width w)`))))
+
+(defun inaddr-str (str)
+ (labels ((invalid ()
+ (error "~s: invalid address ~s" 'inaddr-str str))
+ (mkaddr (octets port)
+ (unless [all octets (op <= 0 @1 255)]
+ (invalid))
+ (unless (<= 0 port 65535)
+ (invalid))
+ (new sockaddr-in
+ addr (+ (ash (pop octets) 24)
+ (ash (pop octets) 16)
+ (ash (pop octets) 8)
+ (car octets))
+ port port))
+ (mkaddr-pf (octets prefix port)
+ (unless [all octets (op <= 0 @1 255)]
+ (invalid))
+ (unless (<= 0 prefix 32)
+ (invalid))
+ (unless (<= 0 port 65535)
+ (invalid))
+ (let* ((addr (+ (ash (or (pop octets) 0) 24)
+ (ash (or (pop octets) 0) 16)
+ (ash (or (pop octets) 0) 8)
+ (or (car octets) 0))))
+ (new sockaddr-in
+ addr (logand addr (ash -1 (- 32 prefix)))
+ port port
+ prefix prefix))))
+ (cond
+ ((r^$ #/\d+\.\d+\.\d+\.\d+:\d+/ str)
+ (tree-bind (addr port) (split* str (rpos #\: str))
+ (mkaddr [mapcar toint (spl #\. addr)] (toint port))))
+ ((r^$ #/\d+\.\d+\.\d+\.\d+(:\d+)?/ str)
+ (mkaddr [mapcar toint (spl #\. str)] 0))
+ ((r^$ #/\d+(\.\d+(\.\d+(\.\d+)?)?)?\/\d+/ str)
+ (tree-bind (addr prefix) (spl #\/ str)
+ (mkaddr-pf [mapcar toint (spl #\. addr)] (toint prefix) 0)))
+ ((r^$ #/\d+(\.\d+(\.\d+(\.\d+)?)?)?\/\d+:\d+/ str)
+ (tree-bind (addr prefix port) (split-str-set str ":/")
+ (mkaddr-pf [mapcar toint (spl #\. addr)] (toint prefix) (toint port))))
+ (t (invalid)))))
+
+(defun in6addr-str (str)
+ (labels ((invalid ()
+ (error "~s: invalid address ~s" 'in6addr-str str))
+ (mkaddr-full (pieces)
+ (unless [all pieces (op <= 0 @1 #xffff)]
+ (invalid))
+ (unless (eql 8 (length pieces))
+ (invalid))
+ (new sockaddr-in6
+ addr (reduce-left (op + @2 (ash @1 16)) pieces)))
+ (mkaddr-brev (pieces-x pieces-y)
+ (let ((len-x (len pieces-x))
+ (len-y (len pieces-y)))
+ (unless (<= (+ len-x len-y) 7)
+ (invalid))
+ (let* ((val-x (reduce-left (op + @2 (ash @1 16)) pieces-x 0))
+ (val-y (reduce-left (op + @2 (ash @1 16)) pieces-y 0))
+ (addr (cond
+ ((null pieces-x) val-y)
+ ((null pieces-y) (ash val-x (* 16 (- 8 len-x))))
+ (t (+ val-y
+ (ash val-x (* 16 (- 8 len-x))))))))
+ (new sockaddr-in6
+ addr addr))))
+ (str-to-pieces (str)
+ (unless (empty str)
+ [mapcar (lop toint 16) (spl #\: str)]))
+ (octets-to-pieces (octets)
+ (unless [all octets (op <= 0 @1 255)]
+ (invalid))
+ (list (+ (ash (pop octets) 8)
+ (pop octets))
+ (+ (ash (pop octets) 8)
+ (pop octets)))))
+ (cond
+ ((r^$ #/\[.*\]:\d+/ str)
+ (tree-bind (addr-str port-str) (split* str (rpos #\: str))
+ (let ((addr (in6addr-str [addr-str 1..-1]))
+ (port (toint port-str)))
+ (unless (<= 0 port 65535)
+ (invalid))
+ (set addr.port port)
+ addr)))
+ ((r^$ #/[^\/]+\/\d+/ str)
+ (tree-bind (addr-str prefix-str) (split* str (rpos #\/ str))
+ (let ((addr (in6addr-str addr-str))
+ (prefix (toint prefix-str)))
+ (unless (<= 0 prefix 128)
+ (invalid))
+ (upd addr.addr (logand (ash -1 (- 128 prefix))))
+ (set addr.prefix prefix)
+ addr)))
+ ((r^$ #/[\da-fA-F]*(:[\da-fA-F]*)*/ str)
+ (let* ((str-splat (regsub "::" "@" str))
+ (maj-pieces (spl #\@ str-splat)))
+ (caseql (len maj-pieces)
+ (1 (mkaddr-full (str-to-pieces (car maj-pieces))))
+ (2 (mkaddr-brev (str-to-pieces (car maj-pieces))
+ (str-to-pieces (cadr maj-pieces))))
+ (t (invalid)))))
+ ((r^$ #/::0*[fF][fF][fF][fF]:\d+\.\d+\.\d+\.\d+/ str)
+ (let* ((bigsplit (split* str (rpos #\: str)))
+ (4part (cadr bigsplit))
+ (octets [mapcar toint (spl #\. 4part)])
+ (pieces (cons #xffff (octets-to-pieces octets))))
+ (mkaddr-brev nil pieces)))
+ (t (invalid)))))
+
+(defplace (sock-peer sock) body
+ (getter setter
+ ^(macrolet ((,getter () ^(sock-peer ,',sock))
+ (,setter (val) ^(sock-set-peer ,',sock ,val)))
+ ,body)))
+
+(defplace (sock-opt sock level option : type) body
+ (getter setter
+ ^(macrolet ((,getter () ^(sock-opt ,',sock ,',level ,',option ,',type))
+ (,setter (val)
+ ^(sock-set-opt ,',sock ,',level ,',option ,val ,',type)))
+ ,body)))
+
+(defun sockaddr-str (str)
+ (cond
+ ((starts-with "[" str) (in6addr-str str))
+ ((starts-with "/" str) (new sockaddr-un path str))
+ ((contains "::" str) (in6addr-str str))
+ ((contains "." str) (inaddr-str str))
+ (t (or (ignerr (in6addr-str str))
+ (inaddr-str str)))))
+
+(defmeth sockaddr-in str-addr (me)
+ (let* ((pfx me.prefix)
+ (port me.port)
+ (addr me.addr)
+ (str (if (and pfx (< pfx 32))
+ (str-inaddr-net addr pfx)
+ (str-inaddr addr))))
+ (if (and port (plusp port))
+ `@str:@port`
+ str)))
+
+(defmeth sockaddr-in6 str-addr (me)
+ (let* ((pfx me.prefix)
+ (port me.port)
+ (addr me.addr)
+ (str (if (and pfx (< pfx 128))
+ (str-in6addr-net addr pfx)
+ (str-in6addr addr))))
+ (if (and port (plusp port))
+ `[@str]:@port`
+ str)))
+
+(defmeth sockaddr-un str-addr (me)
+ (let ((path me.path))
+ (if (stringp me.path)
+ path
+ (error "~s: slot path of ~s isn't a string" '(meth socakddr-un str-addr) me))))
diff --git a/share/txr/stdlib/stream-wrap.tl b/stdlib/stream-wrap.tl
index ba5a5cb2..faae64ae 100644
--- a/share/txr/stdlib/stream-wrap.tl
+++ b/stdlib/stream-wrap.tl
@@ -1,4 +1,4 @@
-;; Copyright 2017-2020
+;; Copyright 2017-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,23 +6,24 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(defstruct stream-wrap nil
stream
diff --git a/stdlib/struct.tl b/stdlib/struct.tl
new file mode 100644
index 00000000..4d544b4d
--- /dev/null
+++ b/stdlib/struct.tl
@@ -0,0 +1,503 @@
+;; Copyright 2015-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defvar *struct-clause-expander* (hash))
+
+(defvar *struct-prelude* (hash))
+(defvar *struct-prelude-alists* (hash))
+
+(defun sys:bad-slot-syntax (form arg)
+ (compile-error form "bad slot syntax ~s" arg))
+
+(defun sys:prune-missing-inits (slot-init-forms)
+ (remove-if (tb ((kind name : (init-form nil init-form-present)))
+ (ignore name init-form)
+ (and (member kind '(:static :instance :function))
+ (not init-form-present)))
+ slot-init-forms))
+
+(defmacro sys:meth-lambda (struct slot params . body)
+ ^(symacrolet ((%fun% '(,struct ,slot)))
+ (lambda ,params ,*body)))
+
+(defmacro defstruct (:form form name-spec super-spec . slot-specs)
+ (tree-bind (name args) (tree-case name-spec
+ ((atom . args) (list atom args))
+ (atom (list atom nil)))
+ (unless (bindable name)
+ (compile-error form "~s isn't a bindable symbol" name))
+ (if (built-in-type-p name)
+ (compile-warning form "~s is a built-in type" name))
+ (unless (proper-listp slot-specs)
+ (compile-error form "bad syntax: dotted form"))
+ (set slot-specs (append [*struct-prelude* name] slot-specs))
+ (let ((instance-init-forms nil)
+ (instance-postinit-forms nil)
+ (instance-fini-forms nil)
+ (instance-postfini-forms nil)
+ (additional-supers nil))
+ (labels ((expand-slot (form slot)
+ (tree-case slot
+ ((op . t)
+ (iflet ((expander [*struct-clause-expander* op]))
+ (append-each ((exslot [expander slot form]))
+ [expand-slot form exslot])
+ :))
+ ((word . args)
+ (cond
+ ((eq word :inherit)
+ (set additional-supers (revappend args additional-supers))
+ nil)
+ (t :)))
+ ((word slname args . body)
+ (caseq word
+ (:method
+ (when (not args)
+ (compile-error form "method ~s needs at least one parameter" slname))
+ ^((:function ,slname
+ (sys:meth-lambda ,slname ,name ,args
+ (block ,slname ,*body)))))
+ (:function ^((,word ,slname
+ (sys:meth-lambda ,slname ,name ,args
+ (block ,slname
+ ,*body)))))
+ ((:static :instance)
+ (when body
+ (sys:bad-slot-syntax form slot))
+ ^((,word ,slname ,args)))
+ (t :)))
+ ((word (arg) . body)
+ (caseq word
+ (:init
+ (unless (bindable arg)
+ (sys:bad-slot-syntax form slot))
+ (if body
+ (push (cons arg body) instance-init-forms))
+ ^((,word nil nil)))
+ (:postinit
+ (unless (bindable arg)
+ (sys:bad-slot-syntax form slot))
+ (if body
+ (push (cons arg body) instance-postinit-forms))
+ ^((,word nil nil)))
+ (:fini
+ (unless (bindable arg)
+ (sys:bad-slot-syntax form slot))
+ (if body
+ (push (cons arg body) instance-fini-forms))
+ ^((,word nil nil)))
+ (:postfini
+ (unless (bindable arg)
+ (sys:bad-slot-syntax form slot))
+ (if body
+ (push (cons arg body) instance-postfini-forms))
+ ^((,word nil nil)))
+ (t (when body
+ (sys:bad-slot-syntax form slot))
+ :)))
+ ((word name)
+ (caseq word
+ ((:static)
+ ^((,word ,name)))
+ ((:instance)
+ ^((,word ,name nil)))
+ ((:method :function)
+ (sys:bad-slot-syntax form slot))
+ (t ^((:instance ,word ,name)))))
+ ((name)
+ ^((:instance ,name nil)))
+ (name
+ ^((:instance ,name nil))))))
+ (let* ((slot-init-forms (append-each ((slot slot-specs))
+ (expand-slot form slot)))
+ (supers (append (if (and super-spec (atom super-spec))
+ (list super-spec)
+ super-spec)
+ additional-supers))
+ (stat-si-forms [keep-if (op member @1 '(:static :function))
+ slot-init-forms car])
+ (pruned-si-forms (sys:prune-missing-inits stat-si-forms))
+ (func-si-forms [keep-if (op eq :function) pruned-si-forms car])
+ (val-si-forms [keep-if (op eq :static) pruned-si-forms car])
+ (inst-si-forms [keep-if (op eq :instance) slot-init-forms car])
+ (stat-slots [mapcar second stat-si-forms])
+ (inst-slots [mapcar second inst-si-forms]))
+ (whenlet ((bad [find-if [notf bindable]
+ (append stat-slots inst-slots)]))
+ (compile-error form
+ (if (symbolp bad)
+ "slot name ~s isn't a bindable symbol"
+ "invalid slot specifier syntax: ~s")
+ bad))
+ (each ((s supers))
+ (or (find-struct-type s)
+ (compile-defr-warning form ^(struct-type . ,s)
+ "inheritance base ~s \
+ \ does not name a struct type"
+ s)))
+ (let ((arg-sym (gensym))
+ (type-sym (gensym)))
+ (register-tentative-def ^(struct-type . ,name))
+ (each ((s stat-slots))
+ (register-tentative-def ^(slot . ,s)))
+ (each ((s inst-slots))
+ (register-tentative-def ^(slot . ,s)))
+ ^(sys:make-struct-type
+ ',name ',supers ',stat-slots ',inst-slots
+ ,(if (or func-si-forms val-si-forms)
+ ^(lambda (,arg-sym)
+ ,*(mapcar (aret ^(when (static-slot-p ,arg-sym ',@2)
+ (static-slot-set ,arg-sym ',@2 ,@3)))
+ (append func-si-forms val-si-forms))))
+ ,(if (or inst-si-forms instance-init-forms
+ instance-fini-forms instance-postfini-forms)
+ ^(lambda (,arg-sym)
+ ,*(if instance-fini-forms
+ ^((finalize ,arg-sym
+ (sys:meth-lambda ,name :fini (,arg-sym)
+ ,*(append-each ((iff instance-fini-forms))
+ ^((let ((,(car iff) ,arg-sym))
+ ,*(cdr iff)))))
+ t)))
+ ,*(if instance-postfini-forms
+ ^((finalize ,arg-sym
+ (sys:meth-lambda ,name :postfini (,arg-sym)
+ ,*(append-each ((iff (nreverse instance-postfini-forms)))
+ ^((let ((,(car iff) ,arg-sym))
+ ,*(cdr iff))))))))
+ ,*(if inst-si-forms
+ ^((let ((,type-sym (struct-type ,arg-sym)))
+ ,*(mapcar (aret ^(unless (static-slot-p ,type-sym ',@2)
+ (slotset ,arg-sym ',@2 ,@3)))
+ inst-si-forms))))
+ ,*(append-each ((iif (nreverse instance-init-forms)))
+ ^((symacrolet ((%fun% '(,name :init)))
+ (let ((,(car iif) ,arg-sym))
+ ,*(cdr iif)))))))
+ ,(when args
+ (when (> (countql : args) 1)
+ (compile-error form
+ "multiple colons in boa syntax"))
+ (let ((col-pos (posq : args)))
+ (let ((req-args [args 0..col-pos])
+ (opt-args (if col-pos [args (succ col-pos)..:])))
+ (let ((r-gens (mapcar (ret (gensym)) req-args))
+ (o-gens (mapcar (ret (gensym)) opt-args))
+ (p-gens (mapcar (ret (gensym)) opt-args)))
+ ^(lambda (,arg-sym ,*r-gens
+ ,*(if opt-args '(:))
+ ,*(if opt-args
+ (mapcar (ret ^(,@1 nil ,@2))
+ o-gens p-gens)))
+ ,*(mapcar (ret ^(set (qref ,arg-sym ,@1) ,@2))
+ req-args r-gens)
+ ,*(mapcar (ret ^(if ,@3
+ (set (qref ,arg-sym ,@1) ,@2)))
+ opt-args o-gens p-gens))))))
+ ,(if instance-postinit-forms
+ ^(sys:meth-lambda ,name :postinit (,arg-sym)
+ ,*(append-each ((ipf (nreverse instance-postinit-forms)))
+ ^((let ((,(car ipf) ,arg-sym))
+ ,*(cdr ipf)))))))))))))
+
+(defmacro sys:struct-lit (name . plist)
+ ^(sys:make-struct-lit ',name ',plist))
+
+(defun sys:check-slot (form slot)
+ (unless (or (sys:slot-types slot)
+ (sys:static-slot-types slot))
+ (compile-defr-warning form ^(slot . ,slot)
+ "~s isn't the name of a struct slot"
+ slot))
+ slot)
+
+(defun sys:check-struct (form stype)
+ (unless (find-struct-type stype)
+ (compile-defr-warning form ^(struct-type . ,stype)
+ "~s does not name a struct type"
+ stype)))
+
+(defmacro qref (:form form obj . refs)
+ (when (null refs)
+ (throwf 'eval-error "~s: bad syntax" 'qref))
+ (tree-case obj
+ ((a b) (if (eq a 't)
+ (let ((s (gensym)))
+ ^(slet ((,s ,b))
+ (if ,s (qref ,s ,*refs))))
+ :))
+ (t (tree-case refs
+ (() ())
+ (((pref sym) . more)
+ (if (eq pref t)
+ (let ((s (gensym)))
+ ^(let ((,s (qref ,obj ,sym)))
+ (if ,s (qref ,s ,*more))))
+ :))
+ (((dw sym . args))
+ (if (eq dw 'dwim)
+ (let ((osym (gensym)))
+ (sys:check-slot form sym)
+ ^(slet ((,osym ,obj))
+ ,(if (and (plusp sys:compat) (<= sys:compat 251))
+ ^[(slot ,osym ',sym) ,*args]
+ ^[(slot ,osym ',sym) ,osym ,*args])))
+ :))
+ (((dw sym . args) . more)
+ (if (eq dw 'dwim)
+ (let ((osym (gensym)))
+ (sys:check-slot form sym)
+ ^(qref (slet ((,osym ,obj))
+ ,(if (and (plusp sys:compat) (<= sys:compat 251))
+ ^[(slot ,osym ',sym) ,*args]
+ ^[(slot ,osym ',sym) ,osym ,*args])) ,*more))
+ :))
+ (((sym . args))
+ (let ((osym (gensym)))
+ (sys:check-slot form sym)
+ ^(slet ((,osym ,obj))
+ (call (slot ,osym ',sym) ,osym ,*args))))
+ (((sym . args) . more)
+ (let ((osym (gensym)))
+ (sys:check-slot form sym)
+ ^(qref (slet ((,osym ,obj))
+ (call (slot ,osym ',sym) ,osym ,*args)) ,*more)))
+ ((sym)
+ (sys:check-slot form sym)
+ ^(slot ,obj ',sym))
+ ((sym . more)
+ (sys:check-slot form sym)
+ ^(qref (slot ,obj ',sym) ,*more))
+ (else (throwf 'eval-error "~s: bad syntax: ~s" 'qref else))))))
+
+(defmacro uref (. args)
+ (cond
+ ((null args) (throwf 'eval-error "~s: bad syntax" 'uref))
+ ((null (cdr args))
+ (if (consp (car args))
+ ^(umeth ,*(car args))
+ ^(usl ,(car args))))
+ ((eq t (car args))
+ (with-gensyms (ovar)
+ ^(lambda (,ovar) (qref (t ,ovar) ,*(cdr args)))))
+ (t (with-gensyms (ovar)
+ ^(lambda (,ovar) (qref ,ovar ,*args))))))
+
+(defun sys:new-type (op form type)
+ (caseq op
+ ((new lnew) (sys:check-struct form type) ^',type)
+ (t type)))
+
+(defun sys:new-expander (op form spec pairs)
+ (when (oddp (length pairs))
+ (compile-error form "slot initform arguments must occur pairwise"))
+ (let ((qpairs (mappend (aret ^(',@1 ,@2)) (tuples 2 pairs))))
+ (tree-case spec
+ ((texpr . args)
+ (if (and (eq texpr 'dwim)
+ (meq op 'new* 'lnew*))
+ :
+ (let ((type (sys:new-type op form texpr)))
+ (caseq op
+ ((new new*) (if qpairs
+ ^(make-struct ,type (list ,*qpairs) ,*args)
+ ^(struct-from-args ,type ,*args)))
+ ((lnew lnew*) ^(make-lazy-struct ,type
+ (lambda ()
+ (cons (list ,*qpairs)
+ (list ,*args)))))))))
+ (texpr
+ (let ((type (sys:new-type op form texpr)))
+ (caseq op
+ ((new new*) ^(struct-from-plist ,type ,*qpairs))
+ ((lnew lnew*) ^(make-lazy-struct ,type
+ (lambda ()
+ (list (list ,*qpairs)))))))))))
+
+(defmacro new (:form form spec . pairs)
+ (sys:new-expander (car form) form spec pairs))
+
+(defmacro new* (:form form spec . pairs)
+ (sys:new-expander (car form) form spec pairs))
+
+(defmacro lnew (:form form spec . pairs)
+ (sys:new-expander (car form) form spec pairs))
+
+(defmacro lnew* (:form form spec . pairs)
+ (sys:new-expander (car form) form spec pairs))
+
+(defmacro meth (obj slot . bound-args)
+ ^[(fun method) ,obj ',slot ,*bound-args])
+
+(defmacro usl (:form form slot)
+ (sys:check-slot form slot)
+ ^(uslot ',slot))
+
+(defmacro umeth (:form form slot . bound-args)
+ (sys:check-slot form slot)
+ ^[(fun umethod) ',slot ,*bound-args])
+
+(defun sys:define-method (type-sym name fun)
+ (caseq name
+ (:init (struct-set-initfun type-sym fun))
+ (:postinit (struct-set-postinitfun type-sym fun))
+ (t (static-slot-ensure type-sym name fun)))
+ ^(meth ,type-sym ,name))
+
+(defmacro defmeth (:form form type-sym name arglist . body)
+ (cond
+ ((not (bindable type-sym))
+ (compile-error form "~s isn't a valid struct name" type-sym))
+ ((not (find-struct-type type-sym))
+ (compile-defr-warning form ^(struct-type . ,type-sym)
+ "definition of struct ~s not seen here" type-sym)))
+ (register-tentative-def ^(slot . ,name))
+ ^(sys:define-method ',type-sym ',name (sys:meth-lambda ,type-sym ,name
+ ,arglist
+ (block ,name ,*body))))
+
+(defmacro with-slots ((. slot-specs) obj-expr . body)
+ (with-gensyms (obj-sym)
+ ^(let ((,obj-sym ,obj-expr))
+ (symacrolet (,*(mapcar [iff consp
+ (aret ^(,@1 (slot ,obj-sym ',@2)))
+ (ret ^(,@1 (slot ,obj-sym ',@1)))]
+ slot-specs))
+ ,*body))))
+
+(defun sys:rslotset (struct sym meth-sym val)
+ (prog1
+ (slotset struct sym val)
+ (call (umethod meth-sym) struct)))
+
+(defmacro usr:rslot (struct sym t)
+ ^(slot ,struct ,sym))
+
+(define-place-macro usr:rslot (struct sym meth-sym)
+ ^(sys:rslot ,struct ,sym ,meth-sym))
+
+(defplace (sys:rslot struct sym meth-sym) body
+ (getter setter
+ (with-gensyms (struct-sym slot-sym meth-slot-sym)
+ ^(slet ((,struct-sym ,struct)
+ (,slot-sym ,sym)
+ (,meth-slot-sym ,meth-sym))
+ (macrolet ((,getter () ^(slot ,',struct-sym ,',slot-sym))
+ (,setter (val) ^(sys:rslotset ,',struct-sym ,',slot-sym
+ ,',meth-slot-sym ,val)))
+ ,body))))
+ (ssetter
+ ^(macrolet ((,ssetter (val) ^(progn
+ (sys:rslotset ,',struct ,',sym
+ ,',meth-sym ,val))))
+ ,body)))
+
+(defmacro define-struct-clause (:form form keyword (. params) . body)
+ (if (meq keyword :static :instance :function :method
+ :init :postinit :fini :postfini :inherit)
+ (compile-error form "~s is a reserved defstruct clause keyword" keyword))
+ (unless (keywordp keyword)
+ (compile-error form "~s: clauses must be named by keyword symbols" keyword))
+ (with-gensyms (slot form)
+ ^(progn
+ (set [*struct-clause-expander* ,keyword]
+ (lambda (,slot ,form)
+ (mac-param-bind ,form ,params (cdr ,slot) ,*body)))
+ ,keyword)))
+
+(defun macroexpand-struct-clause (clause : form)
+ (iflet ((xfun (and (consp clause) [*struct-clause-expander* (car clause)])))
+ [xfun clause form]
+ (cons clause nil)))
+
+(defmacro define-struct-prelude (:form form prelude-name struct-names . clauses)
+ (unless (bindable prelude-name)
+ (compile-error form "~s isn't a valid prelude name" prelude-name))
+ (when (bindable struct-names)
+ (set struct-names (list struct-names)))
+ (each ((sname struct-names))
+ (unless (bindable sname)
+ (compile-error form "~s isn't a valid struct name" sname))
+ (let* ((cell (inhash *struct-prelude-alists* sname nil))
+ (alist (aconsql-new prelude-name clauses (cdr cell))))
+ (rplacd cell alist)
+ (set [*struct-prelude* sname] [mappend cdr (reverse alist)]))
+ nil))
+
+(compile-only
+ (load-for (struct sys:param-parser-base "param")))
+
+(define-struct-clause :delegate (:form form
+ meth-name params delegate-expr
+ : (target-method meth-name))
+ (unless params
+ (compile-error form "delegate method requires at least one argument"))
+ (let* ((obj (car params))
+ (pp (new (fun-param-parser (cdr params) form)))
+ (opt pp.(opt-syms))
+ (args (append pp.req opt pp.rest)))
+ ^((:method ,meth-name
+ (,obj ,*pp.req
+ ,*(if opt
+ (cons : (collect-each ((o pp.opt))
+ (tree-case o
+ ((sym) ^(,sym :))
+ ((t t) o)
+ ((t t t)
+ (compile-error form
+ "~s: three-element optional \ \
+ parameter ~s not supported"
+ o))))))
+ ,*pp.rest)
+ (qref ,delegate-expr (,target-method ,*args))))))
+
+(define-struct-clause :mass-delegate (:form form self-var delegate-expr
+ from-struct . methods)
+ (let ((from-type (find-struct-type from-struct)))
+ (flet ((is-meth (slot)
+ (and (static-slot-p from-type slot)
+ (let ((f (static-slot from-type slot)))
+ (and (functionp f)
+ (plusp (fun-fixparam-count f)))))))
+ (unless from-type
+ (compile-error form "~s doesn't name a struct type" from-struct))
+ (if (starts-with '(*) methods)
+ (set methods
+ (diff [keep-if is-meth (slots from-type)]
+ (cdr methods)))
+ (iflet ((badmeth [remove-if is-meth methods]))
+ (compile-error form "~s aren't methods of type ~s" badmeth from-struct)))
+ (collect-each ((m methods))
+ (let* ((f (static-slot from-type m))
+ (fix (fun-fixparam-count f))
+ (opt (fun-optparam-count f))
+ (var (fun-variadic f))
+ (parms ^(,*(take (- fix opt) (cons self-var (gun (gensym))))
+ ,*(if (plusp opt)
+ ^(: ,*(take opt (gun (gensym)))))
+ ,*(if var (gensym)))))
+ ^(:delegate ,m ,parms ,delegate-expr))))))
diff --git a/share/txr/stdlib/tagbody.tl b/stdlib/tagbody.tl
index de2a8829..c6474089 100644
--- a/share/txr/stdlib/tagbody.tl
+++ b/stdlib/tagbody.tl
@@ -1,4 +1,4 @@
-;; Copyright 2016-2020
+;; Copyright 2016-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,25 +6,26 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
-(defmacro tagbody (:env env . forms)
+(defmacro tagbody (. forms)
(when forms
(let* ((tb-id (gensym "tb-id-"))
(next-var (gensym "next-"))
@@ -42,6 +43,7 @@
(threaded-1 (mapcar (op member-if true) (conses forms)))
(threaded-2 [apply nconc forms]) ;; important side effect
(codes [mapcar car threaded-1]))
+ (ignore threaded-2)
(unless (eql (length (uniq lbls)) (length lbls))
(throwf 'eval-error "~s: duplicate labels occur" 'tagbody))
(let* ((basic-code ^(let ((,tb-id (gensym "tb-dyn-id-"))
diff --git a/share/txr/stdlib/termios.tl b/stdlib/termios.tl
index d8936633..1ccff7c2 100644
--- a/share/txr/stdlib/termios.tl
+++ b/stdlib/termios.tl
@@ -1,4 +1,4 @@
-;; Copyright 2016-2020
+;; Copyright 2016-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,47 +6,48 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(defmeth termios set-iflags (tio . values)
- (set tio.iflag (logior tio.iflag . values)))
+ (set-mask tio.iflag . values))
(defmeth termios set-oflags (tio . values)
- (set tio.oflag (logior tio.oflag . values)))
+ (set-mask tio.oflag . values))
(defmeth termios set-cflags (tio . values)
- (set tio.cflag (logior tio.cflag . values)))
+ (set-mask tio.cflag . values))
(defmeth termios set-lflags (tio . values)
- (set tio.lflag (logior tio.lflag . values)))
+ (set-mask tio.lflag . values))
(defmeth termios clear-iflags (tio . values)
- (set tio.iflag (logand tio.iflag (lognot (logior . values)))))
+ (clear-mask tio.iflag . values))
(defmeth termios clear-oflags (tio . values)
- (set tio.oflag (logand tio.oflag (lognot (logior . values)))))
+ (clear-mask tio.oflag . values))
(defmeth termios clear-cflags (tio . values)
- (set tio.cflag (logand tio.cflag (lognot (logior . values)))))
+ (clear-mask tio.cflag . values))
(defmeth termios clear-lflags (tio . values)
- (set tio.lflag (logand tio.lflag (lognot (logior . values)))))
+ (clear-mask tio.lflag . values))
(defmeth termios go-raw (tio)
tio.(clear-iflags ignbrk brkint parmrk istrip inlcr igncr icrnl ixon)
@@ -56,15 +57,15 @@
(if (boundp 'iexten)
tio.(clear-lflags iexten))
tio.(set-cflags cs8)
- (set tio.[cc vmin] 1)
- (set tio.[cc vtime] 0))
+ (set [tio.cc vmin] 1)
+ (set [tio.cc vtime] 0))
(defmeth termios go-cbreak (tio)
tio.(clear-iflags icrnl)
tio.(clear-lflags icanon)
tio.(set-lflags isig)
- (set tio.[cc vmin] 1)
- (set tio.[cc vtime] 0))
+ (set [tio.cc vmin] 1)
+ (set [tio.cc vtime] 0))
(defmeth termios string-encode (tio)
(let ((*print-base* 16))
diff --git a/share/txr/stdlib/trace.tl b/stdlib/trace.tl
index a9afcd1d..6d3bf600 100644
--- a/share/txr/stdlib/trace.tl
+++ b/stdlib/trace.tl
@@ -1,4 +1,4 @@
-;; Copyright 2016-2020
+;; Copyright 2016-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,23 +6,24 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(defvar *trace-output* *stdout*)
@@ -35,7 +36,7 @@
(defun sys:trace-enter (name args)
[sys:trfm *trace-output* "~*a(~s ~s\n" [sys:tr* sys:*trace-level* 2] "" name args])
-(defun sys:trace-leave (name val)
+(defun sys:trace-leave (val)
[sys:trfm *trace-output* "~*a ~s)\n" [sys:tr* sys:*trace-level* 2] "" val])
(defun sys:trace-canonicalize-name (name)
@@ -76,11 +77,11 @@
(progn
(sys:trace-enter lex-n args)
(let ((val (apply prev args)))
- (sys:trace-leave lex-n val)
+ (sys:trace-leave val)
(set abandoned nil)
val))
(if abandoned
- (sys:trace-leave lex-n :abandoned)))))))
+ (sys:trace-leave :abandoned)))))))
(set (symbol-function n) hook
[sys:*trace-hash* n] prev)))))))
@@ -98,7 +99,7 @@
(each ((n-orig names)
(n [mapcar sys:trace-canonicalize-name names]))
(disable n-orig n))
- (dohash (n v sys:*trace-hash*)
+ (dohash (n #:v sys:*trace-hash*)
(disable n n)))))
(defun sys:trace-redefine-check (orig-name)
diff --git a/share/txr/stdlib/txr-case.tl b/stdlib/txr-case.tl
index 5a507fb1..6d094a44 100644
--- a/share/txr/stdlib/txr-case.tl
+++ b/stdlib/txr-case.tl
@@ -1,4 +1,4 @@
-;; Copyright 2015-2020
+;; Copyright 2015-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,23 +6,24 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(defmacro txr-if (name args input : then else)
(let ((syms (keep-if [andf true symbolp [notf keywordp] [notf (op eq t)]]
@@ -65,4 +66,6 @@
(defmacro txr-case (input-expr . clauses)
(let ((input (gensym "input-")))
^(let ((,input ,input-expr))
+ (if (streamp ,input)
+ (set ,input (get-lines ,input)))
(txr-case-impl ,input ,*clauses))))
diff --git a/share/txr/stdlib/txr-case.txr b/stdlib/txr-case.txr
index 9b65d1bc..9b65d1bc 100644
--- a/share/txr/stdlib/txr-case.txr
+++ b/stdlib/txr-case.txr
diff --git a/stdlib/type.tl b/stdlib/type.tl
new file mode 100644
index 00000000..258116c3
--- /dev/null
+++ b/stdlib/type.tl
@@ -0,0 +1,53 @@
+;; Copyright 2015-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defun sys:typecase-expander (form obj clauses)
+ (let* ((val (gensym))
+ (cond-pairs (collect-each ((cl clauses))
+ (tree-case cl
+ ((type . body)
+ (cond
+ ((eq type t)
+ ^(t ,*(or body '(nil))))
+ ((symbolp type)
+ ^((typep ,val ',type) ,*(or body '(nil))))
+ (t :)))
+ (else (compile-error form
+ "~s: bad clause syntax: ~s"
+ 'typecase else))))))
+ ^(let ((,val ,obj))
+ (cond ,*cond-pairs
+ ,*(if (eq (car form) 'etypecase)
+ ^((t (throwf 'case-error
+ "~s: unhandled type: ~s"
+ 'etypecase (typeof ,val)))))))))
+
+(defmacro typecase (:form f obj . clauses)
+ (sys:typecase-expander f obj clauses))
+
+(defmacro etypecase (:form f obj . clauses)
+ (sys:typecase-expander f obj clauses))
diff --git a/share/txr/stdlib/ver.tl b/stdlib/ver.tl
index bf26de46..f4d416cc 100644
--- a/share/txr/stdlib/ver.tl
+++ b/stdlib/ver.tl
@@ -1,2 +1,2 @@
-(defvarl lib-version 233)
+(defvarl lib-version 294)
(defvarl *lib-version* lib-version)
diff --git a/share/txr/stdlib/ver.txr b/stdlib/ver.txr
index 2339bda7..2339bda7 100644
--- a/share/txr/stdlib/ver.txr
+++ b/stdlib/ver.txr
diff --git a/stdlib/vm-param.tl b/stdlib/vm-param.tl
new file mode 100644
index 00000000..c4e01fe8
--- /dev/null
+++ b/stdlib/vm-param.tl
@@ -0,0 +1,37 @@
+;; Copyright 2018-2024
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;; this list of conditions and the following disclaimer in the documentation
+;; and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defsymacro %lev-size% 1024)
+(defsymacro %max-lev-idx% (pred %lev-size%))
+(defsymacro %lev-bits% 10)
+(defsymacro %max-lev% 63)
+(defsymacro %max-v-lev% (ppred %max-lev%))
+(defsymacro %sm-lev-size% 64)
+(defsymacro %max-sm-lev-idx% (pred %sm-lev-size%))
+(defsymacro %max-sm-lev% 15)
+(defsymacro %sm-lev-bits% 6)
+(defsymacro %max-lambda-fixed-args% 127)
diff --git a/share/txr/stdlib/with-resources.tl b/stdlib/with-resources.tl
index 5c1b8130..e450f469 100644
--- a/share/txr/stdlib/with-resources.tl
+++ b/stdlib/with-resources.tl
@@ -1,4 +1,4 @@
-;; Copyright 2015-2020
+;; Copyright 2015-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,23 +6,24 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(defmacro with-resources (:form f res-bindings . body)
(tree-case res-bindings
@@ -30,8 +31,13 @@
^(let ((,sym ,init))
(with-resources ,rest ,*body)))
(((sym init . cleanup) . rest)
- ^(let ((,sym ,init))
- (when ,sym
+ (if (and (plusp sys:compat) (<= sys:compat 265))
+ ^(let ((,sym ,init))
+ (when ,sym
+ (unwind-protect
+ (with-resources ,rest ,*body)
+ ,*cleanup)))
+ ^(let ((,sym ,init))
(unwind-protect
(with-resources ,rest ,*body)
,*cleanup))))
@@ -40,7 +46,7 @@
(with-resources ,rest ,*body)))
(nil
^(progn ,*body))
- (other (compile-error f "bad syntax"))))
+ (t (compile-error f "bad syntax"))))
(defmacro with-objects (var-init-forms . body)
(let ((gens (mapcar (ret (gensym)) var-init-forms)))
diff --git a/share/txr/stdlib/with-stream.tl b/stdlib/with-stream.tl
index d79ff5da..8017a1f5 100644
--- a/share/txr/stdlib/with-stream.tl
+++ b/stdlib/with-stream.tl
@@ -1,4 +1,4 @@
-;; Copyright 2015-2020
+;; Copyright 2015-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,23 +6,24 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(defmacro with-out-string-stream ((stream) . body)
^(let ((,stream (make-string-output-stream)))
diff --git a/share/txr/stdlib/yield.tl b/stdlib/yield.tl
index 947c3a1d..db07f323 100644
--- a/share/txr/stdlib/yield.tl
+++ b/stdlib/yield.tl
@@ -1,4 +1,4 @@
-;; Copyright 2015-2020
+;; Copyright 2015-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
@@ -6,23 +6,24 @@
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
-;; 1. Redistributions of source code must retain the above copyright notice, this
-;; list of conditions and the following disclaimer.
+;; 1. Redistributions of source code must retain the above copyright notice,
+;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(defstruct (sys:yld-item val cont) nil val cont)
@@ -94,8 +95,6 @@
(nvars (len vis))
(syms [mapcar car vis])
(inits [mapcar cadr vis])
- (letop (if (eq op 'hlet*) 'let* 'let))
- (gens (mapcar (ret (gensym)) vis))
(vec (gensym))
(macs (mapcar (ret ^(,@1 (vecref ,vec ,@2)))
syms (range 0)))
diff --git a/stream.c b/stream.c
index 915ed7e5..1e9019fb 100644
--- a/stream.c
+++ b/stream.c
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,25 +6,27 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
+#define UTF8_DECL_OPENDIR
#include <stdio.h>
#include <string.h>
#include <stddef.h>
@@ -53,12 +55,12 @@
#if HAVE_WINDOWS_H
#include <windows.h>
#endif
-#if HAVE_SOCKETS
-#include <sys/socket.h>
-#endif
#if HAVE_WSPAWN || HAVE_SPAWN
#include <process.h>
#endif
+#if HAVE_ZLIB
+#include <zlib.h>
+#endif
#include "alloca.h"
#include "lib.h"
#include "gc.h"
@@ -71,8 +73,13 @@
#include "eval.h"
#include "regex.h"
#include "txr.h"
-#include "arith.h"
#include "buf.h"
+#if HAVE_ZLIB
+#include "gzio.h"
+#endif
+
+#define max(a, b) ((a) > (b) ? (a) : (b))
+#define min(a, b) ((a) < (b) ? (a) : (b))
/* Adhere to ISO C rules about direction switching on update streams. */
#ifndef __gnu_linux__
@@ -88,9 +95,11 @@ val get_error_s, get_error_str_s, clear_error_s, get_fd_s;
val print_flo_precision_s, print_flo_digits_s, print_flo_format_s;
val pprint_flo_format_s, print_base_s, print_circle_s;
+val print_json_format_s;
val from_start_k, from_current_k, from_end_k;
val real_time_k, name_k, addr_k, fd_k, byte_oriented_k;
+val standard_k;
val format_s;
val stdio_stream_s;
@@ -99,13 +108,18 @@ val stdio_stream_s;
val socket_error_s;
#endif
+struct cobj_class *stream_cls, *stdio_stream_cls;
+
const wchli_t *path_sep_chars = wli("/");
+wchar_t path_var_sep_char = ':';
+
+val top_stderr;
-val shell, shell_arg;
+static val shell, shell_arg;
void strm_base_init(struct strm_base *s)
{
- static struct strm_base init = { indent_off, 60, 10, 0, 0, 0, 0, 0, 0 };
+ static struct strm_base init = { indent_off, 60, 10, 0, 0, 0, 0, 0, nil, 0 };
*s = init;
}
@@ -116,7 +130,8 @@ void strm_base_cleanup(struct strm_base *s)
void strm_base_mark(struct strm_base *s)
{
- (void) s;
+ if (s->close_result)
+ gc_mark(s->close_result);
}
void stream_print_op(val stream, val out, val pretty, struct strm_ctx *ctx)
@@ -140,140 +155,165 @@ void stream_mark_op(val stream)
strm_base_mark(s);
}
-static noreturn void unimpl(val stream, val op)
+static NORETURN void unimpl(val stream, val op)
{
uw_throwf(file_error_s, lit("~a: not supported by stream ~s"),
op, stream, nao);
abort();
}
-static noreturn val unimpl_put_string(val stream, val str)
+static NORETURN val unimpl_put_string(val stream, val str)
{
+ (void) str;
unimpl(stream, lit("put-string"));
}
-static noreturn val unimpl_put_char(val stream, val ch)
+static NORETURN val unimpl_put_char(val stream, val ch)
{
+ (void) ch;
unimpl(stream, lit("put-char"));
}
-static noreturn val unimpl_put_byte(val stream, int byte)
+static NORETURN val unimpl_put_byte(val stream, int byte)
{
+ (void) byte;
unimpl(stream, lit("put-byte"));
}
-static noreturn val unimpl_get_line(val stream)
+static NORETURN val unimpl_get_line(val stream)
{
unimpl(stream, lit("get-line"));
}
-static noreturn val unimpl_get_char(val stream)
+static NORETURN val unimpl_get_char(val stream)
{
unimpl(stream, lit("get-char"));
}
-static noreturn val unimpl_get_byte(val stream)
+static NORETURN val unimpl_get_byte(val stream)
{
unimpl(stream, lit("get-byte"));
}
-static noreturn val unimpl_unget_char(val stream, val ch)
+static NORETURN val unimpl_unget_char(val stream, val ch)
{
+ (void) ch;
unimpl(stream, lit("unget-char"));
}
-static noreturn val unimpl_unget_byte(val stream, int byte)
+static NORETURN val unimpl_unget_byte(val stream, int byte)
{
+ (void) byte;
unimpl(stream, lit("unget-byte"));
}
-static noreturn val unimpl_put_buf(val stream, val buf, cnum pos)
+static NORETURN ucnum unimpl_put_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
{
+ (void) ptr;
+ (void) len;
+ (void) pos;
unimpl(stream, lit("put-buf"));
}
-static noreturn val unimpl_fill_buf(val stream, val buf, cnum pos)
+static NORETURN ucnum unimpl_fill_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
{
+ (void) ptr;
+ (void) len;
+ (void) pos;
unimpl(stream, lit("fill-buf"));
}
-static noreturn val unimpl_seek(val stream, val off, enum strm_whence whence)
+static NORETURN val unimpl_seek(val stream, val off, enum strm_whence whence)
{
+ (void) off;
+ (void) whence;
unimpl(stream, lit("seek-stream"));
}
-static noreturn val unimpl_truncate(val stream, val len)
+static NORETURN val unimpl_truncate(val stream, val len)
{
+ (void) len;
unimpl(stream, lit("truncate-stream"));
}
-static noreturn val unimpl_get_fd(val stream)
-{
- unimpl(stream, lit("fileno"));
-}
-
-static noreturn val unimpl_get_sock_family(val stream)
+static NORETURN val unimpl_get_sock_family(val stream)
{
unimpl(stream, lit("sock-family"));
}
-static noreturn val unimpl_get_sock_type(val stream)
+static NORETURN val unimpl_get_sock_type(val stream)
{
unimpl(stream, lit("sock-type"));
}
-static noreturn val unimpl_get_sock_peer(val stream)
+static NORETURN val unimpl_get_sock_peer(val stream)
{
unimpl(stream, lit("sock-peer"));
}
-static noreturn val unimpl_set_sock_peer(val stream, val peer)
+static NORETURN val unimpl_set_sock_peer(val stream, val peer)
{
+ (void) peer;
unimpl(stream, lit("sock-set-peer"));
}
static val null_put_string(val stream, val str)
{
+ (void) stream;
+ (void) str;
return nil;
}
static val null_put_char(val stream, val ch)
{
+ (void) stream;
+ (void) ch;
return nil;
}
static val null_put_byte(val stream, int byte)
{
+ (void) stream;
+ (void) byte;
return nil;
}
static val null_get_line(val stream)
{
+ (void) stream;
return nil;
}
static val null_get_char(val stream)
{
+ (void) stream;
return nil;
}
static val null_get_byte(val stream)
{
+ (void) stream;
return nil;
}
static val null_close(val stream, val throw_on_error)
{
+ (void) stream;
+ (void) throw_on_error;
return nil;
}
static val null_flush(val stream)
{
+ (void) stream;
return nil;
}
static val null_seek(val stream, val off, enum strm_whence whence)
{
+ (void) stream;
+ (void) off;
+ (void) whence;
return nil;
}
@@ -289,38 +329,43 @@ static val null_get_prop(val stream, val ind)
static val null_set_prop(val stream, val ind, val value)
{
+ (void) stream;
+ (void) ind;
+ (void) value;
return nil;
}
static val null_get_error(val stream)
{
+ (void) stream;
return nil;
}
static val null_get_error_str(val stream)
{
+ (void) stream;
return nil;
}
static val null_clear_error(val stream)
{
+ (void) stream;
return nil;
}
static val null_get_fd(val stream)
{
+ (void) stream;
return nil;
}
-static val generic_put_buf(val stream, val buf, cnum pos)
+static ucnum generic_put_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
{
- val self = lit("put-buf");
struct strm_ops *ops = coerce(struct strm_ops *, stream->co.ops);
- cnum len = c_num(length_buf(buf)), i;
- mem_t *ptr = buf_get(buf, self);
+ ucnum i;
if (pos >= len)
- return num(len);
+ return len;
for (i = pos; i < len; i++)
ops->put_byte(stream, *ptr++);
@@ -328,27 +373,26 @@ static val generic_put_buf(val stream, val buf, cnum pos)
if (i > len)
i = len;
- return num(i);
+ return i;
}
-static val generic_fill_buf(val stream, val buf, cnum pos)
+static ucnum generic_fill_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
{
val self = lit("fill-buf");
struct strm_ops *ops = coerce(struct strm_ops *, stream->co.ops);
- cnum len = c_num(length_buf(buf)), i;
- mem_t *ptr = buf_get(buf, self);
+ ucnum i;
for (i = pos; i < len; i++) {
val byte = ops->get_byte(stream);
if (!byte)
break;
- *ptr++ = c_num(byte);
+ *ptr++ = c_num(byte, self);
}
if (i > len)
i = len;
- return num(i);
+ return i;
}
void fill_stream_ops(struct strm_ops *ops)
@@ -392,7 +436,7 @@ void fill_stream_ops(struct strm_ops *ops)
if (!ops->clear_error)
ops->clear_error = null_clear_error;
if (!ops->get_fd)
- ops->get_fd = unimpl_get_fd;
+ ops->get_fd = null_get_fd;
if (!ops->get_sock_family)
ops->get_sock_family = unimpl_get_sock_family;
if (!ops->get_sock_type)
@@ -403,6 +447,45 @@ void fill_stream_ops(struct strm_ops *ops)
ops->set_sock_peer = unimpl_set_sock_peer;
}
+struct dev_null {
+ struct strm_base a;
+ int fd;
+};
+
+static val dev_null_close(val stream, val throw_on_error)
+{
+ struct dev_null *n = coerce(struct dev_null *, stream->co.handle);
+ (void) throw_on_error;
+ if (n->fd != -1) {
+ close(n->fd);
+ n->fd = -1;
+ return t;
+ }
+ return nil;
+}
+
+static val dev_null_get_fd(val stream)
+{
+ struct dev_null *n = coerce(struct dev_null *, stream->co.handle);
+ if (n->fd == -1 && (n->fd = open("/dev/null", O_RDWR)) == -1) {
+ int eno = errno;
+ uw_ethrowf(errno_to_file_error(eno), lit("error opening /dev/null: ~d/~s"),
+ num(eno), errno_to_str(eno), nao);
+ }
+ return num(n->fd);
+}
+
+static val dev_null_get_prop(val stream, val ind)
+{
+ if (ind == name_k)
+ return null_get_prop(stream, ind);
+
+ if (ind == fd_k)
+ return dev_null_get_fd(stream);
+
+ return nil;
+}
+
static struct strm_ops null_ops =
strm_ops_init(cobj_ops_init(eq,
stream_print_op,
@@ -414,16 +497,17 @@ static struct strm_ops null_ops =
null_get_char, null_get_byte,
unimpl_unget_char, unimpl_unget_byte,
unimpl_put_buf, unimpl_fill_buf,
- null_close, null_flush, null_seek, unimpl_truncate,
- null_get_prop, null_set_prop,
+ dev_null_close, null_flush, null_seek, unimpl_truncate,
+ dev_null_get_prop, null_set_prop,
null_get_error, null_get_error_str, null_clear_error,
- null_get_fd);
+ dev_null_get_fd);
val make_null_stream(void)
{
- struct strm_base *s = coerce(struct strm_base *, chk_malloc(sizeof *s));
- strm_base_init(s);
- return cobj(coerce(mem_t *, s), stream_s, &null_ops.cobj_ops);
+ struct dev_null *n = coerce(struct dev_null *, chk_malloc(sizeof *n));
+ strm_base_init(&n->a);
+ n->fd = -1;
+ return cobj(coerce(mem_t *, n), stream_cls, &null_ops.cobj_ops);
}
#if CONFIG_STDIO_STRICT
@@ -440,8 +524,6 @@ struct stdio_handle {
char *buf;
#if HAVE_FORK_STUFF
pid_t pid;
-#else
- int pid;
#endif
val mode; /* used by tail */
unsigned is_rotated : 8; /* used by tail */
@@ -501,10 +583,9 @@ static void stdio_stream_mark(val stream)
val errno_to_string(val err)
{
- if (err == zero)
- return lit("unspecified error");
- else if (is_num(err))
- return string_utf8(strerror(c_num(err)));
+ val self = lit("get-error-str");
+ if (is_num(err))
+ return errno_to_str(c_num(err, self));
else if (!err)
return lit("no error");
else if (err == t)
@@ -519,14 +600,15 @@ static val stdio_maybe_read_error(val stream)
if (h->f == 0)
uw_throwf(file_error_s, lit("error reading ~s: file closed"), stream, nao);
if (ferror(h->f)) {
- val err = num(errno);
+ int eno = errno;
+ val err = num(eno);
h->err = err;
#ifdef EAGAIN
- if (errno == EAGAIN)
- uw_throwf(timeout_error_s, lit("timed out reading ~s"), stream, nao);
+ if (eno == EAGAIN)
+ uw_ethrowf(timeout_error_s, lit("timed out reading ~s"), stream, nao);
#endif
- uw_throwf(file_error_s, lit("error reading ~s: ~d/~s"),
- stream, err, errno_to_string(err), nao);
+ uw_ethrowf(file_error_s, lit("error reading ~s: ~d/~s"),
+ stream, err, errno_to_string(err), nao);
}
if (feof(h->f))
h->err = t;
@@ -538,28 +620,21 @@ static val stdio_maybe_error(val stream, val action)
struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
val err = num(errno);
if (h->f == 0)
- uw_throwf(file_error_s, lit("error ~a ~s: file closed"), stream, action, nao);
+ uw_ethrowf(file_error_s, lit("error ~a ~s: file closed"), action, stream, nao);
h->err = err;
#ifdef EAGAIN
if (errno == EAGAIN)
- uw_throwf(timeout_error_s, lit("timed out on ~s"), stream, nao);
+ uw_ethrowf(timeout_error_s, lit("timed out on ~s"), stream, nao);
#endif
- uw_throwf(file_error_s, lit("error ~a ~s: ~d/~s"),
- stream, action, err, errno_to_string(err), nao);
+ uw_ethrowf(file_error_s, lit("error ~a ~s: ~d/~s"),
+ action, stream, err, errno_to_string(err), nao);
}
static int se_putc(int ch, FILE *f)
{
int ret;
sig_save_enable;
-#ifdef __CYGWIN__
- {
- char out[2] = { ch, 0 };
- ret = fputs(out, f) == EOF ? EOF : ch;
- }
-#else
ret = putc(ch, f);
-#endif
sig_restore_enable;
return ret;
}
@@ -619,12 +694,13 @@ static int stdio_get_char_callback(mem_t *f)
static val stdio_put_string(val stream, val str)
{
+ val self = lit("put-string");
struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
errno = 0;
if (h->f != 0) {
- const wchar_t *s = c_str(str);
+ const wchar_t *s = c_str(str, self);
stdio_switch(h, stdio_write);
@@ -697,8 +773,6 @@ static val stdio_get_prop(val stream, val ind)
return h->is_real_time ? t : nil;
} else if (ind == name_k) {
return h->descr;
- } else if (ind == fd_k) {
- return h->f ? num(fileno(h->f)) : nil;
} else if (ind == byte_oriented_k) {
return h->is_byte_oriented ? t : nil;
}
@@ -715,6 +789,9 @@ static val stdio_set_prop(val stream, val ind, val prop)
} else if (ind == byte_oriented_k) {
h->is_byte_oriented = prop ? 1 : 0;
return t;
+ } else if (ind == name_k) {
+ h->descr = prop;
+ return t;
}
return nil;
}
@@ -751,7 +828,7 @@ static val stdio_get_fd(val stream)
{
val self = lit("stream-fd");
struct stdio_handle *h = coerce(struct stdio_handle *,
- cobj_handle(self, stream, stdio_stream_s));
+ cobj_handle(self, stream, stdio_stream_cls));
return h->f ? num(fileno(h->f)) : nil;
}
@@ -768,7 +845,7 @@ val generic_get_line(val stream)
for (;;) {
val chr = ops->get_char(stream);
- wint_t ch = chr ? c_chr(chr) : WEOF;
+ wint_t ch = chr ? convert(wint_t, c_chr(chr)) : WEOF;
if (ch == WEOF && buf == 0)
break;
@@ -863,57 +940,53 @@ static val stdio_unget_byte(val stream, int byte)
: stdio_maybe_error(stream, lit("writing"));
}
-static val stdio_put_buf(val stream, val buf, cnum pos)
+static ucnum stdio_put_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
{
val self = lit("put-buf");
- ucnum len = c_unum(length_buf(buf));
- mem_t *ptr = buf_get(buf, self);
struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
if (convert(size_t, len) != len || len > INT_PTR_MAX)
uw_throwf(error_s, lit("~a: buffer too large"), self, nao);
- if (convert(ucnum, pos) >= len)
- return num(len);
+ if (pos >= len)
+ return len;
errno = 0;
if (h->f != 0) {
cnum nwrit = fwrite(ptr + pos, 1, len - pos, h->f);
if (nwrit > 0)
- return num(pos + nwrit);
+ return pos + nwrit;
}
stdio_maybe_error(stream, lit("writing"));
- return zero;
+ return 0;
}
-static val stdio_fill_buf(val stream, val buf, cnum pos)
+static ucnum stdio_fill_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
{
val self = lit("fill-buf");
- ucnum len = c_unum(length_buf(buf));
- mem_t *ptr = buf_get(buf, self);
struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
if (convert(size_t, len) != len || len > INT_PTR_MAX)
uw_throwf(error_s, lit("~a: buffer too large"), self, nao);
- if (convert(ucnum, pos) >= len)
- return num(len);
+ if (pos >= len)
+ return len;
errno = 0;
if (h->f != 0) {
cnum nread = fread(ptr + pos, 1, len - pos, h->f);
if (nread > 0)
- return num(pos + nread);
+ return pos + nread;
}
stdio_maybe_read_error(stream);
- return num(pos);
+ return pos;
}
static val stdio_close(val stream, val throw_on_error)
{
struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
- if (h->f != 0 && h->f != stdin && h->f != stdout) {
+ if (h->f != 0 && h->f != stdin && h->f != stdout && h->f != stderr) {
int result = fclose(h->f);
h->f = 0;
- if (result == EOF && throw_on_error) {
+ if (result == EOF && default_null_arg(throw_on_error)) {
h->err = num(errno);
- uw_throwf(file_error_s, lit("error closing ~s: ~d/~s"),
- stream, num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(file_error_s, lit("error closing ~s: ~d/~s"),
+ stream, num(errno), errno_to_str(errno), nao);
}
return result != EOF ? t : nil;
}
@@ -923,8 +996,9 @@ static val stdio_close(val stream, val throw_on_error)
#if HAVE_FTRUNCATE || HAVE_CHSIZE
static val stdio_truncate(val stream, val len)
{
+ val self = lit("truncate-stream");
struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
- cnum l = c_num(len);
+ cnum l = c_num(len, self);
#if HAVE_FTRUNCATE
typedef off_t trunc_off_t;
int (*truncfun)(int, off_t) = ftruncate;
@@ -1047,25 +1121,49 @@ static struct strm_ops stdio_ops =
static struct strm_ops stdio_sock_ops;
#endif
+#if HAVE_FCNTL
+int w_open_mode(const wchar_t *wname, const struct stdio_mode m)
+{
+ char *name = utf8_dup_to(wname);
+ size_t nsiz = strlen(name) + 1;
+ int flags = (if3(m.read && m.write, O_RDWR, 0) |
+ if3(m.read && !m.write, O_RDONLY, 0) |
+ if3(!m.read && m.write, O_WRONLY, 0) |
+ if3(m.create, if3(!m.notrunc, O_TRUNC, 0) | O_CREAT, 0) |
+ if3(m.append, O_APPEND, 0) |
+ if3(m.excl, O_EXCL, 0) |
+#if O_TMPFILE
+ if3(m.tmpfile, O_TMPFILE, 0) |
+#endif
+ if3(m.nonblock, O_NONBLOCK, 0));
+ char *stkname = coerce(char *, alloca(nsiz));
+ int fd;
+
+ memcpy(stkname, name, nsiz);
+ free(name);
+
+ sig_save_enable;
+ fd = open(stkname, flags, 0666);
+ sig_restore_enable;
+
+ return fd;
+}
+#endif
+
static FILE *w_fopen_mode(const wchar_t *wname, const wchar_t *mode,
const struct stdio_mode m)
{
#if HAVE_FCNTL
- if (m.notrunc) {
- char *name = utf8_dup_to(wname);
- int flags = (m.read ? O_RDWR : O_WRONLY) | O_CREAT;
- int fd = open(name, flags, 0777);
- free(name);
- if (fd < 0)
- return NULL;
- return (fd < 0) ? NULL : w_fdopen(fd, mode);
- }
+ int fd = w_open_mode(wname, m);
+ return (fd < 0) ? NULL : w_fdopen(fd, mode);
#else
- if (m.notrunc)
+ /* TODO: detect if fopen supports "x" in mode */
+ if (m.notrunc || m.excl || m.nonblock)
uw_throwf(file_error_s,
- lit("open-file: \"m\" mode not supported on this system"), nao);
-#endif
+ lit("open-file: specified mode not supported on this system"),
+ nao);
return w_fopen(wname, mode);
+#endif
}
@@ -1082,6 +1180,7 @@ static void tail_calc(unsigned long *state, int *usec, int *mod)
static void tail_strategy(val stream, unsigned long *state)
{
+ val self = lit("open-tail");
struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
int usec = 0, mod = 0;
val mode = nil;
@@ -1117,11 +1216,11 @@ static void tail_strategy(val stream, unsigned long *state)
FILE *newf;
if (!mode)
- mode = normalize_mode(&m, h->mode, m_r);
+ mode = normalize_mode(&m, h->mode, m_r, self);
/* Try to open the file.
*/
- if (!(newf = w_fopen_mode(c_str(h->descr), c_str(mode), m))) {
+ if (!(newf = w_fopen_mode(c_str(h->descr, self), c_str(mode, self), m))) {
/* If already have the file open previously, and the name
* does not open any more, then the file has rotated.
* Have the caller try to read the last bit of data
@@ -1267,61 +1366,45 @@ static int pipevp_close(FILE *f, pid_t pid)
sig_restore_enable;
return status;
}
-#endif
-static int se_pclose(FILE *f)
+val pipe_close_status_helper(val stream, val throw_on_error,
+ int status, val self)
{
- int ret;
- sig_save_enable;
- ret = pclose(f);
- sig_restore_enable;
- return ret;
+ if (status < 0) {
+ if (throw_on_error)
+ uw_ethrowf(process_error_s,
+ lit("~a: stream ~s: unable to obtain status of process: ~d/~s"),
+ self, stream, num(errno), errno_to_str(errno), nao);
+ return nil;
+ } else {
+#if HAVE_SYS_WAIT
+ if (WIFEXITED(status)) {
+ int exitstatus = WEXITSTATUS(status);
+ return num(exitstatus);
+ } else if (default_null_arg(throw_on_error)) {
+ if (WIFSIGNALED(status)) {
+ int termsig = WTERMSIG(status);
+ uw_throwf(process_error_s, lit("~a: stream ~s: process terminated by signal ~a"),
+ self, stream, num(termsig), nao);
+ }
+ }
+#endif
+ return status == 0 ? zero : nil;
+ }
}
static val pipe_close(val stream, val throw_on_error)
{
+ val self = lit("close-stream");
struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
if (h->f != 0) {
-#if HAVE_FORK_STUFF
- int status = h->pid != 0 ? pipevp_close(h->f, h->pid) : se_pclose(h->f);
-#else
- int status = se_pclose(h->f);
-#endif
+ int status = pipevp_close(h->f, h->pid);
h->f = 0;
- if (status < 0) {
- if (throw_on_error)
- uw_throwf(process_error_s,
- lit("unable to obtain status of command ~s: ~d/~s"),
- stream, num(errno), string_utf8(strerror(errno)), nao);
- } else {
-#if HAVE_SYS_WAIT
- if (throw_on_error) {
- if (WIFSIGNALED(status)) {
- int termsig = WTERMSIG(status);
- uw_throwf(process_error_s, lit("pipe ~s terminated by signal ~a"),
- stream, num(termsig), nao);
-#ifndef WIFCONTINUED
-#define WIFCONTINUED(X) 0
-#endif
- } else if (WIFSTOPPED(status) || WIFCONTINUED(status)) {
- uw_throwf(process_error_s,
- lit("processes of closed pipe ~s still running"),
- stream, nao);
- }
- }
- if (WIFEXITED(status)) {
- int exitstatus = WEXITSTATUS(status);
- return num(exitstatus);
- }
-#else
- if (status != 0 && throw_on_error)
- uw_throwf(process_error_s, lit("closing pipe ~s failed"), stream, nao);
-#endif
- return status == 0 ? zero : nil;
- }
+ return pipe_close_status_helper(stream, throw_on_error, status, self);
}
+
return nil;
}
@@ -1352,11 +1435,13 @@ static struct strm_ops pipe_ops =
stdio_get_error_str,
stdio_clear_error,
stdio_get_fd);
+#endif
-static struct stdio_mode do_parse_mode(val mode_str, struct stdio_mode m_dfl)
+static struct stdio_mode do_parse_mode(val mode_str, struct stdio_mode m_dfl,
+ val self)
{
struct stdio_mode m = stdio_mode_init_blank;
- const wchar_t *ms = c_str(default_arg(mode_str, lit("")));
+ const wchar_t *ms = c_str(default_arg_strict(mode_str, null_string), self);
int nredir = 0;
switch (*ms) {
@@ -1372,7 +1457,9 @@ static struct stdio_mode do_parse_mode(val mode_str, struct stdio_mode m_dfl)
case 'a':
ms++;
m.write = 1;
+ m.create = 1;
m.append = 1;
+ m.notrunc = 1;
break;
case 'm':
ms++;
@@ -1380,15 +1467,24 @@ static struct stdio_mode do_parse_mode(val mode_str, struct stdio_mode m_dfl)
m.create = 1;
m.notrunc = 1;
break;
+ case 'T':
+ ms++;
+#if O_TMPFILE
+ m.read = 1;
+ m.write = 1;
+ m.tmpfile = 1;
+#else
+ m.malformed = 1;
+#endif
+ break;
default:
break;
}
if (*ms == '+') {
ms++;
- if (m.read)
- m.write = 1;
m.read = 1;
+ m.write = 1;
}
if (!m.read && !m.write)
@@ -1399,6 +1495,14 @@ static struct stdio_mode do_parse_mode(val mode_str, struct stdio_mode m_dfl)
case 'b':
m.binary = 1;
break;
+ case 'x':
+ /* Ensure only "w" and "w+" can have the "x" option. */
+ if (!m.write || !m.create || m.notrunc) {
+ m.malformed = 1;
+ return m;
+ }
+ m.excl = 1;
+ break;
case 'i':
m.interactive = 1;
break;
@@ -1416,6 +1520,9 @@ static struct stdio_mode do_parse_mode(val mode_str, struct stdio_mode m_dfl)
}
m.unbuf = 1;
break;
+ case 'n':
+ m.nonblock = 1;
+ break;
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
if (m.unbuf) {
@@ -1431,13 +1538,13 @@ static struct stdio_mode do_parse_mode(val mode_str, struct stdio_mode m_dfl)
}
if (ms[1] != '(') {
- if (!isdigit((unsigned char) ms[1]) || !ms[2]) {
+ if (!isdigit(convert(unsigned char, ms[1])) || !ms[2]) {
m.malformed = 1;
return m;
}
m.redir[nredir][0] = ms[1] - '0';
- if (isdigit((unsigned char) ms[2])) {
+ if (isdigit(convert(unsigned char, ms[2]))) {
m.redir[nredir][1] = ms[2] - '0';
} else switch (ms[2]) {
case 'n': case 'x':
@@ -1473,6 +1580,13 @@ static struct stdio_mode do_parse_mode(val mode_str, struct stdio_mode m_dfl)
nredir++;
break;
}
+ case 'z':
+ m.gzip = 1;
+ if (isdigit(convert(unsigned char, ms[1]))) {
+ m.gzlevel = *++ms - '0';
+ break;
+ }
+ break;
default:
m.malformed = 1;
return m;
@@ -1485,11 +1599,12 @@ static struct stdio_mode do_parse_mode(val mode_str, struct stdio_mode m_dfl)
return m;
}
-struct stdio_mode parse_mode(val mode_str, struct stdio_mode m_dfl)
+struct stdio_mode parse_mode(val mode_str, struct stdio_mode m_dfl, val self)
{
- struct stdio_mode m = do_parse_mode(mode_str, m_dfl);
+ struct stdio_mode m = do_parse_mode(mode_str, m_dfl, self);
if (m.malformed)
- uw_throwf(file_error_s, lit("invalid mode string ~s"), mode_str, nao);
+ uw_throwf(file_error_s, lit("~a: invalid mode string ~s"), self,
+ mode_str, nao);
return m;
}
@@ -1514,11 +1629,14 @@ static val format_mode(const struct stdio_mode m)
*ptr++ = '+';
}
- if (m.binary)
+ if (m.binary && !m.gzip)
*ptr++ = 'b';
+ if (m.gzip && m.gzlevel)
+ *ptr++ = '0' + m.gzlevel;
+
#ifdef __CYGWIN__
- if (!m.binary && (opt_compat == 144 || opt_compat == 145))
+ if (!m.gzip && !m.binary && (opt_compat == 144 || opt_compat == 145))
*ptr++ = 't';
#endif
@@ -1526,25 +1644,29 @@ static val format_mode(const struct stdio_mode m)
return string(buf);
}
-val normalize_mode(struct stdio_mode *m, val mode_str, struct stdio_mode m_dfl)
+val normalize_mode(struct stdio_mode *m, val mode_str, struct stdio_mode m_dfl,
+ val self)
{
- *m = do_parse_mode(mode_str, m_dfl);
+ *m = do_parse_mode(mode_str, m_dfl, self);
if (m->malformed)
- uw_throwf(file_error_s, lit("invalid file open mode ~s"), mode_str, nao);
+ uw_throwf(file_error_s, lit("~a: invalid file open mode ~s"),
+ self, mode_str, nao);
return format_mode(*m);
}
-val normalize_mode_no_bin(struct stdio_mode *m, val mode_str, struct stdio_mode m_dfl)
+val normalize_mode_no_bin(struct stdio_mode *m, val mode_str,
+ struct stdio_mode m_dfl, val self)
{
#ifdef __CYGWIN__
- return normalize_mode(m, mode_str, m_dfl);
+ return normalize_mode(m, mode_str, m_dfl, self);
#else
- *m = do_parse_mode(mode_str, m_dfl);
+ *m = do_parse_mode(mode_str, m_dfl, self);
if (m->malformed)
- uw_throwf(file_error_s, lit("invalid file open mode ~s"), mode_str, nao);
+ uw_throwf(file_error_s, lit("~a: invalid file open mode ~s"),
+ self, mode_str, nao);
m->binary = 0;
@@ -1585,7 +1707,7 @@ val set_mode_props(const struct stdio_mode m, val stream)
static val make_stdio_stream_common(FILE *f, val descr, struct cobj_ops *ops)
{
struct stdio_handle *h = coerce(struct stdio_handle *, chk_malloc(sizeof *h));
- val stream = cobj(coerce(mem_t *, h), stdio_stream_s, ops);
+ val stream = cobj(coerce(mem_t *, h), stdio_stream_cls, ops);
strm_base_init(&h->a);
h->f = f;
h->descr = descr;
@@ -1627,11 +1749,6 @@ val make_tail_stream(FILE *f, val descr)
return stream;
}
-val make_pipe_stream(FILE *f, val descr)
-{
- return make_stdio_stream_common(f, descr, &pipe_ops.cobj_ops);
-}
-
#if HAVE_SOCKETS
val make_sock_stream(FILE *f, val family, val type)
{
@@ -1647,7 +1764,7 @@ val stream_fd(val stream)
{
val self = lit("fileno");
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
+ cobj_ops(self, stream, stream_cls));
return ops->get_fd(stream);
}
@@ -1656,7 +1773,7 @@ val sock_family(val stream)
{
val self = lit("sock-family");
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
+ cobj_ops(self, stream, stream_cls));
return ops->get_sock_family(stream);
}
@@ -1664,7 +1781,7 @@ val sock_type(val stream)
{
val self = lit("sock-type");
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
+ cobj_ops(self, stream, stream_cls));
return ops->get_sock_type(stream);
}
@@ -1672,7 +1789,7 @@ val sock_peer(val stream)
{
val self = lit("sock-peer");
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
+ cobj_ops(self, stream, stream_cls));
return ops->get_sock_peer(stream);
}
@@ -1680,7 +1797,7 @@ val sock_set_peer(val stream, val peer)
{
val self = lit("sock-set-peer");
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
+ cobj_ops(self, stream, stream_cls));
return ops->set_sock_peer(stream, peer);
}
#endif
@@ -1739,10 +1856,12 @@ static val dir_get_line(val stream)
static val dir_close(val stream, val throw_on_error)
{
struct dir_handle *h = coerce(struct dir_handle *, stream->co.handle);
+ (void) throw_on_error;
if (h->d != 0) {
closedir(coerce(DIR *, h->d));
h->d = 0;
+ return t;
}
return nil;
@@ -1791,7 +1910,7 @@ static val make_dir_stream(DIR *dir)
strm_base_init(&h->a);
h->d = dir;
h->err = nil;
- return cobj(coerce(mem_t *, h), stream_s, &dir_ops.cobj_ops);
+ return cobj(coerce(mem_t *, h), stream_cls, &dir_ops.cobj_ops);
}
struct string_in {
@@ -1914,7 +2033,7 @@ val make_string_input_stream(val string)
strm_base_init(&s->a);
s->string = string;
s->pos = zero;
- return cobj(coerce(mem_t *, s), stream_s, &string_in_ops.cobj_ops);
+ return cobj(coerce(mem_t *, s), stream_cls, &string_in_ops.cobj_ops);
}
struct byte_input {
@@ -1984,15 +2103,16 @@ static struct strm_ops byte_in_ops =
val make_string_byte_input_stream(val string)
{
- type_assert (stringp(string), (lit("~a is not a string"), string, nao));
+ val self = lit("make-string-byte-input-stream");
+ type_assert (stringp(string), (lit("~a: ~s is not a string"), self, string, nao));
{
- const wchar_t *wstring = c_str(string);
+ const wchar_t *wstring = c_str(string, self);
struct byte_input *bi = coerce(struct byte_input *, chk_malloc(sizeof *bi));
strm_base_init(&bi->a);
bi->buf = utf8_dup_to_buf(wstring, &bi->size, 0);
bi->index = 0;
- return cobj(coerce(mem_t *, bi), stream_s, &byte_in_ops.cobj_ops);
+ return cobj(coerce(mem_t *, bi), stream_cls, &byte_in_ops.cobj_ops);
}
}
@@ -2123,12 +2243,13 @@ static struct strm_ops strlist_in_ops =
val make_strlist_input_stream(val list)
{
- struct strlist_in *s = coerce(struct strlist_in *, chk_malloc(sizeof *s));
+ struct strlist_in *s = coerce(struct strlist_in *, chk_calloc(sizeof *s, 1));
+ val stream = cobj(coerce(mem_t *, s), stream_cls, &strlist_in_ops.cobj_ops);
strm_base_init(&s->a);
s->string = car(list);
s->pos = zero;
s->list = cdr(list);
- return cobj(coerce(mem_t *, s), stream_s, &strlist_in_ops.cobj_ops);
+ return stream;
}
struct string_out {
@@ -2189,6 +2310,7 @@ static val string_out_byte_flush(struct string_out *so, val stream)
static val string_out_put_string(val stream, val str)
{
+ val self = lit("put-string");
struct string_out *so = coerce(struct string_out *, stream->co.handle);
if (so->buf == 0)
@@ -2198,8 +2320,8 @@ static val string_out_put_string(val stream, val str)
string_out_byte_flush(so, stream);
{
- const wchar_t *s = c_str(str);
- size_t len = c_num(length_str(str));
+ const wchar_t *s = c_str(str, self);
+ size_t len = c_num(length_str(str), self);
size_t old_size = so->size;
size_t required_size = len + so->fill + 1;
@@ -2220,7 +2342,7 @@ static val string_out_put_string(val stream, val str)
so->fill += len;
return t;
oflow:
- uw_throw(error_s, lit("string output stream overflow"));
+ uw_throwf(error_s, lit("~a: string output stream overflow"), self, nao);
}
}
@@ -2272,17 +2394,18 @@ val make_string_output_stream(void)
so->buf[0] = 0;
utf8_decoder_init(&so->ud);
so->head = so->tail = 0;
- return cobj(coerce(mem_t *, so), stream_s, &string_out_ops.cobj_ops);
+ return cobj(coerce(mem_t *, so), stream_cls, &string_out_ops.cobj_ops);
}
val get_string_from_stream(val stream)
{
val self = lit("get-string-from-stream");
struct string_out *so = coerce(struct string_out *,
- cobj_handle(self, stream, stream_s));
+ cobj_handle(self, stream, stream_cls));
if (stream->co.ops == &string_out_ops.cobj_ops) {
val out = nil;
+ wchar_t *buf;
if (!so->buf)
return out;
@@ -2291,14 +2414,14 @@ val get_string_from_stream(val stream)
out = string_out_byte_flush(so, stream);
/* Trim to actual size */
- so->buf = coerce(wchar_t *, chk_realloc(coerce(mem_t *, so->buf),
- (so->fill + 1) * sizeof *so->buf));
- out = string_own(so->buf);
+ buf = coerce(wchar_t *, chk_realloc(coerce(mem_t *, so->buf),
+ (so->fill + 1) * sizeof *so->buf));
so->buf = 0;
+ out = string_own(buf);
return out;
} else {
type_assert (stream->co.ops == &string_in_ops.cobj_ops,
- (lit("~a is not a string stream"), stream, nao));
+ (lit("~a: ~s is not a string stream"), self, stream, nao));
{
struct string_in *si = coerce(struct string_in *, stream->co.handle);
return si->string;
@@ -2388,7 +2511,7 @@ val make_strlist_output_stream(void)
strm_base_init(&s->a);
s->lines = nil;
s->strstream = nil;
- stream = cobj(coerce(mem_t *, s), stream_s, &strlist_out_ops.cobj_ops);
+ stream = cobj(coerce(mem_t *, s), stream_cls, &strlist_out_ops.cobj_ops);
s->strstream = strstream;
return stream;
}
@@ -2397,7 +2520,7 @@ val get_list_from_stream(val stream)
{
val self = lit("get-list-from-stream");
struct strlist_out *s = coerce(struct strlist_out *,
- cobj_handle(self, stream, stream_s));
+ cobj_handle(self, stream, stream_cls));
if (stream->co.ops == &strlist_out_ops.cobj_ops) {
val stray = get_string_from_stream(s->strstream);
@@ -2407,7 +2530,7 @@ val get_list_from_stream(val stream)
return nreverse(lines);
}
- type_mismatch(lit("~s is not a string list stream"), stream);
+ type_mismatch(lit("~a: ~s is not a string list stream"), self, stream, nao);
}
struct cat_strm {
@@ -2578,12 +2701,12 @@ val make_catenated_stream(val stream_list)
val catstrm = nil;
strm_base_init(&s->a);
s->streams = nil;
- catstrm = cobj(coerce(mem_t *, s), stream_s, &cat_stream_ops.cobj_ops);
+ catstrm = cobj(coerce(mem_t *, s), stream_cls, &cat_stream_ops.cobj_ops);
s->streams = stream_list;
return catstrm;
}
-val make_catenated_stream_v(struct args *streams)
+val make_catenated_stream_v(varg streams)
{
return make_catenated_stream(args_get_list(streams));
}
@@ -2595,10 +2718,12 @@ val catenated_stream_p(val obj)
val catenated_stream_push(val new_stream, val cat_stream)
{
+ val self = lit("catenated-stream-push");
+
type_assert (streamp(new_stream),
- (lit("~a is not a stream"), new_stream, nao));
+ (lit("~a: ~s is not a stream"), self, new_stream, nao));
type_assert (catenated_stream_p(cat_stream),
- (lit("~a is not a stream"), cat_stream, nao));
+ (lit("~a: ~s is not a stream"), self, cat_stream, nao));
{
struct cat_strm *s = coerce(struct cat_strm *, cat_stream->co.handle);
@@ -2661,16 +2786,16 @@ static val delegate_unget_byte(val stream, int byte)
return s->target_ops->unget_byte(s->target_stream, byte);
}
-static val delegate_put_buf(val stream, val buf, cnum pos)
+static ucnum delegate_put_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
{
struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
- return s->target_ops->put_buf(s->target_stream, buf, pos);
+ return s->target_ops->put_buf(s->target_stream, ptr, len, pos);
}
-static val delegate_fill_buf(val stream, val buf, cnum pos)
+static ucnum delegate_fill_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
{
struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
- return s->target_ops->fill_buf(s->target_stream, buf, pos);
+ return s->target_ops->fill_buf(s->target_stream, ptr, len, pos);
}
static val delegate_close(val stream, val throw_on_error)
@@ -2765,7 +2890,7 @@ static val make_delegate_stream(val self, val orig_stream, size_t handle_size,
struct cobj_ops *ops)
{
struct strm_ops *orig_ops = coerce(struct strm_ops *,
- cobj_ops(self, orig_stream, stream_s));
+ cobj_ops(self, orig_stream, stream_cls));
struct delegate_base *db = coerce(struct delegate_base *,
chk_calloc(1, handle_size));
val delegate_stream;
@@ -2774,7 +2899,7 @@ static val make_delegate_stream(val self, val orig_stream, size_t handle_size,
db->target_stream = nil;
db->target_ops = orig_ops;
- delegate_stream = cobj(coerce(mem_t *, db), stream_s, ops);
+ delegate_stream = cobj(coerce(mem_t *, db), stream_cls, ops);
db->target_stream = orig_stream;
@@ -2826,7 +2951,8 @@ static struct strm_ops record_adapter_ops =
val record_adapter(val regex, val stream, val include_match)
{
val self = lit("record-adapter");
- val rec_adapter = make_delegate_stream(self, default_arg(stream, std_input),
+ val rec_adapter = make_delegate_stream(self,
+ default_arg_strict(stream, std_input),
sizeof (struct record_adapter_base),
&record_adapter_ops.cobj_ops);
struct record_adapter_base *rb = coerce(struct record_adapter_base *,
@@ -2846,7 +2972,7 @@ val stream_set_prop(val stream, val ind, val prop)
{
val self = lit("stream-set-prop");
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
+ cobj_ops(self, stream, stream_cls));
return ops->set_prop(stream, ind, prop);
}
@@ -2854,7 +2980,11 @@ val stream_get_prop(val stream, val ind)
{
val self = lit("stream-get-prop");
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
+ cobj_ops(self, stream, stream_cls));
+
+ if (ind == fd_k && ops->get_fd != null_get_fd)
+ return ops->get_fd(stream);
+
return ops->get_prop(stream, ind);
}
@@ -2871,16 +3001,28 @@ val real_time_stream_p(val obj)
val close_stream(val stream, val throw_on_error)
{
val self = lit("close-stream");
- struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
- return ops->close(stream, throw_on_error);
+ struct strm_base *s = coerce(struct strm_base *,
+ cobj_handle(self, stream, stream_cls));
+ struct strm_ops *ops = coerce(struct strm_ops *, stream->co.ops);
+ val res = s->close_result;
+
+ if (!res) {
+ res = ops->close(stream, throw_on_error);
+
+ if (res == colon_k)
+ res = t;
+ else if (res)
+ s->close_result = res;
+ }
+
+ return res;
}
val get_error(val stream)
{
val self = lit("get-error");
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
+ cobj_ops(self, stream, stream_cls));
return ops->get_error(stream);
}
@@ -2888,7 +3030,7 @@ val get_error_str(val stream)
{
val self = lit("get-error-str");
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
+ cobj_ops(self, stream, stream_cls));
return ops->get_error_str(stream);
}
@@ -2896,43 +3038,51 @@ val clear_error(val stream)
{
val self = lit("clear-error");
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
+ cobj_ops(self, stream, stream_cls));
return ops->clear_error(stream);
}
val get_line(val stream_in)
{
val self = lit("get-line");
- val stream = default_arg(stream_in, std_input);
+ val stream = default_arg_strict(stream_in, std_input);
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
+ cobj_ops(self, stream, stream_cls));
return ops->get_line(stream);
}
val get_char(val stream_in)
{
val self = lit("get-char");
- val stream = default_arg(stream_in, std_input);
+ val stream = default_arg_strict(stream_in, std_input);
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
+ cobj_ops(self, stream, stream_cls));
return ops->get_char(stream);
}
val get_byte(val stream_in)
{
val self = lit("get-byte");
- val stream = default_arg(stream_in, std_input);
+ val stream = default_arg_strict(stream_in, std_input);
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
+ cobj_ops(self, stream, stream_cls));
return ops->get_byte(stream);
}
+val get_bytes(val self, val stream_in, mem_t *ptr, ucnum len)
+{
+ val stream = default_arg_strict(stream_in, std_input);
+ struct strm_ops *ops = coerce(struct strm_ops *,
+ cobj_ops(self, stream, stream_cls));
+ return unum(ops->fill_buf(stream, ptr, len, 0));
+}
+
val unget_char(val ch, val stream_in)
{
val self = lit("unget-char");
- val stream = default_arg(stream_in, std_input);
+ val stream = default_arg_strict(stream_in, std_input);
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
+ cobj_ops(self, stream, stream_cls));
if (!is_chr(ch))
type_mismatch(lit("~a: ~s is not a character"), self, ch, nao);
return ops->unget_char(stream, ch);
@@ -2941,10 +3091,10 @@ val unget_char(val ch, val stream_in)
val unget_byte(val byte, val stream_in)
{
val self = lit("unget-byte");
- cnum b = c_num(byte);
- val stream = default_arg(stream_in, std_input);
+ cnum b = c_num(byte, self);
+ val stream = default_arg_strict(stream_in, std_input);
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
+ cobj_ops(self, stream, stream_cls));
if (b < 0 || b > 255)
uw_throwf(file_error_s, lit("~a: stream ~s: byte value ~a out of range"),
@@ -2956,39 +3106,76 @@ val unget_byte(val byte, val stream_in)
val put_buf(val buf, val pos_in, val stream_in)
{
val self = lit("put-buf");
- val stream = default_arg(stream_in, std_output);
- cnum pos = c_num(default_arg(pos_in, zero));
+ val stream = default_arg_strict(stream_in, std_output);
+ ucnum pos = c_unum(default_arg_strict(pos_in, zero), self);
+ ucnum len = c_unum(length_buf(buf), self);
+ mem_t *ptr = buf_get(buf, self);
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
- return ops->put_buf(stream, buf, pos);
+ cobj_ops(self, stream, stream_cls));
+
+ return unum(ops->put_buf(stream, ptr, len, pos));
}
val fill_buf(val buf, val pos_in, val stream_in)
{
val self = lit("fill-buf");
- val stream = default_arg(stream_in, std_input);
- cnum pos = c_num(default_arg(pos_in, zero));
+ val stream = default_arg_strict(stream_in, std_input);
+ ucnum pos = c_unum(default_arg_strict(pos_in, zero), self);
+ ucnum len = c_unum(length_buf(buf), self);
+ mem_t *ptr = buf_get(buf, self);
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
- return ops->fill_buf(stream, buf, pos);
+ cobj_ops(self, stream, stream_cls));
+ return unum(ops->fill_buf(stream, ptr, len, pos));
}
val fill_buf_adjust(val buf, val pos_in, val stream_in)
{
val self = lit("fill-buf-adjust");
- val stream = default_arg(stream_in, std_input);
- cnum pos = c_num(default_arg(pos_in, zero));
+ val stream = default_arg_strict(stream_in, std_input);
+ ucnum pos = c_unum(default_arg_strict(pos_in, zero), self);
+ val alloc_size = buf_alloc_size(buf);
+ ucnum len = c_unum(alloc_size, self);
+ mem_t *ptr = buf_get(buf, self);
val readpos;
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
- buf_set_length(buf, buf_alloc_size(buf), zero);
- readpos = ops->fill_buf(stream, buf, pos);
+ cobj_ops(self, stream, stream_cls));
+ buf_set_length(buf, alloc_size, zero);
+ readpos = unum(ops->fill_buf(stream, ptr, len, pos));
buf_set_length(buf, readpos, zero);
return readpos;
}
+val get_line_as_buf(val stream_in)
+{
+ val self = lit("get-line-as-buf");
+ val stream = default_arg_strict(stream_in, std_input);
+ struct strm_ops *ops = coerce(struct strm_ops *,
+ cobj_ops(self, stream, stream_cls));
+ val buf = make_buf(zero, nil, num_fast(128));
+ unsigned char bytes[128];
+ size_t count = 0;
+
+ for (;;) {
+ val b = ops->get_byte(stream);
+ if (b == nil || b == num('\n'))
+ break;
+ bytes[count++] = c_num(b, self);
+
+ if (count == sizeof bytes) {
+ buf_put_bytes(buf, length_buf(buf), bytes, count, self);
+ count = 0;
+ }
+ }
+
+ if (count > 0)
+ buf_put_bytes(buf, length_buf(buf), bytes, count, self);
+
+ buf_trim(buf);
+ return buf;
+}
+
struct fmt {
- size_t minsize;
+ const char *type;
const char *dec;
const char *oct;
const char *hex;
@@ -2996,13 +3183,14 @@ struct fmt {
};
static struct fmt fmt_tab[] = {
- { sizeof(short),"%hd", "%ho", "%hx", "%hX" },
- { sizeof(int), "%d", "%o", "%x", "%X" },
- { sizeof(long), "%ld", "%lo", "%lx", "%llX" },
- { sizeof(cnum), "%lld", "%llo", "%llx", "%llX" },
- { sizeof(cnum), "%Ld", "%Lo", "%Lx", "%llX" },
- { sizeof(cnum), "%qd", "%qo", "%qx", "%qX", },
- { sizeof(cnum), "%I64d", "%I64o", "%I64x", "%I64X" },
+ { "short", "%hd", "%ho", "%hx", "%hX" },
+ { "int", "%d", "%o", "%x", "%X" },
+ { "long", "%ld", "%lo", "%lx", "%lX" },
+ { "long long", "%lld", "%llo", "%llx", "%llX" },
+ { "long long", "%Ld", "%Lo", "%Lx", "%LX" },
+ { "long long", "%qd", "%qo", "%qx", "%qX", },
+ { "int64", "%I64d", "%I64o", "%I64x", "%I64X" },
+ { "__int64", "%I64d", "%I64o", "%I64x", "%I64X" },
{ 0, 0, 0, 0, 0 }
};
@@ -3013,16 +3201,29 @@ static void detect_format_string(void)
struct fmt *f;
char buf[64];
cnum num = 1234;
+ const char *cnum_type = if3(strcmp(INTPTR_TYPE, "longlong_t") == 0,
+ LONGLONG_TYPE, INTPTR_TYPE);
- for (f = fmt_tab; f->minsize != 0; f++) {
+ for (f = fmt_tab; f->type != 0; f++) {
+ if (strcmp(cnum_type, f->type) != 0)
+ continue;
memset(buf, 0, sizeof buf);
- if (f->minsize != sizeof num)
+ if (sprintf(buf, f->dec, num) != 4 || strcmp(buf, "1234") != 0)
continue;
- if (sprintf(buf, f->dec, num) == 4 && strcmp(buf, "1234") == 0) {
- num_fmt = f;
- break;
- }
+ memset(buf, 0, sizeof buf);
+ if (sprintf(buf, f->oct, num) != 4 || strcmp(buf, "2322") != 0)
+ continue;
+ memset(buf, 0, sizeof buf);
+ if (sprintf(buf, f->hex, num) != 3 || strcmp(buf, "4d2") != 0)
+ continue;
+ memset(buf, 0, sizeof buf);
+ if (sprintf(buf, f->HEX, num) != 3 || strcmp(buf, "4D2") != 0)
+ continue;
+ num_fmt = f;
+ break;
}
+
+ bug_unless (num_fmt != 0);
}
enum align { al_left, al_center, al_right };
@@ -3065,12 +3266,18 @@ static void vformat_align_post(val stream, enum align align, int slack)
static void vformat_num(val stream, const char *str,
int width, enum align align, int zeropad,
- int precision, int sign)
+ int precision, int add_sign)
{
int sign_char = (str[0] == '-' || str[0] == '+') ? str[0] : 0;
+ int have_sign = sign_char == '-';
+ int mandatory_sign = have_sign || add_sign == '+';
int digit_len = strlen(str) - (sign_char != 0);
- int padlen = precision > digit_len ? precision - digit_len : 0;
- int total_len = digit_len + padlen + (sign_char || sign);
+ int overflow = digit_len > precision;
+ int padlen = overflow ? 0 : precision - digit_len;
+ int tentative_len = digit_len + padlen + (have_sign || add_sign);
+ int total_len = (tentative_len > width &&
+ (have_sign || add_sign)
+ && !mandatory_sign) ? tentative_len - 1 : tentative_len;
int slack = (total_len < width) ? width - total_len : 0;
int i;
@@ -3080,11 +3287,13 @@ static void vformat_num(val stream, const char *str,
for (i = 0; i < padlen; i++)
put_char(chr(' '), stream);
- if (sign_char) {
- put_char(chr(sign_char), stream);
+ if (sign_char)
str++;
- } else if (sign) {
- put_char(chr(sign), stream);
+
+ if (mandatory_sign) {
+ put_char(chr(have_sign ? sign_char : add_sign), stream);
+ } else if (add_sign && tentative_len <= width) {
+ put_char(chr(add_sign), stream);
}
if (zeropad)
@@ -3123,7 +3332,8 @@ static cnum calc_fitlen(const wchar_t *cstr, int precision, int width)
static void vformat_str(val stream, val str, int width, enum align align,
int precision)
{
- const wchar_t *cstr = c_str(str);
+ val self = lit("format");
+ const wchar_t *cstr = c_str(str, self);
cnum fitlen = calc_fitlen(cstr, precision, width);
cnum slack = (fitlen < width) ? width - fitlen : 0;
cnum i, w;
@@ -3146,7 +3356,7 @@ static void vformat_str(val stream, val str, int width, enum align align,
gc_hint(str);
}
-val formatv(val stream_in, val fmtstr, struct args *al)
+val formatv(val stream_in, val fmtstr, varg al)
{
uses_or2;
val stream = if3(stream_in == t,
@@ -3154,21 +3364,23 @@ val formatv(val stream_in, val fmtstr, struct args *al)
or2(stream_in, make_string_output_stream()));
val save_indent = get_indent(stream);
val save_mode = nil;
- val name = lit("format");
+ val self = lit("format");
uw_simple_catch_begin;
{
- const wchar_t *fmt = c_str(fmtstr);
+ const wchar_t *fmt = c_str(fmtstr, self);
enum {
vf_init, vf_width, vf_digits, vf_star, vf_precision, vf_spec
} state = vf_init, saved_state = vf_init;
- int width = 0, precision = 0, precision_p = 0, digits = 0, lt = 0, neg = 0;
- enum align align = al_right;
- int sign = 0, zeropad = 0, dfl_precision = 0;
- int dfl_digits = 0, print_base = 0;
cnum value;
cnum arg_ix = 0;
+ /* conversion variables that are reset before for each conversion */
+ int width = 0, precision = 0, precision_p = 0, digits = 0, lt = 0, neg = 0;
+ int sign = 0, zeropad = 0;
+ enum align align = al_right;
+ /* conversion variables that persist across conversions */
+ int dfl_precision = 0, dfl_digits = 0, print_base = 0;
for (;;) {
val obj;
@@ -3183,14 +3395,9 @@ val formatv(val stream_in, val fmtstr, struct args *al)
break;
case '~':
state = vf_width;
- width = 0;
+ width = precision = precision_p = 0;
+ digits = lt = neg = sign = zeropad = 0;
align = al_right;
- zeropad = 0;
- precision = 0;
- precision_p = 0;
- digits = 0;
- lt = 0;
- neg = 0;
continue;
default:
put_char(chr(ch), stream);
@@ -3235,8 +3442,11 @@ val formatv(val stream_in, val fmtstr, struct args *al)
case vf_precision:
switch (ch) {
case '0':
- zeropad = 1;
- continue;
+ if (!zeropad) {
+ zeropad = 1;
+ continue;
+ }
+ /* fallthrough */
case '1': case '2': case '3': case '4': case '5':
case '6': case '7': case '8': case '9':
saved_state = state;
@@ -3246,6 +3456,9 @@ val formatv(val stream_in, val fmtstr, struct args *al)
case '+': case ' ':
sign = ch;
continue;
+ case '-':
+ sign = '0';
+ continue;
case '*':
saved_state = state;
state = vf_star;
@@ -3263,7 +3476,7 @@ val formatv(val stream_in, val fmtstr, struct args *al)
digits = (digits * 10) + (ch - '0');
if (digits > 999999)
uw_throwf(assert_s, lit("~a: ridiculous precision or field"),
- name, nao);
+ self, nao);
continue;
default:
do_digits:
@@ -3296,35 +3509,61 @@ val formatv(val stream_in, val fmtstr, struct args *al)
}
break;
case vf_star:
- obj = args_get_checked(name, al, &arg_ix);
- digits = c_num(obj);
+ obj = args_get_checked(self, al, &arg_ix);
+ digits = c_num(obj, self);
goto do_digits;
break;
case vf_spec:
state = vf_init;
+ if (zeropad && !precision_p) {
+ zeropad = precision = 0;
+ precision_p = 1;
+ }
switch (ch) {
case 'x': case 'X':
- obj = args_get_checked(name, al, &arg_ix);
+ obj = args_get_checked(self, al, &arg_ix);
typ = type(obj);
hex:
- if (typ == BGNUM) {
- int nchars = mp_radix_size(mp(obj), 16);
- if (nchars >= convert(int, sizeof (num_buf)))
- pnum = coerce(char *, chk_malloc(nchars + 1));
- mp_toradix_case(mp(obj), coerce(unsigned char *, pnum), 16, ch == 'x');
- } else {
- const char *fmt = ch == 'x' ? num_fmt->hex : num_fmt->HEX;
- value = c_num(obj);
- if (value < 0) {
- num_buf[0] = '-';
- sprintf(num_buf + 1, fmt, -value);
- } else {
- sprintf(num_buf, fmt, value);
+ switch (typ) {
+ case BGNUM:
+ {
+ int nchars = mp_radix_size(mp(obj), 16);
+ if (nchars >= convert(int, sizeof (num_buf)))
+ pnum = coerce(char *, chk_malloc(nchars + 1));
+ mp_toradix_case(mp(obj), coerce(unsigned char *, pnum), 16, ch == 'x');
+ }
+ break;
+ case BUF:
+ {
+ ucnum len = c_unum(length_buf(obj), self);
+ ucnum nchars = 2 * len + 1;
+
+ if (len >= INT_PTR_MAX)
+ uw_throwf(error_s, lit("~a: ~~~a conversion given "
+ "too large a buf argument"),
+ self, chr(ch), nao);
+
+ pnum = coerce(char *, chk_malloc(nchars));
+ buf_hex(obj, pnum, nchars, ch == 'X');
+ }
+ break;
+ case NUM:
+ case CHR:
+ default:
+ {
+ const char *fmt = ch == 'x' ? num_fmt->hex : num_fmt->HEX;
+ value = c_num(obj, self);
+ if (value < 0) {
+ num_buf[0] = '-';
+ sprintf(num_buf + 1, fmt, -value);
+ } else {
+ sprintf(num_buf, fmt, value);
+ }
}
}
goto output_num;
case 'o': case 'b':
- obj = args_get_checked(name, al, &arg_ix);
+ obj = args_get_checked(self, al, &arg_ix);
typ = type(obj);
oct:
if (typ == BGNUM) {
@@ -3334,10 +3573,10 @@ val formatv(val stream_in, val fmtstr, struct args *al)
pnum = coerce(char *, chk_malloc(nchars + 1));
mp_toradix(mp(obj), coerce(unsigned char *, pnum), rad);
} else if (ch == 'o') {
- cnum value = c_num(obj);
+ cnum value = c_num(obj, self);
sprintf(num_buf, num_fmt->oct, value);
} else {
- cnum val = c_num(obj);
+ cnum val = c_num(obj, self);
int s = (val < 0);
int i = sizeof num_buf;
@@ -3359,7 +3598,7 @@ val formatv(val stream_in, val fmtstr, struct args *al)
}
goto output_num;
case 'f': case 'e':
- obj = args_get_checked(name, al, &arg_ix);
+ obj = args_get_checked(self, al, &arg_ix);
{
double n;
@@ -3372,29 +3611,33 @@ val formatv(val stream_in, val fmtstr, struct args *al)
n = c_flo(obj, lit("format"));
break;
case NUM:
- n = convert(double, c_num(obj));
+ n = convert(double, c_num(obj, self));
break;
default:
- uw_throwf(error_s, lit("format: ~~~a conversion requires "
+ uw_throwf(error_s, lit("~a: ~~~a conversion requires "
"numeric arg: ~s given"),
- chr(ch), obj, nao);
+ self, chr(ch), obj, nao);
}
if (!precision_p) {
if (!dfl_digits)
- dfl_digits = c_num(cdr(lookup_var(nil, print_flo_digits_s)));
+ dfl_digits = c_num(cdr(lookup_var(nil, print_flo_digits_s)), self);
precision = dfl_digits;
}
/* guard against num_buf overflow */
if (precision > 128)
- uw_throwf(error_s, lit("excessive precision in format: ~s"),
- num(precision), nao);
+ uw_throwf(error_s, lit("~a: excessive precision: ~s"),
+ self, num(precision), nao);
if (ch == 'e') {
sprintf(num_buf, "%.*e", precision, n);
{
+#if CONFIG_LOCALE_TOLERANCE
+ char *dec = strchr(num_buf, dec_point);
+#else
char *dec = strchr(num_buf, '.');
+#endif
char *exp = strchr(dec ? dec : num_buf, 'e');
if (exp) {
@@ -3425,19 +3668,26 @@ val formatv(val stream_in, val fmtstr, struct args *al)
continue;
}
precision = (width ? width - 1 : 0);
+#if CONFIG_LOCALE_TOLERANCE
+ if (dec_point != '.') {
+ char *dot = num_buf;
+ while ((dot = strchr(dot, dec_point)) != 0)
+ *dot++ = '.';
+ }
+#endif
goto output_num;
}
case 'd':
- obj = args_get_checked(name, al, &arg_ix);
+ obj = args_get_checked(self, al, &arg_ix);
typ = type(obj);
goto dec;
case 'a': case 's':
- obj = args_get_checked(name, al, &arg_ix);
+ obj = args_get_checked(self, al, &arg_ix);
typ = type(obj);
if (typ == NUM || typ == BGNUM) {
if (!print_base)
- print_base = c_num(cdr(lookup_var(nil, print_base_s)));
+ print_base = c_num(cdr(lookup_var(nil, print_base_s)), self);
switch (print_base) {
case 0:
case 2:
@@ -3458,8 +3708,10 @@ val formatv(val stream_in, val fmtstr, struct args *al)
dec:
switch (typ) {
case NUM:
- value = c_num(obj);
+ value = c_num(obj, self);
sprintf(num_buf, num_fmt->dec, value);
+ if (width)
+ precision = min(precision, width - 1);
goto output_num;
case BGNUM:
{
@@ -3468,20 +3720,31 @@ val formatv(val stream_in, val fmtstr, struct args *al)
pnum = coerce(char *, chk_malloc(nchars + 1));
mp_toradix(mp(obj), coerce(unsigned char *, pnum), 10);
}
+ if (width)
+ precision = min(precision, width - 1);
goto output_num;
case FLNUM:
if (!precision_p) {
if (!dfl_precision)
dfl_precision = c_num(cdr(lookup_var(nil,
- print_flo_precision_s)));
+ print_flo_precision_s)),
+ self);
precision = dfl_precision;
}
if (precision > 500)
- uw_throwf(error_s, lit("excessive precision in format: ~s"),
- num(precision), nao);
+ uw_throwf(error_s, lit("~a: excessive precision: ~s"),
+ self, num(precision), nao);
- sprintf(num_buf, "%.*g", precision, obj->fl.n);
+ sprintf(num_buf, "%.*g", precision, c_f(obj));
+
+#if CONFIG_LOCALE_TOLERANCE
+ if (dec_point != '.') {
+ char *dot = num_buf;
+ while ((dot = strchr(dot, dec_point)) != 0)
+ *dot++ = '.';
+ }
+#endif
{
char *dec = strchr(num_buf, '.');
@@ -3505,7 +3768,7 @@ val formatv(val stream_in, val fmtstr, struct args *al)
}
if (ch == 's' && (!precision_p || precision > 0) && !dec && !exp)
- strcat(num_buf, ".0");
+ strcat(num_buf, ".0");
}
if (!isdigit(num_buf[0]) && !isdigit(num_buf[1])) {
@@ -3513,7 +3776,8 @@ val formatv(val stream_in, val fmtstr, struct args *al)
continue;
}
- precision = (width ? width - 1 : 0);
+ precision = max(0, min(precision, width - 1));
+
goto output_num;
default:
if (width != 0 || precision_p) {
@@ -3527,7 +3791,7 @@ val formatv(val stream_in, val fmtstr, struct args *al)
continue;
case 'p':
{
- val ptr = args_get_checked(name, al, &arg_ix);
+ val ptr = args_get_checked(self, al, &arg_ix);
value = coerce(cnum, ptr);
sprintf(num_buf, num_fmt->hex, value);
}
@@ -3561,7 +3825,7 @@ val formatv(val stream_in, val fmtstr, struct args *al)
}
if (args_more(al, arg_ix))
- uw_throwf(assert_s, lit("~a: excess arguments"), name, nao);
+ uw_throwf(assert_s, lit("~a: excess arguments"), self, nao);
}
@@ -3581,7 +3845,7 @@ val formatv(val stream_in, val fmtstr, struct args *al)
val vformat(val stream, val fmtstr, va_list vl)
{
val arg;
- args_decl(args, ARGS_MAX);
+ args_decl_constsize(args, ARGS_MAX);
while ((arg = va_arg(vl, val)) != nao)
args_add_checked(lit("format"), args, arg);
@@ -3603,7 +3867,7 @@ val format(val stream, val str, ...)
val st = if3(stream == t,
std_output,
or2(stream, make_string_output_stream()));
- class_check(self, st, stream_s);
+ class_check(self, st, stream_cls);
{
va_list vl;
@@ -3615,7 +3879,7 @@ val format(val stream, val str, ...)
}
}
-val fmt(val string, struct args *args)
+val fmt(val string, varg args)
{
return formatv(nil, string, args);
}
@@ -3631,17 +3895,18 @@ static val put_indent(val stream, struct strm_ops *ops, cnum chars)
val put_string(val string, val stream_in)
{
val self = lit("put-string");
- val stream = default_arg(stream_in, std_output);
- struct strm_base *s = coerce(struct strm_base *, stream->co.handle);
+ val stream = default_arg_strict(stream_in, std_output);
+ struct strm_base *s = coerce(struct strm_base *,
+ cobj_handle(self, stream, stream_cls));
if (lazy_stringp(string)) {
return lazy_str_put(string, stream_in, s);
} else {
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
+ cobj_ops(self, stream, stream_cls));
cnum col = s->column;
- const wchar_t *str = c_str(string), *p = str;
+ const wchar_t *str = c_str(string, self), *p = str;
if (s->indent_mode != indent_off && s->indent_mode != indent_foff) {
while (*str)
@@ -3674,10 +3939,11 @@ val put_string(val string, val stream_in)
val put_char(val ch, val stream_in)
{
val self = lit("put-char");
- val stream = default_arg(stream_in, std_output);
+ val stream = default_arg_strict(stream_in, std_output);
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
- struct strm_base *s = coerce(struct strm_base *, stream->co.handle);
+ cobj_ops(self, stream, stream_cls));
+ struct strm_base *s = coerce(struct strm_base *,
+ cobj_handle(self, stream, stream_cls));
wint_t cch = c_chr(ch);
switch (cch) {
@@ -3716,10 +3982,10 @@ val put_char(val ch, val stream_in)
val put_byte(val byte, val stream_in)
{
val self = lit("put-byte");
- val stream = default_arg(stream_in, std_output);
+ val stream = default_arg_strict(stream_in, std_output);
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
- cnum b = c_num(byte);
+ cobj_ops(self, stream, stream_cls));
+ cnum b = c_num(byte, self);
if (b < 0 || b > 255)
uw_throwf(file_error_s, lit("~a: stream ~s: byte value ~a out of range"),
@@ -3728,9 +3994,11 @@ val put_byte(val byte, val stream_in)
return ops->put_byte(stream, b);
}
-val put_line(val string, val stream)
+val put_line(val string, val stream_in)
{
- return (put_string(default_arg(string, null_string), stream), put_char(chr('\n'), stream));
+ val stream = default_arg_strict(stream_in, std_output);
+ return (put_string(default_arg_strict(string, null_string), stream),
+ put_char(chr('\n'), stream));
}
val put_strings(val strings, val stream)
@@ -3754,9 +4022,9 @@ val put_lines(val lines, val stream)
val flush_stream(val stream_in)
{
val self = lit("flush-stream");
- val stream = default_arg(stream_in, std_output);
+ val stream = default_arg_strict(stream_in, std_output);
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
+ cobj_ops(self, stream, stream_cls));
return ops->flush(stream);
}
@@ -3764,7 +4032,7 @@ val seek_stream(val stream, val offset, val whence)
{
val self = lit("seek-stream");
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
+ cobj_ops(self, stream, stream_cls));
enum strm_whence w;
if (whence == from_start_k)
@@ -3784,7 +4052,7 @@ val truncate_stream(val stream, val len)
{
val self = lit("truncate-stream");
struct strm_ops *ops = coerce(struct strm_ops *,
- cobj_ops(self, stream, stream_s));
+ cobj_ops(self, stream, stream_cls));
if (missingp(len))
len = ops->seek(stream, zero, strm_cur);
return ops->truncate(stream, len);
@@ -3794,7 +4062,7 @@ val get_indent_mode(val stream)
{
val self = lit("get-indent-mode");
struct strm_base *s = coerce(struct strm_base *,
- cobj_handle(self, stream, stream_s));
+ cobj_handle(self, stream, stream_cls));
return num_fast(s->indent_mode);
}
@@ -3802,10 +4070,10 @@ val test_set_indent_mode(val stream, val compare, val mode)
{
val self = lit("test-set-indent-mode");
struct strm_base *s = coerce(struct strm_base *,
- cobj_handle(self, stream, stream_s));
+ cobj_handle(self, stream, stream_cls));
val oldval = num_fast(s->indent_mode);
if (oldval == compare)
- s->indent_mode = convert(enum indent_mode, c_num(mode));
+ s->indent_mode = convert(enum indent_mode, c_num(mode, self));
return oldval;
}
@@ -3813,10 +4081,10 @@ val test_neq_set_indent_mode(val stream, val compare, val mode)
{
val self = lit("test-neq-set-indent-mode");
struct strm_base *s = coerce(struct strm_base *,
- cobj_handle(self, stream, stream_s));
+ cobj_handle(self, stream, stream_cls));
val oldval = num_fast(s->indent_mode);
if (oldval != compare)
- s->indent_mode = convert(enum indent_mode, c_num(mode));
+ s->indent_mode = convert(enum indent_mode, c_num(mode, self));
return oldval;
}
@@ -3824,9 +4092,9 @@ val set_indent_mode(val stream, val mode)
{
val self = lit("set-indent-mode");
struct strm_base *s = coerce(struct strm_base *,
- cobj_handle(self, stream, stream_s));
+ cobj_handle(self, stream, stream_cls));
val oldval = num_fast(s->indent_mode);
- s->indent_mode = convert(enum indent_mode, c_num(mode));
+ s->indent_mode = convert(enum indent_mode, c_num(mode, self));
return oldval;
}
@@ -3834,7 +4102,7 @@ val get_indent(val stream)
{
val self = lit("get-indent");
struct strm_base *s = coerce(struct strm_base *,
- cobj_handle(self, stream, stream_s));
+ cobj_handle(self, stream, stream_cls));
return num(s->indent_chars);
}
@@ -3842,9 +4110,9 @@ val set_indent(val stream, val indent)
{
val self = lit("set-indent");
struct strm_base *s = coerce(struct strm_base *,
- cobj_handle(self, stream, stream_s));
+ cobj_handle(self, stream, stream_cls));
val oldval = num(s->indent_chars);
- s->indent_chars = c_num(indent);
+ s->indent_chars = c_num(indent, self);
if (s->indent_chars < 0)
s->indent_chars = 0;
return oldval;
@@ -3854,10 +4122,22 @@ val inc_indent(val stream, val delta)
{
val self = lit("inc-indent");
struct strm_base *s = coerce(struct strm_base *,
- cobj_handle(self, stream, stream_s));
+ cobj_handle(self, stream, stream_cls));
val oldval = num(s->indent_chars);
val col = num(s->column);
- s->indent_chars = c_num(plus(delta, col));
+ s->indent_chars = c_num(plus(delta, col), self);
+ if (s->indent_chars < 0)
+ s->indent_chars = 0;
+ return oldval;
+}
+
+val inc_indent_abs(val stream, val delta)
+{
+ val self = lit("inc-indent-abs");
+ struct strm_base *s = coerce(struct strm_base *,
+ cobj_handle(self, stream, stream_cls));
+ val oldval = num(s->indent_chars);
+ s->indent_chars = c_num(plus(delta, oldval), self);
if (s->indent_chars < 0)
s->indent_chars = 0;
return oldval;
@@ -3867,7 +4147,7 @@ val width_check(val stream, val alt)
{
val self = lit("width-check");
struct strm_base *s = coerce(struct strm_base *,
- cobj_handle(self, stream, stream_s));
+ cobj_handle(self, stream, stream_cls));
if ((s->indent_mode == indent_code &&
s->column >= s->indent_chars + s->code_width) ||
@@ -3890,7 +4170,7 @@ val force_break(val stream)
{
val self = lit("force-break");
struct strm_base *s = coerce(struct strm_base *,
- cobj_handle(self, stream, stream_s));
+ cobj_handle(self, stream, stream_cls));
s->force_break = 1;
return stream;
}
@@ -3899,9 +4179,9 @@ val set_max_length(val stream, val length)
{
val self = lit("set-max-length");
struct strm_base *s = coerce(struct strm_base *,
- cobj_handle(self, stream, stream_s));
+ cobj_handle(self, stream, stream_cls));
cnum old_max = s->max_length;
- s->max_length = c_num(length);
+ s->max_length = c_num(length, self);
return num(old_max);
}
@@ -3909,9 +4189,9 @@ val set_max_depth(val stream, val depth)
{
val self = lit("set-max-depth");
struct strm_base *s = coerce(struct strm_base *,
- cobj_handle(self, stream, stream_s));
+ cobj_handle(self, stream, stream_cls));
cnum old_max = s->max_depth;
- s->max_depth = c_num(depth);
+ s->max_depth = c_num(depth, self);
return num(old_max);
}
@@ -3929,11 +4209,11 @@ struct strm_ctx *get_ctx(val stream)
return s->ctx;
}
-val get_string(val stream_in, val nchars, val close_after_p)
+val get_string(val stream_in, val nchars_in, val close_after_p)
{
- val stream = default_arg(stream_in, std_input);
+ val stream = default_arg_strict(stream_in, std_input);
val strstream = make_string_output_stream();
- nchars = default_null_arg(nchars);
+ val nchars = default_null_arg(nchars_in);
val ch;
if (nchars) {
@@ -3952,24 +4232,16 @@ val get_string(val stream_in, val nchars, val close_after_p)
return get_string_from_stream(strstream);
}
-static DIR *w_opendir(const wchar_t *wname)
-{
- char *name = utf8_dup_to(wname);
- DIR *d = opendir(name);
- free(name);
- return d;
-}
-
-
val open_directory(val path)
{
- DIR *d = w_opendir(c_str(path));
+ val self = lit("open-directory");
+ DIR *d = w_opendir(c_str(path, self));
if (!d) {
int eno = errno;
- uw_throwf(errno_to_file_error(eno),
- lit("error opening directory ~s: ~d/~s"),
- path, num(eno), string_utf8(strerror(eno)), nao);
+ uw_ethrowf(errno_to_file_error(eno),
+ lit("error opening directory ~s: ~d/~s"),
+ path, num(eno), errno_to_str(eno), nao);
}
return make_dir_stream(d);
@@ -3977,49 +4249,109 @@ val open_directory(val path)
val open_file(val path, val mode_str)
{
+ val self = lit("open-file");
struct stdio_mode m, m_r = stdio_mode_init_r;
- val norm_mode = normalize_mode(&m, mode_str, m_r);
- FILE *f = w_fopen_mode(c_str(path), c_str(norm_mode), m);
+ val norm_mode = normalize_mode(&m, mode_str, m_r, self);
- if (!f) {
- int eno = errno;
- uw_throwf(errno_to_file_error(eno), lit("error opening ~s: ~d/~s"),
- path, num(eno), string_utf8(strerror(eno)), nao);
+#if HAVE_ZLIB
+again:
+#endif
+ if (!m.gzip) {
+ FILE *f = w_fopen_mode(c_str(path, self), c_str(norm_mode, self), m);
+
+ if (!f)
+ goto error;
+
+ return set_mode_props(m, make_stdio_stream(f, path));
+ } else {
+#if HAVE_ZLIB
+ gzFile f = w_gzopen_mode(c_str(path, self), c_str(norm_mode, self),
+ m, self);
+
+ if (!f)
+ goto error;
+
+ if (m.read && gzdirect(f)) {
+ gzclose(f);
+ m.gzip = 0;
+ goto again;
+ }
+
+ return make_gzio_stream(f, -1, path, m.write);
+#else
+ uw_ethrowf(file_error_s, lit("~a: not built with zlib support"),
+ self, nao);
+#endif
}
- return set_mode_props(m, make_stdio_stream(f, path));
+error:
+ {
+ int eno = errno;
+ uw_ethrowf(errno_to_file_error(eno), lit("error opening ~s: ~d/~s"),
+ path, num(eno), errno_to_str(eno), nao);
+ }
}
-val open_fileno(val fd, val mode_str)
+val open_fileno(val fd, val mode_str, val pid_opt)
{
+ val self = lit("open-fileno");
struct stdio_mode m, m_r = stdio_mode_init_r;
- FILE *f = (errno = 0, w_fdopen(c_num(fd), c_str(normalize_mode(&m, mode_str, m_r))));
+ val norm_mode = normalize_mode(&m, mode_str, m_r, self);
+ val pid = default_arg(pid_opt, nil);
- if (!f) {
- int eno = errno;
- close(c_num(fd));
- uw_throwf(errno_to_file_error(eno), lit("error opening descriptor ~a: ~d/~s"),
- fd, num(eno), string_utf8(strerror(eno)), nao);
- }
+ if (!m.gzip) {
+ FILE *f = (errno = 0, w_fdopen(c_num(fd, self),
+ c_str(norm_mode, self)));
+
+ if (!f)
+ {
+ int eno = errno;
+ close(c_num(fd, self));
+ uw_ethrowf(errno_to_file_error(eno),
+ lit("error opening descriptor ~a: ~d/~s"),
+ fd, num(eno), errno_to_str(eno), nao);
+ }
- return set_mode_props(m, make_stdio_stream(f, format(nil,
- lit("fd ~d"),
- fd, nao)));
+ {
+ val descr = format(nil, lit("fd ~d"), fd, nao);
+
+#if HAVE_FORK_STUFF
+ return set_mode_props(m, if3(pid,
+ make_pipevp_stream(f, descr,
+ c_num(pid, self)),
+ make_stdio_stream(f, descr)));
+#else
+ return set_mode_props(m, make_stdio_stream(f, descr));
+#endif
+ }
+
+ } else {
+#if HAVE_ZLIB
+ cnum fdn = c_num(fd, self);
+ gzFile f = w_gzdopen_mode(fdn, c_str(norm_mode, self), m, self);
+ return make_gzio_stream(f, fdn, format(nil, lit("fd ~d"), fd, nao),
+ m.write);
+#else
+ uw_ethrowf(file_error_s, lit("~a: not built with zlib support"),
+ self, nao);
+#endif
+ }
}
val open_tail(val path, val mode_str, val seek_end_p)
{
+ val self = lit("open-tail");
struct stdio_mode m, m_r = stdio_mode_init_r;
- val mode = normalize_mode(&m, mode_str, m_r);
- FILE *f = w_fopen_mode(c_str(path), c_str(mode), m);
+ val mode = normalize_mode(&m, mode_str, m_r, self);
+ FILE *f = w_fopen_mode(c_str(path, self), c_str(mode, self), m);
struct stdio_handle *h;
val stream;
unsigned long state = 0;
if (f && default_null_arg(seek_end_p))
if (fseek(f, 0, SEEK_END) < 0)
- uw_throwf(file_error_s, lit("error seeking to end of ~s: ~d/~s"),
- path, num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(file_error_s, lit("error seeking to end of ~s: ~d/~s"),
+ path, num(errno), errno_to_str(errno), nao);
stream = make_tail_stream(f, path);
h = coerce(struct stdio_handle *, stream->co.handle);
@@ -4033,6 +4365,9 @@ struct save_fds {
volatile int in;
volatile int out;
volatile int err;
+ volatile int subin;
+ volatile int subout;
+ volatile int suberr;
};
#define FDS_IN 1
@@ -4041,39 +4376,72 @@ struct save_fds {
static void fds_init(struct save_fds *fds)
{
- fds->in = fds->out = fds->err = -1;
+ fds->in = fds->out = fds->err = fds->subin = fds->subin = fds->subin = -1;
}
-static int fds_subst(val stream, int fd_std)
+static int fds_getfd(val stream, val self)
{
- int fd_orig = c_num(stream_fd(stream));
+ val sfd = stream_fd(stream);
+ int fd_sub = if3(integerp(sfd), c_num(sfd, self), INT_MIN);
+
- if (fd_orig == fd_std)
+ if (fd_sub == INT_MIN)
+ uw_throwf(file_error_s, lit("~a: (fileno ~s) is ~s, which is unusable"),
+ self, stream, sfd, nao);
+
+ return fd_sub;
+}
+
+#if HAVE_WSPAWN || HAVE_SPAWN
+static int fds_subst(int fd_sub, int fd_std, val self)
+{
+ if (fd_sub == fd_std)
return -1;
{
int fd_dup = dup(fd_std);
if (fd_dup != -1) {
- dup2(fd_orig, fd_std);
+ dup2(fd_sub, fd_std);
return fd_dup;
}
- uw_throwf(file_error_s, lit("failed to duplicate file descriptor: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(file_error_s, lit("~a: failed to duplicate file descriptor: ~d/~s"),
+ self, num(errno), errno_to_str(errno), nao);
}
}
+#endif
+
+static void fds_subst_nosave(int fd_sub, int fd_std)
+{
+ if (fd_sub == fd_std)
+ return;
+ dup2(fd_sub, fd_std);
+}
-static void fds_swizzle(struct save_fds *fds, int flags)
+static void fds_prepare(struct save_fds *fds, int flags, val self)
{
if ((flags & FDS_IN) != 0)
- fds->in = fds_subst(std_input, STDIN_FILENO);
+ fds->subin = fds_getfd(std_input, self);
if ((flags & FDS_OUT) != 0)
- fds->out = fds_subst(std_output, STDOUT_FILENO);
+ fds->subout = fds_getfd(std_output, self);
if ((flags & FDS_ERR) != 0)
- fds->err = fds_subst(std_error, STDERR_FILENO);
+ fds->suberr = fds_getfd(std_error, self);
+}
+
+#if HAVE_WSPAWN || HAVE_SPAWN
+static void fds_swizzle(struct save_fds *fds, int flags, val self)
+{
+ if ((flags & FDS_IN) != 0)
+ fds->in = fds_subst(fds->subin, STDIN_FILENO, self);
+
+ if ((flags & FDS_OUT) != 0)
+ fds->out = fds_subst(fds->subout, STDOUT_FILENO, self);
+
+ if ((flags & FDS_ERR) != 0)
+ fds->err = fds_subst(fds->suberr, STDERR_FILENO, self);
}
static void fds_restore(struct save_fds *fds)
@@ -4093,37 +4461,43 @@ static void fds_restore(struct save_fds *fds)
close(fds->err);
}
}
+#endif
-
-val open_command(val path, val mode_str)
+static void fds_clobber(struct save_fds *fds, int flags)
{
- struct stdio_mode m, m_r = stdio_mode_init_r;
- val mode = normalize_mode_no_bin(&m, mode_str, m_r);
- int input = m.read != 0;
- struct save_fds sfds;
- FILE *f = 0;
-
- fds_init(&sfds);
-
- uw_simple_catch_begin;
+ if ((flags & FDS_IN) != 0)
+ fds_subst_nosave(fds->subin, STDIN_FILENO);
- fds_swizzle(&sfds, (input ? FDS_IN : FDS_OUT) | FDS_ERR);
+ if ((flags & FDS_OUT) != 0)
+ fds_subst_nosave(fds->subout, STDOUT_FILENO);
- f = w_popen(c_str(path), c_str(mode));
+ if ((flags & FDS_ERR) != 0)
+ fds_subst_nosave(fds->suberr, STDERR_FILENO);
+}
- if (!f) {
- int eno = errno;
- uw_throwf(errno_to_file_error(eno), lit("error opening pipe ~s: ~d/~s"),
- path, num(eno), string_utf8(strerror(eno)), nao);
- }
+val path_search(val name, val path_in)
+{
+ val self = lit("path-search");
+ val ps = static_str(path_sep_chars);
- uw_unwind {
- fds_restore(&sfds);
+ if (empty(name) || equal(name, lit(".")) || equal(name, lit(".."))) {
+ return nil;
+ } else if (break_str(name, ps)) {
+ return name;
+ } else {
+ val path = default_arg_strict(path_in, getenv_wrap(lit("PATH")));
+ val spath = if3(listp(path), path, split_str(path, chr(path_var_sep_char)));
+ for (; spath; spath = cdr(spath)) {
+ val dir = car(spath);
+ val full = path_cat(dir, name);
+ char *full8 = utf8_dup_to(c_str(full, self));
+ int res = access(full8, F_OK);
+ free(full8);
+ if (res == 0)
+ return full;
+ }
+ return nil;
}
-
- uw_catch_end;
-
- return set_mode_props(m, make_pipe_stream(f, path));
}
#if HAVE_FORK_STUFF
@@ -4131,8 +4505,7 @@ static val open_subprocess(val name, val mode_str, val args, val fun)
{
val self = lit("open-subprocess");
struct stdio_mode m, m_r = stdio_mode_init_r;
- val mode = normalize_mode(&m, mode_str, m_r);
- int input = m.read != 0;
+ int input = (normalize_mode(&m, mode_str, m_r, self), m.read != 0);
int fd[2];
pid_t pid;
char **argv = 0;
@@ -4140,19 +4513,21 @@ static val open_subprocess(val name, val mode_str, val args, val fun)
int i, nargs;
struct save_fds sfds;
val ret = nil;
+ int fds_flags = (input ? FDS_IN : FDS_OUT) | FDS_ERR;
args = default_null_arg(args);
fun = default_null_arg(fun);
- nargs = c_num(length(args)) + 1;
+ nargs = c_num(length(args), self) + 1;
if (!name && !fun)
uw_throwf(error_s, lit("~a: program name and/or function required"), self, nao);
- fds_init(&sfds);
+ if (!input)
+ flush_stream(std_output);
- uw_simple_catch_begin;
+ fds_init(&sfds);
- fds_swizzle(&sfds, (input ? FDS_IN : FDS_OUT) | FDS_ERR);
+ fds_prepare(&sfds, fds_flags, self);
if (nargs < 0 || nargs == INT_MAX)
uw_throwf(error_s, lit("~a: argument list overflow"), self, nao);
@@ -4163,15 +4538,15 @@ static val open_subprocess(val name, val mode_str, val args, val fun)
if (pipe(fd) == -1) {
int eno = errno;
free(argv);
- uw_throwf(errno_to_file_error(eno),
- lit("opening pipe ~s, pipe syscall failed: ~d/~s"),
- name, num(eno), string_utf8(strerror(eno)), nao);
+ uw_ethrowf(errno_to_file_error(eno),
+ lit("opening pipe ~s, pipe syscall failed: ~d/~s"),
+ name, num(eno), errno_to_str(eno), nao);
}
if (argv) {
for (i = 0, iter = cons(name, args); iter; i++, iter = cdr(iter)) {
val arg = car(iter);
- argv[i] = utf8_dup_to(c_str(arg));
+ argv[i] = utf8_dup_to(c_str(arg, self));
}
argv[i] = 0;
}
@@ -4184,11 +4559,13 @@ static val open_subprocess(val name, val mode_str, val args, val fun)
free(argv[i]);
free(argv);
}
- uw_throwf(process_error_s, lit("opening pipe ~s, fork syscall failed: ~d/~s"),
- name, num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(process_error_s, lit("opening pipe ~s, fork syscall failed: ~d/~s"),
+ name, num(errno), errno_to_str(errno), nao);
}
if (pid == 0) {
+ fds_clobber(&sfds, fds_flags);
+
if (input) {
dup2(fd[1], STDOUT_FILENO);
if (fd[1] != STDOUT_FILENO) /* You never know */
@@ -4232,13 +4609,15 @@ static val open_subprocess(val name, val mode_str, val args, val fun)
if (fun)
funcall(fun);
- if (argv)
+ if (argv) {
+ val ch_env = child_env;
+ if (ch_env != t)
+ replace_env(ch_env);
execvp(argv[0], argv);
+ }
_exit(errno);
} else {
int whichfd;
- char *utf8mode = utf8_dup_to(c_str(mode));
- FILE *f;
if (input) {
close(fd[1]);
@@ -4258,28 +4637,26 @@ static val open_subprocess(val name, val mode_str, val args, val fun)
fcntl(whichfd, F_SETFD, FD_CLOEXEC);
#endif
- if ((f = fdopen(whichfd, utf8mode)) == 0) {
+ uw_simple_catch_begin;
+
+ ret = open_fileno(num(whichfd), mode_str, num(pid));
+
+ uw_unwind {
int status;
- kill(pid, SIGINT);
- kill(pid, SIGTERM);
- while (waitpid(pid, &status, 0) == -1 && errno == EINTR)
- ;
- free(utf8mode);
- uw_throwf(file_error_s, lit("opening pipe ~s, fdopen failed: ~d/~s"),
- name, num(errno), string_utf8(strerror(errno)), nao);
+ if (ret == nil) {
+ int eno = errno;
+ kill(pid, SIGINT);
+ kill(pid, SIGTERM);
+ while (waitpid(pid, &status, 0) == -1 && errno == EINTR)
+ ;
+ uw_ethrowf(file_error_s, lit("opening pipe ~s: ~d/~s"),
+ name, num(eno), errno_to_str(eno), nao);
+ }
}
- free(utf8mode);
- /* TODO: catch potential OOM exception here and kill process. */
- ret = set_mode_props(m, make_pipevp_stream(f, name, pid));
+ uw_catch_end;
}
- uw_unwind {
- fds_restore(&sfds);
- }
-
- uw_catch_end;
-
return ret;
}
@@ -4287,99 +4664,24 @@ val open_process(val name, val mode_str, val args)
{
return open_subprocess(name, mode_str, args, nil);
}
-#else
-
-static void string_extend_count(int count, val out, val tail)
-{
- int i;
- for (i = 0; i < count; i++)
- string_extend(out, tail);
-}
-
-static val win_escape_cmd(val str)
-{
- const wchar_t *s;
- val out = string(L"");
-
- for (s = c_str(str); *s; s++) {
- switch (*s) {
- case ' ': case '\t':
- string_extend(out, lit("\""));
- string_extend(out, chr(*s));
- string_extend(out, lit("\""));
- break;
- default:
- string_extend(out, chr(*s));
- }
- }
-
- return out;
-}
-static val win_escape_arg(val str)
+val open_command(val command, val mode_str)
{
- int bscount = 0, i;
- const wchar_t *s;
- val out = string(L"");
-
- for (s = c_str(str); *s; s++) {
- switch (*s) {
- case '"':
- string_extend_count(bscount, out, lit("\\\\"));
- string_extend(out, lit("\\^\""));
- bscount = 0;
- break;
- case '\\':
- bscount++;
- break;
- case '^': case '%': case '!':
- case '\n': case '&': case '|':
- case '<': case '>':
- case '(': case ')':
- for (i = 0; i < bscount; i++)
- string_extend_count(bscount, out, lit("\\"));
- string_extend(out, chr('^'));
- string_extend(out, chr(*s));
- break;
- default:
- for (i = 0; i < bscount; i++)
- string_extend_count(bscount, out, lit("\\"));
- string_extend(out, chr(*s));
- bscount = 0;
- break;
- }
- }
-
- for (i = 0; i < bscount; i++)
- string_extend(out, lit("\\"));
-
- return out;
-}
-
-static val win_make_cmdline(val args)
-{
- val out = string(L"");
-
- string_extend(out, win_escape_cmd(pop(&args)));
- string_extend(out, chr(' '));
-
- while (args) {
- string_extend(out, lit("^\""));
- string_extend(out, win_escape_arg(pop(&args)));
- if (args)
- string_extend(out, lit("^\" "));
- else
- string_extend(out, lit("^\""));
- }
-
- return out;
+#ifdef __CYGWIN__
+ uses_or2;
+ const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);
+ val interp = if3(psc[0] == '\\',
+ or2(getenv_wrap(lit("COMSPEC")),
+ lit("C:\\WINDOWS\\system32\\cmd.exe")),
+ lit("/bin/sh"));
+ val opt = if3(psc[0] == '\\', lit("/c"), lit("-c"));
+#else
+ val interp = lit("/bin/sh");
+ val opt = lit("-c");
+#endif
+ return open_process(interp, mode_str, list(opt, command, nao));
}
-val open_process(val name, val mode_str, val args)
-{
- val win_cmdline = win_make_cmdline(cons(name, default_null_arg(args)));
- return open_command(win_cmdline, mode_str);
-}
#endif
#if HAVE_WSPAWN || HAVE_SPAWN
@@ -4415,36 +4717,60 @@ static val run(val command, val args)
val iter;
int i, nargs, status = 0;
struct save_fds sfds;
+ volatile val save_env, ch_env = child_env;
args = default_null_arg(args);
- nargs = c_num(length(args)) + 1;
+ nargs = c_num(length(args), self) + 1;
+
+ flush_stream(std_output);
fds_init(&sfds);
uw_simple_catch_begin;
- fds_swizzle(&sfds, FDS_IN | FDS_OUT | FDS_ERR);
+ fds_prepare(&sfds, FDS_IN | FDS_OUT | FDS_ERR, self);
+
+ fds_swizzle(&sfds, FDS_IN | FDS_OUT | FDS_ERR, self);
if (nargs < 0 || nargs == INT_MAX)
uw_throwf(error_s, lit("~a: argument list overflow"), self, nao);
+ if (ch_env != t) {
+ save_env = env();
+ replace_env(ch_env);
+ }
+
wargv = coerce(const wchar_t **, chk_xalloc(nargs + 1, sizeof *wargv, self));
for (i = 0, iter = cons(command, args); iter; i++, iter = cdr(iter))
- wargv[i] = c_str(car(iter));
+ wargv[i] = c_str(car(iter), self);
wargv[i] = 0;
+ if (status == 0) {
#if HAVE_WSPAWN
- status = _wspawnvp(_P_WAIT, c_str(command), wargv);
+ status = _wspawnvp(_P_WAIT, c_str(command, self), wargv);
#else
- status = w_spawnvp(_P_WAIT, c_str(command), nargs, wargv);
+ status = w_spawnvp(_P_WAIT, c_str(command, self), nargs, wargv);
#endif
+#ifdef __CYGWIN__
+ /* Cygwin spawnvp reports regular termination status in upper 8 bits, and
+ * termination signal in lower 8 bits. Let's massage it so that we produce
+ * the same behavior as on Linux.
+ */
+ if (status && status < 0x100)
+ status = -1; /* ensure nil return */
+ else
+ status >>= 8;
+#endif
+ }
free(strip_qual(wchar_t **, wargv));
gc_hint(args);
uw_unwind {
+ if (ch_env != t)
+ replace_env(save_env);
fds_restore(&sfds);
}
@@ -4453,11 +4779,6 @@ static val run(val command, val args)
return (status < 0) ? nil : num(status);
}
-static val sh(val command)
-{
- return run(lit("cmd.exe"), list(lit("/C"), command, nao));
-}
-
#elif HAVE_FORK_STUFF
static val run(val name, val args)
@@ -4471,7 +4792,7 @@ static val run(val name, val args)
val ret = nil;
args = default_null_arg(args);
- nargs = c_num(length(args)) + 1;
+ nargs = c_num(length(args), self) + 1;
if (nargs < 0 || nargs == INT_MAX)
uw_throwf(error_s, lit("~a: argument list overflow"), self, nao);
@@ -4480,15 +4801,15 @@ static val run(val name, val args)
for (i = 0, iter = cons(name, args); iter; i++, iter = cdr(iter)) {
val arg = car(iter);
- argv[i] = utf8_dup_to(c_str(arg));
+ argv[i] = utf8_dup_to(c_str(arg, self));
}
argv[i] = 0;
- fds_init(&sfds);
+ flush_stream(std_output);
- uw_simple_catch_begin;
+ fds_init(&sfds);
- fds_swizzle(&sfds, FDS_IN | FDS_OUT | FDS_ERR);
+ fds_prepare(&sfds, FDS_IN | FDS_OUT | FDS_ERR, self);
pid = fork();
@@ -4496,11 +4817,15 @@ static val run(val name, val args)
for (i = 0; i < nargs; i++)
free(argv[i]);
free(argv);
- uw_throwf(process_error_s, lit("opening process ~s, fork syscall failed: ~d/~s"),
- name, num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(process_error_s, lit("opening process ~s, fork syscall failed: ~d/~s"),
+ name, num(errno), errno_to_str(errno), nao);
}
if (pid == 0) {
+ val ch_env = child_env;
+ fds_clobber(&sfds, FDS_IN | FDS_OUT | FDS_ERR);
+ if (ch_env != t)
+ replace_env(ch_env);
execvp(argv[0], argv);
_exit(errno);
} else {
@@ -4523,31 +4848,80 @@ static val run(val name, val args)
}
out:
- uw_unwind {
- fds_restore(&sfds);
- }
-
- uw_catch_end;
-
return ret;
}
+#endif
+
+#if HAVE_WSPAWN || HAVE_SPAWN || HAVE_FORK_STUFF
+
static val sh(val command)
{
return run(shell, list(shell_arg, command, nao));
}
-#else
-#error port me!
#endif
+static val sh_esc_dq(val string)
+{
+ return str_esc(lit("$`\\\""), chr('\\'), string);
+}
+
+static val sh_esc_sq(val string)
+{
+ return str_esc(lit("'"), lit("'\\'"), string);
+}
+
+static val sh_esc_common(val string, int all, val self)
+{
+ const wchar_t *s, *str = c_str(string, self);
+ int sq = 0, dq = 0, es = 0;
+
+ for (s = str; *s; s++)
+ {
+ wchar_t ch = *s;
+
+ if (ch == '\'')
+ es = sq = 1;
+ else if (wcschr(L"$`\\\"", ch))
+ es = dq = 1;
+ else if (wcschr(L"|&;<>() \t\n*?[#~", ch))
+ es = 1;
+ else if (all && wcschr(L"=%", ch))
+ es = 1;
+ }
+
+ if (!es)
+ return string;
+
+ if (!dq)
+ return scat3(chr('"'), string, chr('"'));
+
+ if (!sq)
+ return scat3(chr('\''), string, chr('\''));
+
+ return scat3(chr('\''), sh_esc_sq(string), chr('\''));
+}
+
+static val sh_esc(val string)
+{
+ return sh_esc_common(string, 0, lit("sh-esc"));
+}
+
+static val sh_esc_all(val string)
+{
+ return sh_esc_common(string, 1, lit("sh-esc-all"));
+}
+
val remove_path(val path, val throw_on_error)
{
- if (w_remove(c_str(path)) < 0) {
+ val self = lit("remove-path");
+
+ if (w_remove(c_str(path, self)) < 0) {
if (default_null_arg(throw_on_error) || errno != ENOENT) {
int eno = errno;
- uw_throwf(errno_to_file_error(eno), lit("trying to remove ~s: ~d/~s"),
- path, num(eno), string_utf8(strerror(eno)), nao);
+ uw_ethrowf(errno_to_file_error(eno), lit("trying to remove ~s: ~d/~s"),
+ path, num(eno), errno_to_str(eno), nao);
}
return nil;
}
@@ -4557,11 +4931,13 @@ val remove_path(val path, val throw_on_error)
val rename_path(val from, val to)
{
- if (w_rename(c_str(from), c_str(to)) < 0) {
+ val self = lit("rename-path");
+
+ if (w_rename(c_str(from, self), c_str(to, self)) < 0) {
int eno = errno;
- uw_throwf(errno_to_file_error(eno),
- lit("trying to rename ~s to ~s: ~d/~s"),
- from, to, num(eno), string_utf8(strerror(eno)), nao);
+ uw_ethrowf(errno_to_file_error(eno),
+ lit("trying to rename ~s to ~s: ~d/~s"),
+ from, to, num(eno), errno_to_str(eno), nao);
}
return t;
@@ -4597,50 +4973,91 @@ static val open_files_star(val file_list, val substitute_stream, val mode)
}
}
-static val ap_regex;
+static val volume_prefix_p(const wchar_t *str)
+{
+ enum { init, slash } state;
-val abs_path_p(val path)
+ for (state = init; *str; str++) {
+ wchar_t ch = *str;
+ switch (state) {
+ case init:
+ if (iswalnum(ch))
+ continue;
+ if (ch == ':') {
+ state = slash;
+ continue;
+ }
+ return nil;
+ case slash:
+ if (ch == '/' || ch == '\\')
+ return t;
+ return nil;
+ }
+ }
+
+ return nil;
+}
+
+static val volume_name_p(const wchar_t *str)
{
- val ch;
+ for (; *str; str++) {
+ if (iswalnum(*str))
+ continue;
+ if (*str == ':')
+ return t;
+ break;
+ }
+
+ return nil;
+}
- if (length(path) == zero)
+val portable_abs_path_p(val path)
+{
+ val self = lit("portable-abs-path-p");
+ const wchar_t *str = c_str(path, self);
+
+ if (*str == 0)
return nil;
- if ((ch = chr_str(path, zero)) == chr('/') || ch == chr('\\'))
+ if (str[0] == '/' || str[0] == '\\')
return t;
+ return volume_prefix_p(str);
+}
- if (!ap_regex)
- ap_regex = regex_compile(lit("[A-Za-z0-9]+:[/\\\\]"), nil);
+val abs_path_p(val path)
+{
+ val self = lit("abs-path-p");
+ const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);
+ const wchar_t *str = c_str(path, self);
- if (match_regex(path, ap_regex, zero))
+ if (*str == 0)
+ return nil;
+ if (wcschr(psc, str[0]))
return t;
- return nil;
-}
+ if (psc[0] != '\\')
+ return nil;
-static val plp_regex;
+ return volume_prefix_p(str);
+}
val pure_rel_path_p(val path)
{
- val ch;
- val len = length_str(path);
+ val self = lit("pure-rel-path-p");
+ const wchar_t *str = c_str(path, self);
- if (len == zero)
+ if (str[0] == 0)
return t;
- if ((ch = chr_str(path, zero)) == chr('/') || ch == chr('\\'))
+ if (str[0] == '/' || str[0] == '\\')
return nil;
- if (len == one)
- return ch == chr('.') ? nil : t;
+ if (str[1] == 0)
+ return str[0] == '.' ? nil : t;
- if (ch == chr('.') &&
- ((ch = chr_str(path, one)) == chr('/') || ch == chr('\\')))
+ if (str[0] == '.' && (str[1] == '/' || str[1] == '\\'))
return nil;
- if (!plp_regex)
- plp_regex = regex_compile(lit("[A-Za-z0-9]+:"), nil);
-
- if (match_regex(path, plp_regex, zero))
+ if (volume_name_p(str))
return nil;
return t;
@@ -4652,19 +5069,21 @@ static void detect_path_separators(void)
struct utsname un;
if (uname(&un) >= 0) {
- if (strncmp(un.sysname, "CYGNAL", 6) == 0)
+ if (strncmp(un.sysname, "CYGNAL", 6) == 0) {
path_sep_chars = wli("\\/");
- return;
+ path_var_sep_char = ';';
+ }
}
#endif
}
val base_name(val path, val suff)
{
- const wchar_t *wpath = c_str(path);
- const wchar_t *end = wpath + c_num(length_str(path));
+ val self = lit("base-name");
+ const wchar_t *wpath = c_str(path, self);
+ const wchar_t *end = wpath + c_num(length_str(path), self);
const wchar_t *rsep;
- const wchar_t *psc = wref(coerce(const wchar_t *, path_sep_chars));
+ const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);
if (end == wpath)
return null_string;
@@ -4683,9 +5102,9 @@ val base_name(val path, val suff)
{
val base = mkustring(num_fast(end - rsep));
- init_str(base, rsep);
+ init_str(base, rsep, self);
return if3(!null_or_missing_p(suff) && ends_with(suff, base, nil, nil) &&
- neql(length(suff), length(base)),
+ plusp(length(suff)) && neql(length(suff), length(base)),
sub(base, zero, neg(length(suff))),
base);
}
@@ -4693,9 +5112,10 @@ val base_name(val path, val suff)
val dir_name(val path)
{
- const wchar_t *wpath = c_str(path);
- const wchar_t *rsep = wpath + c_num(length_str(path));
- const wchar_t *psc = wref(coerce(const wchar_t *, path_sep_chars));
+ val self = lit("dir-name");
+ const wchar_t *wpath = c_str(path, self);
+ const wchar_t *rsep = wpath + c_num(length_str(path), self);
+ const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);
if (rsep == wpath)
return lit(".");
@@ -4722,14 +5142,187 @@ val dir_name(val path)
{
val base = mkustring(num_fast(rsep - wpath - 1));
- return init_str(base, wpath);
+ return init_str(base, wpath, self);
+ }
+}
+
+val short_suffix(val name, val alt_in)
+{
+ val self = lit("short-suffix");
+ const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);
+ const wchar_t *str = c_str(name, self);
+ const wchar_t *dot = wcsrchr(str, '.');
+ const wchar_t *sl = if3(dot, wcspbrk(dot + 1, psc), 0);
+ int sl_trail = if3(sl, sl[wcsspn(sl, psc)] == 0, 0);
+
+ if (!dot || (sl && sl[1] && !sl_trail) || dot == str || wcschr(psc, dot[-1])) {
+ return default_null_arg(alt_in);
+ } else {
+ wchar_t *suff = chk_strdup(dot);
+ if (sl)
+ suff[sl - dot] = 0;
+ return string_own(suff);
+ }
+}
+
+val long_suffix(val name, val alt_in)
+{
+ val self = lit("long-suffix");
+ const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);
+ const wchar_t *str = c_str(name, self);
+ const wchar_t *dot = wcschr(str, '.');
+
+ {
+ const wchar_t *sl;
+
+ while (dot && (sl = wcspbrk(dot, psc)) && sl[1] && sl[wcsspn(sl, psc)] != 0)
+ dot = wcschr(sl + 1, '.');
+
+ if (dot && (dot == str || wcschr(psc, dot[-1])))
+ dot = wcschr(dot + 1, '.');
+
+ if (!dot || dot == str) {
+ return default_null_arg(alt_in);
+ } else {
+ wchar_t *suff = chk_strdup(dot);
+ if (sl)
+ suff[sl - dot] = 0;
+ return string_own(suff);
+ }
+ }
+}
+
+val trim_short_suffix(val name)
+{
+ val self = lit("trim-short-suffix");
+ const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);
+ const wchar_t *str = c_str(name, self);
+ const wchar_t *dot = wcsrchr(str, '.');
+ const wchar_t *sl = if3(dot, wcspbrk(dot + 1, psc), 0);
+ int sl_trail = if3(sl, sl[wcsspn(sl, psc)] == 0, 0);
+
+ if (!dot || (sl && sl[1] && !sl_trail) || dot == str || wcschr(psc, dot[-1])) {
+ return name;
+ } else {
+ size_t off = dot - str;
+ if (sl) {
+ size_t slsz = wcslen(sl) + 1;
+ size_t nchar = off + slsz;
+ wchar_t *out = chk_wmalloc(nchar);
+ wmemcpy(out, str, off);
+ wmemcpy(out + off, sl, slsz);
+ return string_own(out);
+ } else {
+ wchar_t *pref = chk_substrdup(str, 0, dot - str);
+ return string_own(pref);
+ }
+ }
+}
+
+val trim_long_suffix(val name)
+{
+ val self = lit("trim-long-suffix");
+ const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);
+ const wchar_t *str = c_str(name, self);
+ const wchar_t *dot = wcschr(str, '.');
+
+ {
+ const wchar_t *sl;
+
+ while (dot && (sl = wcspbrk(dot, psc)) && sl[1] && sl[wcsspn(sl, psc)] != 0)
+ dot = wcschr(sl + 1, '.');
+
+ if (dot && (dot == str || wcschr(psc, dot[-1])))
+ dot = wcschr(dot + 1, '.');
+
+ if (!dot || dot == str) {
+ return name;
+ } else {
+ size_t off = dot - str;
+ if (sl) {
+ size_t slsz = wcslen(sl) + 1;
+ size_t nchar = off + slsz;
+ wchar_t *out = chk_wmalloc(nchar);
+ wmemcpy(out, str, off);
+ wmemcpy(out + off, sl, slsz);
+ return string_own(out);
+ } else {
+ wchar_t *pref = chk_substrdup(str, 0, dot - str);
+ return string_own(pref);
+ }
+ }
+ }
+}
+
+val trim_path_seps(val name)
+{
+ val self = lit("trim-path-seps");
+ const wchar_t *str = c_str(name, self);
+ const wchar_t *psc = L"/\\";
+ const wchar_t *fsl = 0;
+ cnum len = c_num(length_str(name), self);
+
+ if (portable_abs_path_p(name))
+ fsl = wcspbrk(str, psc);
+
+ while (len-- > 0)
+ if (!wcschr(psc, str[len]) || str + len == fsl)
+ break;
+
+ return string_own(chk_substrdup(str, 0, len + 1));
+}
+
+val add_suffix(val name, val suffix)
+{
+ val self = lit("add-suffix");
+ size_t len_n = c_unum(length_str(name), self);
+ size_t len_s = c_unum(length_str(suffix), self);
+ const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);
+ const wchar_t *nam = c_str(name, self);
+ const wchar_t *suf = c_str(suffix, self);
+ const wchar_t *sl = wcspbrk(nam, psc);
+
+ if (psc[0] == '\\' || 1) {
+ const wchar_t *set = L"ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ L"abcdefghijklmnopqrstuvwxyz"
+ L"0123456789";
+ const wchar_t *drv = nam + wcsspn(nam, set);
+ if (drv[0] == ':' && sl == drv + 1) {
+ if (drv - nam > 1) {
+ if (wcschr(psc, drv[2]))
+ sl = wcspbrk(drv + 3, psc);
+ } else if (drv > nam) {
+ sl = wcspbrk(drv + 2, psc);
+ }
+ }
+ }
+
+ if (sl == nam)
+ sl = wcspbrk(nam + 1, psc);
+
+ while (sl) {
+ const wchar_t *nsl = sl + 1 + wcsspn(sl + 1, psc);
+
+ if (*nsl == 0) {
+ size_t nchar = len_n + len_s + 1;
+ size_t offs = sl - nam;
+ wchar_t *out = chk_wmalloc(nchar);
+ wmemcpy(out, nam, offs);
+ wmemcpy(out + offs, suf, len_s);
+ wcscpy(out + offs + len_s, sl);
+ return string_own(out);
+ }
+
+ sl = wcspbrk(nsl, psc);
}
+
+ return scat2(name, suffix);
}
val path_cat(val dir_name, val base_name)
{
- val dl = length(dir_name);
- val bl = length(base_name);
+ val dl = length_str(dir_name);
+ val bl = length_str(base_name);
val ps = static_str(path_sep_chars);
if (dl == zero)
@@ -4765,6 +5358,25 @@ val path_cat(val dir_name, val base_name)
return scat(lit("/"), dir_name, base_name, nao);
}
+static val path_vcat(varg args)
+{
+ cnum ix = 0;
+
+ if (!args_more(args, ix)) {
+ return lit(".");
+ } else {
+ val accum = args_get(args, &ix);
+
+ if (!stringp(accum))
+ uw_throwf(file_error_s, lit("path-cat: ~s isn't a string"), accum, nao);
+
+ while (args_more(args, ix))
+ accum = path_cat(accum, args_get(args, &ix));
+
+ return accum;
+ }
+}
+
val make_byte_input_stream(val obj)
{
val self = lit("make-byte-input-stream");
@@ -4782,6 +5394,72 @@ val make_byte_input_stream(val obj)
}
}
+val tmpfile_wrap(void)
+{
+ val self = lit("tmpfile");
+ struct stdio_mode m_blank = stdio_mode_init_blank;
+ struct stdio_mode m = do_parse_mode(lit("w+b"), m_blank, self);
+ FILE *tf = tmpfile();
+ if (tf != 0)
+ return set_mode_props(m, make_stdio_stream(tf, self));
+ uw_ethrowf(file_error_s, lit("~a failed: ~d/~s"),
+ self, num(errno), errno_to_str(errno), nao);
+}
+
+#if HAVE_MKDTEMP
+
+val mkdtemp_wrap(val prefix)
+{
+ val self = lit("mkdtemp");
+ char *tmpl = utf8_dup_to(c_str(scat2(prefix, lit("XXXXXX")), self));
+
+ if (mkdtemp(tmpl) != 0) {
+ val ret = string_utf8(tmpl);
+ free(tmpl);
+ return ret;
+ }
+
+ free(tmpl);
+ uw_ethrowf(file_error_s, lit("mkdtemp failed: ~d/~s"),
+ num(errno), errno_to_str(errno), nao);
+}
+
+#endif
+
+#if HAVE_MKSTEMP
+
+val mkstemp_wrap(val prefix, val suffix)
+{
+ val self = lit("mkstemp");
+ val suff = default_arg_strict(suffix, null_string);
+ val templ = scat3(prefix, lit("XXXXXX"), suff);
+ cnum slen = c_num(length(suff), self);
+ char *tmpl = utf8_dup_to(c_str(templ, self));
+ val name;
+ int fd;
+
+#if HAVE_MKSTEMPS
+ fd = mkstemps(tmpl, slen);
+#else
+ if (slen > 0) {
+ free(tmpl);
+ uw_throwf(system_error_s, lit("~a: suffix not supported"), self, nao);
+ }
+ fd = mkstemp(tmpl);
+#endif
+ name = string_utf8(tmpl);
+ free(tmpl);
+ if (fd != -1) {
+ val stream = open_fileno(num(fd), lit("w+b"), nil);
+ stream_set_prop(stream, name_k, name);
+ return stream;
+ }
+ uw_ethrowf(file_error_s, lit("~a failed: ~d/~s"),
+ self, num(errno), errno_to_str(errno), nao);
+}
+
+#endif
+
static val iobuf_free_list;
val iobuf_get(void)
@@ -4811,8 +5489,7 @@ void iobuf_list_empty(void)
void stream_init(void)
{
- prot1(&ap_regex);
- prot1(&plp_regex);
+ prot1(&top_stderr);
detect_format_string();
detect_path_separators();
@@ -4825,6 +5502,7 @@ void stream_init(void)
addr_k = intern(lit("addr"), keyword_package);
fd_k = intern(lit("fd"), keyword_package);
byte_oriented_k = intern(lit("byte-oriented"), keyword_package);
+ standard_k = intern(lit("standard"), keyword_package);
format_s = intern(lit("format"), user_package);
stdio_stream_s = intern(lit("stdio-stream"), user_package);
#if HAVE_SOCKETS
@@ -4851,6 +5529,9 @@ void stream_init(void)
clear_error_s = intern(lit("clear-error"), user_package);
get_fd_s = intern(lit("get-fd"), user_package);
+ stream_cls = cobj_register(stream_s);
+ stdio_stream_cls = cobj_register_super(stdio_stream_s, stream_cls);
+
reg_var(stdin_s = intern(lit("*stdin*"), user_package),
make_stdio_stream(stdin, lit("stdin")));
reg_var(stdout_s = intern(lit("*stdout*"), user_package),
@@ -4858,7 +5539,7 @@ void stream_init(void)
reg_var(stddebug_s = intern(lit("*stddebug*"), user_package),
make_stdio_stream(stdout, lit("debug")));
reg_var(stderr_s = intern(lit("*stderr*"), user_package),
- make_stdio_stream(stderr, lit("stderr")));
+ top_stderr = make_stdio_stream(stderr, lit("stderr")));
reg_var(stdnull_s = intern(lit("*stdnull*"), user_package),
make_null_stream());
@@ -4877,6 +5558,7 @@ void stream_init(void)
reg_var(print_base_s = intern(lit("*print-base*"), user_package),
num_fast(10));
reg_var(print_circle_s = intern(lit("*print-circle*"), user_package), nil);
+ reg_var(print_json_format_s = intern(lit("*print-json-format*"), user_package), nil);
#if HAVE_ISATTY
if (isatty(fileno(stdin)) == 1) {
@@ -4913,6 +5595,7 @@ void stream_init(void)
reg_fun(unget_byte_s, func_n2o(unget_byte, 1));
reg_fun(put_buf_s, func_n3o(put_buf, 1));
reg_fun(fill_buf_s, func_n3o(fill_buf, 1));
+ reg_fun(intern(lit("get-line-as-buf"), user_package), func_n1o(get_line_as_buf, 0));
reg_fun(intern(lit("fill-buf-adjust"), user_package), func_n3o(fill_buf_adjust, 1));
reg_fun(intern(lit("flush-stream"), user_package), func_n1o(flush_stream, 0));
reg_fun(intern(lit("seek-stream"), user_package), func_n3(seek_stream));
@@ -4935,25 +5618,39 @@ void stream_init(void)
reg_fun(intern(lit("record-adapter"), user_package), func_n3o(record_adapter, 1));
reg_fun(intern(lit("open-directory"), user_package), func_n1(open_directory));
reg_fun(intern(lit("open-file"), user_package), func_n2o(open_file, 1));
- reg_fun(intern(lit("open-fileno"), user_package), func_n2o(open_fileno, 1));
+ reg_fun(intern(lit("open-fileno"), user_package), func_n3o(open_fileno, 1));
reg_fun(intern(lit("open-tail"), user_package), func_n3o(open_tail, 1));
+ reg_fun(intern(lit("path-search"), user_package), func_n2o(path_search, 1));
reg_fun(intern(lit("open-command"), user_package), func_n2o(open_command, 1));
reg_fun(intern(lit("open-pipe"), user_package), func_n2(open_command));
reg_fun(intern(lit("open-process"), user_package), func_n3o(open_process, 2));
#if HAVE_FORK_STUFF
reg_fun(intern(lit("open-subprocess"), user_package), func_n4o(open_subprocess, 2));
#endif
+#if HAVE_WSPAWN || HAVE_SPAWN || HAVE_FORK_STUFF
reg_fun(intern(lit("sh"), user_package), func_n1(sh));
reg_fun(intern(lit("run"), user_package), func_n2o(run, 1));
+#endif
+ reg_fun(intern(lit("sh-esc"), user_package), func_n1(sh_esc));
+ reg_fun(intern(lit("sh-esc-all"), user_package), func_n1(sh_esc_all));
+ reg_fun(intern(lit("sh-esc-dq"), user_package), func_n1(sh_esc_dq));
+ reg_fun(intern(lit("sh-esc-sq"), user_package), func_n1(sh_esc_sq));
reg_fun(intern(lit("remove-path"), user_package), func_n2o(remove_path, 1));
reg_fun(intern(lit("rename-path"), user_package), func_n2(rename_path));
reg_fun(intern(lit("open-files"), user_package), func_n3o(open_files, 1));
reg_fun(intern(lit("open-files*"), user_package), func_n3o(open_files_star, 1));
+ reg_fun(intern(lit("portable-abs-path-p"), user_package), func_n1(portable_abs_path_p));
reg_fun(intern(lit("abs-path-p"), user_package), func_n1(abs_path_p));
reg_fun(intern(lit("pure-rel-path-p"), user_package), func_n1(pure_rel_path_p));
reg_fun(intern(lit("base-name"), user_package), func_n2o(base_name, 1));
reg_fun(intern(lit("dir-name"), user_package), func_n1(dir_name));
- reg_fun(intern(lit("path-cat"), user_package), func_n2(path_cat));
+ reg_fun(intern(lit("short-suffix"), user_package), func_n2o(short_suffix, 1));
+ reg_fun(intern(lit("long-suffix"), user_package), func_n2o(long_suffix, 1));
+ reg_fun(intern(lit("trim-short-suffix"), user_package), func_n1(trim_short_suffix));
+ reg_fun(intern(lit("trim-long-suffix"), user_package), func_n1(trim_long_suffix));
+ reg_fun(intern(lit("trim-path-seps"), user_package), func_n1(trim_path_seps));
+ reg_fun(intern(lit("path-cat"), user_package), func_n0v(path_vcat));
+ reg_fun(intern(lit("add-suffix"), user_package), func_n2(add_suffix));
reg_varl(intern(lit("path-sep-chars"), user_package), static_str(path_sep_chars));
reg_fun(intern(lit("get-indent-mode"), user_package), func_n1(get_indent_mode));
reg_fun(intern(lit("test-set-indent-mode"), user_package), func_n3(test_set_indent_mode));
@@ -4962,6 +5659,7 @@ void stream_init(void)
reg_fun(intern(lit("get-indent"), user_package), func_n1(get_indent));
reg_fun(intern(lit("set-indent"), user_package), func_n2(set_indent));
reg_fun(intern(lit("inc-indent"), user_package), func_n2(inc_indent));
+ reg_fun(intern(lit("inc-indent-abs"), user_package), func_n2(inc_indent_abs));
reg_fun(intern(lit("width-check"), user_package), func_n2(width_check));
reg_fun(intern(lit("force-break"), user_package), func_n1(force_break));
reg_fun(intern(lit("set-max-length"), user_package), func_n2(set_max_length));
@@ -4970,6 +5668,13 @@ void stream_init(void)
reg_varl(intern(lit("indent-data"), user_package), num_fast(indent_data));
reg_varl(intern(lit("indent-code"), user_package), num_fast(indent_code));
reg_varl(intern(lit("indent-foff"), user_package), num_fast(indent_foff));
+ reg_fun(intern(lit("tmpfile"), user_package), func_n0(tmpfile_wrap));
+#if HAVE_MKDTEMP
+ reg_fun(intern(lit("mkdtemp"), user_package), func_n1(mkdtemp_wrap));
+#endif
+#if HAVE_MKSTEMP
+ reg_fun(intern(lit("mkstemp"), user_package), func_n2o(mkstemp_wrap, 1));
+#endif
#if HAVE_SOCKETS
uw_register_subtype(socket_error_s, error_s);
@@ -4978,7 +5683,9 @@ void stream_init(void)
fill_stream_ops(&null_ops);
fill_stream_ops(&stdio_ops);
fill_stream_ops(&tail_ops);
+#if HAVE_FORK_STUFF
fill_stream_ops(&pipe_ops);
+#endif
fill_stream_ops(&string_in_ops);
fill_stream_ops(&byte_in_ops);
fill_stream_ops(&strlist_in_ops);
@@ -5017,4 +5724,15 @@ void stream_init(void)
}
}
#endif
+
+#if HAVE_ZLIB
+ gzio_init();
+#endif
+}
+
+void stream_compat_fixup(int compat_ver)
+{
+ if (compat_ver <= 258)
+ reg_fun(intern(lit("abs-path-p"), user_package),
+ func_n1(portable_abs_path_p));
}
diff --git a/stream.h b/stream.h
index 2d7688c6..d4300154 100644
--- a/stream.h
+++ b/stream.h
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
enum strm_whence {
@@ -55,6 +56,7 @@ struct strm_base {
unsigned force_break;
cnum max_length;
cnum max_depth;
+ val close_result;
struct strm_ctx *ctx;
};
@@ -69,8 +71,8 @@ struct strm_ops {
val (*get_byte)(val);
val (*unget_char)(val, val);
val (*unget_byte)(val, int);
- val (*put_buf)(val, val, cnum);
- val (*fill_buf)(val, val, cnum);
+ ucnum (*put_buf)(val, mem_t *, ucnum len, ucnum pos);
+ ucnum (*fill_buf)(val, mem_t *, ucnum len, ucnum pos);
val (*close)(val, val);
val (*flush)(val);
val (*seek)(val, val, enum strm_whence);
@@ -109,26 +111,38 @@ struct stdio_mode {
unsigned append : 1;
unsigned binary : 1;
unsigned notrunc : 1;
+ unsigned excl : 1;
+ unsigned nonblock : 1;
unsigned interactive : 1;
unsigned unbuf : 1;
unsigned linebuf : 1;
+ unsigned gzip : 1;
+ unsigned gzlevel : 4;
+ unsigned tmpfile : 1;
int buforder : 5;
int redir[STDIO_MODE_NREDIRS][2];
};
-#define stdio_mode_init_blank { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -1 }
-#define stdio_mode_init_r { 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, -1 }
-#define stdio_mode_init_rpb { 0, 1, 1, 0, 0, 1, 0, 0, 0, 0, -1 }
+#define stdio_mode_init_blank { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -1, { { 0 } } }
+#define stdio_mode_init_r { 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -1, { { 0 } } }
+#define stdio_mode_init_rpb { 0, 1, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, -1, { { 0 } } }
#define std_input (deref(lookup_var_l(nil, stdin_s)))
#define std_output (deref(lookup_var_l(nil, stdout_s)))
#define std_debug (deref(lookup_var_l(nil, stddebug_s)))
#define std_error (deref(lookup_var_l(nil, stderr_s)))
#define std_null (deref(lookup_var_l(nil, stdnull_s)))
+
+enum json_fmt {
+ json_fmt_default,
+ json_fmt_standard
+};
+
loc lookup_var_l(val env, val sym);
extern val from_start_k, from_current_k, from_end_k;
extern val real_time_k, name_k, addr_k, fd_k, byte_oriented_k;
+extern val standard_k;
extern val format_s;
extern val stdio_stream_s;
@@ -142,12 +156,18 @@ extern val get_error_s, get_error_str_s, clear_error_s, get_fd_s;
extern val print_flo_precision_s, print_flo_digits_s, print_flo_format_s;
extern val pprint_flo_format_s, print_base_s, print_circle_s;
+extern val print_json_format_s;
#if HAVE_SOCKETS
extern val socket_error_s;
#endif
extern const wchli_t *path_sep_chars;
+extern wchar_t path_var_sep_char;
+
+extern val top_stderr;
+
+extern struct cobj_class *stream_cls, *stdio_stream_cls;
void strm_base_init(struct strm_base *s);
void strm_base_cleanup(struct strm_base *s);
@@ -156,16 +176,20 @@ void fill_stream_ops(struct strm_ops *ops);
void stream_print_op(val stream, val out, val pretty, struct strm_ctx *);
void stream_mark_op(val stream);
void stream_destroy_op(val stream);
-struct stdio_mode parse_mode(val mode_str, struct stdio_mode m_dfl);
-val normalize_mode(struct stdio_mode *m, val mode_str, struct stdio_mode m_dfl);
-val normalize_mode_no_bin(struct stdio_mode *m, val mode_str, struct stdio_mode m_dfl);
+int w_open_mode(const wchar_t *wname, const struct stdio_mode m);
+struct stdio_mode parse_mode(val mode_str, struct stdio_mode m_dfl, val self);
+val normalize_mode(struct stdio_mode *m, val mode_str,
+ struct stdio_mode m_dfl, val self);
+val normalize_mode_no_bin(struct stdio_mode *m, val mode_str,
+ struct stdio_mode m_dfl, val self);
val set_mode_props(const struct stdio_mode m, val stream);
val generic_get_line(val stream);
val errno_to_string(val err);
val make_null_stream(void);
val make_stdio_stream(FILE *, val descr);
val make_tail_stream(FILE *, val descr);
-val make_pipe_stream(FILE *, val descr);
+val pipe_close_status_helper(val stream, val throw_on_error,
+ int status, val self);
val stream_fd(val stream);
#if HAVE_SOCKETS
val make_sock_stream(FILE *f, val family, val type);
@@ -193,11 +217,13 @@ val clear_error(val stream);
val get_line(val);
val get_char(val);
val get_byte(val);
+val get_bytes(val self, val, mem_t *ptr, ucnum len);
val unget_char(val ch, val stream);
val unget_byte(val byte, val stream);
val put_buf(val buf, val pos, val stream);
val fill_buf(val buf, val pos, val stream);
val fill_buf_adjust(val buf, val pos, val stream);
+val get_line_as_buf(val stream);
val vformat(val stream, val string, va_list);
val vformat_to_string(val string, va_list);
val format(val stream, val string, ...);
@@ -219,6 +245,7 @@ val set_indent_mode(val stream, val mode);
val get_indent(val stream);
val set_indent(val stream, val indent);
val inc_indent(val stream, val delta);
+val inc_indent_abs(val stream, val delta);
val width_check(val stream, val alt);
val force_break(val stream);
val set_max_length(val stream, val length);
@@ -228,9 +255,10 @@ struct strm_ctx *get_ctx(val stream);
val get_string(val stream, val nchars, val close_after_p);
val open_directory(val path);
val open_file(val path, val mode_str);
-val open_fileno(val fd, val mode_str);
+val open_fileno(val fd, val mode_str, val pid_opt);
val open_tail(val path, val mode_str, val seek_end_p);
val open_command(val path, val mode_str);
+val path_search(val name, val path_in);
val open_process(val path, val mode_str, val args);
val make_catenated_stream(val stream_list);
val make_catenated_stream_v(struct args *streams);
@@ -238,13 +266,24 @@ val catenated_stream_p(val obj);
val catenated_stream_push(val new_stream, val cat_stream);
val remove_path(val path, val throw_on_error);
val rename_path(val from, val to);
+val portable_abs_path_p(val path);
val abs_path_p(val path);
val pure_rel_path_p(val path);
val base_name(val path, val suff);
val dir_name(val path);
+val short_suffix(val name, val alt_in);
+val long_suffix(val name, val alt_in);
+val trim_short_suffix(val name);
+val trim_long_suffix(val name);
+val trim_path_seps(val name);
val path_cat(val dir_name, val base_name);
+val add_suffix(val name, val suffix);
val make_byte_input_stream(val obj);
val iobuf_get(void);
void iobuf_put(val buf);
void iobuf_list_empty(void);
+val tmpfile_wrap(void);
+val mkdtemp_wrap(val prefix);
+val mkstemp_wrap(val prefix, val suffix);
void stream_init(void);
+void stream_compat_fixup(int compat_ver);
diff --git a/struct.c b/struct.c
index b00b7d9e..a2b1e79a 100644
--- a/struct.c
+++ b/struct.c
@@ -1,4 +1,4 @@
-/* Copyright 2015-2020
+/* Copyright 2015-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stddef.h>
@@ -45,7 +46,7 @@
#include "args.h"
#include "cadr.h"
#include "txr.h"
-#include "lisplib.h"
+#include "autoload.h"
#include "struct.h"
#define max(a, b) ((a) > (b) ? (a) : (b))
@@ -79,8 +80,10 @@ struct struct_type {
cnum nslots;
cnum nstslots;
cnum nsupers;
+ cnum ndsupers;
val supers;
struct struct_type **sus;
+ struct struct_type **dsus;
val slots;
val stinitfun;
val initfun;
@@ -89,14 +92,15 @@ struct struct_type {
val dvtypes;
struct stslot *stslot;
struct stslot **spslot;
+ unsigned dupe : 1;
};
struct struct_inst {
struct struct_type *type;
- cnum id : sizeof (cnum) * CHAR_BIT - TAG_SHIFT;
+ cnum id : NUM_BIT;
unsigned lazy : 1;
unsigned dirty : 1;
- val slot[1];
+ val slot[FLEX_ARRAY];
};
val struct_type_s, meth_s, print_s, make_struct_lit_s;
@@ -105,11 +109,18 @@ val slot_s, derived_s;
val nullify_s, from_list_s, lambda_set_s;
+val iter_begin_s, iter_more_s, iter_item_s, iter_step_s, iter_reset_s;
+
static val *special_sym[num_special_slots] = {
&equal_s, &nullify_s, &from_list_s, &lambda_s, &lambda_set_s,
- &length_s, &car_s, &cdr_s, &rplaca_s, &rplacd_s
+ &length_s, &length_lt_s, &car_s, &cdr_s, &rplaca_s, &rplacd_s,
+ &iter_begin_s, &iter_more_s, &iter_item_s, &iter_step_s, &iter_reset_s,
+ &plus_s
};
+static struct cobj_class *struct_type_cls;
+struct cobj_class *struct_cls;
+
static val struct_type_hash;
static val slot_hash;
static val struct_type_finalize_f;
@@ -120,10 +131,10 @@ static val struct_type_finalize(val obj);
static_forward(struct cobj_ops struct_type_ops);
static struct stslot *lookup_static_slot_desc(struct struct_type *st, val sym);
-static val make_struct_type_compat(val name, val super, val slots,
- val initfun, val boactor);
-static val call_super_method(val inst, val sym, struct args *);
-static val call_super_fun(val type, val sym, struct args *);
+static val make_struct_type_compat(val name, val super,
+ val slots, val initfun, val boactor);
+static val call_super_method(val inst, val sym, varg );
+static val call_super_fun(val type, val sym, varg );
void struct_init(void)
{
@@ -141,19 +152,23 @@ void struct_init(void)
nullify_s = intern(lit("nullify"), user_package);
from_list_s = intern(lit("from-list"), user_package);
lambda_set_s = intern(lit("lambda-set"), user_package);
- struct_type_hash = make_hash(nil, nil, nil);
- slot_hash = make_hash(nil, nil, t);
- slot_type_hash = make_hash(nil, nil, nil);
- slot_type_hash = make_hash(nil, nil, nil);
- static_slot_type_hash = make_hash(nil, nil, nil);
+ iter_begin_s = intern(lit("iter-begin"), user_package);
+ iter_more_s = intern(lit("iter-more"), user_package);
+ iter_item_s = intern(lit("iter-item"), user_package);
+ iter_step_s = intern(lit("iter-step"), user_package);
+ iter_reset_s = intern(lit("iter-reset"), user_package);
+
+ struct_type_cls = cobj_register(struct_type_s);
+ struct_cls = cobj_register(struct_s);
+
+ struct_type_hash = make_hash(hash_weak_none, nil);
+ slot_hash = make_hash(hash_weak_none, t);
+ slot_type_hash = make_hash(hash_weak_none, nil);
+ static_slot_type_hash = make_hash(hash_weak_none, nil);
struct_type_finalize_f = func_n1(struct_type_finalize);
- if (opt_compat && opt_compat <= 117)
- reg_fun(intern(lit("make-struct-type"), user_package),
- func_n5(make_struct_type_compat));
- else
- reg_fun(intern(lit("make-struct-type"), user_package),
- func_n8o(make_struct_type, 7));
+ reg_fun(intern(lit("make-struct-type"), user_package),
+ func_n8o(make_struct_type, 7));
reg_fun(intern(lit("make-struct-type"), system_package),
func_n8(make_struct_type));
@@ -193,8 +208,6 @@ void struct_init(void)
reg_fun(intern(lit("call-super-fun"), user_package),
func_n2v(call_super_fun));
reg_fun(intern(lit("slotp"), user_package), func_n2(slotp));
- if (opt_compat && opt_compat <= 118)
- reg_fun(intern(lit("slot-p"), user_package), func_n2(slotp));
reg_fun(intern(lit("static-slot-p"), user_package), func_n2(static_slot_p));
reg_fun(intern(lit("structp"), user_package), func_n1(structp));
reg_fun(intern(lit("struct-type"), user_package), func_n1(struct_type));
@@ -208,7 +221,17 @@ void struct_init(void)
reg_fun(intern(lit("static-slot-types"), system_package), func_n1(static_slot_types));
}
-static noreturn void no_such_struct(val ctx, val sym)
+void struct_compat_fixup(int compat_ver)
+{
+ if (compat_ver <= 118)
+ reg_fun(intern(lit("slot-p"), user_package), func_n2(slotp));
+
+ if (compat_ver <= 117)
+ reg_fun(intern(lit("make-struct-type"), user_package),
+ func_n5(make_struct_type_compat));
+}
+
+static NORETURN void no_such_struct(val ctx, val sym)
{
uw_throwf(error_s, lit("~a: ~s does not name a struct type"),
ctx, sym, nao);
@@ -222,7 +245,7 @@ static val struct_type_finalize(val obj)
for (iter = st->slots; iter; iter = cdr(iter)) {
val slot = car(iter);
- slot_cache_t slot_cache = slot->s.slot_cache;
+ slot_cache_set_t *slot_cache = slot->s.slot_cache;
int i, j;
remhash(slot_hash, cons(slot, id));
@@ -249,7 +272,15 @@ static void call_stinitfun_chain(struct struct_type *st, val stype)
}
}
-static struct struct_type *stype_handle(val *pobj, val ctx)
+static struct struct_inst *struct_handle(val obj, val ctx)
+{
+ if (cobjp(obj) && obj->co.ops == &struct_inst_ops)
+ return coerce(struct struct_inst *, obj->co.handle);
+ uw_throwf(type_error_s, lit("~a: ~s isn't a structure"),
+ ctx, obj, nao);
+}
+
+static struct struct_type *stype_handle_impl(val *pobj, val obj_ok, val ctx)
{
val obj = *pobj;
@@ -261,18 +292,30 @@ static struct struct_type *stype_handle(val *pobj, val ctx)
no_such_struct(ctx, obj);
*pobj = stype;
return coerce(struct struct_type *, cobj_handle(ctx, stype,
- struct_type_s));
+ struct_type_cls));
}
case COBJ:
- if (obj->co.cls == struct_type_s)
+ if (obj->co.cls == struct_type_cls)
return coerce(struct struct_type *, obj->co.handle);
+ if (obj_ok && obj->co.cls == struct_cls)
+ return struct_handle(obj, ctx)->type;
/* fallthrough */
default:
- uw_throwf(error_s, lit("~a: ~s isn't a struct type"),
+ uw_throwf(type_error_s, lit("~a: ~s isn't a struct type"),
ctx, obj, nao);
}
}
+static struct struct_type *stype_handle(val *pobj, val ctx)
+{
+ return stype_handle_impl(pobj, nil, ctx);
+}
+
+static struct struct_type *stype_handle_obj(val *pobj, val ctx)
+{
+ return stype_handle_impl(pobj, t, ctx);
+}
+
static void static_slot_home_fixup(struct struct_type *st)
{
cnum i;
@@ -289,6 +332,72 @@ static void static_slot_home_fixup(struct struct_type *st)
}
}
+static void invalidate_special_slot_nonexistence(struct struct_type *st)
+{
+ if (st->spslot != 0) {
+ int i;
+ for (i = 0; i < num_special_slots; i++) {
+ if (st->spslot[i] == coerce(struct stslot *, -1))
+ st->spslot[i] = 0;
+ }
+ }
+}
+
+static void invalidate_special_slots(struct struct_type *st)
+{
+ if (st->spslot != 0)
+ memset(st->spslot, 0, sizeof *st->spslot * num_special_slots);
+}
+
+
+static val get_all_supers(val supers, val self)
+{
+ list_collect_decl (all_supers, ptail);
+
+ ptail = list_collect_append(ptail, supers);
+
+ for (; supers; supers = us_cdr(supers)) {
+ val super = us_car(supers);
+ struct struct_type *su = stype_handle(&super, self);
+ int i;
+
+ ptail = list_collect_append(ptail, su->supers);
+
+ for (i = 0; i < su->nsupers; i++) {
+ struct struct_type *ssu = su->sus[i];
+ ptail = list_collect_append(ptail, get_all_supers(ssu->supers, self));
+ }
+ }
+
+ return all_supers;
+}
+
+static val get_duplicate_supers(val supers, val self)
+{
+ list_collect_decl (dup_supers, ptail);
+ val all_supers = get_all_supers(supers, self);
+ ucnum bloom = 0;
+ val iter;
+
+ for (iter = all_supers; iter; iter = us_cdr(iter)) {
+ val super = us_car(iter);
+ struct struct_type *st = stype_handle(&super, self);
+ int pos = st->id % (sizeof bloom * CHAR_BIT);
+ ucnum mask = convert(ucnum, 1) << pos;
+
+ if ((mask & bloom) != 0) {
+ if (memq(super, all_supers) != iter && !memq(super, dup_supers)) {
+ ptail = list_collect(ptail, super);
+ st->dupe = 1;
+ }
+ }
+
+ bloom |= mask;
+ }
+
+ return dup_supers;
+}
+
static struct struct_type **get_struct_handles(cnum nsupers, val supers,
val self)
{
@@ -319,7 +428,7 @@ static cnum count_super_stslots(cnum nsupers, struct struct_type **sus,
return c;
}
-static val get_super_slots(cnum nsupers, struct struct_type **sus, val self)
+static val get_super_slots(cnum nsupers, struct struct_type **sus)
{
cnum i;
val slots = nil;
@@ -352,6 +461,12 @@ val make_struct_type(val name, val supers,
val self = lit("make-struct-type");
val iter;
+ autoload_try_struct(name);
+
+ if (built_in_type_p(name))
+ uw_throwf(error_s, lit("~a: ~s is a built-in type"),
+ self, name, nao);
+
if (!listp(supers))
supers = cons(supers, nil);
@@ -366,7 +481,7 @@ val make_struct_type(val name, val supers,
no_such_struct(self, super);
ptail = list_collect(ptail, supertype);
} else {
- class_check(self, super, struct_type_s);
+ class_check(self, super, struct_type_cls);
ptail = list_collect(ptail, super);
}
}
@@ -385,34 +500,38 @@ val make_struct_type(val name, val supers,
self, nao);
} else {
struct struct_type *st = coerce(struct struct_type *,
- chk_malloc(sizeof *st));
- cnum nsupers = c_num(length(supers));
+ chk_calloc(1, sizeof *st));
+ val dup_supers = if3(opt_compat && opt_compat <= 242,
+ nil, get_duplicate_supers(supers, self));
+ cnum nsupers = c_num(length(supers), self);
+ cnum ndsupers = c_num(length(dup_supers), self);
struct struct_type **sus = get_struct_handles(nsupers, supers, self);
+ struct struct_type **dsus = get_struct_handles(ndsupers, dup_supers, self);
val id = num_fast(coerce(ucnum, st) / (uptopow2(sizeof *st) / 2));
- val super_slots = get_super_slots(nsupers, sus, self);
+ val super_slots = get_super_slots(nsupers, sus);
val all_slots = uniq(append2(super_slots, append2(static_slots, slots)));
cnum stsl_upb = c_num(plus(length(static_slots),
- num(count_super_stslots(nsupers, sus, self))));
- val stype = cobj(coerce(mem_t *, st), struct_type_s, &struct_type_ops);
+ num(count_super_stslots(nsupers, sus, self))),
+ self);
+ val stype = cobj(coerce(mem_t *, st), struct_type_cls, &struct_type_ops);
val iter;
cnum sl, stsl, i;
struct stslot null_ptr = { nil, 0, 0, nil };
st->self = stype;
st->name = name;
- st->id = c_num(id);
- st->nslots = st->nstslots = 0;
+ st->id = c_num(id, self);
st->slots = all_slots;
st->nsupers = nsupers;
+ st->ndsupers = ndsupers;
st->supers = supers;
- st->stslot = 0;
st->sus = sus;
+ st->dsus = dsus;
st->stinitfun = static_initfun;
st->initfun = initfun;
st->boactor = boactor;
st->postinitfun = default_null_arg(postinitfun);
st->dvtypes = nil;
- st->spslot = 0;
gc_finalize(stype, struct_type_finalize_f, nil);
@@ -438,7 +557,7 @@ val make_struct_type(val name, val supers,
struct stslot *ss = &st->stslot[n];
val key = if2(su, cons(slot, num_fast(su->id)));
val msl = if2(su, gethash(slot_hash, key));
- cnum m = (coerce(cnum, msl) >> TAG_SHIFT) - STATIC_SLOT_BASE;
+ cnum m = c_n(msl) - STATIC_SLOT_BASE;
if (!inherited_p || (opt_compat && opt_compat <= 151)) {
ss->home_type = stype;
@@ -471,6 +590,7 @@ val make_struct_type(val name, val supers,
st->nslots = sl;
st->nstslots = stsl;
static_slot_home_fixup(st);
+ invalidate_special_slots(st);
sethash(struct_type_hash, name, stype);
@@ -504,13 +624,13 @@ val find_struct_type(val sym)
{
uses_or2;
return or2(gethash(struct_type_hash, sym),
- if2(lisplib_try_load(sym),
+ if2(autoload_try_struct(sym),
gethash(struct_type_hash, sym)));
}
val struct_type_p(val obj)
{
- return cobjclassp(obj, struct_type_s);
+ return cobjclassp(obj, struct_type_cls);
}
val struct_get_initfun(val type)
@@ -542,7 +662,7 @@ val struct_set_postinitfun(val type, val fun)
val super(val type, val idx)
{
val self = lit("super");
- cnum ix = c_num(default_arg(idx, zero));
+ cnum ix = c_num(default_arg(idx, zero), self);
if (ix < 0)
uw_throwf(error_s,
@@ -550,15 +670,7 @@ val super(val type, val idx)
self, idx, nao);
{
- struct struct_type *st;
-
- if (structp(type)) {
- struct struct_inst *si = coerce(struct struct_inst *, type->co.handle);
- st = si->type;
- } else {
- st = stype_handle(&type, self);
- }
-
+ struct struct_type *st = stype_handle_obj(&type, self);
return if2(ix < st->nsupers, st->sus[ix]->self);
}
}
@@ -566,6 +678,7 @@ val super(val type, val idx)
static void struct_type_print(val obj, val out, val pretty, struct strm_ctx *c)
{
struct struct_type *st = coerce(struct struct_type *, obj->co.handle);
+ (void) pretty;
(void) c;
format(out, lit("#<struct-type ~s>"), st->name, nao);
}
@@ -576,6 +689,7 @@ static void struct_type_destroy(val obj)
free(st->stslot);
free(st->spslot);
free(st->sus);
+ free(st->dsus);
free(st);
}
@@ -603,28 +717,56 @@ static void struct_type_mark(val obj)
}
}
-static void call_initfun_chain(struct struct_type *st, val strct)
+static void call_initfun_chain(struct struct_type *st, val strct,
+ struct struct_type *root, ucnum *seen)
{
if (st) {
cnum i;
+ if (st != root && st->dupe)
+ for (i = 0; i < root->ndsupers; i++) {
+ if (st == root->dsus[i]) {
+ const int bits_ucnum = sizeof *seen * CHAR_BIT;
+ cnum index = i / bits_ucnum;
+ cnum bit = i % bits_ucnum;
+ ucnum mask = convert(ucnum, 1) << bit;
+ if ((seen[index] & mask) != 0)
+ return;
+ seen[index] |= mask;
+ }
+ }
+
for (i = st->nsupers - 1; i >= 0; i--)
- call_initfun_chain(st->sus[i], strct);
+ call_initfun_chain(st->sus[i], strct, root, seen);
if (st->initfun)
funcall1(st->initfun, strct);
}
}
-static void call_postinitfun_chain(struct struct_type *st, val strct)
+static void call_postinitfun_chain(struct struct_type *st, val strct,
+ struct struct_type *root, ucnum *seen)
{
if (st) {
int derived_first = (opt_compat && opt_compat <= 148);
cnum i;
+ if (st != root && st->dupe)
+ for (i = 0; i < root->ndsupers; i++) {
+ if (st == root->dsus[i]) {
+ const int bits_ucnum = sizeof *seen * CHAR_BIT;
+ cnum index = i / bits_ucnum;
+ cnum bit = i % bits_ucnum;
+ ucnum mask = convert(ucnum, 1) << bit;
+ if ((seen[index] & mask) != 0)
+ return;
+ seen[index] |= mask;
+ }
+ }
+
if (derived_first && st->postinitfun)
funcall1(st->postinitfun, strct);
for (i = st->nsupers - 1; i >= 0; i--)
- call_postinitfun_chain(st->sus[i], strct);
+ call_postinitfun_chain(st->sus[i], strct, root, seen);
if (!derived_first && st->postinitfun)
funcall1(st->postinitfun, strct);
}
@@ -642,18 +784,29 @@ val allocate_struct(val type)
si->lazy = 0;
si->dirty = 1;
bug_unless (type == st->self);
- return cobj(coerce(mem_t *, si), st->name, &struct_inst_ops);
+ return cobj(coerce(mem_t *, si), struct_cls, &struct_inst_ops);
}
+#define alloc_seen(name, size_name) \
+ const int bits_ucnum = sizeof (ucnum) * CHAR_BIT; \
+ size_t nelem_name = (st->ndsupers + bits_ucnum - 1) / bits_ucnum; \
+ size_t size_name = nelem_name * sizeof (ucnum); \
+ ucnum *name ## tmp = coerce(ucnum *, alloca(size_name)); \
+ ucnum *name = (memset(name ## tmp, 0, size_name), name ## tmp)
+
+#define clear_seen(name, size_name) \
+ memset(name, 0, size_name)
+
static val make_struct_impl(val self, val type,
- struct args *plist, struct args *args)
+ varg plist, varg args)
{
struct struct_type *st = stype_handle(&type, self);
- cnum nslots = st->nslots, sl;
+ cnum nslots = st->nslots;
size_t size = offsetof(struct struct_inst, slot) + sizeof (val) * nslots;
- struct struct_inst *si = coerce(struct struct_inst *, chk_malloc(size));
+ struct struct_inst *si = coerce(struct struct_inst *, chk_calloc(1, size));
val sinst;
volatile val inited = nil;
+ alloc_seen (seen, seensz);
if (args_more(args, 0) && !st->boactor) {
free(si);
@@ -662,20 +815,17 @@ static val make_struct_impl(val self, val type,
self, type, nao);
}
- for (sl = 0; sl < nslots; sl++)
- si->slot[sl] = nil;
si->type = st;
si->id = st->id;
- si->lazy = 0;
si->dirty = 1;
- sinst = cobj(coerce(mem_t *, si), st->name, &struct_inst_ops);
+ sinst = cobj(coerce(mem_t *, si), struct_cls, &struct_inst_ops);
bug_unless (type == st->self);
uw_simple_catch_begin;
- call_initfun_chain(st, sinst);
+ call_initfun_chain(st, sinst, st, seen);
{
cnum index = 0;
@@ -693,7 +843,9 @@ static val make_struct_impl(val self, val type,
generic_funcall(st->boactor, args_copy);
}
- call_postinitfun_chain(st, sinst);
+ clear_seen(seen, seensz);
+
+ call_postinitfun_chain(st, sinst, st, seen);
inited = t;
@@ -704,24 +856,26 @@ static val make_struct_impl(val self, val type,
uw_catch_end;
+ gc_hint(type);
+
return sinst;
}
-val make_struct(val type, val plist, struct args *boa)
+val make_struct(val type, val plist, varg boa)
{
args_decl_list(pargs, ARGS_MIN, plist);
return make_struct_impl(lit("make-struct"), type, pargs, boa);
}
-val struct_from_plist(val type, struct args *plist)
+val struct_from_plist(val type, varg plist)
{
- args_decl(boa, 0);
+ args_decl_constsize(boa, ARGS_ABS_MIN);
return make_struct_impl(lit("struct-from-plist"), type, plist, boa);
}
-val struct_from_args(val type, struct args *boa)
+val struct_from_args(val type, varg boa)
{
- args_decl(pargs, 0);
+ args_decl_constsize(pargs, ARGS_ABS_MIN);
return make_struct_impl(lit("struct-from-args"), type, pargs, boa);
}
@@ -732,6 +886,7 @@ static void lazy_struct_init(val sinst, struct struct_inst *si)
volatile val inited = nil;
val cell = funcall(si->slot[0]);
cons_bind (plist, args, cell);
+ alloc_seen (seen, seensz);
si->slot[0] = nil;
@@ -743,7 +898,7 @@ static void lazy_struct_init(val sinst, struct struct_inst *si)
uw_simple_catch_begin;
- call_initfun_chain(st, sinst);
+ call_initfun_chain(st, sinst, st, seen);
for (; plist; plist = cddr(plist))
slotset(sinst, car(plist), cadr(plist));
@@ -753,7 +908,9 @@ static void lazy_struct_init(val sinst, struct struct_inst *si)
generic_funcall(st->boactor, argv);
}
- call_postinitfun_chain(st, sinst);
+ clear_seen(seen, seensz);
+
+ call_postinitfun_chain(st, sinst, st, seen);
inited = t;
@@ -777,22 +934,23 @@ val make_lazy_struct(val type, val argfun)
{
val self = lit("make-lazy-struct");
struct struct_type *st = stype_handle(&type, self);
- cnum nslots = st->nslots, sl;
+ cnum nslots = st->nslots;
cnum nalloc = nslots ? nslots : 1;
size_t size = offsetof(struct struct_inst, slot) + sizeof (val) * nalloc;
- struct struct_inst *si = coerce(struct struct_inst *, chk_malloc(size));
+ struct struct_inst *si = coerce(struct struct_inst *, chk_calloc(1, size));
val sinst;
- for (sl = 0; sl < nslots; sl++)
- si->slot[sl] = nil;
si->type = st;
si->id = st->id;
si->lazy = 1;
+ si->dirty = 1;
- sinst = cobj(coerce(mem_t *, si), st->name, &struct_inst_ops);
+ sinst = cobj(coerce(mem_t *, si), struct_cls, &struct_inst_ops);
bug_unless (type == st->self);
+ gc_hint(type);
+
si->slot[0] = argfun;
return sinst;
@@ -800,7 +958,7 @@ val make_lazy_struct(val type, val argfun)
val make_struct_lit(val type, val plist)
{
- args_decl(args, 0);
+ args_decl_constsize(args, ARGS_ABS_MIN);
val strct;
if (opt_compat && opt_compat <= 154) {
@@ -814,19 +972,11 @@ val make_struct_lit(val type, val plist)
return strct;
}
-static struct struct_inst *struct_handle(val obj, val ctx)
-{
- if (cobjp(obj) && obj->co.ops == &struct_inst_ops)
- return coerce(struct struct_inst *, obj->co.handle);
- uw_throwf(error_s, lit("~a: ~s isn't a structure"),
- ctx, obj, nao);
-}
-
static struct struct_inst *struct_handle_for_slot(val obj, val ctx, val slot)
{
if (cobjp(obj) && obj->co.ops == &struct_inst_ops)
return coerce(struct struct_inst *, obj->co.handle);
- uw_throwf(error_s, lit("~a: attempt to access slot ~s of non-structure ~s"),
+ uw_throwf(type_error_s, lit("~a: attempt to access slot ~s of non-structure ~s"),
ctx, slot, obj, nao);
}
@@ -841,7 +991,7 @@ val copy_struct(val strct)
struct struct_inst *si_copy = coerce(struct struct_inst *, chk_malloc(size));
check_init_lazy_struct(strct, si);
memcpy(si_copy, si, size);
- copy = cobj(coerce(mem_t *, si_copy), st->name, &struct_inst_ops);
+ copy = cobj(coerce(mem_t *, si_copy), struct_cls, &struct_inst_ops);
gc_hint(strct);
return copy;
}
@@ -897,6 +1047,7 @@ val reset_struct(val strct)
cnum i;
volatile val inited = nil;
int compat_190 = opt_compat && opt_compat <= 190;
+ alloc_seen (seen, seensz);
check_init_lazy_struct(strct, si);
@@ -905,10 +1056,12 @@ val reset_struct(val strct)
for (i = 0; i < st->nslots; i++)
si->slot[i] = nil;
- call_initfun_chain(st, strct);
+ call_initfun_chain(st, strct, st, seen);
- if (!compat_190)
- call_postinitfun_chain(st, strct);
+ if (!compat_190) {
+ clear_seen(seen, seensz);
+ call_postinitfun_chain(st, strct, st, seen);
+ }
inited = t;
@@ -970,10 +1123,17 @@ static void cache_set_insert(slot_cache_entry_t *set, cnum id, cnum slot)
static loc lookup_slot(val inst, struct struct_inst *si, val sym)
{
- slot_cache_t slot_cache = sym->s.slot_cache;
+ slot_cache_set_t *slot_cache = sym->s.slot_cache;
cnum id = si->id;
- if (slot_cache != 0) {
+ if (slot_cache == 0) {
+ slot_cache = coerce(slot_cache_set_t *,
+ chk_calloc(SLOT_CACHE_SIZE,
+ sizeof (slot_cache_set_t)));
+ sym->s.slot_cache = slot_cache;
+ }
+
+ {
slot_cache_set_t *set = &slot_cache[id % SLOT_CACHE_SIZE];
cnum slot = cache_set_lookup(*set, id);
@@ -987,7 +1147,7 @@ static loc lookup_slot(val inst, struct struct_inst *si, val sym)
} else {
val key = cons(sym, num_fast(id));
val sl = gethash(slot_hash, key);
- cnum slnum = coerce(cnum, sl) >> TAG_SHIFT;
+ cnum slnum = c_n(sl);
rcyc_cons(key);
@@ -1002,29 +1162,6 @@ static loc lookup_slot(val inst, struct struct_inst *si, val sym)
return mkloc(si->slot[slnum], inst);
}
}
- } else {
- slot_cache = coerce(slot_cache_t,
- chk_calloc(SLOT_CACHE_SIZE,
- sizeof (slot_cache_set_t)));
- slot_cache_set_t *set = &slot_cache[id % SLOT_CACHE_SIZE];
- val key = cons(sym, num_fast(id));
- val sl = gethash(slot_hash, key);
- cnum slnum = coerce(cnum, sl) >> TAG_SHIFT;
-
- sym->s.slot_cache = slot_cache;
-
- rcyc_cons(key);
-
- if (sl) {
- cache_set_insert(*set, id, slnum);
- if (slnum >= STATIC_SLOT_BASE) {
- struct struct_type *st = si->type;
- struct stslot *stsl = &st->stslot[slnum - STATIC_SLOT_BASE];
- return stslot_loc(stsl);
- }
- check_init_lazy_struct(inst, si);
- return mkloc(si->slot[slnum], inst);
- }
}
return nulloc;
@@ -1032,7 +1169,7 @@ static loc lookup_slot(val inst, struct struct_inst *si, val sym)
static struct stslot *lookup_static_slot_desc(struct struct_type *st, val sym)
{
- slot_cache_t slot_cache = sym->s.slot_cache;
+ slot_cache_set_t *slot_cache = sym->s.slot_cache;
cnum id = st->id;
if (slot_cache != 0) {
@@ -1044,7 +1181,7 @@ static struct stslot *lookup_static_slot_desc(struct struct_type *st, val sym)
} else if (slot < 0) {
val key = cons(sym, num_fast(id));
val sl = gethash(slot_hash, key);
- cnum slnum = coerce(cnum, sl) >> TAG_SHIFT;
+ cnum slnum = c_n(sl);
rcyc_cons(key);
@@ -1055,13 +1192,13 @@ static struct stslot *lookup_static_slot_desc(struct struct_type *st, val sym)
}
}
} else {
- slot_cache = coerce(slot_cache_t,
- chk_calloc(SLOT_CACHE_SIZE,
- sizeof (slot_cache_set_t)));
+ slot_cache_set_t *slot_cache = coerce(slot_cache_set_t *,
+ chk_calloc(SLOT_CACHE_SIZE,
+ sizeof *slot_cache));
slot_cache_set_t *set = &slot_cache[id % SLOT_CACHE_SIZE];
val key = cons(sym, num_fast(id));
val sl = gethash(slot_hash, key);
- cnum slnum = coerce(cnum, sl) >> TAG_SHIFT;
+ cnum slnum = c_n(sl);
sym->s.slot_cache = slot_cache;
@@ -1087,7 +1224,7 @@ static loc lookup_slot_load(val inst, struct struct_inst *si, val sym)
{
loc ptr = lookup_slot(inst, si, sym);
if (nullocp(ptr)) {
- lisplib_try_load(sym);
+ autoload_try_slot(sym);
return lookup_slot(inst, si, sym);
}
return ptr;
@@ -1097,7 +1234,7 @@ static loc lookup_static_slot_load(struct struct_type *st, val sym)
{
loc ptr = lookup_static_slot(st, sym);
if (nullocp(ptr)) {
- lisplib_try_load(sym);
+ autoload_try_slot(sym);
return lookup_static_slot(st, sym);
}
return ptr;
@@ -1108,19 +1245,19 @@ static struct stslot *lookup_static_slot_desc_load(struct struct_type *st,
{
struct stslot *stsl = lookup_static_slot_desc(st, sym);
if (stsl == 0) {
- lisplib_try_load(sym);
+ autoload_try_slot(sym);
return lookup_static_slot_desc(st, sym);
}
return stsl;
}
-static noreturn void no_such_slot(val ctx, val type, val slot)
+static NORETURN void no_such_slot(val ctx, val type, val slot)
{
uw_throwf(error_s, lit("~a: ~s has no slot named ~s"),
ctx, type, slot, nao);
}
-static noreturn void no_such_static_slot(val ctx, val type, val slot)
+static NORETURN void no_such_static_slot(val ctx, val type, val slot)
{
uw_throwf(error_s, lit("~a: ~s has no static slot named ~s"),
ctx, type, slot, nao);
@@ -1190,17 +1327,6 @@ val static_slot(val stype, val sym)
no_such_static_slot(self, stype, sym);
}
-static void invalidate_special_slot_nonexistence(struct struct_type *st)
-{
- if (st->spslot != 0) {
- int i;
- for (i = 0; i < num_special_slots; i++) {
- if (st->spslot[i] == coerce(struct stslot *, -1))
- st->spslot[i] = 0;
- }
- }
-}
-
val static_slot_set(val stype, val sym, val newval)
{
val self = lit("static-slot-set");
@@ -1330,6 +1456,7 @@ static val static_slot_ens_rec(val stype, val sym, val newval,
sizeof *st->stslot,
coerce(mem_t *, &null_ptr)));
static_slot_home_fixup_rec(st);
+ invalidate_special_slots(st);
set(mkloc(st->slots, stype), append2(st->slots, cons(sym, nil)));
stsl = &st->stslot[st->nstslots];
@@ -1398,7 +1525,7 @@ val static_slot_home(val stype, val sym)
static val do_super(struct struct_type *st,
val inst, val sym, val self,
- struct args *args)
+ varg args)
{
val type = st->self;
cnum i;
@@ -1433,7 +1560,7 @@ static val do_super(struct struct_type *st,
type, nao);
}
-static val call_super_method(val inst, val sym, struct args *args)
+static val call_super_method(val inst, val sym, varg args)
{
val type = struct_type(inst);
val self = lit("call-super-method");
@@ -1441,7 +1568,7 @@ static val call_super_method(val inst, val sym, struct args *args)
return do_super(st, inst, sym, self, args);
}
-static val call_super_fun(val type, val sym, struct args *args)
+static val call_super_fun(val type, val sym, varg args)
{
val self = lit("call-super-fun");
struct struct_type *st = stype_handle(&type, self);
@@ -1461,7 +1588,7 @@ val static_slot_p(val type, val sym)
if (memq(sym, st->slots)) {
val key = cons(sym, num_fast(st->id));
val sl = gethash(slot_hash, key);
- cnum slnum = coerce(cnum, sl) >> TAG_SHIFT;
+ cnum slnum = c_n(sl);
rcyc_cons(key);
@@ -1492,7 +1619,7 @@ val struct_type(val strct)
val struct_type_name(val stype)
{
- struct struct_type *st = stype_handle(&stype, lit("struct-type-name"));
+ struct struct_type *st = stype_handle_obj(&stype, lit("struct-type-name"));
return st->name;
}
@@ -1532,10 +1659,11 @@ static val method_fun(val env, varg args)
static val method_args_fun(val dargs, varg args)
{
- struct args *da = dargs->a.args;
+ val self = lit("method");
+ varg da = dargs->a.args;
val fun = dargs->a.car;
val strct = dargs->a.cdr;
- cnum da_nargs = da->fill + c_num(length(da->list));
+ cnum da_nargs = da->fill + c_num(length(da->list), self);
args_decl(args_call, max(args->fill + 1 + da_nargs, ARGS_MIN));
args_add(args_call, strct);
args_cat(args_call, da);
@@ -1549,7 +1677,7 @@ val method(val strct, val slotsym)
return func_f0v(cons(slot(strct, slotsym), strct), method_fun);
}
-val method_args(val strct, val slotsym, struct args *args)
+val method_args(val strct, val slotsym, varg args)
{
if (!args_more(args, 0))
return func_f0v(cons(slot(strct, slotsym), strct), method_fun);
@@ -1586,13 +1714,13 @@ val uslot(val slot)
return func_f1(slot, uslot_fun);
}
-static val umethod_fun(val sym, struct args *args)
+static val umethod_fun(val sym, varg args)
{
val self = lit("umethod");
if (!args_more(args, 0)) {
- uw_throwf(error_s, lit("~a: object argument required to call ~s"),
- self, env, nao);
+ uw_throwf(type_error_s, lit("~a: object argument required to call ~s"),
+ self, sym, nao);
} else {
val strct = args_at(args, 0);
@@ -1608,27 +1736,26 @@ static val umethod_fun(val sym, struct args *args)
}
}
-static val umethod_args_fun(val dargs, struct args *args)
+static val umethod_args_fun(val dargs, varg args)
{
val self = lit("umethod");
val sym = dargs->a.car;
- struct args *da = dargs->a.args;
+ varg da = dargs->a.args;
if (!args_more(args, 0)) {
- uw_throwf(error_s, lit("~a: object argument required to call ~s"),
- self, env, nao);
+ uw_throwf(type_error_s, lit("~a: object argument required to call ~s"),
+ self, sym, nao);
} else {
- cnum da_nargs = da->fill + c_num(length(da->list));
+ cnum da_nargs = da->fill + c_num(length(da->list), self);
cnum index = 0;
val strct = args_get(args, &index);
+ struct struct_inst *si = struct_handle_for_slot(strct, self, sym);
args_decl(args_call, max(args->fill + da_nargs, ARGS_MIN));
args_add(args_call, strct);
args_cat(args_call, da);
args_normalize_exact(args_call, da_nargs + 1);
args_cat_zap_from(args_call, args, index);
- struct struct_inst *si = struct_handle_for_slot(strct, self, sym);
-
if (sym && symbolp(sym)) {
loc ptr = lookup_slot(strct, si, sym);
if (!nullocp(ptr))
@@ -1639,7 +1766,7 @@ static val umethod_args_fun(val dargs, struct args *args)
}
}
-val umethod(val slot, struct args *args)
+val umethod(val slot, varg args)
{
if (!args_more(args, 0))
return func_f0v(slot, umethod_fun);
@@ -1740,7 +1867,7 @@ static ucnum struct_inst_hash(val obj, int *count, ucnum seed)
check_init_lazy_struct(obj, si);
for (sl = 0; sl < nslots; sl++) {
- cnum hash = equal_hash(si->slot[sl], count, seed);
+ ucnum hash = equal_hash(si->slot[sl], count, seed);
out += hash;
out &= NUM_MAX;
}
@@ -1839,54 +1966,20 @@ val method_name(val fun)
return nil;
}
-val get_slot_syms(val package, val is_current, val method_only)
-{
- val result_hash = make_hash(nil, nil, nil);
- struct hash_iter sthi;
- val sth_cell;
-
- us_hash_iter_init(&sthi, struct_type_hash);
-
- while ((sth_cell = hash_iter_next(&sthi))) {
- val stype = us_cdr(sth_cell);
- val sl_iter;
- struct struct_type *st = coerce(struct struct_type *, stype->co.handle);
-
- for (sl_iter = st->slots; sl_iter; sl_iter = cdr(sl_iter)) {
- val slot = car(sl_iter);
-
- if (gethash(result_hash, slot))
- continue;
-
- if (!is_current && symbol_package(slot) != package)
- continue;
-
- if (!symbol_visible(package, slot))
- continue;
-
- if (method_only) {
- loc ptr = lookup_static_slot(st, slot);
- if (nullocp(ptr))
- continue;
- if (!functionp(deref(ptr)))
- continue;
- }
-
- sethash(result_hash, slot, t);
- }
- }
-
- return result_hash;
-}
-
val slot_types(val slot)
{
- return gethash(slot_type_hash, slot);
+ uses_or2;
+ return or2(gethash(slot_type_hash, slot),
+ if2(autoload_try_slot(slot),
+ gethash(slot_type_hash, slot)));
}
val static_slot_types(val slot)
{
- return gethash(static_slot_type_hash, slot);
+ uses_or2;
+ return or2(gethash(static_slot_type_hash, slot),
+ if2(autoload_try_slot(slot),
+ gethash(static_slot_type_hash, slot)));
}
val slot_type_reg(val slot, val strct)
@@ -1906,7 +1999,7 @@ val static_slot_type_reg(val slot, val strct)
val typelist = gethash(static_slot_type_hash, slot);
if (!memq(strct, typelist)) {
- sethash(slot_type_hash, slot, cons(strct, typelist));
+ sethash(static_slot_type_hash, slot, cons(strct, typelist));
uw_purge_deferred_warning(cons(slot_s, slot));
}
@@ -1916,10 +2009,24 @@ val static_slot_type_reg(val slot, val strct)
val get_special_slot(val obj, enum special_slot spidx)
{
val slot = *special_sym[spidx];
- if (opt_compat && opt_compat <= 224)
+
+ if (opt_compat && opt_compat <= 224) {
return maybe_slot(obj, slot);
- struct struct_inst *si = coerce(struct struct_inst *, obj->co.handle);
- return get_special_static_slot(si->type, spidx, slot);
+ } else {
+ struct struct_inst *si = coerce(struct struct_inst *, obj->co.handle);
+ return get_special_static_slot(si->type, spidx, slot);
+ }
+}
+
+val get_special_required_slot(val obj, enum special_slot spidx)
+{
+ val content = get_special_slot(obj, spidx);
+ if (content == nil) {
+ val slot = *special_sym[spidx];
+ uw_throwf(error_s, lit("~s is missing required ~s slot"),
+ obj, slot, nao);
+ }
+ return content;
}
val get_special_slot_by_type(val stype, enum special_slot spidx)
diff --git a/struct.h b/struct.h
index 5021c993..7360e772 100644
--- a/struct.h
+++ b/struct.h
@@ -1,4 +1,4 @@
-/* Copyright 2015-2020
+/* Copyright 2015-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,35 +6,40 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
extern val struct_type_s, meth_s, print_s, make_struct_lit_s;
extern val init_k, postinit_k;
extern val slot_s, derived_s;
extern val lambda_set_s;
+extern val iter_begin_s, iter_more_s, iter_item_s, iter_step_s, iter_reset_s;
extern struct cobj_ops struct_inst_ops;
+extern struct cobj_class *struct_cls;
enum special_slot {
equal_m, nullify_m, from_list_m, lambda_m, lambda_set_m,
- length_m, car_m, cdr_m, rplaca_m, rplacd_m,
+ length_m, length_lt_m, car_m, cdr_m, rplaca_m, rplacd_m,
+ iter_begin_m, iter_more_m, iter_item_m, iter_step_m, iter_reset_m,
+ plus_m,
num_special_slots
};
@@ -48,9 +53,9 @@ val struct_set_initfun(val type, val fun);
val struct_get_postinitfun(val type);
val struct_set_postinitfun(val type, val fun);
val super(val type, val idx);
-val make_struct(val type, val plist, struct args *);
-val struct_from_plist(val type, struct args *plist);
-val struct_from_args(val type, struct args *boa);
+val make_struct(val type, val plist, varg );
+val struct_from_plist(val type, varg plist);
+val struct_from_args(val type, varg boa);
val make_lazy_struct(val type, val argfun);
val make_struct_lit(val type, val plist);
val allocate_struct(val type);
@@ -77,17 +82,18 @@ val struct_type(val strct);
val struct_type_name(val stype);
val struct_subtype_p(val sub, val sup);
val method(val strct, val slotsym);
-val method_args(val strct, val slotsym, struct args *);
+val method_args(val strct, val slotsym, varg );
val super_method(val strct, val slotsym);
val uslot(val slot);
-val umethod(val slot, struct args *);
+val umethod(val slot, varg );
val method_name(val fun);
-val get_slot_syms(val package, val is_current, val method_only);
val slot_types(val slot);
val static_slot_types(val slot);
val slot_type_reg(val slot, val strct);
val static_slot_type_reg(val slot, val strct);
val get_special_slot(val obj, enum special_slot spidx);
+val get_special_required_slot(val obj, enum special_slot spidx);
val get_special_slot_by_type(val stype, enum special_slot spidx);
INLINE int obj_struct_p(val obj) { return obj->co.ops == &struct_inst_ops; }
void struct_init(void);
+void struct_compat_fixup(int compat_ver);
diff --git a/strudel.c b/strudel.c
index 5aa4f67e..dc7e48cb 100644
--- a/strudel.c
+++ b/strudel.c
@@ -1,4 +1,4 @@
-/* Copyright 2017-2020
+/* Copyright 2017-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,37 +6,36 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
-#include <stddef.h>
#include <stdio.h>
-#include <stdlib.h>
#include <stdarg.h>
#include <wchar.h>
-#include <signal.h>
#include "config.h"
#include "lib.h"
#include "stream.h"
#include "gc.h"
#include "eval.h"
#include "struct.h"
+#include "buf.h"
#include "strudel.h"
struct strudel_base { /* stru-ct del-egate :) */
@@ -120,20 +119,26 @@ static val strudel_unget_byte(val stream, int byte)
return funcall2(meth, obj, num_fast(byte));
}
-static val strudel_put_buf(val stream, val buf, cnum pos)
+static ucnum strudel_put_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
{
+ val self = lit("put-buf");
struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle);
+ obj_t buf_obj;
+ val buf = init_borrowed_buf(&buf_obj, unum(len), ptr);
val obj = sb->obj;
val meth = slot(obj, put_buf_s);
- return funcall3(meth, obj, buf, num(pos));
+ return c_unum(funcall3(meth, obj, buf, num(pos)), self);
}
-static val strudel_fill_buf(val stream, val buf, cnum pos)
+static ucnum strudel_fill_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
{
+ val self = lit("fill-buf");
struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle);
+ obj_t buf_obj;
+ val buf = init_borrowed_buf(&buf_obj, unum(len), ptr);
val obj = sb->obj;
val meth = slot(obj, fill_buf_s);
- return funcall3(meth, obj, buf, num(pos));
+ return c_unum(funcall3(meth, obj, buf, num(pos)), self);
}
static val strudel_close(val stream, val throw_on_error)
@@ -141,7 +146,7 @@ static val strudel_close(val stream, val throw_on_error)
struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle);
val obj = sb->obj;
val meth = slot(obj, close_s);
- return funcall2(meth, obj, throw_on_error);
+ return funcall2(meth, obj, default_null_arg(throw_on_error));
}
static val strudel_flush(val stream)
@@ -254,7 +259,7 @@ val make_struct_delegate_stream(val target_obj)
val stream;
strm_base_init(&sb->a);
sb->obj = nil;
- stream = cobj(coerce(mem_t *, sb), stream_s, &strudel_ops.cobj_ops);
+ stream = cobj(coerce(mem_t *, sb), stream_cls, &strudel_ops.cobj_ops);
sb->obj = target_obj;
return stream;
}
diff --git a/strudel.h b/strudel.h
index c2da46f9..0571d870 100644
--- a/strudel.h
+++ b/strudel.h
@@ -1,4 +1,4 @@
-/* Copyright 2017-2020
+/* Copyright 2017-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
diff --git a/sysif.c b/sysif.c
index 770ac330..d81bcaa5 100644
--- a/sysif.c
+++ b/sysif.c
@@ -1,4 +1,4 @@
-/* Copyright 2010-2020
+/* Copyright 2010-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,29 +6,33 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
+#define UTF8_DECL_OPENDIR
+#include <stdarg.h>
#include <stddef.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
+#include <dirent.h>
#include <wchar.h>
#include <signal.h>
#include <errno.h>
@@ -85,6 +89,9 @@
#if HAVE_UTIME
#include <utime.h>
#endif
+#if HAVE_RLIMIT
+#include <sys/resource.h>
+#endif
#include "alloca.h"
#include "lib.h"
#include "stream.h"
@@ -96,10 +103,23 @@
#include "eval.h"
#include "args.h"
#include "struct.h"
-#include "arith.h"
#include "itypes.h"
#include "txr.h"
#include "sysif.h"
+#if CONFIG_LARGE_FILE_OFFSET
+#include "arith.h"
+#endif
+
+#ifndef DT_DIR
+#undef DT_UNKNOWN
+#define DT_FIFO 1
+#define DT_CHR 2
+#define DT_DIR 4
+#define DT_BLK 6
+#define DT_REG 8
+#define DT_LNK 10
+#define DT_SOCK 12
+#endif
val stat_s;
val dev_k, ino_k, mode_k, nlink_k, uid_k;
@@ -109,10 +129,16 @@ val dev_s, ino_s, mode_s, nlink_s, uid_s;
val gid_s, rdev_s, size_s, blksize_s, blocks_s;
val atime_s, mtime_s, ctime_s;
val atime_nsec_s, mtime_nsec_s, ctime_nsec_s;
-val path_s;
+val path_s, dir_s, dirent_s;
+
+val child_env_s;
+
+#if HAVE_PWUID || HAVE_GRGID
+val passwd_s;
+#endif
#if HAVE_PWUID
-val passwd_s, gecos_s, dir_s, shell_s;
+val gecos_s, shell_s;
#endif
#if HAVE_GRGID
@@ -132,16 +158,60 @@ val flock_s, type_s, whence_s, start_s, len_s, pid_s;
val dlhandle_s, dlsym_s;
#endif
+val rlim_s, cur_s, max_s;
+static val rlim_st;
+
+struct cobj_class *dir_cls;
+
static val at_exit_list;
+static val dirent_st;
+
+static val env_list, env_hash;
+
static val errno_wrap(val newval)
{
+ val self = lit("errno");
val oldval = num(errno);
if (default_null_arg(newval))
- errno = c_num(newval);
+ errno = c_num(newval, self);
return oldval;
}
+val errno_to_str(int eno)
+{
+#if HAVE_STRERROR_POSIX
+ char buf[128];
+ return strerror_r(eno, buf, sizeof buf) >= 0 ? string_utf8(buf) : nil;
+#elif HAVE_STRERROR_GNU
+ char buf[128];
+ return string_utf8(strerror_r(eno, buf, sizeof buf));
+#else
+ return string_utf8(strerror(eno));
+#endif
+}
+
+static val strerror_wrap(val errnum)
+{
+ val self = lit("strerror");
+ int eno = c_int(errnum, self);
+ return errno_to_str(eno);
+}
+
+#if HAVE_STRSIGNAL
+
+static val strsignal_wrap(val signum)
+{
+ val self = lit("strsignal");
+ int sig = c_int(signum, self);
+ const char *str = strsignal(sig);
+ return if3(str,
+ string_utf8(strsignal(sig)),
+ format(nil, lit("Unknown signal %s"), signum, nao));
+}
+
+#endif
+
#if HAVE_DAEMON
static val daemon_wrap(val nochdir, val noclose)
{
@@ -150,16 +220,19 @@ static val daemon_wrap(val nochdir, val noclose)
}
#endif
-static val exit_wrap(val status)
+val exit_wrap(val status)
{
+ val self = lit("exit");
int stat;
- if (status == nil)
+ if missingp(status)
+ stat = EXIT_SUCCESS;
+ else if (status == nil)
stat = EXIT_FAILURE;
else if (status == t)
stat = EXIT_SUCCESS;
else
- stat = c_num(status);
+ stat = c_num(status, self);
exit(stat);
/* notreached */
@@ -194,16 +267,19 @@ static val abort_wrap(void)
val usleep_wrap(val usec)
{
+ val self = lit("usleep");
val retval;
- cnum u = c_num(usec);
+ cnum u = c_num(usec, self);
sig_save_enable;
#if HAVE_POSIX_NANOSLEEP
- struct timespec ts;
- ts.tv_sec = u / 1000000;
- ts.tv_nsec = (u % 1000000) * 1000;
- retval = if3(nanosleep(&ts, 0) == 0, t, nil);
+ {
+ struct timespec ts;
+ ts.tv_sec = u / 1000000;
+ ts.tv_nsec = (u % 1000000) * 1000;
+ retval = if3(nanosleep(&ts, 0) == 0, t, nil);
+ }
#elif HAVE_POSIX_SLEEP && HAVE_POSIX_USLEEP
retval = if2(sleep(u / 1000000) == 0 &&
usleep(u % 1000000) == 0, t);
@@ -234,20 +310,94 @@ static val getppid_wrap(void)
#endif
-static val env_hash(void)
+val env(void)
{
- val env_strings = env();
- val hash = make_hash(nil, nil, t);
+ if (env_list) {
+ return env_list;
+ } else {
+ list_collect_decl (out, ptail);
+#if HAVE_ENVIRON
+ extern char **environ;
+ char **iter = environ;
+
+ for (; *iter != 0; iter++)
+ ptail = list_collect(ptail, string_utf8(*iter));
+
+ return env_list = out;
+#elif HAVE_GETENVIRONMENTSTRINGS
+ wchar_t *env = GetEnvironmentStringsW();
+ wchar_t *iter = env;
- for (; env_strings; env_strings = cdr(env_strings)) {
- val estr = car(env_strings);
- val eqpos = break_str(estr, lit("="));
- val key = sub(estr, 0, eqpos);
- val val = sub(estr, succ(eqpos), t);
- sethash(hash, key, val);
+ if (iter == 0)
+ oom();
+
+ for (; *iter; iter += wcslen(iter) + 1)
+ ptail = list_collect(ptail, string(iter));
+
+ FreeEnvironmentStringsW(env);
+
+ return env_list = out;
+#else
+ uw_throwf(error_s, lit("environment strings not available"), nao);
+#endif
}
+}
+
+val replace_env(val env_list)
+{
+#if HAVE_ENVIRON && HAVE_SETENV
+ val self = lit("replace-env");
+ extern char **environ;
+ val iter;
+ static char *empty_env[1];
+
+ environ = empty_env;
+
+ for (iter = env_list; iter; iter = cdr(iter)) {
+ const wchar_t *pair = c_str(car(iter), self);
+ char *pair8 = utf8_dup_to(pair);
+ char *eq = strchr(pair8, '=');
+ int res;
+ if (eq != 0) {
+ char *name = chk_substrdup_utf8(pair8, 0, eq - pair8);
+ res = setenv(name, eq + 1, 1);
+ free(name);
+ } else {
+ res = setenv(pair8, "", 1);
+ }
+ free(pair8);
+ if (res < 0)
+ uw_ethrowf(system_error_s, lit("~a: setenv failed: ~d/~s"),
+ self, num(errno), errno_to_str(errno), nao);
+ }
+
+ return env_list;
+#else
+ uw_throwf(error_s, lit("environ mechanism not available"), nao);
+#endif
+}
+
+static val get_env_hash(void)
+{
+ if (env_hash) {
+ return env_hash;
+ } else {
+ val env_strings = env();
+ val hash = make_hash(hash_weak_none, t);
+
+ for (; env_strings; env_strings = cdr(env_strings)) {
+ val estr = car(env_strings);
+ val eqpos = break_str(estr, lit("="));
+ val key = sub(estr, 0, eqpos);
+ val val = sub(estr, succ(eqpos), t);
+ sethash(hash, key, val);
+ }
- return hash;
+ if (!opt_compat || opt_compat > 244)
+ env_hash = hash;
+
+ return hash;
+ }
}
val errno_to_file_error(int err)
@@ -272,15 +422,16 @@ val errno_to_file_error(int err)
#if HAVE_MKDIR
static val mkdir_wrap(val path, val mode)
{
- cnum cmode = c_num(default_arg(mode, num_fast(0777)));
- char *u8path = utf8_dup_to(c_str(path));
+ val self = lit("mkdir");
+ cnum cmode = c_num(default_arg(mode, num_fast(0777)), self);
+ char *u8path = utf8_dup_to(c_str(path, self));
int err = mkdir(u8path, cmode);
free(u8path);
if (err < 0) {
int eno = errno;
- uw_throwf(errno_to_file_error(eno), lit("mkdir ~a: ~d/~s"),
- path, num(eno), string_utf8(strerror(eno)), nao);
+ uw_ethrowf(errno_to_file_error(eno), lit("mkdir ~a: ~d/~s"),
+ path, num(eno), errno_to_str(eno), nao);
}
return t;
@@ -288,23 +439,23 @@ static val mkdir_wrap(val path, val mode)
#elif HAVE_WINDOWS_H
static val mkdir_wrap(val path, val mode)
{
- int err = _wmkdir(c_str(path));
+ int err = _wmkdir(c_str(path, self));
(void) mode;
if (err < 0) {
int eno = errno;
- uw_throwf(errno_to_file_error(eno), lit("mkdir ~a: ~d/~s"),
- path, num(eno), string_utf8(strerror(eno)), nao);
+ uw_ethrowf(errno_to_file_error(eno), lit("mkdir ~a: ~d/~s"),
+ path, num(eno), errno_to_str(eno), nao);
}
return t;
}
#endif
-#if HAVE_CHMOD || HAVE_CHOWN || HAVE_SYS_STAT || HAVE_FILE_STAMP_CHANGE
+#if HAVE_CHMOD || HAVE_CHOWN || HAVE_FCHDIR || HAVE_SYS_STAT || HAVE_FILE_STAMP_CHANGE
static int get_fd(val stream, val self)
{
- val fd_in = if3(integerp(stream), stream, stream_get_prop(stream, fd_k));
+ val fd_in = if3(integerp(stream), stream, stream_fd(stream));
if (stream && !fd_in)
uw_throwf(file_error_s,
@@ -321,10 +472,10 @@ static int get_fd(val stream, val self)
#endif
#if HAVE_SYS_STAT
-static int do_stat(val wpath, struct stat *buf)
+static int do_stat(val wpath, struct stat *buf, val self)
{
if (stringp(wpath)) {
- char *path = utf8_dup_to(c_str(wpath));
+ char *path = utf8_dup_to(c_str(wpath, self));
int res = stat(path, buf);
free(path);
return res;
@@ -336,9 +487,9 @@ static int do_stat(val wpath, struct stat *buf)
}
#ifdef S_IFLNK
-static int do_lstat(val wpath, struct stat *buf)
+static int do_lstat(val wpath, struct stat *buf, val self)
{
- char *path = utf8_dup_to(c_str(wpath));
+ char *path = utf8_dup_to(c_str(wpath, self));
int res = lstat(path, buf);
free(path);
return res;
@@ -349,7 +500,7 @@ static int do_lstat(val wpath, struct stat *buf)
#endif
#if HAVE_MKDIR || HAVE_WINDOWS_H
-static val mkdir_nothrow_exists(val path, val mode)
+static val mkdir_nothrow_exists(val path, val mode, val self)
{
val ret = t;
@@ -368,7 +519,7 @@ static val mkdir_nothrow_exists(val path, val mode)
#if HAVE_SYS_STAT
{
struct stat st;
- int err = do_stat(path, &st);
+ int err = do_stat(path, &st, self);
if (err == 0 && !S_ISDIR(st.st_mode))
ret = num(EEXIST);
}
@@ -388,6 +539,7 @@ static val mkdir_nothrow_exists(val path, val mode)
static val ensure_dir(val path, val mode)
{
+ val self = lit("ensure-dir");
#if HAVE_WINDOWS_H
val sep = lit("\\");
val sep_set = lit("\\/");
@@ -401,20 +553,19 @@ static val ensure_dir(val path, val mode)
for (;;) {
if (length(partial_path) != zero)
- ret = mkdir_nothrow_exists(partial_path, mode);
+ ret = mkdir_nothrow_exists(partial_path, mode, self);
if (!split_path)
break;
- partial_path = format(nil, lit("~a~a~a"),
- partial_path, sep, pop(&split_path), nao);
+ partial_path = scat3(partial_path, sep, pop(&split_path));
}
if (integerp(ret)) {
- int eno = c_num(ret);
- uw_throwf(errno_to_file_error(eno),
- lit("ensure-dir: ~a: ~d/~s"), path, ret,
- string_utf8(strerror(eno)), nao);
+ int eno = c_num(ret, self);
+ uw_ethrowf(errno_to_file_error(eno),
+ lit("ensure-dir: ~a: ~d/~s"), path, ret,
+ errno_to_str(eno), nao);
}
return ret;
@@ -424,14 +575,25 @@ static val ensure_dir(val path, val mode)
#if HAVE_UNISTD_H
static val chdir_wrap(val path)
{
- char *u8path = utf8_dup_to(c_str(path));
- int err = chdir(u8path);
- free(u8path);
+ val self = lit("chdir");
+ int err;
+
+#if HAVE_FCHDIR
+ if (!stringp(path)) {
+ int fd = get_fd(path, self);
+ err = fchdir(fd);
+ } else
+#endif
+ {
+ char *u8path = utf8_dup_to(c_str(path, self));
+ err = chdir(u8path);
+ free(u8path);
+ }
if (err < 0) {
int eno = errno;
- uw_throwf(errno_to_file_error(eno), lit("chdir ~a: ~d/~s"),
- path, num(eno), string_utf8(strerror(eno)), nao);
+ uw_ethrowf(errno_to_file_error(eno), lit("chdir ~a: ~d/~s"),
+ path, num(eno), errno_to_str(eno), nao);
}
return t;
@@ -448,13 +610,13 @@ val getcwd_wrap(void)
int eno = errno;
free(u8buf);
if (eno != ERANGE) {
- uw_throwf(errno_to_file_error(eno), lit("getcwd: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(errno_to_file_error(eno), lit("getcwd: ~d/~s"),
+ num(errno), errno_to_str(errno), nao);
}
if (2 * guess > guess)
guess *= 2;
else
- uw_throwf(file_error_s, lit("getcwd: weird problem"), nao);
+ uw_ethrowf(file_error_s, lit("getcwd: weird problem"), nao);
} else {
val out = string_utf8(u8buf);
free(u8buf);
@@ -465,14 +627,15 @@ val getcwd_wrap(void)
static val rmdir_wrap(val path)
{
- char *u8path = utf8_dup_to(c_str(path));
+ val self = lit("rmdir");
+ char *u8path = utf8_dup_to(c_str(path, self));
int err = rmdir(u8path);
free(u8path);
if (err < 0) {
int eno = errno;
- uw_throwf(errno_to_file_error(eno), lit("rmdir ~a: ~d/~s"),
- path, num(eno), string_utf8(strerror(eno)), nao);
+ uw_ethrowf(errno_to_file_error(eno), lit("rmdir ~a: ~d/~s"),
+ path, num(eno), errno_to_str(eno), nao);
}
return t;
@@ -483,17 +646,20 @@ static val rmdir_wrap(val path)
static val makedev_wrap(val major, val minor)
{
- return num(makedev(c_num(major), c_num(minor)));
+ val self = lit("makedev");
+ return num(makedev(c_num(major, self), c_num(minor, self)));
}
static val minor_wrap(val dev)
{
- return num(minor(c_num(dev)));
+ val self = lit("minor");
+ return num(minor(c_num(dev, self)));
}
static val major_wrap(val dev)
{
- return num(major(c_num(dev)));
+ val self = lit("major");
+ return num(major(c_num(dev, self)));
}
#endif
@@ -502,22 +668,23 @@ static val major_wrap(val dev)
static val mknod_wrap(val path, val mode, val dev)
{
- cnum cmode = c_num(mode);
- cnum cdev = c_num(default_arg(dev, zero));
- char *u8path = utf8_dup_to(c_str(path));
+ val self = lit("mknod");
+ cnum cmode = c_num(mode, self);
+ cnum cdev = c_num(default_arg(dev, zero), self);
+ char *u8path = utf8_dup_to(c_str(path, self));
int err = mknod(u8path, cmode, cdev);
free(u8path);
if (err < 0) {
int eno = errno;
#if HAVE_MAKEDEV
- uw_throwf(errno_to_file_error(eno), lit("mknod ~a ~a ~a (~d:~d): ~d/~s"),
- path, mode, dev, major_wrap(dev), minor_wrap(dev), num(eno),
- string_utf8(strerror(eno)), nao);
+ uw_ethrowf(errno_to_file_error(eno), lit("mknod ~a ~a ~a (~d:~d): ~d/~s"),
+ path, mode, dev, major_wrap(dev), minor_wrap(dev), num(eno),
+ errno_to_str(eno), nao);
#else
- uw_throwf(errno_to_file_error(eno), lit("mknod ~a ~a ~a: ~d/~s"),
- path, mode, dev, num(eno),
- string_utf8(strerror(eno)), nao);
+ uw_ethrowf(errno_to_file_error(eno), lit("mknod ~a ~a ~a: ~d/~s"),
+ path, mode, dev, num(eno),
+ errno_to_str(eno), nao);
#endif
}
@@ -530,16 +697,17 @@ static val mknod_wrap(val path, val mode, val dev)
static val mkfifo_wrap(val path, val mode)
{
- cnum cmode = c_num(mode);
- char *u8path = utf8_dup_to(c_str(path));
+ val self = lit("mkfifo");
+ cnum cmode = c_num(mode, self);
+ char *u8path = utf8_dup_to(c_str(path, self));
int err = mkfifo(u8path, cmode);
free(u8path);
if (err < 0) {
int eno = errno;
- uw_throwf(errno_to_file_error(eno), lit("mknod ~a ~a: ~d/~s"),
- path, mode, num(eno),
- string_utf8(strerror(eno)), nao);
+ uw_ethrowf(errno_to_file_error(eno), lit("mknod ~a ~a: ~d/~s"),
+ path, mode, num(eno),
+ errno_to_str(eno), nao);
}
return t;
@@ -561,11 +729,11 @@ static val chmod_wrap(val target, val mode)
val self = lit("chmod");
cnum cmode = 0;
int err = 0;
- char *u8path = if3(stringp(target), utf8_dup_to(c_str(target)), 0);
+ char *u8path = if3(stringp(target), utf8_dup_to(c_str(target, self)), 0);
int fd = if3(u8path, -1, get_fd(target, self));
if (integerp(mode)) {
- cmode = c_num(mode);
+ cmode = c_num(mode, self);
} else if (stringp(mode)) {
#if HAVE_SYS_STAT
struct stat st;
@@ -579,7 +747,7 @@ static val chmod_wrap(val target, val mode)
err = fstat(fd, &st);
if (err == 0) {
- const wchar_t *cm = c_str(mode);
+ const wchar_t *cm = c_str(mode, self);
wchar_t ch;
mode_t srcm = 0, oldm = st.st_mode;
@@ -713,14 +881,14 @@ inval:
if (err < 0) {
int eno = errno;
val error = errno_to_file_error(eno);
- val errstr = string_utf8(strerror(eno));
+ val errstr = errno_to_str(eno);
if (stringp(mode))
- uw_throwf(error, lit("~a ~a ~a: ~d/~s"),
- self, target, mode, num(eno), errstr, nao);
+ uw_ethrowf(error, lit("~a ~a ~a: ~d/~s"),
+ self, target, mode, num(eno), errstr, nao);
else
- uw_throwf(error, lit("~a ~a #o~o: ~d/~s"),
- self, target, mode, num(eno), errstr, nao);
+ uw_ethrowf(error, lit("~a ~a #o~o: ~d/~s"),
+ self, target, mode, num(eno), errstr, nao);
}
return t;
@@ -732,12 +900,12 @@ inval:
static val do_chown(val target, val uid, val gid, val link_p, val self)
{
- cnum cuid = c_num(uid);
- cnum cgid = c_num(gid);
+ cnum cuid = c_num(uid, self);
+ cnum cgid = c_num(gid, self);
int err;
if (stringp(target)) {
- char *u8path = utf8_dup_to(c_str(target));
+ char *u8path = utf8_dup_to(c_str(target, self));
err = if3(link_p, lchown, chown)(u8path, cuid, cgid);
free(u8path);
} else {
@@ -747,9 +915,9 @@ static val do_chown(val target, val uid, val gid, val link_p, val self)
if (err < 0) {
int eno = errno;
- uw_throwf(errno_to_file_error(eno), lit("~a ~a ~a ~a: ~d/~s"),
- self, target, uid, gid, num(eno),
- string_utf8(strerror(eno)), nao);
+ uw_ethrowf(errno_to_file_error(eno), lit("~a ~a ~a ~a: ~d/~s"),
+ self, target, uid, gid, num(eno),
+ errno_to_str(eno), nao);
}
return t;
@@ -771,8 +939,9 @@ static val lchown_wrap(val target, val uid, val gid)
static val symlink_wrap(val target, val to)
{
- const wchar_t *wtarget = c_str(target);
- const wchar_t *wto = c_str(to);
+ val self = lit("symlink");
+ const wchar_t *wtarget = c_str(target, self);
+ const wchar_t *wto = c_str(to, self);
char *u8target = utf8_dup_to(wtarget);
char *u8to = utf8_dup_to(wto);
int err = symlink(u8target, u8to);
@@ -781,35 +950,54 @@ static val symlink_wrap(val target, val to)
if (err < 0) {
int eno = errno;
- uw_throwf(errno_to_file_error(eno), lit("symlink ~a ~a: ~d/~s"),
- target, to, num(eno), string_utf8(strerror(eno)), nao);
+ uw_ethrowf(errno_to_file_error(eno), lit("symlink ~a ~a: ~d/~s"),
+ target, to, num(eno), errno_to_str(eno), nao);
}
return t;
}
-static val link_wrap(val target, val to)
+static val link_wrap_common(val target, val to, val follow_link, val self)
{
- const wchar_t *wtarget = c_str(target);
- const wchar_t *wto = c_str(to);
+ const wchar_t *wtarget = c_str(target, self);
+ const wchar_t *wto = c_str(to, self);
char *u8target = utf8_dup_to(wtarget);
char *u8to = utf8_dup_to(wto);
+#if HAVE_LINKAT
+ int err = linkat(AT_FDCWD, u8target, AT_FDCWD, u8to,
+ if3(follow_link, AT_SYMLINK_FOLLOW, 0));
+#else
int err = link(u8target, u8to);
+ (void) follow_link;
+#endif
free(u8target);
free(u8to);
if (err < 0) {
int eno = errno;
- uw_throwf(errno_to_file_error(eno), lit("link ~a ~a: ~d/~s"),
- target, to, num(eno), string_utf8(strerror(eno)), nao);
+ uw_ethrowf(errno_to_file_error(eno), lit("link ~a ~a: ~d/~s"),
+ target, to, num(eno), errno_to_str(eno), nao);
}
return t;
}
+static val link_wrap(val target, val to)
+{
+ return link_wrap_common(target, to, nil, lit("link"));
+}
+
+#if HAVE_LINKAT
+static val rlink_wrap(val target, val to)
+{
+ return link_wrap_common(target, to, t, lit("rlink"));
+}
+#endif
+
static val readlink_wrap(val path)
{
- char *u8path = utf8_dup_to(c_str(path));
+ val self = lit("readlink");
+ char *u8path = utf8_dup_to(c_str(path, self));
ssize_t guess = 256;
for (;;) {
@@ -821,12 +1009,12 @@ static val readlink_wrap(val path)
if (2 * guess > guess)
guess *= 2;
else
- uw_throwf(file_error_s, lit("readlink: weird problem"), nao);
+ uw_ethrowf(file_error_s, lit("readlink: weird problem"), nao);
} else if (bytes <= 0) {
int eno = errno;
free(u8buf);
- uw_throwf(errno_to_file_error(eno), lit("readlink ~a: ~d/~s"),
- path, num(eno), string_utf8(strerror(eno)), nao);
+ uw_ethrowf(errno_to_file_error(eno), lit("readlink ~a: ~d/~s"),
+ path, num(eno), errno_to_str(eno), nao);
} else {
val out;
u8buf[bytes] = 0;
@@ -845,11 +1033,11 @@ static void flock_pack(val self, val in, struct flock *out)
{
out->l_type = c_short(slot(in, type_s), self);
out->l_whence = c_short(slot(in, whence_s), self);
- out->l_start = c_num(slot(in, start_s));
- out->l_len = c_num(slot(in, len_s));
+ out->l_start = c_num(slot(in, start_s), self);
+ out->l_len = c_num(slot(in, len_s), self);
}
-static void flock_unpack(val self, val out, struct flock *in)
+static void flock_unpack(val out, struct flock *in)
{
slotset(out, type_s, num(in->l_type));
slotset(out, whence_s, num(in->l_whence));
@@ -889,12 +1077,13 @@ static val fcntl_wrap(val fd_in, val cmd_in, val arg_in)
if (missingp(arg_in)) {
errno = EINVAL;
} else {
- struct flock fl = { 0 };
+ struct flock fl = all_zero_init;
flock_pack(self, arg_in, &fl);
res = fcntl(fd, cmd, &fl);
if (cmd == F_GETLK)
- flock_unpack(self, arg_in, &fl);
+ flock_unpack(arg_in, &fl);
}
+ break;
default:
errno = EINVAL;
break;
@@ -917,69 +1106,79 @@ static val fork_wrap(void)
static val wait_wrap(val pid, val flags)
{
- cnum p = c_num(default_arg(pid, negone));
- cnum f = c_num(default_arg(flags, zero));
+ val self = lit("wait");
+ cnum p = c_num(default_arg(pid, negone), self);
+ cnum f = c_num(default_arg(flags, zero), self);
int status = 0, result = waitpid(p, &status, f);
return if2(result >= 0, cons(num(result), num(status)));
}
static val wifexited(val status)
{
- int s = c_num(if3(consp(status), cdr(status), status));
+ val self = lit("wifexited");
+ int s = c_num(if3(consp(status), cdr(status), status), self);
return tnil(WIFEXITED(s));
}
static val wexitstatus(val status)
{
- int s = c_num(if3(consp(status), cdr(status), status));
+ val self = lit("wexitstatus");
+ int s = c_num(if3(consp(status), cdr(status), status), self);
return num(WEXITSTATUS(s));
}
static val wifsignaled(val status)
{
- int s = c_num(if3(consp(status), cdr(status), status));
+ val self = lit("wifsignaled");
+ int s = c_num(if3(consp(status), cdr(status), status), self);
return tnil(WIFSIGNALED(s));
}
static val wtermsig(val status)
{
- int s = c_num(if3(consp(status), cdr(status), status));
+ val self = lit("wtermsig");
+ int s = c_num(if3(consp(status), cdr(status), status), self);
return num(WTERMSIG(s));
}
#ifdef WCOREDUMP
static val wcoredump(val status)
{
- int s = c_num(if3(consp(status), cdr(status), status));
+ val self = lit("wcoredump");
+ int s = c_num(if3(consp(status), cdr(status), status), self);
return tnil(WCOREDUMP(s));
}
#endif
static val wifstopped(val status)
{
- int s = c_num(if3(consp(status), cdr(status), status));
+ val self = lit("wifstopped");
+ int s = c_num(if3(consp(status), cdr(status), status), self);
return tnil(WIFSTOPPED(s));
}
static val wstopsig(val status)
{
- int s = c_num(if3(consp(status), cdr(status), status));
+ val self = lit("wstopsig");
+ int s = c_num(if3(consp(status), cdr(status), status), self);
return num(WSTOPSIG(s));
}
#ifdef WIFCONTINUED
static val wifcontinued(val status)
{
- int s = c_num(if3(consp(status), cdr(status), status));
+ val self = lit("wifcontinued");
+ int s = c_num(if3(consp(status), cdr(status), status), self);
return tnil(WIFCONTINUED(s));
}
#endif
static val dup_wrap(val old, val neu)
{
+ val self = lit("dupfd");
if (missingp(neu))
- return num(dup(c_num(old)));
- return num(dup2(c_num(old), c_num(neu)));
+ return num(dup(c_num(old, self)));
+ return num(dup2(c_num(old, self), c_num(neu, self)));
}
static val close_wrap(val fd, val throw_on_error)
@@ -989,8 +1188,8 @@ static val close_wrap(val fd, val throw_on_error)
if (res < 0) {
if (default_null_arg(throw_on_error)) {
int eno = errno;
- uw_throwf(errno_to_file_error(eno), lit("close ~a: ~d/~s"),
- fd, num(eno), string_utf8(strerror(eno)), nao);
+ uw_ethrowf(errno_to_file_error(eno), lit("close ~a: ~d/~s"),
+ fd, num(eno), errno_to_str(eno), nao);
}
return nil;
}
@@ -1002,28 +1201,41 @@ val exec_wrap(val file, val args_opt)
{
val self = lit("execvp");
val args = default_null_arg(args_opt);
- int nargs = c_num(length(args)) + 1;
+ int nargs = c_num(length(args), self) + 1;
char **argv = if3(nargs < 0 || nargs == INT_MAX,
(uw_throwf(process_error_s, lit("~a: argument list overflow"),
self, nao), convert(char **, 0)),
coerce(char **, chk_xalloc(nargs + 1, sizeof *argv, self)));
val iter;
- int i;
+ val ch_env = child_env;
+ val save_env = nil;
+ int res, i;
for (i = 0, iter = cons(file, args); iter; i++, iter = cdr(iter)) {
val arg = car(iter);
- argv[i] = utf8_dup_to(c_str(arg));
+ argv[i] = utf8_dup_to(c_str(arg, self));
}
argv[i] = 0;
- if (execvp(argv[0], argv) < 0)
- uw_throwf(process_error_s, lit("~s ~a: ~d/~s"),
- self, file, num(errno), string_utf8(strerror(errno)), nao);
+ if (ch_env != t) {
+ save_env = env();
+ replace_env(ch_env);
+ }
+
+ res = execvp(argv[0], argv);
+
+ if (ch_env != t)
+ replace_env(save_env);
+
+ if (res < 0)
+ uw_ethrowf(process_error_s, lit("~s ~a: ~d/~s"),
+ self, file, num(errno), errno_to_str(errno), nao);
uw_throwf(process_error_s, lit("~s ~a returned"), self, file, nao);
}
static val exit_star_wrap(val status)
{
+ val self = lit("exit*");
int stat;
if (status == nil)
@@ -1031,7 +1243,7 @@ static val exit_star_wrap(val status)
else if (status == t)
stat = EXIT_SUCCESS;
else
- stat = c_num(status);
+ stat = c_num(status, self);
_exit(stat);
/* notreached */
@@ -1040,9 +1252,11 @@ static val exit_star_wrap(val status)
#endif
-time_t c_time(val time)
+time_t c_time(val time, val self)
{
- return if3(convert(time_t, -1) > 0, c_unum(time), c_num(time));
+ return if3(convert(time_t, -1) > 0,
+ convert(time_t, c_unum(time, self)),
+ convert(time_t, c_num(time, self)));
}
val num_time(time_t time)
@@ -1074,10 +1288,10 @@ static val stat_to_list(struct stat st)
nao);
}
-val stat_to_struct(struct stat st, val path)
+val stat_to_struct(struct stat st, val path, val stat_opt)
{
- args_decl(args, ARGS_MIN);
- val strct = make_struct(stat_s, nil, args);
+ args_decl_constsize(args, ARGS_MIN);
+ val strct = default_arg(stat_opt, make_struct(stat_s, nil, args));
slotset(strct, dev_s, num(st.st_dev));
slotset(strct, ino_s, num(st.st_ino));
slotset(strct, mode_s, num(st.st_mode));
@@ -1112,34 +1326,34 @@ val stat_to_struct(struct stat st, val path)
}
#endif
-static val stat_impl(val obj, int (*statfn)(val, struct stat *),
- val name, val path)
+static val stat_impl(val obj, int (*statfn)(val, struct stat *, val),
+ val name, val path, val stat_opt)
{
#if HAVE_SYS_STAT
struct stat st;
- int res = statfn(obj, &st);
+ int res = statfn(obj, &st, name);
if (res == -1) {
int eno = errno;
- uw_throwf(errno_to_file_error(eno), lit("unable to ~a ~a: ~d/~s"),
- name, obj, num(eno), string_utf8(strerror(eno)), nao);
+ uw_ethrowf(errno_to_file_error(eno), lit("unable to ~a ~a: ~d/~s"),
+ name, obj, num(eno), errno_to_str(eno), nao);
}
return if3(opt_compat && opt_compat <= 113,
- stat_to_list(st), stat_to_struct(st, path));
+ stat_to_list(st), stat_to_struct(st, path, stat_opt));
#else
uw_throwf(file_error_s, lit("~a is not implemented"), name, nao);
#endif
}
-val stat_wrap(val path)
+val stat_wrap(val path, val stat_opt)
{
- return stat_impl(path, do_stat, lit("stat"), path);
+ return stat_impl(path, do_stat, lit("stat"), path, stat_opt);
}
-static val lstat_wrap(val path)
+static val lstat_wrap(val path, val stat_opt)
{
- return stat_impl(path, do_lstat, lit("lstat"), path);
+ return stat_impl(path, do_lstat, lit("lstat"), path, stat_opt);
}
#if HAVE_FILE_STAMP_CHANGE
@@ -1158,22 +1372,22 @@ static val do_utimes(val target, val atime, val atimens,
int res = -1;
if (stringp(target)) {
- char *u8path = utf8_dup_to(c_str(target));
+ char *u8path = utf8_dup_to(c_str(target, self));
#if HAVE_FUTIMENS
int flags = if3(symlink_nofollow, AT_SYMLINK_NOFOLLOW, 0);
struct timespec times[2];
- times[0].tv_sec = c_time(atime);
+ times[0].tv_sec = c_time(atime, self);
times[0].tv_nsec = timens(atimens, self);
- times[1].tv_sec = c_time(mtime);
+ times[1].tv_sec = c_time(mtime, self);
times[1].tv_nsec = timens(mtimens, self);
res = utimensat(AT_FDCWD, u8path, times, flags);
#else
errno = -EINVAL;
if (integerp(atimens) || integerp(mtimens)) {
struct timeval times[2];
- times[0].tv_sec = c_time(atime);
+ times[0].tv_sec = c_time(atime, self);
times[0].tv_usec = c_long(trunc(atimens, num_fast(1000)), self);
- times[1].tv_sec = c_time(mtime);
+ times[1].tv_sec = c_time(mtime, self);
times[1].tv_usec = c_long(trunc(mtimens, num_fast(1000)), self);
if (symlink_nofollow) {
#if HAVE_LUTIMES
@@ -1196,9 +1410,9 @@ static val do_utimes(val target, val atime, val atimens,
#if HAVE_FUTIMENS
struct timespec times[2];
int fd = get_fd(target, self);
- times[0].tv_sec = c_time(atime);
+ times[0].tv_sec = c_time(atime, self);
times[0].tv_nsec = timens(atimens, self);
- times[1].tv_sec = c_time(mtime);
+ times[1].tv_sec = c_time(mtime, self);
times[1].tv_nsec = timens(mtimens, self);
res = futimens(fd, times);
#elif HAVE_FUTIMES
@@ -1206,9 +1420,9 @@ static val do_utimes(val target, val atime, val atimens,
int fd = get_fd(target, self);
errno = -EINVAL;
if (integerp(atimens) || integerp(mtimens)) {
- times[0].tv_sec = c_time(atime);
+ times[0].tv_sec = c_time(atime, self);
times[0].tv_usec = c_long(trunc(atimens, num_fast(1000)), self);
- times[1].tv_sec = c_time(mtime);
+ times[1].tv_sec = c_time(mtime, self);
times[1].tv_usec = c_long(trunc(mtimens, num_fast(1000)), self);
res = futimes(fd, times);
}
@@ -1219,21 +1433,21 @@ static val do_utimes(val target, val atime, val atimens,
if (res == -1) {
int eno = errno;
- uw_throwf(errno_to_file_error(eno), lit("~s: failed: ~d/~s"),
- self, num(eno), string_utf8(strerror(eno)), nao);
+ uw_ethrowf(errno_to_file_error(eno), lit("~s: failed: ~d/~s"),
+ self, num(eno), errno_to_str(eno), nao);
}
return t;
}
-static val wrap_utimes(val target, val atime, val atimens,
+static val utimes_wrap(val target, val atime, val atimens,
val mtime, val mtimens)
{
val self = lit("utimes");
return do_utimes(target, atime, atimens, mtime, mtimens, nil, self);
}
-static val wrap_lutimes(val target, val atime, val atimens,
+static val lutimes_wrap(val target, val atime, val atimens,
val mtime, val mtimens)
{
val self = lit("lutimes");
@@ -1245,14 +1459,16 @@ static val wrap_lutimes(val target, val atime, val atimens,
#if HAVE_SYS_STAT
-static val umask_wrap(val mask)
+val umask_wrap(val mask)
{
+ val self = lit("umask");
+
if (missingp(mask)) {
mode_t m = umask(0777);
(void) umask(m);
return num(m);
}
- return num(umask(c_num(mask)));
+ return num(umask(c_num(mask, self)));
}
#endif
@@ -1264,8 +1480,8 @@ static val pipe_wrap(void)
int fd[2];
if (pipe(fd) < 0) {
int eno = errno;
- uw_throwf(errno_to_file_error(eno), lit("pipe failed: ~d/~s"),
- num(eno), string_utf8(strerror(eno)), nao);
+ uw_ethrowf(errno_to_file_error(eno), lit("pipe failed: ~d/~s"),
+ num(eno), errno_to_str(eno), nao);
}
return cons(num(fd[0]), num(fd[1]));
}
@@ -1274,24 +1490,46 @@ static val pipe_wrap(void)
val getenv_wrap(val name)
{
- char *nameu8 = utf8_dup_to(c_str(name));
+ val self = lit("getenv");
+ char *nameu8 = utf8_dup_to(c_str(name, self));
char *lookup = getenv(nameu8);
val result = lookup ? string_utf8(lookup) : nil;
free(nameu8);
+ if (env_hash)
+ sethash(env_hash, name, result);
return result;
}
+#if HAVE_SETENV
+
static val setenv_wrap(val name, val value, val overwrite)
{
- const wchar_t *wname = c_str(name);
- const wchar_t *wvalu = value ? c_str(value) : 0;
+ val self = lit("setenv");
+ const wchar_t *wname = c_str(name, self);
+ const wchar_t *wvalu = value ? c_str(value, self) : 0;
int ovw = default_arg_strict(overwrite, t) != nil;
char *nameu8 = utf8_dup_to(wname);
char *valu8 = wvalu ? utf8_dup_to(wvalu) : 0;
- if (valu8)
+ if (valu8) {
setenv(nameu8, valu8, ovw);
- else if (ovw)
+ env_list = nil;
+
+ if (env_hash) {
+ if (ovw) {
+ sethash(env_hash, name, value);
+ } else {
+ val new_p;
+ val cell = gethash_c(self, env_hash, name, mkcloc(new_p));
+ if (new_p)
+ us_rplacd(cell, value);
+ }
+ }
+ } else if (ovw) {
unsetenv(nameu8);
+ env_list = nil;
+ if (env_hash)
+ remhash(env_hash, name);
+ }
free(valu8);
free(nameu8);
return value;
@@ -1299,46 +1537,54 @@ static val setenv_wrap(val name, val value, val overwrite)
static val unsetenv_wrap(val name)
{
- char *nameu8 = utf8_dup_to(c_str(name));
+ val self = lit("unsetenv");
+ char *nameu8 = utf8_dup_to(c_str(name, self));
unsetenv(nameu8);
free(nameu8);
+ env_list = nil;
+ if (env_hash)
+ remhash(env_hash, name);
return name;
}
+#endif
+
#if HAVE_POLL
static val poll_wrap(val poll_list, val timeout_in)
{
- nfds_t i, len = c_num(length(poll_list));
- val iter;
- struct pollfd *pfd = coerce(struct pollfd *, chk_calloc(len, sizeof *pfd));
+ val self = lit("poll");
+ nfds_t i, len = c_num(length(poll_list), self);
+ seq_iter_t iter;
+ val elem;
+ struct pollfd *pfd = coerce(struct pollfd *, alloca(len * sizeof *pfd));
val timeout = default_arg(timeout_in, negone);
int res;
- for (i = 0, iter = poll_list; iter; iter = cdr(iter), i++) {
- cons_bind (obj, events, car(iter));
+ seq_iter_init(self, &iter, poll_list);
+
+ for (i = 0; seq_get(&iter, &elem); i++) {
+ cons_bind (obj, events, elem);
- pfd[i].events = c_num(events);
+ pfd[i].events = c_num(events, self);
switch (type(obj)) {
case NUM:
- pfd[i].fd = c_num(obj);
+ pfd[i].fd = c_num(obj, self);
break;
case COBJ:
- if (subtypep(obj->co.cls, stream_s)) {
- val fdval = stream_get_prop(obj, fd_k);
+ if (typep(obj, stream_s)) {
+ val fdval = stream_fd(obj);
if (!fdval) {
- free(pfd);
uw_throwf(file_error_s,
lit("poll: stream ~s doesn't have a file descriptor"),
obj, nao);
}
- pfd[i].fd = c_num(fdval);
+ pfd[i].fd = c_num(fdval, self);
break;
}
/* fallthrough */
default:
- free(pfd);
uw_throwf(file_error_s,
lit("poll: ~s isn't a stream or file descriptor"),
obj, nao);
@@ -1346,29 +1592,29 @@ static val poll_wrap(val poll_list, val timeout_in)
}
}
- res = poll(pfd, len, c_num(timeout));
+ sig_save_enable;
- if (res < 0) {
- free(pfd);
- uw_throwf(file_error_s, lit("poll failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
- }
+ res = poll(pfd, len, c_num(timeout, self));
- if (res == 0) {
- free(pfd);
+ sig_restore_enable;
+
+ if (res < 0)
+ uw_ethrowf(file_error_s, lit("poll failed: ~d/~s"),
+ num(errno), errno_to_str(errno), nao);
+
+ if (res == 0)
return nil;
- }
{
list_collect_decl (out, ptail);
- for (i = 0, iter = poll_list; iter; iter = cdr(iter), i++) {
- val pair = car(iter);
+ seq_iter_init(self, &iter, poll_list);
+
+ for (i = 0; seq_get(&iter, &elem); i++) {
if (pfd[i].revents)
- ptail = list_collect(ptail, cons(car(pair), num(pfd[i].revents)));
+ ptail = list_collect(ptail, cons(car(elem), num(pfd[i].revents)));
}
- free(pfd);
return out;
}
}
@@ -1422,40 +1668,44 @@ static val getgroups_wrap(void)
free(arr);
}
- uw_throwf(system_error_s, lit("~s failed: ~d/~s"),
- self, num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(system_error_s, lit("~s failed: ~d/~s"),
+ self, num(errno), errno_to_str(errno), nao);
abort();
}
static val setuid_wrap(val nval)
{
- if (setuid(c_num(nval)) == -1)
- uw_throwf(system_error_s, lit("setuid failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ val self = lit("setuid");
+ if (setuid(c_num(nval, self)) == -1)
+ uw_ethrowf(system_error_s, lit("setuid failed: ~d/~s"),
+ num(errno), errno_to_str(errno), nao);
return t;
}
static val seteuid_wrap(val nval)
{
- if (seteuid(c_num(nval)) == -1)
- uw_throwf(system_error_s, lit("seteuid failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ val self = lit("seteuid");
+ if (seteuid(c_num(nval, self)) == -1)
+ uw_ethrowf(system_error_s, lit("seteuid failed: ~d/~s"),
+ num(errno), errno_to_str(errno), nao);
return t;
}
static val setgid_wrap(val nval)
{
- if (setgid(c_num(nval)) == -1)
- uw_throwf(system_error_s, lit("setgid failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ val self = lit("setgid");
+ if (setgid(c_num(nval, self)) == -1)
+ uw_ethrowf(system_error_s, lit("setgid failed: ~d/~s"),
+ num(errno), errno_to_str(errno), nao);
return t;
}
static val setegid_wrap(val nval)
{
- if (setegid(c_num(nval)) == -1)
- uw_throwf(system_error_s, lit("setegid failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ val self = lit("setegid");
+ if (setegid(c_num(nval, self)) == -1)
+ uw_ethrowf(system_error_s, lit("setegid failed: ~d/~s"),
+ num(errno), errno_to_str(errno), nao);
return t;
}
@@ -1547,6 +1797,8 @@ void drop_privilege(void)
void simulate_setuid_setgid(val open_script)
{
+ val self = lit("txr");
+
if (repress_called != RC_MAGIC || (is_setuid && seteuid(orig_euid) != 0))
abort();
@@ -1554,11 +1806,11 @@ void simulate_setuid_setgid(val open_script)
return;
{
- val fdv = stream_get_prop(open_script, fd_k);
+ val fdv = stream_fd(open_script);
if (fdv) {
struct stat stb;
- cnum fd = c_num(fdv);
+ cnum fd = c_num(fdv, self);
if (fstat(fd, &stb) != 0)
goto drop;
@@ -1586,7 +1838,7 @@ drop:
static val setgroups_wrap(val list)
{
val self = lit("setgroups");
- ucnum len = c_num(length(list));
+ ucnum len = c_num(length(list), self);
if (convert(ucnum, convert(size_t, len)) != len) {
uw_throwf(system_error_s, lit("~a: list too long"), self, nao);
@@ -1595,7 +1847,7 @@ static val setgroups_wrap(val list)
int i = 0, res;
for (; list; i++, list = cdr(list)) {
- cnum gid = c_num(car(list));
+ cnum gid = c_num(car(list), self);
arr[i] = gid;
}
@@ -1604,8 +1856,8 @@ static val setgroups_wrap(val list)
free(arr);
if (res != 0)
- uw_throwf(system_error_s, lit("setgroups failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(system_error_s, lit("setgroups failed: ~d/~s"),
+ num(errno), errno_to_str(errno), nao);
return t;
}
@@ -1619,8 +1871,8 @@ static val getresuid_wrap(void)
{
uid_t r, e, s;
if (getresuid(&r, &e, &s) != 0)
- uw_throwf(system_error_s, lit("getresuid failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(system_error_s, lit("getresuid failed: ~d/~s"),
+ num(errno), errno_to_str(errno), nao);
return list(num(r), num(e), num(s), nao);
}
@@ -1628,24 +1880,26 @@ static val getresgid_wrap(void)
{
gid_t r, e, s;
if (getresgid(&r, &e, &s) != 0)
- uw_throwf(system_error_s, lit("getresgid failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(system_error_s, lit("getresgid failed: ~d/~s"),
+ num(errno), errno_to_str(errno), nao);
return list(num(r), num(e), num(s), nao);
}
static val setresuid_wrap(val r, val e, val s)
{
- if (setresuid(c_num(r), c_num(e), c_num(s)) != 0)
- uw_throwf(system_error_s, lit("setresuid failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ val self = lit("setresuid");
+ if (setresuid(c_num(r, self), c_num(e, self), c_num(s, self)) != 0)
+ uw_ethrowf(system_error_s, lit("setresuid failed: ~d/~s"),
+ num(errno), errno_to_str(errno), nao);
return t;
}
static val setresgid_wrap(val r, val e, val s)
{
- if (setresuid(c_num(r), c_num(e), c_num(s)) != 0)
- uw_throwf(system_error_s, lit("setresuid failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ val self = lit("setresgid");
+ if (setresuid(c_num(r, self), c_num(e, self), c_num(s, self)) != 0)
+ uw_ethrowf(system_error_s, lit("setresuid failed: ~d/~s"),
+ num(errno), errno_to_str(errno), nao);
return t;
}
@@ -1678,7 +1932,7 @@ static void fill_passwd(val to, struct passwd *from)
static val make_pwstruct(struct passwd *p)
{
- args_decl(args, ARGS_MIN);
+ args_decl_constsize(args, ARGS_MIN);
val out = make_struct(passwd_s, nil, args);
fill_passwd(out, p);
return out;
@@ -1699,18 +1953,20 @@ static val getpwent_wrap(void)
static val getpwuid_wrap(val uid)
{
+ val self = lit("getpwuid");
char buf[1024];
struct passwd pw, *p;
- int res = getpwuid_r(c_num(uid), &pw, buf, sizeof buf, &p);
+ int res = getpwuid_r(c_num(uid, self), &pw, buf, sizeof buf, &p);
return (res == 0 && p != 0) ? make_pwstruct(&pw) : nil;
}
static val getpwnam_wrap(val wname)
{
+ val self = lit("getpwnam");
char buf[1024];
struct passwd pw, *p;
- char *name = utf8_dup_to(c_str(wname));
+ char *name = utf8_dup_to(c_str(wname, self));
int res = getpwnam_r(name, &pw, buf, sizeof buf, &p);
free(name);
@@ -1727,13 +1983,15 @@ static val getpwent_wrap(void)
static val getpwuid_wrap(val uid)
{
- struct passwd *p = getpwuid(c_num(uid));
+ val self = lit("getpwuid");
+ struct passwd *p = getpwuid(c_num(uid, self));
return (p != 0) ? make_pwstruct(p) : nil;
}
static val getpwnam_wrap(val wname)
{
- char *name = utf8_dup_to(c_str(wname));
+ val self = lit("getpwnam");
+ char *name = utf8_dup_to(c_str(wname, self));
struct passwd *p = getpwnam(name);
free(name);
return (p != 0) ? make_pwstruct(p) : nil;
@@ -1772,7 +2030,7 @@ static void fill_group(val to, struct group *from)
static val make_grstruct(struct group *g)
{
- args_decl(args, ARGS_MIN);
+ args_decl_constsize(args, ARGS_MIN);
val out = make_struct(group_s, nil, args);
fill_group(out, g);
return out;
@@ -1792,18 +2050,20 @@ static val getgrent_wrap(void)
static val getgrgid_wrap(val uid)
{
+ val self = lit("getgrgid");
char buf[1024];
struct group gr, *g;
- int res = getgrgid_r(c_num(uid), &gr, buf, sizeof buf, &g);
+ int res = getgrgid_r(c_num(uid, self), &gr, buf, sizeof buf, &g);
return (res == 0 && g != 0) ? make_grstruct(&gr) : nil;
}
static val getgrnam_wrap(val wname)
{
+ val self = lit("getgrnam");
char buf[1024];
struct group gr, *g;
- char *name = utf8_dup_to(c_str(wname));
+ char *name = utf8_dup_to(c_str(wname, self));
int res = getgrnam_r(name, &gr, buf, sizeof buf, &g);
free(name);
@@ -1814,13 +2074,14 @@ static val getgrnam_wrap(val wname)
static val getgrgid_wrap(val uid)
{
- struct group *g = getgrgid(c_num(uid));
+ struct group *g = getgrgid(c_num(uid, self));
return (g != 0) ? make_grstruct(g) : nil;
}
static val getgrnam_wrap(val wname)
{
- char *name = utf8_dup_to(c_str(wname));
+ val self = lit("getgrnam");
+ char *name = utf8_dup_to(c_str(wname, self));
struct group *g = getgrnam(name);
free(name);
return (g != 0) ? make_grstruct(g) : nil;
@@ -1830,84 +2091,48 @@ static val getgrnam_wrap(val wname)
#if HAVE_CRYPT || HAVE_CRYPT_R
-static int salt_char_p(wchar_t ch)
-{
- return ((ch >= 'a' && ch <= 'z') ||
- (ch >= 'A' && ch <= 'Z') ||
- (ch >= '0' && ch <= '9') ||
- (ch == '.') || (ch == '/'));
-}
-
-static const wchar_t *validate_salt(const wchar_t *salt)
-{
- const wchar_t *s = salt;
-
- if (salt_char_p(*s)) {
- if (salt_char_p(*++s))
- return salt;
- else
- goto badsalt;
- }
-
- if (*s++ != '$')
- goto badsalt;
-
- switch (*s++) {
- case '1': case '5': case '6':
- break;
- case '2':
- if (*s >= 'a' && *s++ <= 'z')
- break;
- /* fallthrough */
- default:
- goto badsalt;
- }
-
- if (*s++ != '$')
- goto badsalt;
-
- if (wcsncmp(s, L"rounds=", 7) == 0) {
- size_t ispn = wcsspn(s += 7, L"0123456789");
- s += ispn;
- if (*s++ != '$')
- goto badsalt;
- }
-
- while (salt_char_p(*s))
- s++;
-
- if (*s && *s != '$')
- goto badsalt;
-
- return salt;
-
-badsalt:
- errno = EINVAL;
- return 0;
-}
-
static val crypt_wrap(val wkey, val wsalt)
{
- const wchar_t *cwkey = c_str(wkey);
- const wchar_t *cwsalt = validate_salt(c_str(wsalt));
-
- if (cwsalt != 0) {
- char *key = utf8_dup_to(cwkey);
- char *salt = utf8_dup_to(cwsalt);
+ val self = lit("crypt");
+ const wchar_t *cwkey = c_str(wkey, self);
+ const wchar_t *cwsalt = c_str(wsalt, self);
+ char *key = utf8_dup_to(cwkey);
+ char *salt = utf8_dup_to(cwsalt);
#if HAVE_CRYPT_R
- struct crypt_data cd;
- char *hash = (cd.initialized = 0, crypt_r(key, salt, &cd));
+ struct crypt_data *cd = coerce(struct crypt_data *, chk_malloc(sizeof *cd));
+ char *hash = (cd->initialized = 0, crypt_r(key, salt, cd));
#else
- char *hash = crypt(key, salt);
+ char *hash = crypt(key, salt);
+#endif
+
+ free(key);
+ free(salt);
+
+ /* libraries cannot agree on how to report unrecognized or bad hashes:
+ *
+ * - older glibc versions, other libraries return null
+ * - libxcrypt, integrated into newer glibc puts out two
+ * possible failure tokens "*0" or "*1", documenting
+ * that an error token starts with "*" and is less than 13
+ * characters long.
+ * - musl uses "*" and "x", the latter being in the valid hash charset!
+ *
+ * let's go with: null or less than 13 chars means error.
+ */
+ if (hash != 0 && memchr(hash, 0, 13) == 0) {
+ val ret = string_utf8(hash);
+#if HAVE_CRYPT_R
+ free(cd);
#endif
- free(key);
- free(salt);
- if (hash != 0)
- return string_utf8(hash);
+ return ret;
}
- uw_throwf(error_s, lit("crypt failed: ~d/~s"), num(errno),
- string_utf8(strerror(errno)), nao);
+#if HAVE_CRYPT_R
+ free(cd);
+#endif
+
+ uw_ethrowf(error_s, lit("crypt failed: ~d/~s"), num(errno),
+ errno_to_str(errno), nao);
}
#endif
@@ -1963,9 +2188,10 @@ int stdio_fseek(FILE *f, val off, int whence)
#if HAVE_FNMATCH
static val fnmatch_wrap(val pattern, val string, val flags)
{
- const wchar_t *pattern_ws = c_str(pattern);
- const wchar_t *string_ws = c_str(string);
- cnum c_flags = c_num(default_arg(flags, zero));
+ val self = lit("fnmatch");
+ const wchar_t *pattern_ws = c_str(pattern, self);
+ const wchar_t *string_ws = c_str(string, self);
+ cnum c_flags = c_num(default_arg(flags, zero), self);
char *pattern_u8 = utf8_dup_to(pattern_ws);
char *string_u8 = utf8_dup_to(string_ws);
int res = fnmatch(pattern_u8, string_u8, c_flags);
@@ -1985,7 +2211,7 @@ static val fnmatch_wrap(val pattern, val string, val flags)
#if HAVE_UNAME
static val uname_wrap(void)
{
- args_decl(args, ARGS_MIN);
+ args_decl_constsize(args, ARGS_MIN);
struct utsname un;
int res;
if ((res = uname(&un)) >= 0) {
@@ -2000,8 +2226,8 @@ static val uname_wrap(void)
#endif
return out;
}
- uw_throwf(error_s, lit("uname failed: ~d/~s"), num(errno),
- string_utf8(strerror(errno)), nao);
+ uw_ethrowf(error_s, lit("uname failed: ~d/~s"), num(errno),
+ errno_to_str(errno), nao);
}
#endif
@@ -2015,20 +2241,19 @@ static void cptr_dl_destroy_op(val obj)
}
}
-static struct cobj_ops cptr_dl_ops = {
- cobj_equal_handle_op,
- cptr_print_op,
- cptr_dl_destroy_op,
- cobj_mark_op,
- cobj_handle_hash_op
-};
+static struct cobj_ops cptr_dl_ops = cobj_ops_init(cobj_equal_handle_op,
+ cptr_print_op,
+ cptr_dl_destroy_op,
+ cobj_mark_op,
+ cobj_handle_hash_op);
static val dlopen_wrap(val name, val flags)
{
+ val self = lit("dlopen");
const wchar_t *name_ws = if3(null_or_missing_p(name),
- 0, c_str(name));
+ 0, c_str(name, self));
char *name_u8 = if3(name_ws != 0, utf8_dup_to(name_ws), 0);
- cnum f = if3(missingp(flags), RTLD_LAZY, c_num(flags));
+ cnum f = if3(missingp(flags), RTLD_LAZY, c_num(flags, self));
mem_t *ptr = coerce(mem_t *, (dlerror(), dlopen(name_u8, f)));
free(name_u8);
if (ptr == 0) {
@@ -2059,7 +2284,7 @@ static val dlclose_wrap(val cptr)
static val dlsym_wrap(val dlptr, val name)
{
val self = lit("dlsym");
- const wchar_t *name_ws = c_str(name);
+ const wchar_t *name_ws = c_str(name, self);
char *name_u8 = utf8_dup_to(name_ws);
mem_t *dl = cptr_handle(dlptr, dlhandle_s, self);
mem_t *sym = coerce(mem_t *, dlsym(dl, name_u8));
@@ -2071,7 +2296,8 @@ static void dlsym_error(val dlptr, val name, val self)
{
char *err = dlerror();
if (err)
- uw_throwf(error_s, lit("~a: ~a"), self, string_utf8(err), nao);
+ uw_throwf(error_s, lit("~a: while looking up ~a in ~s: ~a"),
+ self, name, dlptr, string_utf8(err), nao);
else
uw_throwf(error_s, lit("~a: ~a not found in ~s"),
self, name, dlptr, nao);
@@ -2094,8 +2320,8 @@ static val dlvsym_wrap(val dlptr, val name, val ver)
if (null_or_missing_p(ver)) {
return dlsym_wrap(dlptr, name);
} else {
- const wchar_t *name_ws = c_str(name);
- const wchar_t *ver_ws = c_str(ver);
+ const wchar_t *name_ws = c_str(name, self);
+ const wchar_t *ver_ws = c_str(ver, self);
char *name_u8 = utf8_dup_to(name_ws);
char *ver_u8 = utf8_dup_to(ver_ws);
mem_t *dl = cptr_handle(dlptr, dlhandle_s, self);
@@ -2121,7 +2347,8 @@ static val dlvsym_checked(val dlptr, val name, val ver)
#if HAVE_REALPATH
static val realpath_wrap(val path)
{
- const wchar_t *path_ws = c_str(path);
+ val self = lit("realpath");
+ const wchar_t *path_ws = c_str(path, self);
char *path_u8 = utf8_dup_to(path_ws);
char *rp_u8 = realpath(path_u8, 0);
val rp = if2(rp_u8, string_utf8(rp_u8));
@@ -2131,9 +2358,189 @@ static val realpath_wrap(val path)
}
#endif
+#if HAVE_ISATTY
+static val isatty_wrap(val spec)
+{
+ val fdval;
+ val self = lit("isatty");
+
+ if (streamp(spec))
+ fdval = stream_get_prop(spec, fd_k);
+ else
+ fdval = spec;
+
+ if (fdval) {
+ int fd = c_int(fdval, self);
+ return if2(fd && isatty(fd) > 0, t);
+ }
+
+ return nil;
+}
+#endif
+
+struct dir {
+ DIR *dir;
+ val path;
+};
+
+static void opendir_free(val obj)
+{
+ struct dir *d = coerce(struct dir *, obj->co.handle);
+ if (d->dir != 0) {
+ closedir(d->dir);
+ d->dir = 0;
+ }
+ free(d);
+}
+
+static void opendir_mark(val obj)
+{
+ struct dir *d = coerce(struct dir *, obj->co.handle);
+ gc_mark(d->path);
+}
+
+static struct cobj_ops opendir_ops = cobj_ops_init(eq,
+ cobj_print_op,
+ opendir_free,
+ opendir_mark,
+ cobj_eq_hash_op);
+static val opendir_wrap(val path, val prefix_p)
+{
+ val self = lit("opendir");
+ DIR *dir = w_opendir(c_str(path, self));
+
+ if (dir == 0) {
+ uw_ethrowf(system_error_s, lit("opendir failed for ~a: ~d/~s"),
+ path, num(errno), errno_to_str(errno), nao);
+ } else {
+ struct dir *d = coerce(struct dir *, chk_malloc(sizeof *d));
+ val obj = cobj(coerce(mem_t *, d), dir_cls, &opendir_ops);
+ d->dir = dir;
+ d->path = if2(default_null_arg(prefix_p), path);
+ return obj;
+ }
+}
+
+static val closedir_wrap(val dirobj)
+{
+ val self = lit("closedir");
+ struct dir *d = coerce(struct dir *, cobj_handle(self, dirobj, dir_cls));
+
+ if (d->dir != 0) {
+ closedir(d->dir);
+ d->dir = 0;
+ return t;
+ }
+
+ return nil;
+}
+
+static val readdir_wrap(val dirobj, val dirent_in)
+{
+ val self = lit("readdir");
+ struct dir *d = coerce(struct dir *, cobj_handle(self, dirobj, dir_cls));
+ struct dirent *dent = if3(d->dir != 0, readdir(d->dir), 0);
+
+ for (;;) {
+ if (dent == 0) {
+ closedir_wrap(dirobj);
+ return nil;
+ } else if (!strcmp(dent->d_name, ".") || !strcmp(dent->d_name, "..")) {
+ dent = readdir(d->dir);
+ continue;
+ } else {
+ args_decl_constsize(args, ARGS_MIN);
+ val dirent = default_arg(dirent_in, make_struct(dirent_st, nil, args));
+ slotset(dirent, name_s,
+ if3(d->path,
+ path_cat(d->path, string_utf8(dent->d_name)),
+ string_utf8(dent->d_name)));
+ slotset(dirent, ino_s, num(dent->d_ino));
+#ifdef _DIRENT_HAVE_D_TYPE
+ slotset(dirent, type_s, num(dent->d_type));
+#else
+ if (dirent_in == dirent)
+ slotset(dirent, type_s, nil);
+#endif
+ return dirent;
+ }
+ }
+}
+
+static val dirstat(val dirent, val dir_path, val stat_opt)
+{
+ val self = lit("dirstat");
+ val name = slot(dirent, name_s);
+ val path = if3(null_or_missing_p(dir_path), name, path_cat(dir_path, name));
+ val stat = lstat_wrap(path, stat_opt);
+ val mode = slot(stat, mode_s);
+
+ if (mode) {
+ cnum mod = c_num(mode, self);
+ val type = nil;
+
+ switch (mod & S_IFMT) {
+ case S_IFBLK: type = num_fast(DT_BLK); break;
+ case S_IFCHR: type = num_fast(DT_CHR); break;
+ case S_IFDIR: type = num_fast(DT_DIR); break;
+ case S_IFIFO: type = num_fast(DT_FIFO); break;
+ case S_IFLNK: type = num_fast(DT_LNK); break;
+ case S_IFREG: type = num_fast(DT_REG); break;
+ case S_IFSOCK: type = num_fast(DT_SOCK); break;
+ }
+
+ if (type)
+ slotset(dirent, type_s, type);
+ }
+
+ return stat;
+}
+
+#if HAVE_RLIMIT
+val getrlimit_wrap(val resource, val rlim_opt)
+{
+ val self = lit("getrlimit");
+ struct rlimit rl;
+ val rlim = rlim_opt;
+ int res = getrlimit(c_int(resource, self), &rl);
+
+ if (res != 0)
+ uw_ethrowf(system_error_s, lit("~a failed for ~a: ~d/~s"),
+ self, resource, num(errno), errno_to_str(errno), nao);
+
+ if (missingp(rlim)) {
+ args_decl_constsize(args, ARGS_MIN);
+ rlim = make_struct(rlim_st, nil, args);
+ }
+
+ slotset(rlim, cur_s, unum(rl.rlim_cur));
+ slotset(rlim, max_s, unum(rl.rlim_max));
+ return rlim;
+}
+
+val setrlimit_wrap(val resource, val rlim)
+{
+ val self = lit("setrlimit");
+ struct rlimit rl;
+
+ rl.rlim_cur = c_unum(slot(rlim, cur_s), self);
+ rl.rlim_max = c_unum(slot(rlim, max_s), self);
+
+ {
+ int res = setrlimit(c_int(resource, self), &rl);
+
+ if (res != 0)
+ uw_ethrowf(system_error_s, lit("~a failed for ~a: ~d/~s"),
+ self, resource, num(errno), errno_to_str(errno), nao);
+ }
+
+ return t;
+}
+#endif
+
void sysif_init(void)
{
- prot1(&at_exit_list);
+ protect(&at_exit_list, &dirent_st, &rlim_st, &env_list, &env_hash, convert(val *, 0));
atexit(at_exit_handler);
@@ -2168,10 +2575,13 @@ void sysif_init(void)
mtime_nsec_s = intern(lit("mtime-nsec"), user_package);
ctime_nsec_s = intern(lit("ctime-nsec"), user_package);
path_s = intern(lit("path"), user_package);
-#if HAVE_PWUID
+ dir_s = intern(lit("dir"), user_package);
+ dirent_s = intern(lit("dirent"), user_package);
+#if HAVE_PWUID || HAVE_GRGID
passwd_s = intern(lit("passwd"), user_package);
+#endif
+#if HAVE_PWUID
gecos_s = intern(lit("gecos"), user_package);
- dir_s = intern(lit("dir"), user_package);
shell_s = intern(lit("shell"), user_package);
#endif
#if HAVE_GRGID
@@ -2195,6 +2605,9 @@ void sysif_init(void)
len_s = intern(lit("len"), user_package);
pid_s = intern(lit("pid"), user_package);
#endif
+ child_env_s = intern(lit("*child-env*"), user_package);
+
+ dir_cls = cobj_register(dir_s);
make_struct_type(stat_s, nil, nil,
list(dev_s, ino_s, mode_s, nlink_s, uid_s, gid_s,
@@ -2259,25 +2672,35 @@ void sysif_init(void)
reg_varl(intern(lit("emfile"), user_package), num_fast(EMFILE));
reg_varl(intern(lit("emlink"), user_package), num_fast(EMLINK));
reg_varl(intern(lit("emsgsize"), user_package), num_fast(EMSGSIZE));
+#ifdef EMULTIHOP
reg_varl(intern(lit("emultihop"), user_package), num_fast(EMULTIHOP));
+#endif
reg_varl(intern(lit("enametoolong"), user_package), num_fast(ENAMETOOLONG));
reg_varl(intern(lit("enetdown"), user_package), num_fast(ENETDOWN));
reg_varl(intern(lit("enetreset"), user_package), num_fast(ENETRESET));
reg_varl(intern(lit("enetunreach"), user_package), num_fast(ENETUNREACH));
reg_varl(intern(lit("enfile"), user_package), num_fast(ENFILE));
reg_varl(intern(lit("enobufs"), user_package), num_fast(ENOBUFS));
+#ifdef ENODATA
reg_varl(intern(lit("enodata"), user_package), num_fast(ENODATA));
+#endif
reg_varl(intern(lit("enodev"), user_package), num_fast(ENODEV));
reg_varl(intern(lit("enoent"), user_package), num_fast(ENOENT));
reg_varl(intern(lit("enoexec"), user_package), num_fast(ENOEXEC));
reg_varl(intern(lit("enolck"), user_package), num_fast(ENOLCK));
+#ifdef ENOLINK
reg_varl(intern(lit("enolink"), user_package), num_fast(ENOLINK));
+#endif
reg_varl(intern(lit("enomem"), user_package), num_fast(ENOMEM));
reg_varl(intern(lit("enomsg"), user_package), num_fast(ENOMSG));
reg_varl(intern(lit("enoprotoopt"), user_package), num_fast(ENOPROTOOPT));
reg_varl(intern(lit("enospc"), user_package), num_fast(ENOSPC));
+#ifdef ENOSR
reg_varl(intern(lit("enosr"), user_package), num_fast(ENOSR));
+#endif
+#ifdef ENOSTR
reg_varl(intern(lit("enostr"), user_package), num_fast(ENOSTR));
+#endif
reg_varl(intern(lit("enosys"), user_package), num_fast(ENOSYS));
reg_varl(intern(lit("enotconn"), user_package), num_fast(ENOTCONN));
reg_varl(intern(lit("enotdir"), user_package), num_fast(ENOTDIR));
@@ -2295,7 +2718,9 @@ void sysif_init(void)
reg_varl(intern(lit("eownerdead"), user_package), num_fast(EOWNERDEAD));
#endif
reg_varl(intern(lit("eperm"), user_package), num_fast(EPERM));
+#ifdef EPIPE
reg_varl(intern(lit("epipe"), user_package), num_fast(EPIPE));
+#endif
reg_varl(intern(lit("eproto"), user_package), num_fast(EPROTO));
reg_varl(intern(lit("eprotonosupport"), user_package), num_fast(EPROTONOSUPPORT));
reg_varl(intern(lit("eprototype"), user_package), num_fast(EPROTOTYPE));
@@ -2304,14 +2729,20 @@ void sysif_init(void)
reg_varl(intern(lit("espipe"), user_package), num_fast(ESPIPE));
reg_varl(intern(lit("esrch"), user_package), num_fast(ESRCH));
reg_varl(intern(lit("estale"), user_package), num_fast(ESTALE));
+#ifdef ETIME
reg_varl(intern(lit("etime"), user_package), num_fast(ETIME));
+#endif
reg_varl(intern(lit("etimedout"), user_package), num_fast(ETIMEDOUT));
reg_varl(intern(lit("etxtbsy"), user_package), num_fast(ETXTBSY));
reg_varl(intern(lit("ewouldblock"), user_package), num_fast(EWOULDBLOCK));
reg_varl(intern(lit("exdev"), user_package), num_fast(EXDEV));
reg_fun(intern(lit("errno"), user_package), func_n1o(errno_wrap, 0));
- reg_fun(intern(lit("exit"), user_package), func_n1(exit_wrap));
+ reg_fun(intern(lit("strerror"), user_package), func_n1o(strerror_wrap, 0));
+#if HAVE_STRSIGNAL
+ reg_fun(intern(lit("strsignal"), user_package), func_n1(strsignal_wrap));
+#endif
+ reg_fun(intern(lit("exit"), user_package), func_n1o(exit_wrap, 0));
reg_fun(intern(lit("at-exit-call"), user_package), func_n1(at_exit_call));
reg_fun(intern(lit("at-exit-do-not-call"), user_package), func_n1(at_exit_do_not_call));
reg_fun(intern(lit("abort"), user_package), func_n0(abort_wrap));
@@ -2324,7 +2755,8 @@ void sysif_init(void)
#endif
reg_fun(intern(lit("env"), user_package), func_n0(env));
- reg_fun(intern(lit("env-hash"), user_package), func_n0(env_hash));
+ reg_fun(intern(lit("replace-env"), user_package), func_n1(replace_env));
+ reg_fun(intern(lit("env-hash"), user_package), func_n0(get_env_hash));
#if HAVE_DAEMON
reg_fun(intern(lit("daemon"), user_package), func_n2(daemon_wrap));
@@ -2368,6 +2800,9 @@ void sysif_init(void)
reg_fun(intern(lit("symlink"), user_package), func_n2(symlink_wrap));
reg_fun(intern(lit("link"), user_package), func_n2(link_wrap));
reg_fun(intern(lit("readlink"), user_package), func_n1(readlink_wrap));
+#if HAVE_LINKAT
+ reg_fun(intern(lit("rlink"), user_package), func_n2(rlink_wrap));
+#endif
#endif
#if HAVE_FCNTL
@@ -2429,16 +2864,16 @@ void sysif_init(void)
#endif
#if HAVE_FILE_STAMP_CHANGE
- reg_fun(intern(lit("utimes"), user_package), func_n5(wrap_utimes));
- reg_fun(intern(lit("lutimes"), user_package), func_n5(wrap_lutimes));
+ reg_fun(intern(lit("utimes"), user_package), func_n5(utimes_wrap));
+ reg_fun(intern(lit("lutimes"), user_package), func_n5(lutimes_wrap));
#endif
{
- val fn = func_n1(stat_wrap);
+ val fn = func_n2o(stat_wrap, 1);
reg_fun(intern(lit("stat"), user_package), fn);
reg_fun(intern(lit("fstat"), user_package), fn);
}
- reg_fun(intern(lit("lstat"), user_package), func_n1(lstat_wrap));
+ reg_fun(intern(lit("lstat"), user_package), func_n2o(lstat_wrap, 1));
#if HAVE_SYS_STAT
#ifndef S_IFSOCK
@@ -2571,8 +3006,11 @@ void sysif_init(void)
reg_fun(intern(lit("pipe"), user_package), func_n0(pipe_wrap));
#endif
reg_fun(intern(lit("getenv"), user_package), func_n1(getenv_wrap));
+#if HAVE_SETENV
reg_fun(intern(lit("setenv"), user_package), func_n3o(setenv_wrap, 2));
reg_fun(intern(lit("unsetenv"), user_package), func_n1(unsetenv_wrap));
+#endif
+ reg_var(child_env_s, t);
#if HAVE_GETEUID
reg_fun(intern(lit("getuid"), user_package), func_n0(getuid_wrap));
@@ -2687,4 +3125,63 @@ void sysif_init(void)
#if HAVE_REALPATH
reg_fun(intern(lit("realpath"), user_package), func_n1(realpath_wrap));
#endif
+
+#if HAVE_ISATTY
+ reg_fun(intern(lit("isatty"), user_package), func_n1(isatty_wrap));
+#endif
+
+ dirent_st = make_struct_type(dirent_s, nil, nil,
+ list(name_s, ino_s, type_s, nao),
+ nil, nil, nil, nil);
+ reg_fun(intern(lit("opendir"), user_package), func_n2o(opendir_wrap, 1));
+ reg_fun(intern(lit("closedir"), user_package), func_n1(closedir_wrap));
+ reg_fun(intern(lit("readdir"), user_package), func_n2o(readdir_wrap, 1));
+ reg_fun(intern(lit("dirstat"), user_package), func_n3o(dirstat, 2));
+
+#ifdef DT_UNKNOWN
+ reg_varl(intern(lit("dt-unknown"), user_package), num_fast(DT_UNKNOWN));
+#endif
+ reg_varl(intern(lit("dt-fifo"), user_package), num_fast(DT_FIFO));
+ reg_varl(intern(lit("dt-chr"), user_package), num_fast(DT_CHR));
+ reg_varl(intern(lit("dt-dir"), user_package), num_fast(DT_DIR));
+ reg_varl(intern(lit("dt-blk"), user_package), num_fast(DT_BLK));
+ reg_varl(intern(lit("dt-reg"), user_package), num_fast(DT_REG));
+ reg_varl(intern(lit("dt-lnk"), user_package), num_fast(DT_LNK));
+ reg_varl(intern(lit("dt-sock"), user_package), num_fast(DT_SOCK));
+
+ rlim_s = intern(lit("rlim"), user_package);
+ cur_s = intern(lit("cur"), user_package);
+ max_s = intern(lit("max"), user_package);
+ rlim_st = make_struct_type(rlim_s, nil, nil,
+ list(cur_s, max_s, nao),
+ nil, nil, nil, nil);
+#if HAVE_RLIMIT
+ reg_fun(intern(lit("getrlimit"), user_package), func_n2o(getrlimit_wrap, 1));
+ reg_fun(intern(lit("setrlimit"), user_package), func_n2(setrlimit_wrap));
+#if CONFIG_LARGE_FILE_OFFSET
+ {
+ val rlim_inf = bignum_dbl_uipt(RLIM_INFINITY);
+ val rlim_smax = if3(RLIM_SAVED_MAX == RLIM_INFINITY,
+ rlim_inf, bignum_dbl_uipt(RLIM_SAVED_MAX));
+ val rlim_scur = if3(RLIM_SAVED_CUR == RLIM_INFINITY,
+ rlim_inf, bignum_dbl_uipt(RLIM_SAVED_CUR));
+ reg_varl(intern(lit("rlim-saved-max"), user_package), rlim_smax);
+ reg_varl(intern(lit("rlim-saved-cur"), user_package), rlim_scur);
+ reg_varl(intern(lit("rlim-infinity"), user_package), rlim_inf);
+ }
+#else
+ reg_varl(intern(lit("rlim-saved-max"), user_package), num_ex(RLIM_SAVED_MAX));
+ reg_varl(intern(lit("rlim-saved-cur"), user_package), num_ex(RLIM_SAVED_CUR));
+ reg_varl(intern(lit("rlim-infinity"), user_package), num_ex(RLIM_INFINITY));
+#endif
+ reg_varl(intern(lit("rlimit-core"), user_package), num_fast(RLIMIT_CORE));
+ reg_varl(intern(lit("rlimit-cpu"), user_package), num_fast(RLIMIT_CPU));
+ reg_varl(intern(lit("rlimit-data"), user_package), num_fast(RLIMIT_DATA));
+ reg_varl(intern(lit("rlimit-fsize"), user_package), num_fast(RLIMIT_FSIZE));
+ reg_varl(intern(lit("rlimit-nofile"), user_package), num_fast(RLIMIT_NOFILE));
+ reg_varl(intern(lit("rlimit-stack"), user_package), num_fast(RLIMIT_STACK));
+#ifdef RLIMIT_AS
+ reg_varl(intern(lit("rlimit-as"), user_package), num_fast(RLIMIT_AS));
+#endif
+#endif
}
diff --git a/sysif.h b/sysif.h
index c2a650c0..40009e83 100644
--- a/sysif.h
+++ b/sysif.h
@@ -1,4 +1,4 @@
-/* Copyright 2013-2020
+/* Copyright 2013-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
extern val stat_s;
@@ -35,21 +36,29 @@ extern val atime_s, mtime_s, ctime_s;
extern val atime_nsec_s, mtime_nsec_s, ctime_nsec_s;
extern val path_s;
+extern val child_env_s;
+#define child_env (deref(lookup_var_l(nil, child_env_s)))
+
val errno_to_file_error(int err);
+val env(void);
+val replace_env(val env_list);
val getenv_wrap(val name);
+val errno_to_str(int err);
+val exit_wrap(val status);
val at_exit_call(val func);
val at_exit_do_not_call(val func);
val usleep_wrap(val usec);
#if HAVE_FORK_STUFF
val exec_wrap(val file, val args_opt);
#endif
-time_t c_time(val time);
+time_t c_time(val time, val self);
val num_time(time_t time);
#if HAVE_SYS_STAT
struct stat;
-val stat_to_struct(struct stat st, val path);
+val stat_to_struct(struct stat st, val path, val stat_opt);
+val umask_wrap(val mask);
#endif
-val stat_wrap(val path);
+val stat_wrap(val path, val stat_opt);
val stdio_ftell(FILE *);
int stdio_fseek(FILE *, val, int whence);
#if HAVE_GETEUID
@@ -64,4 +73,8 @@ INLINE void simulate_setuid_setgid(val open_script) { }
#if HAVE_UNISTD_H
val getcwd_wrap(void);
#endif
+#if HAVE_RLIMIT
+val getrlimit_wrap(val resource, val rlim_opt);
+val setrlimit_wrap(val resource, val rlim);
+#endif
void sysif_init(void);
diff --git a/syslog.c b/syslog.c
index e767ac33..63da504b 100644
--- a/syslog.c
+++ b/syslog.c
@@ -1,4 +1,4 @@
-/* Copyright 2013-2020
+/* Copyright 2013-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stddef.h>
@@ -30,7 +31,6 @@
#include <stdlib.h>
#include <stdarg.h>
#include <wchar.h>
-#include <signal.h>
#include <syslog.h>
#include "config.h"
#include "alloca.h"
@@ -90,12 +90,13 @@ void syslog_init(void)
val openlog_wrap(val wident, val optmask, val facility)
{
+ val self = lit("openlog");
static char *ident;
- cnum coptmask = c_num(default_arg(optmask, zero));
- cnum cfacility = c_num(default_arg(facility, num_fast(LOG_USER)));
+ cnum coptmask = c_num(default_arg(optmask, zero), self);
+ cnum cfacility = c_num(default_arg(facility, num_fast(LOG_USER)), self);
char *old_ident = ident;
- ident = utf8_dup_to(c_str(wident));
+ ident = utf8_dup_to(c_str(wident, self));
openlog(ident, coptmask, cfacility);
@@ -106,14 +107,16 @@ val openlog_wrap(val wident, val optmask, val facility)
val setlogmask_wrap(val mask)
{
- return num(setlogmask(c_num(mask)));
+ val self = lit("setlogmask");
+ return num(setlogmask(c_num(mask, self)));
}
-val syslog_wrapv(val prio, val fmt, struct args *args)
+val syslog_wrapv(val prio, val fmt, varg args)
{
+ val self = lit("syslog");
val text = formatv(nil, fmt, args);
- cnum cprio = c_num(prio);
- char *u8text = utf8_dup_to(c_str(text));
+ cnum cprio = c_num(prio, self);
+ char *u8text = utf8_dup_to(c_str(text, self));
syslog(cprio, "%s", u8text);
return nil;
}
@@ -240,7 +243,7 @@ val make_syslog_stream(val prio)
strm_base_init(&s->a);
s->prio = prio;
s->strstream = nil;
- stream = cobj(coerce(mem_t *, s), stream_s, &syslog_strm_ops.cobj_ops);
+ stream = cobj(coerce(mem_t *, s), stream_cls, &syslog_strm_ops.cobj_ops);
s->strstream = strstream;
return stream;
}
diff --git a/syslog.h b/syslog.h
index 23a03d21..690a4e66 100644
--- a/syslog.h
+++ b/syslog.h
@@ -1,4 +1,4 @@
-/* Copyright 2013-2020
+/* Copyright 2013-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
@@ -41,5 +42,5 @@ val openlog_wrap(val ident, val optmask, val facility);
val closelog_wrap(void);
val setlogmask_wrap(val mask);
val syslog_wrap(val prio, val fmt, val args);
-val syslog_wrapv(val prio, val fmt, struct args *args);
+val syslog_wrapv(val prio, val fmt, varg args);
val make_syslog_stream(val prio);
diff --git a/tags.tl b/tags.tl
deleted file mode 100755
index 1bc1112b..00000000
--- a/tags.tl
+++ /dev/null
@@ -1,194 +0,0 @@
-#!/usr/bin/env txr
-
-(define-option-struct tags-opts nil
- (nil help :bool "List this help text.")
- (a append :bool "Append to existing tags file, without sorting.")
- (m merge :bool "Merge with existing tags file, sorting combined content.")
- (nil exclude (cumul :text) "Skip paths matching glob pattern given \ \
- in TEXT. Multiple patterns can be specified."))
-
-(defstruct tag ()
- ident
- path
- pattern
- (type "?")
-
- (:postinit (me)
- (upd me.ident tostringp))
-
- (:method text (me)
- `@{me.ident}\t@{me.path}\t/^@{me.pattern}$/;"\t@{me.type}`))
-
-(defun escape (str)
- (mappend (do caseql @1
- ((#\^ #\$ #\/) (list #\\ @1))
- (t (list @1)))
- str))
-
-(defstruct file-tag tag
- (:postinit (me)
- (set me.ident (base-name me.path)))
- (:method text (me)
- `@{me.ident}\t@{me.path}\t;"\tF`))
-
-(defstruct fun-tag tag
- (type "f"))
-
-(defstruct var-tag tag
- (type "v"))
-
-(defstruct struct-tag tag
- (type "s"))
-
-(defstruct type-tag tag
- (type "t"))
-
-(defstruct slot-tag tag
- (type "m")
- parent
- expattern
- (:method text (me)
- `@{me.ident}\t@{me.path}\t/^@{me.pattern}$/ \
- @(if me.expattern `;/@(escape me.ident)/`);"\t \
- @{me.type}\tstruct:@{me.parent}`))
-
-(defstruct orig-tag tag
- line
- (:method text (me) me.line))
-
-(defvarl err-ret (gensym))
-
-(defun get-pat (lines form)
- (tree-case (source-loc form)
- ((line . file) (escape [lines line]))))
-
-(defun collect-tags (path)
- (let* ((text (file-get-string path))
- (text (if (starts-with "#!" text) `;@text` text))
- (lines (cons "" (spl #\newline text)))
- (stream (make-string-byte-input-stream text))
- (*rec-source-loc* t))
- (build
- (add (new file-tag
- path path))
- (macrolet ((ntag (type ident : parent pattern-obj)
- ^(new ,type ident ,ident
- path path
- pattern ,*(if pattern-obj
- ^((get-pat lines ,pattern-obj))
- ^((get-pat lines obj)))
- ,*(if parent ^(parent ,parent))
- ,*(if pattern-obj ^(expattern t)))))
- (labels ((process-form (obj)
- (when (consp obj)
- (caseq (car obj)
- ((progn eval-only compile-only with-dyn-lib)
- [mapdo process-form (cdr obj)])
- ((defun defmacro define-place-macro deffi deffi-cb)
- (add (ntag fun-tag (cadr obj))))
- ((defvar defvarl defparm defparml defsymacro)
- (add (ntag var-tag (cadr obj))))
- ((defmeth)
- (add (ntag slot-tag (caddr obj) (cadr obj))))
- ((defplace)
- (tree-bind (op (name . args) . body) obj
- (add (ntag fun-tag name))))
- ((typedef)
- (add (ntag type-tag (cadr obj))))
- ((defpackage)
- (add (ntag struct-tag (cadr obj))))
- ((define-option-struct)
- (let ((struct-name (cadr obj)))
- (add (ntag struct-tag struct-name))
- (each ((obj (cdddr obj)))
- (tree-bind (short long . rest) obj
- (cond
- (long (add (ntag slot-tag long struct-name)))
- (short (add (ntag slot-tag short struct-name))))))))
- ((defstruct)
- (let ((struct-obj obj)
- (struct-name (tree-case (cadr obj)
- ((atom . rest) atom)
- (atom atom))))
- (add (ntag struct-tag struct-name))
- (each ((obj (cdddr obj)))
- (tree-case obj
- ((word name . rest)
- (caseq word
- ((:method :function :static :instance)
- (add (ntag slot-tag name struct-name)))
- (t :)))
- ((word (arg) . body)
- (caseq word
- ((:init :postinit :fini))
- (t :)))
- ((name . rest)
- (add (ntag slot-tag name struct-name)))
- (name
- (add (ntag slot-tag name struct-name struct-obj)))))))))))
- (whilet ((obj (read stream *stderr* err-ret path))
- ((neq obj err-ret)))
- (process-form obj)))))))
-
-(defun write-tagfile (tags o)
- (when o.merge
- (catch
- (let* ((lines (file-get-lines "tags"))
- (orig-tags (collect-each ((line lines))
- (new orig-tag ident (m^ #/[^\t]*/ line)
- line line))))
- (set tags (merge tags orig-tags : .ident)))
- (path-not-found (e))))
- (with-stream (stream (open-file "tags" (if o.append "a" "w")))
- (each ((tag tags))
- (put-line tag.(text) stream))))
-
-(defvarl ftw-actionretval 0)
-(defvarl ftw-continue 0)
-(defvarl ftw-skip-subtree 0)
-
-(defmacro static-when (expr . body)
- (when (eval expr) ^(progn ,*body)))
-
-(compile-only
- (let ((o (new tags-opts)))
- o.(getopts *args*)
- (when o.help
- (put-line "\nUsage:\n")
- (put-line ` @{*load-path*} [options] {file|dir}*\n`)
- (put-line "Directory arguments are recursively searched for *.tl files.")
- (put-line "If no arguments are given, the current directory is searched.")
- o.(opthelp)
- (exit t))
-
- (unless o.out-args
- (push "." o.out-args))
-
- (when (and o.merge o.append)
- (put-line `@{*load-path*}: --append and --merge are mutually exclusive`)
- (exit nil))
-
- (let* ((have-arv (boundp 'ftw-actionretval))
- (excf [apply orf (mapcar (do op fnmatch @@1 @1) o.exclude)])
- (skips ())
- (tags (build
- (ftw o.out-args
- (lambda (path type stat . rest)
- (caseql* type
- (ftw-f (when (and (or (member path o.out-args)
- (ends-with ".tl" path))
- (not [excf path])
- (not [excf (base-name path)])
- (not (some skips (op starts-with @1 path))))
- (pend (ignerr (collect-tags path)))
- ftw-continue))
- (ftw-d (while (and skips (starts-with path (car skips)))
- (pop skips))
- (cond
- ((or [excf path] [excf (base-name path)])
- (static-when (zerop ftw-actionretval)
- (push `@path/` skips))
- ftw-skip-subtree)))
- (t ftw-continue)))
- (logior ftw-phys ftw-actionretval)))))
- (write-tagfile (sort tags : .ident) o))))
diff --git a/termios.c b/termios.c
index 6179f2b5..f1dcbf76 100644
--- a/termios.c
+++ b/termios.c
@@ -1,4 +1,4 @@
-/* Copyright 2016-2020
+/* Copyright 2016-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stdarg.h>
@@ -44,6 +45,9 @@
#include "unwind.h"
#include "stream.h"
#include "struct.h"
+#include "sysif.h"
+#include "txr.h"
+#include "autoload.h"
#include "termios.h"
val termios_s, iflag_s, oflag_s, cflag_s, lflag_s, cc_s, ispeed_s, ospeed_s;
@@ -187,7 +191,7 @@ static speed_t termios_baud_to_speed(cnum baud)
static val termios_unpack(struct termios *in)
{
- args_decl(args, ARGS_MIN);
+ args_decl_constsize(args, ARGS_MIN);
val out = make_struct(termios_s, nil, args);
int i, cc_sz = convert(int, sizeof in->c_cc / sizeof in->c_cc[0]);
val cc = vector(num_fast(cc_sz), nil);
@@ -206,22 +210,22 @@ static val termios_unpack(struct termios *in)
return out;
}
-static void termios_pack(struct termios *out, val in)
+static void termios_pack(struct termios *out, val in, val self)
{
int i, cc_sz = convert(int, sizeof out->c_cc / sizeof out->c_cc[0]);
val cc = slot(in, cc_s);
- out->c_iflag = c_num(slot(in, iflag_s));
- out->c_oflag = c_num(slot(in, oflag_s));
- out->c_cflag = c_num(slot(in, cflag_s));
- out->c_lflag = c_num(slot(in, lflag_s));
+ out->c_iflag = c_num(slot(in, iflag_s), self);
+ out->c_oflag = c_num(slot(in, oflag_s), self);
+ out->c_cflag = c_num(slot(in, cflag_s), self);
+ out->c_lflag = c_num(slot(in, lflag_s), self);
- cfsetispeed(out, termios_baud_to_speed(c_num(slot(in, ispeed_s))));
- cfsetospeed(out, termios_baud_to_speed(c_num(slot(in, ospeed_s))));
+ cfsetispeed(out, termios_baud_to_speed(c_num(slot(in, ispeed_s), self)));
+ cfsetospeed(out, termios_baud_to_speed(c_num(slot(in, ospeed_s), self)));
for (i = 0; i < cc_sz; i++) {
val ch = vecref(cc, num_fast(i));
- cnum c = c_num(ch);
+ cnum c = c_num(ch, self);
out->c_cc[i] = c;
@@ -248,101 +252,108 @@ static val get_fd(val stream)
static val tcgetattr_wrap(val stream)
{
+ val self = lit("tcgetattr");
struct termios tio;
int res;
val fd = get_fd(stream);
- res = tcgetattr(c_num(fd), &tio);
+ res = tcgetattr(c_num(fd, self), &tio);
if (res < 0)
- uw_throwf(system_error_s, lit("tcgetattr failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(system_error_s, lit("~a: failed: ~d/~s"),
+ self, num(errno), errno_to_str(errno), nao);
return termios_unpack(&tio);
}
static val tcsetattr_wrap(val termios, val actions, val stream)
{
+ val self = lit("tcsetattr");
struct termios tio;
int res;
val fd = get_fd(stream);
actions = default_arg(actions, num(TCSADRAIN));
- res = tcgetattr(c_num(fd), &tio);
+ res = tcgetattr(c_num(fd, self), &tio);
if (res < 0)
- uw_throwf(system_error_s, lit("tcgetattr failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(system_error_s, lit("~a: failed to retrieve settings: ~d/~s"),
+ self, num(errno), errno_to_str(errno), nao);
- termios_pack(&tio, termios);
+ termios_pack(&tio, termios, self);
- res = tcsetattr(c_num(fd), c_num(actions), &tio);
+ res = tcsetattr(c_num(fd, self), c_num(actions, self), &tio);
if (res < 0)
- uw_throwf(system_error_s, lit("tcsetattr failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(system_error_s, lit("~a: failed: ~d/~s"),
+ num(errno), errno_to_str(errno), nao);
return termios;
}
static val tcsendbreak_wrap(val duration, val stream)
{
+ val self = lit("tcsendbreak");
val fd = get_fd(stream);
- int res = tcsendbreak(c_num(fd), if3(missingp(duration),
- 500, c_num(duration)));
+ int res = tcsendbreak(c_num(fd, self), if3(missingp(duration),
+ 500, c_num(duration, self)));
if (res < 0)
- uw_throwf(system_error_s, lit("tcsendbreak failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(system_error_s, lit("~a: failed: ~d/~s"),
+ self, num(errno), errno_to_str(errno), nao);
return t;
}
static val tcdrain_wrap(val stream)
{
+ val self = lit("tcdrain");
val fd = get_fd(stream);
- int res = tcdrain(c_num(fd));
+ int res = tcdrain(c_num(fd, self));
if (res < 0)
- uw_throwf(system_error_s, lit("tcdrain failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(system_error_s, lit("~a: failed: ~d/~s"),
+ self, num(errno), errno_to_str(errno), nao);
return t;
}
static val tcflush_wrap(val queue, val stream)
{
+ val self = lit("tcflush");
val fd = get_fd(stream);
- int res = tcflush(c_num(fd), c_num(queue));
+ int res = tcflush(c_num(fd, self), c_num(queue, self));
if (res < 0)
- uw_throwf(system_error_s, lit("tcflush failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(system_error_s, lit("~a: failed: ~d/~s"),
+ self, num(errno), errno_to_str(errno), nao);
return t;
}
static val tcflow_wrap(val action, val stream)
{
+ val self = lit("tcflush");
val fd = get_fd(stream);
- int res = tcflow(c_num(fd), c_num(action));
+ int res = tcflow(c_num(fd, self), c_num(action, self));
if (res < 0)
- uw_throwf(system_error_s, lit("tcflow failed: ~d/~s"),
- num(errno), string_utf8(strerror(errno)), nao);
+ uw_ethrowf(system_error_s, lit("~a: failed: ~d/~s"),
+ self, num(errno), errno_to_str(errno), nao);
return t;
}
static val encode_speeds(val termios)
{
- struct termios tio = { 0 };
+ val self = lit("encode-speeds");
+ struct termios tio = all_zero_init;
- tio.c_iflag = c_num(slot(termios, iflag_s));
- tio.c_cflag = c_num(slot(termios, cflag_s));
- cfsetispeed(&tio, termios_baud_to_speed(c_num(slot(termios, ispeed_s))));
- cfsetospeed(&tio, termios_baud_to_speed(c_num(slot(termios, ospeed_s))));
+ tio.c_iflag = c_num(slot(termios, iflag_s), self);
+ tio.c_cflag = c_num(slot(termios, cflag_s), self);
+ cfsetispeed(&tio, termios_baud_to_speed(c_num(slot(termios, ispeed_s), self)));
+ cfsetospeed(&tio, termios_baud_to_speed(c_num(slot(termios, ospeed_s), self)));
slotset(termios, iflag_s, num(tio.c_iflag));
slotset(termios, cflag_s, num(tio.c_cflag));
@@ -351,16 +362,35 @@ static val encode_speeds(val termios)
static val decode_speeds(val termios)
{
- struct termios tio = { 0 };
+ val self = lit("decode-speeds");
+ struct termios tio = all_zero_init;
- tio.c_cflag = c_num(slot(termios, cflag_s));
- tio.c_iflag = c_num(slot(termios, iflag_s));
+ tio.c_cflag = c_num(slot(termios, cflag_s), self);
+ tio.c_iflag = c_num(slot(termios, iflag_s), self);
slotset(termios, ispeed_s, num(termios_speed_to_baud(cfgetispeed(&tio))));
slotset(termios, ospeed_s, num(termios_speed_to_baud(cfgetospeed(&tio))));
return termios;
}
+static val termios_set_entries(val fun)
+{
+ val slname[] = {
+ lit("set-iflags"), lit("set-oflags"), lit("set-cflags"), lit("set-lflags"),
+ lit("clear-iflags"), lit("clear-oflags"), lit("clear-cflags"), lit("clear-lflags"),
+ lit("go-raw"), lit("go-cbreak"), lit("go-canon"),
+ lit("string-encode"), lit("string-decode"), nil
+ };
+ autoload_set(al_slot, slname, fun);
+ return nil;
+}
+
+static val termios_instantiate(void)
+{
+ load(scat2(stdlib_path, lit("termios")));
+ return nil;
+}
+
void termios_init(void)
{
val termios_t;
@@ -451,13 +481,21 @@ void termios_init(void)
reg_varl(intern(lit("ocrnl"), user_package), num_fast(OCRNL));
reg_varl(intern(lit("onocr"), user_package), num_fast(ONOCR));
reg_varl(intern(lit("onlret"), user_package), num_fast(ONLRET));
+#ifdef OFILL
reg_varl(intern(lit("ofill"), user_package), num_fast(OFILL));
+#endif
#ifdef OFDEL
reg_varl(intern(lit("ofdel"), user_package), num_fast(OFDEL));
#endif
+#ifdef VTDLY
reg_varl(intern(lit("vtdly"), user_package), num_fast(VTDLY));
+#endif
+#ifdef VT0
reg_varl(intern(lit("vt0"), user_package), num_fast(VT0));
+#endif
+#ifdef VT1
reg_varl(intern(lit("vt1"), user_package), num_fast(VT1));
+#endif
#ifdef NLDLY
reg_varl(intern(lit("nldly"), user_package), num_fast(NLDLY));
reg_varl(intern(lit("nl0"), user_package), num_fast(NL0));
@@ -472,9 +510,17 @@ void termios_init(void)
#endif
#ifdef TABDLY
reg_varl(intern(lit("tabdly"), user_package), num_fast(TABDLY));
+#endif
+#ifdef TAB0
reg_varl(intern(lit("tab0"), user_package), num_fast(TAB0));
+#endif
+#ifdef TAB1
reg_varl(intern(lit("tab1"), user_package), num_fast(TAB1));
+#endif
+#ifdef TAB2
reg_varl(intern(lit("tab2"), user_package), num_fast(TAB2));
+#endif
+#ifdef TAB3
reg_varl(intern(lit("tab3"), user_package), num_fast(TAB3));
#endif
#ifdef BSDLY
@@ -506,10 +552,10 @@ void termios_init(void)
reg_varl(intern(lit("cbaudex"), user_package), num_fast(CBAUDEX));
#endif
#ifdef CMSPAR
- reg_varl(intern(lit("cmspar"), user_package), num_fast(CMSPAR));
+ reg_varl(intern(lit("cmspar"), user_package), num(CMSPAR));
#endif
#ifdef CRTSCTS
- reg_varl(intern(lit("crtscts"), user_package), num_fast(CRTSCTS));
+ reg_varl(intern(lit("crtscts"), user_package), num(CRTSCTS));
#endif
/* lflag bits */
reg_varl(intern(lit("isig"), user_package), num_fast(ISIG));
@@ -557,4 +603,6 @@ void termios_init(void)
reg_varl(intern(lit("tcsanow"), user_package), num_fast(TCSANOW));
reg_varl(intern(lit("tcsadrain"), user_package), num_fast(TCSADRAIN));
reg_varl(intern(lit("tcsaflush"), user_package), num_fast(TCSAFLUSH));
+
+ autoload_reg(termios_instantiate, termios_set_entries);
}
diff --git a/termios.h b/termios.h
index 5fd8b2ea..7dcc70e8 100644
--- a/termios.h
+++ b/termios.h
@@ -1,4 +1,4 @@
-/* Copyright 2016-2020
+/* Copyright 2016-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
void termios_init(void);
diff --git a/tests/000/binding.expected b/tests/000/binding.expected
new file mode 100644
index 00000000..9e5303f0
--- /dev/null
+++ b/tests/000/binding.expected
@@ -0,0 +1,6 @@
+x="1"
+y="2"
+z[0]="1"
+z[1]="2"
+a="1"
+b="0"
diff --git a/tests/000/binding.txr b/tests/000/binding.txr
new file mode 100644
index 00000000..95faa20d
--- /dev/null
+++ b/tests/000/binding.txr
@@ -0,0 +1,5 @@
+@(bind x 1)
+@(bind y 2)
+@(rebind z (x y))
+@(bind (a b) (0 1))
+@(rebind (a b) (b a))
diff --git a/tests/000/nilvar.expected b/tests/000/nilvar.expected
new file mode 100644
index 00000000..70985094
--- /dev/null
+++ b/tests/000/nilvar.expected
@@ -0,0 +1 @@
+a:c
diff --git a/tests/000/nilvar.txr b/tests/000/nilvar.txr
new file mode 100644
index 00000000..a6d1391c
--- /dev/null
+++ b/tests/000/nilvar.txr
@@ -0,0 +1,3 @@
+@(next :string "a !b c")
+@(coll)@(cases)@{nil /!\S+/}@(or)@{var /\S+/}@(end)@(end)
+@(do (put-line (join-with ":" var)))
diff --git a/tests/002/query-1.txr b/tests/002/query-1.txr
index 0b4eced2..4bd6c97f 100644
--- a/tests/002/query-1.txr
+++ b/tests/002/query-1.txr
@@ -1,3 +1,5 @@
+@(do (unless (path-executable-to-me-p "/bin/sh")
+ (exit 13)))
@(next `!ls @TESTDIR/proc | sort -n`)
@(collect)
@{process /[0-9]+/}
diff --git a/tests/006/freeform-4.expected b/tests/006/freeform-4.expected
new file mode 100644
index 00000000..62857f54
--- /dev/null
+++ b/tests/006/freeform-4.expected
@@ -0,0 +1,26 @@
+###
+FF:
+1
+2
+ /FF
+
+X, Y : 1 2
+
+###
+FF:
+3
+4
+ /FF
+
+X, Y : 3 4
+
+X[0]="1"
+X[1]="3"
+Y[0]="2"
+Y[1]="4"
+FF[0]="1\
+2\
+"
+FF[1]="3\
+4\
+"
diff --git a/tests/006/freeform-4.txr b/tests/006/freeform-4.txr
new file mode 100644
index 00000000..328626eb
--- /dev/null
+++ b/tests/006/freeform-4.txr
@@ -0,0 +1,20 @@
+@(next :list '("1" "2" "3" "4"))
+@(collect)
+@ (all)
+@X
+@Y
+@ (and)
+@ (freeform 2)
+@FF
+@ (end)
+@(end)
+@(output)
+@ (repeat)
+###
+FF:
+@FF /FF
+
+X, Y : @X @Y
+
+@ (end)
+@(end)
diff --git a/tests/006/freeform-5.expected b/tests/006/freeform-5.expected
new file mode 100644
index 00000000..99433ca3
--- /dev/null
+++ b/tests/006/freeform-5.expected
@@ -0,0 +1,4 @@
+bar="BAR"
+zzy="ZZY"
+next="NEXT"
+nextnext="NEXTNEXT"
diff --git a/tests/006/freeform-5.txr b/tests/006/freeform-5.txr
new file mode 100644
index 00000000..f1ec48c8
--- /dev/null
+++ b/tests/006/freeform-5.txr
@@ -0,0 +1,7 @@
+@(next :list (append (repeat (list (mkstring 99 #\A)) 100)
+ '("FOOBARXYZZY" "NEXT" "NEXTNEXT")))
+@(freeform)
+@(skip)FOO@{bar}XY
+@zzy
+@next
+@nextnext
diff --git a/tests/007/except-3.expected b/tests/007/except-3.expected
new file mode 100644
index 00000000..257cc564
--- /dev/null
+++ b/tests/007/except-3.expected
@@ -0,0 +1 @@
+foo
diff --git a/tests/007/except-3.txr b/tests/007/except-3.txr
new file mode 100644
index 00000000..f672c7d2
--- /dev/null
+++ b/tests/007/except-3.txr
@@ -0,0 +1,3 @@
+@(next (open-command "echo foo; kill -KILL $$") :nothrow)
+@a
+@(do (put-line a))
diff --git a/tests/007/except-4.expected b/tests/007/except-4.expected
new file mode 100644
index 00000000..5716ca59
--- /dev/null
+++ b/tests/007/except-4.expected
@@ -0,0 +1 @@
+bar
diff --git a/tests/007/except-4.txr b/tests/007/except-4.txr
new file mode 100644
index 00000000..50c85539
--- /dev/null
+++ b/tests/007/except-4.txr
@@ -0,0 +1,8 @@
+@(include "../common")
+@(try)
+@(next (open-command "echo foo; kill -KILL $$"))
+@a
+@(catch)
+@(bind a "bar")
+@(end)
+@(do (put-line a))
diff --git a/tests/008/call-2.txr b/tests/008/call-2.txr
new file mode 100644
index 00000000..10257f62
--- /dev/null
+++ b/tests/008/call-2.txr
@@ -0,0 +1,6 @@
+@(define foo (var))
+@var
+@(end)
+@(next :list '("A" "B"))
+@(call (quote foo) "A")
+@(call (quote foo) "B")
diff --git a/tests/008/call.expected b/tests/008/call.expected
new file mode 100644
index 00000000..f644dfc5
--- /dev/null
+++ b/tests/008/call.expected
@@ -0,0 +1,2 @@
+correct
+1
diff --git a/tests/008/call.txr b/tests/008/call.txr
new file mode 100644
index 00000000..0cbb39f6
--- /dev/null
+++ b/tests/008/call.txr
@@ -0,0 +1,13 @@
+@(next :list '("1"))
+@(define match1 (A))
+@ (all)
+1
+@ (and)
+@A
+@ (end)
+@(end)
+@(call 'match1 A)
+@(output)
+correct
+@A
+@(end)
diff --git a/tests/008/mdo.txr b/tests/008/mdo.txr
new file mode 100644
index 00000000..dbc8b50c
--- /dev/null
+++ b/tests/008/mdo.txr
@@ -0,0 +1,7 @@
+@(mdo (defvar a))
+@(mdo (push 1 a))
+@(define foo)
+@ (mdo (push 2 a))
+@(end)
+@(foo)
+@(do (assert (equal a '(2 1))))
diff --git a/tests/008/no-stdin-hang.txr b/tests/008/no-stdin-hang.txr
new file mode 100644
index 00000000..4b29f021
--- /dev/null
+++ b/tests/008/no-stdin-hang.txr
@@ -0,0 +1,5 @@
+@(define foo (var))
+@(next :list '("a"))
+@var
+@(end)
+@(foo x)
diff --git a/tests/008/repeat.expected b/tests/008/repeat.expected
new file mode 100644
index 00000000..495d096a
--- /dev/null
+++ b/tests/008/repeat.expected
@@ -0,0 +1,3 @@
+1 3 a
+2 3 b
+3 3 c
diff --git a/tests/008/repeat.txr b/tests/008/repeat.txr
new file mode 100644
index 00000000..dba54831
--- /dev/null
+++ b/tests/008/repeat.txr
@@ -0,0 +1,6 @@
+@(bind a ("a" "b" "c"))
+@(output)
+@(repeat :counter (i 1) :vars ((x (len a))))
+@i @x @a
+@(end)
+@(end)
diff --git a/tests/009/json.expected b/tests/009/json.expected
index 6330a595..e9d2e644 100644
--- a/tests/009/json.expected
+++ b/tests/009/json.expected
@@ -1,54 +1,54 @@
-AST: #H(() ("web-app" #H(() ("servlet" #(#H(() ("servlet-name" "cofaxCDS") ("servlet-class" "org.cofax.cds.CDSServlet")
- ("init-param" #H(() ("dataStoreName" "cofax") ("cachePagesRefresh" 10.0) ("defaultListTemplate" "listTemplate.htm")
- ("useJSP" :false) ("cachePagesDirtyRead" 10.0) ("useDataStore" :true)
- ("cachePagesTrack" 200.0) ("dataStoreMaxConns" 100.0) ("cachePackageTagsStore" 200.0)
- ("configGlossary:poweredBy" "Cofax") ("dataStoreInitConns" 10.0)
- ("dataStorePassword" "dataStoreTestQuery") ("templateLoaderClass" "org.cofax.FilesTemplateLoader")
- ("configGlossary:poweredByIcon" "/images/cofax.gif") ("dataStoreTestQuery" "SET NOCOUNT ON;select test='test';")
- ("dataStoreConnUsageLimit" 100.0) ("dataStoreUrl" "jdbc:microsoft:sqlserver://LOCALHOST:1433;DatabaseName=goon")
- ("redirectionClass" "org.cofax.SqlRedirection") ("dataStoreUser" "sa")
- ("jspListTemplate" "listTemplate.jsp") ("configGlossary:adminEmail" "ksm@pobox.com")
- ("cacheTemplatesTrack" 100.0) ("defaultFileTemplate" "articleTemplate.htm")
- ("templateOverridePath" "") ("cachePagesStore" 100.0) ("templatePath" "templates")
- ("configGlossary:installationAt" "Philadelphia, PA") ("dataStoreClass" "org.cofax.SqlDataStore")
- ("cachePackageTagsTrack" 200.0) ("jspFileTemplate" "articleTemplate.jsp")
- ("dataStoreLogFile" "/usr/local/tomcat/logs/datastore.log") ("cacheTemplatesRefresh" 15.0)
- ("cacheTemplatesStore" 50.0) ("searchEngineRobotsDb" "WEB-INF/robots.db")
- ("templateProcessorClass" "org.cofax.WysiwygTemplate") ("dataStoreDriver" "com.microsoft.jdbc.sqlserver.SQLServerDriver")
- ("dataStoreLogLevel" "debug") ("cachePackageTagsRefresh" 60.0)
- ("configGlossary:staticPath" "/content/static") ("maxUrlLength" 500.0)
- ("searchEngineFileTemplate" "forSearchEngines.htm") ("searchEngineListTemplate" "forSearchEnginesList.htm"))))
- #H(() ("servlet-name" "cofaxEmail") ("servlet-class" "org.cofax.cds.EmailServlet")
- ("init-param" #H(() ("mailHost" "mail1") ("mailHostOverride" "mail2"))))
- #H(() ("servlet-name" "cofaxAdmin") ("servlet-class" "org.cofax.cds.AdminServlet"))
- #H(() ("servlet-name" "fileServlet") ("servlet-class" "org.cofax.cds.FileServlet"))
- #H(() ("servlet-name" "cofaxTools") ("servlet-class" "org.cofax.cms.CofaxToolsServlet")
- ("init-param" #H(() ("adminGroupID" 4.0) ("fileTransferFolder" "/usr/local/tomcat/webapps/content/fileTransferFolder")
- ("lookInContext" 1.0) ("dataLogMaxSize" "") ("removePageCache" "/content/admin/remove?cache=pages&id=")
- ("dataLogLocation" "/usr/local/tomcat/logs/dataLog.log") ("logMaxSize" "")
- ("betaServer" :true) ("logLocation" "/usr/local/tomcat/logs/CofaxTools.log")
- ("removeTemplateCache" "/content/admin/remove?cache=templates&id=")
- ("templatePath" "toolstemplates/") ("dataLog" 1.0) ("log" 1.0))))))
- ("taglib" #H(() ("taglib-uri" "cofax.tld") ("taglib-location" "/WEB-INF/tlds/cofax.tld")))
- ("servlet-mapping" #H(() ("cofaxAdmin" "/admin/*") ("cofaxCDS" "/") ("fileServlet" "/static/*")
- ("cofaxEmail" "/cofaxutil/aemail/*") ("cofaxTools" "/tools/*"))))))
+AST: (("web-app" (("servlet" #((("servlet-name" "cofaxCDS") ("servlet-class" "org.cofax.cds.CDSServlet")
+ ("init-param" (("configGlossary:installationAt" "Philadelphia, PA") ("configGlossary:adminEmail" "ksm@pobox.com")
+ ("configGlossary:poweredBy" "Cofax") ("configGlossary:poweredByIcon" "/images/cofax.gif")
+ ("configGlossary:staticPath" "/content/static") ("templateProcessorClass" "org.cofax.WysiwygTemplate")
+ ("templateLoaderClass" "org.cofax.FilesTemplateLoader") ("templatePath" "templates")
+ ("templateOverridePath" "") ("defaultListTemplate" "listTemplate.htm")
+ ("defaultFileTemplate" "articleTemplate.htm") ("useJSP" :false)
+ ("jspListTemplate" "listTemplate.jsp") ("jspFileTemplate" "articleTemplate.jsp")
+ ("cachePackageTagsTrack" 200.0) ("cachePackageTagsStore" 200.0)
+ ("cachePackageTagsRefresh" 60.0) ("cacheTemplatesTrack" 100.0)
+ ("cacheTemplatesStore" 50.0) ("cacheTemplatesRefresh" 15.0) ("cachePagesTrack" 200.0)
+ ("cachePagesStore" 100.0) ("cachePagesRefresh" 10.0) ("cachePagesDirtyRead" 10.0)
+ ("searchEngineListTemplate" "forSearchEnginesList.htm") ("searchEngineFileTemplate" "forSearchEngines.htm")
+ ("searchEngineRobotsDb" "WEB-INF/robots.db") ("useDataStore" :true)
+ ("dataStoreClass" "org.cofax.SqlDataStore") ("redirectionClass" "org.cofax.SqlRedirection")
+ ("dataStoreName" "cofax") ("dataStoreDriver" "com.microsoft.jdbc.sqlserver.SQLServerDriver")
+ ("dataStoreUrl" "jdbc:microsoft:sqlserver://LOCALHOST:1433;DatabaseName=goon")
+ ("dataStoreUser" "sa") ("dataStorePassword" "dataStoreTestQuery")
+ ("dataStoreTestQuery" "SET NOCOUNT ON;select test='test';") ("dataStoreLogFile" "/usr/local/tomcat/logs/datastore.log")
+ ("dataStoreInitConns" 10.0) ("dataStoreMaxConns" 100.0) ("dataStoreConnUsageLimit" 100.0)
+ ("dataStoreLogLevel" "debug") ("maxUrlLength" 500.0))))
+ (("servlet-name" "cofaxEmail") ("servlet-class" "org.cofax.cds.EmailServlet")
+ ("init-param" (("mailHost" "mail1") ("mailHostOverride" "mail2"))))
+ (("servlet-name" "cofaxAdmin") ("servlet-class" "org.cofax.cds.AdminServlet"))
+ (("servlet-name" "fileServlet") ("servlet-class" "org.cofax.cds.FileServlet"))
+ (("servlet-name" "cofaxTools") ("servlet-class" "org.cofax.cms.CofaxToolsServlet")
+ ("init-param" (("templatePath" "toolstemplates/") ("log" 1.0) ("logLocation" "/usr/local/tomcat/logs/CofaxTools.log")
+ ("logMaxSize" "") ("dataLog" 1.0) ("dataLogLocation" "/usr/local/tomcat/logs/dataLog.log")
+ ("dataLogMaxSize" "") ("removePageCache" "/content/admin/remove?cache=pages&id=")
+ ("removeTemplateCache" "/content/admin/remove?cache=templates&id=")
+ ("fileTransferFolder" "/usr/local/tomcat/webapps/content/fileTransferFolder")
+ ("lookInContext" 1.0) ("adminGroupID" 4.0) ("betaServer" :true))))))
+ ("servlet-mapping" (("cofaxCDS" "/") ("cofaxEmail" "/cofaxutil/aemail/*") ("cofaxAdmin" "/admin/*")
+ ("fileServlet" "/static/*") ("cofaxTools" "/tools/*")))
+ ("taglib" (("taglib-uri" "cofax.tld") ("taglib-location" "/WEB-INF/tlds/cofax.tld"))))))
Unmatched junk: ""
-AST: #("JSON Test Pattern pass1" #H(() ("object with 1 member" #("array with 1 element")))
- #H(()) #() -42.0 :true :false :null #H(() ("compact" #(1.0 2.0 3.0 4.0 5.0 6.0 7.0)) ("quotes" "&#34; \" %22 0x22 034 &#x22;")
- ("object" #H(())) ("0123456789" "digit") ("" 2.3456789012e76)
- ("ALPHA" "ABCDEFGHIJKLMNOPQRSTUVWYZ") ("digit" "0123456789")
- ("quote" "\"") (" s p a c e d " #(1.0 2.0 3.0 4.0 5.0 6.0 7.0))
- ("one" 1.0) ("alpha" "abcdefghijklmnopqrstuvwyz") ("E" 1.23456789e34)
- ("comment" "// /* <!-- --") ("special" "`1~!@#$%^&*()_+-={':[,]}|;.</>?")
- ("url" "http://www.JSON.org/") ("null" :null) ("hex" "ģ䕧覫췯ꯍ")
- ("controls" "\b\f\n\r\t") ("address" "50 St. James Street") ("# -- --> */" " ")
- ("\\/\\\\\"쫾몾ꮘﳞ볚\b\f\n\r\t`1~!@#$%^&*()_+-=[]{}|;:',./<>?" "A key can be any string")
- ("space" " ") ("e" 1.23456789e-13) ("real" -9876.54321) ("array" #())
- ("jsontext" "{\"object with 1 member\":[\"array with 1 element\"]}")
- ("zero" 0.0) ("false" :false) ("slash" "/ & \\/") ("integer" 1234567890.0)
- ("backslash" "\\\\") ("true" :true))
+AST: #("JSON Test Pattern pass1" (("object with 1 member" #("array with 1 element")))
+ nil #() -42.0 :true :false :null (("integer" 1234567890.0) ("real" -9876.54321) ("e" 1.23456789e-13)
+ ("E" 1.23456789e34) ("" 2.3456789012e76) ("zero" 0.0) ("one" 1.0)
+ ("space" " ") ("quote" "\"") ("backslash" "\\\\") ("controls" "\b\f\n\r\t")
+ ("slash" "/ & \\/") ("alpha" "abcdefghijklmnopqrstuvwyz") ("ALPHA" "ABCDEFGHIJKLMNOPQRSTUVWYZ")
+ ("digit" "0123456789") ("0123456789" "digit") ("special" "`1~!@#$%^&*()_+-={':[,]}|;.</>?")
+ ("hex" "ģ䕧覫췯ꯍ") ("true" :true) ("false" :false) ("null" :null)
+ ("array" #()) ("object" nil) ("address" "50 St. James Street")
+ ("url" "http://www.JSON.org/") ("comment" "// /* <!-- --") ("# -- --> */" " ")
+ (" s p a c e d " #(1.0 2.0 3.0 4.0 5.0 6.0 7.0)) ("compact" #(1.0 2.0 3.0 4.0 5.0 6.0 7.0))
+ ("jsontext" "{\"object with 1 member\":[\"array with 1 element\"]}")
+ ("quotes" "&#34; \" %22 0x22 034 &#x22;") ("\\/\\\\\"쫾몾ꮘﳞ볚\b\f\n\r\t`1~!@#$%^&*()_+-=[]{}|;:',./<>?"
+ "A key can be any string"))
0.5 98.6 99.44 1066.0 10.0 1.0 0.1 1.0 2.0 2.0 "rosebud")
Unmatched junk: ""
diff --git a/tests/009/json.txr b/tests/009/json.txr
index 5c2732e8..1c705de1 100644
--- a/tests/009/json.txr
+++ b/tests/009/json.txr
@@ -57,16 +57,15 @@
@(end)
@;
@; Recognize an object: a collection of string/value pairs,
-@; turning them into an equal-based hash table
+@; turning them into a list.
@;
@(define object (v))@\
@(local p e pair)@\
- @(ws){@(ws)@(coll :gap 0 :vars (pair))@\
+ @(ws){@(ws)@(coll :gap 0 :vars (v))@\
@(string p):@(value e)@/,?/@\
- @(bind pair (p e))@\
+ @(bind v (p e))@\
@(until)}@\
@(end)}@(ws)@\
- @(bind v @(progn ^#H((:equal-based) ,*pair)))@\
@(end)
@;
@; Recognize an array.
diff --git a/tests/010/cons.tl b/tests/010/cons.tl
new file mode 100644
index 00000000..de293652
--- /dev/null
+++ b/tests/010/cons.tl
@@ -0,0 +1,14 @@
+(load "../common")
+
+(let ((x (list* 1 2 3 4)))
+ (mtest
+ (set x (delcons x x)) (2 3 . 4)
+ (set x (delcons x x)) (3 . 4)
+ (set x (delcons x x)) 4
+ (set x (delcons x x)) 4))
+
+(let ((x (list* 1 2 3 4 5)))
+ (mtest
+ (delcons (cdr x) x) (1 3 4 . 5)
+ (delcons (cddr x) x) (1 3 . 5)
+ (delcons (cdr x) x) (1 . 5)))
diff --git a/tests/010/eof-status.expected b/tests/010/eof-status.expected
new file mode 100644
index 00000000..2b636133
--- /dev/null
+++ b/tests/010/eof-status.expected
@@ -0,0 +1,2 @@
+a="a"
+status="5"
diff --git a/tests/010/eof-status.txr b/tests/010/eof-status.txr
new file mode 100644
index 00000000..0da9c633
--- /dev/null
+++ b/tests/010/eof-status.txr
@@ -0,0 +1,3 @@
+@(next (open-command "echo a; exit 5"))
+@a
+@(eof status)
diff --git a/tests/010/hash.tl b/tests/010/hash.tl
new file mode 100644
index 00000000..d6a8542b
--- /dev/null
+++ b/tests/010/hash.tl
@@ -0,0 +1,94 @@
+(load "../common")
+
+(mtest
+ (uni #H(() ("a") ("b")) #H(() ("b") ("c"))) (("a") ("b") ("c"))
+ (diff #H(() ("a") ("b")) #H(() ("b") ("c"))) (("a"))
+ (isec #H(() ("a") ("b")) #H(() ("b") ("c"))) (("b")))
+
+(mtest
+ [group-by identity '(1 1 2 2 3 3 3)] #H(() (1 (1 1)) (2 (2 2)) (3 (3 3 3)))
+ (group-by (op mod @1 3) (range 0 10)) #H(() (0 (0 3 6 9))
+ (1 (1 4 7 10))
+ (2 (2 5 8)))
+ [group-map (op mod @1 3) sum (range 0 10)] #H(() (0 18) (1 22) (2 15)))
+
+(mtest
+ [group-reduce (hash) identity (do inc @1)
+ "fourscoreandsevenyearsago" 0] #H(() (#\a 3) (#\c 1) (#\d 1)
+ (#\e 4) (#\f 1) (#\g 1)
+ (#\n 2) (#\o 3) (#\r 3)
+ (#\s 3) (#\u 1) (#\v 1)
+ (#\y 1))
+ [group-reduce (hash) evenp + (range 1 10) 0] #H(() (t 30) (nil 25)))
+
+(mtest
+ (hash-props) #H(())
+ (hash-props 1 2) #H(() (1 2))
+ (hash-props 1 2 'a 'b) #H(() (1 2) (a b))
+ (hash-props 1) :error
+ (hash-props 1 2 'a) :error)
+
+;; Test that growing a hash table works while iterators
+;; are referencing it.
+(let ((h (hash-list (range 0 199))))
+ (let ((i (hash-begin h)))
+ (each ((x 200..1000))
+ (set [h x] x))
+ (each ((x 0..1000))
+ (vtest [h x] x))))
+
+;; Test that when an iterator is created which references
+;; a table which is then resized, and from which all
+;; entries are subsequently deleted, when the iterator
+;; then marches, it will not see the deleted entries.
+(let ((h (hash-list (range 0 199))))
+ (let ((i (hash-begin h)))
+ (each ((x 200..1000))
+ (set [h x] x))
+ (each ((x 0..1000))
+ (del [h x]))
+ (test (hash-next i) nil)))
+
+;; Test that when an iterator is created which references
+;; a table which is then resized, and from which values
+;; are never deleted, the iterator will visit all the
+;; original items that existed when it was created.
+(let ((h (hash-list (range 0 199))))
+ (let ((i (hash-begin h)))
+ (each ((x 200..1000))
+ (set [h x] x))
+ (let ((items (build (whilet ((cell (hash-next i)))
+ (add (car cell))))))
+ (test (diff 0..200 items) nil))))
+
+(test [hash-map square '(1 2 3)]
+ #H(() (1 1) (2 4) (3 9)))
+
+(let ((h1 #H(() (a 1) (b 2) (c 3) (d 4)))
+ (h2 #H(() (b -2) (c -3) (d -4) (e -5))))
+ (mtest
+ (hash-uni h1 h2) #H(() (a 1) (b 2) (c 3) (d 4) (e -5))
+ [hash-uni h1 h2 +] #H(() (a 1) (b 0) (c 0) (d 0) (e -5))
+ [hash-uni h1 h2 + -] #H(() (a -1) (b -4) (c -6) (d -8) (e -5))
+ [hash-uni h1 h2 + : -] #H(() (a 1) (b 4) (c 6) (d 8) (e 5))
+ [hash-uni h1 h2 + - -] #H(() (a -1) (b 0) (c 0) (d 0) (e 5)))
+ (mtest
+ [hash-join h1 h2 +] :error
+ [hash-join h1 h2 + 0] :error
+ [hash-join h1 h2 + : 0] :error
+ [hash-join h1 h2 + 0 0] #H(() (a 1) (b 0) (c 0) (d 0) (e -5)))
+ (mtest
+ (hash-diff h1 h2) #H(() (a 1))
+ (hash-diff h2 h1) #H(() (e -5)))
+ (mtest
+ (hash-symdiff h1 h2) #H(() (a 1) (e -5))
+ (hash-symdiff h2 h1) #H(() (a 1) (e -5)))
+ (mtest
+ (hash-isec h1 h2) #H(() (b 2) (c 3) (d 4))
+ [hash-isec h1 h2 +] #H(() (b 0) (c 0) (d 0))))
+
+(mtest
+ (eql (hash-equal "abc") (hash-equal "abc")) t
+ (eql (hash-equal (expt 2 128)) (hash-equal (expt 2 128))) t
+ (eql (hash-eql "abc") (hash-eql "abc")) nil
+ (eql (hash-eql (expt 2 128)) (hash-eql (expt 2 128))) t)
diff --git a/tests/010/json.tl b/tests/010/json.tl
new file mode 100644
index 00000000..d419295f
--- /dev/null
+++ b/tests/010/json.tl
@@ -0,0 +1,194 @@
+(load "../common")
+
+(mtest
+ #J0 0.0
+ #J"abc" "abc"
+ #Jtrue t
+ #Jfalse nil
+ #Jnull null)
+
+(mtest
+ #J1 1.0
+ #J 1 1.0
+ #J123 123.0
+ #J0.123 0.123
+ #J1.123 1.123
+ #J1E3 1000.0
+ #J1.1E3 1100.0
+ #J1.1E+3 1100.0
+ #J1.1E+03 1100.0
+ #J1.1e3 1100.0
+ #J1.1e+3 1100.0
+ #J1.1e+03 1100.0)
+
+(mtest
+ #J"" ""
+ #J"\u0000" "\xdc00"
+ #J"\u0001" "\x1"
+ #J"a\u0000b" "a\xdc00;b"
+ #J"a\u0001b" "a\x1;b"
+ #J"\b\t\n\f\r" "\b\t\n\f\r"
+ #J"\/\\\"" "/\\\"")
+
+(when (> (sizeof wchar) 2)
+ (let ((chr (read "\"\\x10437\"")))
+ (vtest #J"\ud801\udc37" `@chr`)
+ (vtest #J"a\ud801\udc37b" `a@{chr}b`)))
+
+(mtest
+ #J[] #()
+ #J[ ] #()
+ #J[ ] #()
+ #J [ ] #()
+ #J[null] #(null)
+ #J[false] #(nil)
+ #J[true] #(t)
+ #J["abc"] #("abc")
+ #J[1,2,3] #(1.0 2.0 3.0)
+ #J[ 1 , 2 , 3 ] #(1.0 2.0 3.0)
+ #J[[]] #(#())
+ #J[[],[]] #(#() #())
+ #J[ [] , [] ] #(#() #())
+ #J[[1],[2],3] #(#(1.0) #(2.0) 3.0))
+
+(mtest
+ #J{} #H(())
+ #J{ } #H(())
+ #J{ } #H(())
+ #J { } #H(())
+ #J{true:true} #H(() (t t)))
+ #J{ true : true } #H(() (t t))
+ #J{ {} : {} } #H(() (#H(()) #H(())))
+ #J{ "a" : 1.0 } #H(() (a 1.0))
+ #J{ "a" : 1.0, "b" : [null] } #H(() (a 1.0) (b #(null)))
+
+(mtest
+ #J[
+ ] #()
+ #J[1,
+ 2,
+ 3] #(1.0 2.0 3.0)
+ #J{"foo":
+ "bar"}
+ #H(() ("foo" "bar")))
+
+(let ((*print-circle* t))
+ (mstest
+ #J[#1="abc", #1#] "#(#1=\"abc\" #1#)"
+ #2=#J[1, #2#] "#1=#(1.0 #J#1#)"
+ #J#3=[1, #3#] "#1=#(1.0 #1#)"
+ #4=#J{#4#:#4#} "#1=#H(() (#2=#J#1# #2#))"
+ #J#5={#5#:#5#} "#1=#H(() (#1# #1#))")
+
+ (let ((chash #J{"foo":#6="bar", "xyzzy":#6#}))
+ (mtest
+ [chash "xyzzy"] "bar"
+ (eq [chash "foo"] [chash "xyzzy"]) t)))
+
+(mtest
+ ^#J~(+ 1.0 1) #J2
+ ^#J[1, ~(+ 2.0 2)] #J[1, 4]
+ ^#J[1, ~(+ 2.0 2), 3] #J[1, 4, 3]
+ (eval ^^#J~#(1.0 ,*(list 2.0 3.0) 4.0)) #J[1, 2, 3, 4]
+ ^#J[1, ~*(list 2.0 3.0), 4] #J[1, 2, 3, 4]
+ #J^[1, ~(+ 2.0 2)] #(1.0 4.0)
+ #J^[1, ~(+ 2.0 2), 3] #(1.0 4.0 3.0)
+ ^#J{~(join "abc" "def") : "ghi"} #J{"abcdef":"ghi"}
+ #J^{~(join "abc" "def") : "ghi"} #H(() ("abcdef" "ghi")))
+
+;; get-json
+(mtest
+ (get-json "0") 0.0
+ (get-json "\"abc\"") "abc"
+ (get-json "true") t
+ (get-json "false") nil
+ (get-json "null") null
+ (get-json "[1,2,3]") #(1.0 2.0 3.0)
+ (get-json "{\"a\":\"b\"}") #H(() ("a" "b")))
+
+(mtest
+ (get-json "0 \n") 0.0
+ (get-json "\"abc\" \n") "abc"
+ (get-json "true \n") t
+ (get-json "false \n") nil
+ (get-json "null \n") null
+ (get-json "[1,2,3] \n") #(1.0 2.0 3.0)
+ (get-json "{\"a\":\"b\"} \n") #H(() ("a" "b")))
+
+(mtest
+ (get-json "0,") :error
+ (get-json "\"abc\",") :error
+ (get-json "true,") :error
+ (get-json "false,") :error
+ (get-json "null,") :error
+ (get-json "[1,2,3],") :error
+ (get-json "{\"a\":\"b\"},") :error)
+
+(mtest
+ (tojson #(1.0 "abc" t)) "[1,\"abc\",true]"
+ (tojson "<!--") "\"<\\u0021--\""
+ (tojson "a<!--b") "\"a<\\u0021--b\""
+ (tojson "<!-") "\"<!-\""
+ (tojson "-->") "\"-\\u002D>\""
+ (tojson "a-->b") "\"a-\\u002D>b\""
+ (tojson "->") "\"->\""
+ (tojson "</") "\"</\""
+ (tojson "</scrip") "\"</scrip\""
+ (tojson "</script") "\"<\\/script\""
+ (tojson "a</scriptb") "\"a<\\/scriptb\"")
+
+(mtest
+ (get-jsons "") nil
+ (get-jsons "true") (t)
+ (get-jsons "1 1 [2] {3:4}") (1.0 1.0 #(2.0) #H(() (3.0 4.0))))
+
+(mtest
+ (get-json "{ , }") :error
+ (get-json "{ 1:2, }") :error
+ (get-json "{ 1:2, 3:4, }") :error
+ (get-json "[ , ]") :error
+ (get-json "[ 1, ]") :error
+ (get-json "[ 1, 2, ]") :error)
+
+(let ((*read-bad-json* t))
+ (mtest
+ (get-json "{ , }") :error
+ (get-json "{ 1:2, }") #H(() (1.0 2.0))
+ (get-json "{ 1:2, 3:4, }") #H(() (1.0 2.0) (3.0 4.0))
+ (get-json "[ , ]") :error
+ (get-json "[ 1, ]") #(1.0)
+ (get-json "[ 1, 2, ]") #(1.0 2.0)))
+
+(mtest
+ (with-out-string-stream (s) (put-json nil s)) "false"
+ (with-out-string-stream (s) (put-jsons nil s)) ""
+ (with-out-string-stream (s) (put-jsons '(1.0 t nil) s)) "1\ntrue\nfalse\n")
+
+(with-temp-file (name s "json")
+ (mtest
+ (file-put-json name #(1.0 2.0 3.0)) t
+ (file-get-string name) "[1,2,3]\n"
+ (file-get-json name) #(1.0 2.0 3.0)
+ (file-append-json name #H(() ("a" t))) t
+ (file-get-string name) "[1,2,3]\n{\"a\":true}\n"
+ (file-get-jsons name) (#(1.0 2.0 3.0)
+ #H(() ("a" t)))
+ (file-put-jsons name '(1.0 t null)) t
+ (file-get-jsons name) (1.0 t null)
+ (file-get-string name) "1\ntrue\nnull\n")
+ (if (path-executable-to-me-p "/bin/sh")
+ (mtest
+ (command-put-json `cat > @name` #(#() #())) t
+ (file-get-string name) "[[],[]]\n"
+ (command-get-json `cat @name`) #(#() #())
+ (command-put-jsons `cat > @name` '(#() 1.0 nil)) t
+ (file-get-string name) "[]\n1\nfalse\n"
+ (command-get-jsons `cat @name`) (#() 1.0 nil))))
+
+(mtest
+ (tojson 1) "1"
+ (tojson 123123123123123123123123123123) "123123123123123123123123123123"
+ (tojson '(1 2 3 4 5)) "[1,2,3,4,5]")
+
+(test
+ (get-json "[1, 2, ; foo\n 3]") #(1.0 2.0 3.0))
diff --git a/tests/010/qquote.tl b/tests/010/qquote.tl
new file mode 100644
index 00000000..26d5417b
--- /dev/null
+++ b/tests/010/qquote.tl
@@ -0,0 +1,42 @@
+(let ((nullsym nil)
+ (sym 's)
+ (atom "abc")
+ (cons '(x y z))
+ (dwim '[]))
+ (tree-bind (x y (op arg)) ^(a b @,nullsym)
+ (assert (eq op 'sys:var))
+ (assert (eq arg nullsym)))
+ (tree-bind (x y (op arg)) ^(a b @,sym)
+ (assert (eq op 'sys:var))
+ (assert (eq arg sym)))
+ (tree-bind (x y . (op arg)) ^(a b . @,sym)
+ (assert (eq op 'sys:var))
+ (assert (eq arg sym)))
+ (tree-bind (x y (op arg)) ^(a b @,atom)
+ (assert (eq op 'sys:var))
+ (assert (eq arg atom)))
+ (tree-bind (x y . (op arg)) ^(a b . @,atom)
+ (assert (eq op 'sys:var))
+ (assert (eq arg atom)))
+ (tree-bind (x y (op arg)) ^(a b @,cons)
+ (assert (eq op 'sys:expr))
+ (assert (eq arg cons)))
+ (tree-bind (x y . (op arg)) ^(a b . @,cons)
+ (assert (eq op 'sys:expr))
+ (assert (eq arg cons)))
+ (tree-bind (x y (op arg)) ^(a b @,dwim)
+ (assert (eq op 'sys:expr))
+ (assert (eq arg dwim)))
+ (tree-bind (x y . (op arg)) ^(a b . @,dwim)
+ (assert (eq op 'sys:expr))
+ (assert (eq arg dwim)))
+ (tree-bind (x y (op arg . tail)) ^(a b (sys:expr ,sym . foo))
+ (assert (eq op 'sys:expr))
+ (assert (eq arg sym))
+ (assert (eq tail 'foo)))
+ (tree-bind (x y (op arg0 arg1)) ^(a b (sys:expr ,sym foo))
+ (assert (eq op 'sys:expr))
+ (assert (eq arg0 sym))
+ (assert (eq arg1 'foo)))
+ (tree-bind (x y (op)) ^(a b (sys:expr))
+ (assert (eq op 'sys:expr))))
diff --git a/tests/010/range.tl b/tests/010/range.tl
new file mode 100644
index 00000000..4cc9ee95
--- /dev/null
+++ b/tests/010/range.tl
@@ -0,0 +1,103 @@
+(load "../common")
+
+(mtest
+ (range 1 1) (1)
+ (range 1.0 1.0) (1.0)
+ (range #\a #\a) (#\a)
+ (range #R(1 1) #R(1 1)) (#R(1 1)))
+
+(mtest
+ (range 0 4) (0 1 2 3 4)
+ (range 4 0) (4 3 2 1 0)
+ (range 0.0 4.0) (0.0 1.0 2.0 3.0 4.0)
+ (range 4.0 0.0) (4.0 3.0 2.0 1.0 0.0)
+ (range #\a #\c) (#\a #\b #\c)
+ (range #\c #\a) (#\c #\b #\a)
+ (range #R(0 0) #R(4 4)) (#R(0 0) #R(1 1) #R(2 2) #R(3 3) #R(4 4))
+ (range #R(4 4) #R(0 0)) (#R(4 4) #R(3 3) #R(2 2) #R(1 1) #R(0 0)))
+
+(mtest
+ (len (range 1 1 "")) :error
+ (len (range 1 2 "")) :error)
+
+(mtest
+ (range 0 4 2) (0 2 4)
+ (range 4 0 -2) (4 2 0)
+ (range 0.0 4.0 2) (0.0 2.0 4.0)
+ (range 4.0 0.0 -2) (4.0 2.0 0.0)
+ (range #\a #\e 2) (#\a #\c #\e)
+ (range #\e #\a -2) (#\e #\c #\a)
+ (range #R(0 0) #R(4 4) 2) (#R(0 0) #R(2 2) #R(4 4))
+ (range #R(4 4) #R(0 0) -2) (#R(4 4) #R(2 2) #R(0 0))
+ (range 1 32 (op * 2)) (1 2 4 8 16 32))
+
+(mtest
+ (range* 1 1) nil
+ (range* 1.0 1.0) nil
+ (range* #\a #\a) nil
+ (range* #R(1 1) #R(1 1)) nil)
+
+(mtest
+ (range* 0 4) (0 1 2 3)
+ (range* 4 0) (4 3 2 1)
+ (range* 0.0 4.0) (0.0 1.0 2.0 3.0)
+ (range* 4.0 0.0) (4.0 3.0 2.0 1.0)
+ (range* #\a #\c) (#\a #\b)
+ (range* #\c #\a) (#\c #\b)
+ (range* #R(0 0) #R(4 4)) (#R(0 0) #R(1 1) #R(2 2) #R(3 3))
+ (range* #R(4 4) #R(0 0)) (#R(4 4) #R(3 3) #R(2 2) #R(1 1)))
+
+(mtest
+ (len (range* 1 1 "")) 0
+ (len (range* 1 2 "")) :error)
+
+(mtest
+ (range* 0 4 2) (0 2)
+ (range* 4 0 -2) (4 2)
+ (range* 0.0 4.0 2) (0.0 2.0)
+ (range* 4.0 0.0 -2) (4.0 2.0)
+ (range* #\a #\e 2) (#\a #\c)
+ (range* #\e #\a -2) (#\e #\c)
+ (range* #R(0 0) #R(4 4) 2) (#R(0 0) #R(2 2))
+ (range* #R(4 4) #R(0 0) -2) (#R(4 4) #R(2 2))
+ (range* 1 32 (op * 2)) (1 2 4 8 16))
+
+(mtest
+ (range 0 1.25 0.5) (0 0.5 1.0)
+ (range* 0 1.25 0.5) (0 0.5 1.0))
+
+(mtest
+ (range "A" "A") nil
+ (range "A" "A" 0) :error
+ (range "A" "A" -2) :error)
+
+(mtest
+ (range "A" "C") ("A" "B" "C")
+ (range "A" "C" 2) ("A" "C")
+ (range "A" "D" 2) ("A" "C")
+ (range "A" "E" 2) ("A" "C" "E")
+ (range "A" "C" 3) ("A")
+ (range "A" "E" 3) ("A" "D"))
+
+(mtest
+ (range* "A" "C") ("A" "B")
+ (range* "A" "C" 2) ("A")
+ (range* "A" "D" 2) ("A" "C")
+ (range* "A" "E" 2) ("A" "C")
+ (range* "A" "C" 3) ("A")
+ (range* "A" "E" 3) ("A" "D"))
+
+(mtest
+ [range "ABCD" nil rest] ("ABCD" "BCD" "CD" "D" nil)
+ [range* "ABCD" nil rest] ("ABCD" "BCD" "CD" "D"))
+
+(defstruct udnum nil
+ v
+ (:method + (me arg) (new udnum v (+ me.v arg)))
+ (:method > (me arg) (> me.v arg))
+ (:method < (me arg) (< me.v arg))
+ (:method = (me arg) (= me.v arg)))
+
+(mtest
+ (range (new udnum v 0) (new udnum v 3)) (#S(udnum v 0) #S(udnum v 1) #S(udnum v 2) #S(udnum v 3))
+ (range* (new udnum v 0) (new udnum v 3)) (#S(udnum v 0) #S(udnum v 1) #S(udnum v 2)))
diff --git a/tests/010/seq.expected b/tests/010/seq.expected
index 9c4d860d..691e6ac4 100644
--- a/tests/010/seq.expected
+++ b/tests/010/seq.expected
@@ -14,3 +14,39 @@ exception!
38 37 36 35 34 33 32 31 30 29 28 27 26 25 24 23 22 21 20 19 18
17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
#((8 . #\g) (6 . #\f)) #((7 . #\h) (5 . #\e) (4 . #\d) (3 . #\c) (2 . #\b) (1 . #\a))
+"bdf"
+"aceg"
+"g"
+"abcdef"
+"abcdefg"
+""
+"abcdefg"
+""
+"aceg"
+"bdf"
+(1 3 5)
+(0 2 4 6)
+(0 1 2 3 4 5 6)
+nil
+(0 1 2 3 4 5 6)
+nil
+(0 2 4 6)
+(1 3 5)
+#(1 3 5)
+#(0 2 4 6)
+#(0 1 2 3 4 5 6)
+#()
+#(0 1 2 3 4 5 6)
+#()
+#(0 2 4 6)
+#(1 3 5)
+#b'bbddff'
+#b'aaccee99'
+#b'99'
+#b'aabbccddeeff'
+#b'aabbccddeeff99'
+#b''
+#b'aabbccddeeff99'
+#b''
+#b'aaccee99'
+#b'bbddff'
diff --git a/tests/010/seq.txr b/tests/010/seq.txr
index 080b01ad..18f5c198 100644
--- a/tests/010/seq.txr
+++ b/tests/010/seq.txr
@@ -14,7 +14,62 @@
(format t "~s ~s\n" (del [*s* 1]) *s*)
(format t "~s ~s\n" (del [*s* -1]) *s*)
(catch (pr (del [*s* 3]) *s*) (t (x) (caught x)))
- (pr [sort *v* >])
- (pr [sort *v2* > cdr])
- (pr [sort (range 1 100) >])
- (pr2 (del [*v2* 1..3]) *v2*))
+ (pr [nsort *v* >])
+ (pr [nsort *v2* > cdr])
+ (pr [nsort (range 1 100) >])
+ (pr2 (del [*v2* 1..3]) *v2*)
+ (let ((s (copy "abcdefg")))
+ (pr (del [s '(1 3 5)]))
+ (pr s))
+ (let ((s (copy "abcdefg")))
+ (pr (del [s '(6)]))
+ (pr s))
+ (let ((s (copy "abcdefg")))
+ (pr (del [s '(0 1 2 3 4 5 6)]))
+ (pr s))
+ (let ((s (copy "abcdefg")))
+ (pr (del [s '(-7 -6 -5 -4 -3 -2 -1)]))
+ (pr s))
+ (let ((s (copy "abcdefg")))
+ (pr (del [s '(-7 -5 -3 -1)]))
+ (pr s))
+ (let ((s (list 0 1 2 3 4 5 6)))
+ (pr (del [s '(1 3 5)]))
+ (pr s))
+ (let ((s (list 0 1 2 3 4 5 6)))
+ (pr (del [s '(0 1 2 3 4 5 6)]))
+ (pr s))
+ (let ((s (list 0 1 2 3 4 5 6)))
+ (pr (del [s '(-7 -6 -5 -4 -3 -2 -1)]))
+ (pr s))
+ (let ((s (list 0 1 2 3 4 5 6)))
+ (pr (del [s '(-7 -5 -3 -1)]))
+ (pr s))
+ (let ((s (vec 0 1 2 3 4 5 6)))
+ (pr (del [s '(1 3 5)]))
+ (pr s))
+ (let ((s (vec 0 1 2 3 4 5 6)))
+ (pr (del [s '(0 1 2 3 4 5 6)]))
+ (pr s))
+ (let ((s (vec 0 1 2 3 4 5 6)))
+ (pr (del [s '(-7 -6 -5 -4 -3 -2 -1)]))
+ (pr s))
+ (let ((s (vec 0 1 2 3 4 5 6)))
+ (pr (del [s '(-7 -5 -3 -1)]))
+ (pr s))
+ (let ((s (copy #b'aabbccddeeff99')))
+ (pr (del [s '(1 3 5)]))
+ (pr s))
+ (let ((s (copy #b'aabbccddeeff99')))
+ (pr (del [s '(6)]))
+ (pr s))
+ (let ((s (copy #b'aabbccddeeff99')))
+ (pr (del [s '(0 1 2 3 4 5 6)]))
+ (pr s))
+ (let ((s (copy #b'aabbccddeeff99')))
+ (pr (del [s '(-7 -6 -5 -4 -3 -2 -1)]))
+ (pr s))
+ (let ((s (copy #b'aabbccddeeff99')))
+ (pr (del [s '(-7 -5 -3 -1)]))
+ (pr s))
+ )
diff --git a/tests/010/span-var.txr b/tests/010/span-var.txr
new file mode 100644
index 00000000..036acc6a
--- /dev/null
+++ b/tests/010/span-var.txr
@@ -0,0 +1,39 @@
+@(define fun (x y))
+@(bind x "x")
+@y
+@y
+@y
+@(end)
+@(next :list '("a" "a" "a" "b" "c"))
+@{z (fun x "a")}
+@(require (equal x "x"))
+@(require (equal z '("a" "a" "a")))
+@(define fun2 (x y))@(bind x "x")@y@(end)
+@(next :string "ab")
+@{w (fun2 x "a")}@y
+@(require (equal w "a"))
+@(require (equal y "b"))
+@(next :list '("a" "a" "a" "b" "c"))
+@(bind d ("d"))
+@(cases)
+@ {d (fun "x" "a")}
+@ {require (not "get here")}
+@(or)
+@ (require "get here")
+@(end)
+@(next :string "ab")
+@(cases)
+@ {d (fun2 "x" "a")}
+@ {require (not "get here")}
+@(or)
+@ (require "get here")
+@(end)
+@(bind n "123")
+@(next :string "123456")
+@(cases)
+@ {n /\d+/}
+@ {require (not "get here")}
+@(or)
+@ {m /\d+/}
+@ (require (equal m "123456"))
+@(end)
diff --git a/tests/010/tree.tl b/tests/010/tree.tl
new file mode 100644
index 00000000..9d00fda6
--- /dev/null
+++ b/tests/010/tree.tl
@@ -0,0 +1,264 @@
+(load "../common")
+
+(defvarl tr (tree))
+(defvarl keys '(0 6 8 11 10 2 16 3 17 7 19 12 15 13 18 4 14 5 1 9))
+
+(test tr #T(()))
+
+(mtest
+ (treep tr) t
+ (treep 42) nil)
+
+(mtest
+ (len #T()) 0
+ (len #T(() 1)) 1
+ (len #T(() 1 2)) 2
+ (len #T(() 1 2 3)) 3
+ (len #T(() 1 1 1)) 3)
+
+(each ((n keys))
+ (tree-insert tr n))
+
+(mtest
+ (tree-lookup tr 0) 0
+ (tree-lookup tr 1) 1
+ (tree-lookup tr 2) 2
+ (tree-lookup tr 3) 3
+ (tree-lookup tr 4) 4
+ (tree-lookup tr 5) 5
+ (tree-lookup tr 6) 6
+ (tree-lookup tr 7) 7
+ (tree-lookup tr 8) 8
+ (tree-lookup tr 9) 9
+ (tree-lookup tr 10) 10
+ (tree-lookup tr 11) 11
+ (tree-lookup tr 12) 12
+ (tree-lookup tr 13) 13
+ (tree-lookup tr 14) 14
+ (tree-lookup tr 15) 15
+ (tree-lookup tr 16) 16
+ (tree-lookup tr 17) 17
+ (tree-lookup tr 18) 18
+ (tree-lookup tr 19) 19)
+
+(mtest
+ [tr 0] 0
+ [tr 5] 5
+ [tr 19] 19)
+
+(mtest
+ [tr 0..3] (0 1 2)
+ [tr 3..5] (3 4)
+ [tr -2..0] ()
+ [tr -2..4] (0 1 2 3)
+ [tr :..4] (0 1 2 3)
+ [tr 18..100] (18 19)
+ [tr 18..:] (18 19)
+ [tr 100..200] ())
+
+(vtest
+ [tr :..:] (range 0 19))
+
+(vtest (build (for* ((i (tree-begin tr))
+ (n (tree-next i)))
+ (n)
+ ((set n (tree-next i)))
+ (add (key n))))
+ (range 0 19))
+
+(vtest (build (for* ((j (tree-begin tr))
+ (i (progn (tree-next j) (tree-next j) (tree-reset j tr)))
+ (n (tree-next i)))
+ (n)
+ ((set n (tree-next i)))
+ (add (key n))))
+ (range 0 19))
+
+(vtest (build (for* ((j (tree-begin tr))
+ (i (progn (tree-next j) (tree-next j) (tree-reset j tr)))
+ (n (tree-peek i)))
+ ((and n (eq (tree-next i) n)))
+ ((set n (tree-peek i)))
+ (add (key n))))
+ (range 0 19))
+
+(defvarl trc (copy-search-tree tr))
+
+(vtest trc tr)
+
+(tree-clear trc)
+
+(test trc #T(()))
+
+(test (tree-delete tr 6) 6)
+
+(vtest (build (for* ((i (tree-begin tr 6))
+ (n (tree-next i)))
+ (n)
+ ((set n (tree-next i)))
+ (add (key n))))
+ (range 7 19))
+
+(vtest (build (for* ((i (tree-begin tr 0))
+ (n (tree-next i)))
+ (n)
+ ((set n (tree-next i)))
+ (add (key n))))
+ (rlist 0..5 7..19))
+
+(vtest (build (for* ((i (tree-begin tr 8))
+ (n (tree-next i)))
+ (n)
+ ((set n (tree-next i)))
+ (add (key n))))
+ (range 8 19))
+
+(vtest (build (for* ((i (tree-reset (tree-begin #T(())) tr 8))
+ (n (tree-next i)))
+ (n)
+ ((set n (tree-next i)))
+ (add (key n))))
+ (range 8 19))
+
+(test (let* ((t0 (tree-begin tr))
+ (t1 (progn (tree-next t0) (copy-tree-iter t0))))
+ (tree-next t0)
+ (tree-next t0)
+ (list (key (tree-next t1))
+ (key (tree-next t1))
+ (key (tree-next t1))))
+ (1 2 3))
+
+(test (let* ((t0 (tree-begin tr))
+ (t1 (progn (tree-next t0) (copy-tree-iter t0)))
+ (t2 (replace-tree-iter (tree-begin tr) t0)))
+ (tree-next t0)
+ (tree-next t0)
+ (list (key (tree-next t1))
+ (key (tree-next t1))
+ (key (tree-next t2))
+ (key (tree-next t2))))
+ (1 2 1 2))
+
+(test (tree-next (tree-begin tr 20)) nil)
+
+(test (tree-next (tree-begin #T(()) 0)) nil)
+(test (key (tree-next (tree-begin #T(() 1) 1))) 1)
+
+(mtest
+ (tree-delete tr 0) 0
+ (tree-delete tr 1) 1
+ (tree-delete tr 2) 2
+ (tree-delete tr 3) 3
+ (tree-delete tr 4) 4
+ (tree-delete tr 5) 5
+ (tree-delete tr 7) 7
+ (tree-delete tr 8) 8
+ (tree-delete tr 9) 9
+ (tree-delete tr 10) 10
+ (tree-delete tr 11) 11
+ (tree-delete tr 12) 12
+ (tree-delete tr 13) 13
+ (tree-delete tr 14) 14
+ (tree-delete tr 15) 15
+ (tree-delete tr 16) 16
+ (tree-delete tr 17) 17
+ (tree-delete tr 18) 18
+ (tree-delete tr 19) 19)
+
+(set *tree-fun-whitelist* [list* '= '< 'to *tree-fun-whitelist*])
+
+(let ((tr [tree '(1 2 3) identity < =]))
+ (mtest
+ tr #T((identity < =) 1 2 3)
+ (copy-search-tree tr) #T((identity < =) 1 2 3)
+ (make-similar-tree tr) #T((identity < =))))
+
+(test
+ (collect-each ((el (tree-begin #T(() 1 2 3 4 5) 2 5)))
+ (* 10 el))
+ (20 30 40))
+
+(mtest
+ (uni #T(() "a" "b") #T(() "b" "c")) ("a" "b" "c")
+ (diff #T(() "a" "b") #T(() "b" "c")) ("a")
+ (isec #T(() "a" "b") #T(() "b" "c")) ("b"))
+
+(defstruct (item label key) ()
+ label
+ key
+ (:method equal (it) it.key))
+
+(defun make-items ()
+ (vec (new (item 'a 1))
+ (new (item 'b 2))
+ (new (item 'c 2))
+ (new (item 'd 2))
+ (new (item 'e 2))
+ (new (item 'f 3))))
+
+(let* ((items (make-items))
+ (tr (tree items : : : t)))
+ (each ((it items))
+ (vtest (tree-delete tr it) it))
+ (test tr #T(())))
+
+(let* ((items (make-items))
+ (tr (tree items : : : t)))
+ (each ((it items))
+ (let* ((tn (tree-lookup-node tr it.key))
+ (iu (key tn)))
+ (vtest (tree-delete-specific-node tr tn) tn)
+ (each ((iv tr))
+ (test (eq iv.label iu.label) nil))))
+ (test tr #T(())))
+
+(let* ((items (make-items))
+ (tr (tree items : : : t)))
+ (vtest (vec-list [mapcar .label tr]) [mapcar .label items]))
+
+(let ((tr (tree)))
+ (mtest
+ (tree-insert tr 1) #N(1 nil nil)
+ (tree-insert tr 1) #N(1 nil nil)
+ (tree-insert tr 1) #N(1 nil nil))
+ (tree-insert tr 2)
+ (test (tree-count tr) 2)
+ (tree-insert tr 1 t)
+ (test (tree-count tr) 3))
+
+(mtest
+ (tree-min-node (tree)) nil
+ (tree-min-node (tree '(1))) #N(1 nil nil)
+ (tree-min-node (tree '(1 2 3))) #N(1 nil nil))
+
+(mtest
+ (tree-min (tree)) nil
+ (tree-min (tree '(1))) 1
+ (tree-min (tree '(1 2 3))) 1)
+
+(let ((tr (tree '(1 2 3 4 5 6 7 8 9 10))))
+ (mtest
+ (tree-count tr) 10
+ (tree-del-min tr) 1
+ (tree-del-min tr) 2
+ (tree-del-min tr) 3
+ (tree-count tr) 7
+ (tree-del-min tr) 4
+ (tree-count tr) 6
+ (tree-del-min tr) 5
+ (tree-del-min tr) 6
+ (tree-del-min tr) 7
+ (tree-del-min tr) 8
+ (tree-count tr) 2
+ (tree-del-min tr) 9
+ (tree-count tr) 1
+ (tree-del-min tr) 10
+ (tree-count tr) 0
+ (tree-del-min tr) nil))
+
+(let* ((tr [tree '(#R(1 10) #R(11 20) #R(21 30)) to])
+ (node (tree-lookup-node tr 10)))
+ (test node #N(#R(1 10) nil nil))
+ (tree-delete-specific-node tr node)
+ (test tr #T((to) #R(11 20) #R(21 30))))
diff --git a/tests/010/vec.tl b/tests/010/vec.tl
new file mode 100644
index 00000000..f7b182c1
--- /dev/null
+++ b/tests/010/vec.tl
@@ -0,0 +1,53 @@
+(load "../common")
+
+(let ((v0 (vec))
+ (v3 (vec 1 2 3)))
+ (mtest
+ v0 #()
+ v3 #(1 2 3)
+ (fill-vec v0 nil) #()
+ (fill-vec v0 nil -1 -1) :error
+ (fill-vec v0 nil 1 1) :error
+ (fill-vec v3 nil 0 0) #(1 2 3)
+ (fill-vec v3 nil 1 1) #(1 2 3)
+ (fill-vec v3 nil 2 2) #(1 2 3)
+ (fill-vec v3 nil 3 3) #(1 2 3)
+ (fill-vec v3 nil -3 -3) #(1 2 3)
+ (fill-vec v3 nil 4 0) :error
+ (fill-vec v3 nil 4 4) :error
+ (fill-vec v3 nil 0 4) :error
+ (fill-vec v3 nil -1 0) #(1 2 3)
+ (fill-vec v3 nil 1 0) #(1 2 3)
+ (fill-vec v3 nil 2 1) #(1 2 3)
+ (fill-vec v3 nil 3 2) #(1 2 3)
+ (fill-vec v3 nil -4 -3) :error
+ (fill-vec v3 nil -3 -4) :error
+ (fill-vec v3 nil) #(nil nil nil)
+ (fill-vec v3 1 0 1) #(1 nil nil)
+ (fill-vec v3 2 1 2) #(1 2 nil)
+ (fill-vec v3 3 2 3) #(1 2 3)
+ (fill-vec v3 0 1) #(1 0 0)
+ (fill-vec v3 2 -1) #(1 0 2)
+ (fill-vec v3 3 -3) #(3 3 3))
+ (fill-vec v3 0 -2 -1) #(3 0 3))
+
+(mtest
+ (nested-vec) nil
+ (nested-vec-of 0 4) #(0 0 0 0)
+ (nested-vec-of 0 4 3) #(#(0 0 0)
+ #(0 0 0)
+ #(0 0 0)
+ #(0 0 0))
+ (nested-vec-of 'a 4 3 2) #(#(#(a a) #(a a) #(a a))
+ #(#(a a) #(a a) #(a a))
+ #(#(a a) #(a a) #(a a))
+ #(#(a a) #(a a) #(a a)))
+ (nested-vec-of 'a 1 1 1) #(#(#(a)))
+ (nested-vec-of 'a 1 1 0) #(#(#()))
+ (nested-vec-of 'a 1 0 1) #(#())
+ (nested-vec-of 'a 1 0) #(#())
+ (nested-vec-of 'a 0 1) #()
+ (nested-vec-of 'a 0) #()
+
+ (nested-vec-of 'a 4 0 1) #(#() #() #() #())
+ (nested-vec-of 'a 4 0) #(#() #() #() #()))
diff --git a/tests/011/keyparams.tl b/tests/011/keyparams.tl
new file mode 100644
index 00000000..189081d3
--- /dev/null
+++ b/tests/011/keyparams.tl
@@ -0,0 +1,47 @@
+(load "../common")
+
+(defvarl v :v)
+(defsymacro u (identity :u))
+(defvarl x :x)
+(defvarl y :y)
+
+(mtest
+ [(lambda (:key))] nil
+ [(lambda (:key a))] :error
+ [(lambda (:key a) a) 1] 1)
+
+(mtest
+ [(lambda (:key -- (a v)) a)] :v
+ [(lambda (:key -- (a 'v)) a)] v
+ [(lambda (:key -- (a v a-p)) (list a a-p))] (:v nil)
+ [(lambda (:key -- (a 'v a-p)) (list a a-p))] (v nil))
+
+(mtest
+ [(lambda (:key -- (a v)) a) :a 1] 1
+ [(lambda (:key -- (a 'v)) a) :a 1] 1
+ [(lambda (:key -- (a v a-p)) (list a a-p)) :a 1] (1 t)
+ [(lambda (:key -- (a 'v a-p)) (list a a-p)) :a 1] (1 t))
+
+(mtest
+ [(lambda (:key -- (a v) (b u)) (list a b)) :a 1] (1 :u)
+ [(lambda (:key -- (a 'v) (b 'u)) (list a b)) :b 1] (v 1)
+ [(lambda (:key -- (a v a-p) (b u b-p)) (list a a-p b b-p)) :a 1] (1 t :u nil)
+ [(lambda (:key -- (a v a-p) (b u b-p)) (list a a-p b b-p)) :b 1] (:v nil 1 t))
+
+(test
+ [(lambda (:key -- (a v) . r) (list a r)) :a 1] (1 (:a 1)))
+
+(defun key-place (:key -- x y (s nil s-p)) ^(,x ,y ,s ,s-p))
+
+(defset key-place (:key -- x y) s
+ ^(key-place :x ,x :y ,y :s ,s))
+
+(test
+ (set (key-place :x 3 :y 4) 42) (3 4 42 t))
+
+(defmacro kp (r (:key -- (a v a-p) (b u b-p)) : ((:key -- (c x c-p) (d y d-p))))
+ ^'(r ,a ,a-p ,b ,b-p ,c ,c-p ,d ,d-p))
+
+(mtest
+ (kp :r ()) (r :v nil :u nil :x nil :y nil)
+ (kp 0 (:a 1 :b 2) (:d 3)) (r 1 t 2 t :x nil 3 t))
diff --git a/tests/011/macros-3.expected b/tests/011/macros-3.expected
deleted file mode 100644
index e69de29b..00000000
--- a/tests/011/macros-3.expected
+++ /dev/null
diff --git a/tests/011/macros-3.tl b/tests/011/macros-3.tl
index bf7cf9a6..fda312da 100644
--- a/tests/011/macros-3.tl
+++ b/tests/011/macros-3.tl
@@ -10,3 +10,16 @@
(macrolet ((m (:form f) f))
(m))))))
42)
+
+(defvarl x 0)
+(defmacro mac-time-counter () (inc x))
+(defsymacro s (mac-time-counter))
+
+(mtest s 1
+ s 2
+ s 3)
+
+(test (symacrolet ((a 42))
+ (labels ()
+ a))
+ 42)
diff --git a/tests/011/macros-4.tl b/tests/011/macros-4.tl
new file mode 100644
index 00000000..440dcd9e
--- /dev/null
+++ b/tests/011/macros-4.tl
@@ -0,0 +1,11 @@
+(load "../common")
+
+(defmacro xsqrt (:match :form f)
+ (((* @exp @exp)) exp)
+ (@else f))
+
+(defmacro xexpt (:match :form f)
+ ((@exp 2) ^(* ,exp ,exp))
+ (@else f))
+
+(test (expand '(xsqrt (xexpt x 2))) x)
diff --git a/tests/011/mandel.txr b/tests/011/mandel.txr
index 8a701526..cfa24857 100644
--- a/tests/011/mandel.txr
+++ b/tests/011/mandel.txr
@@ -1,16 +1,14 @@
@(do
- (defvar x-centre -0.5)
- (defvar y-centre 0.0)
- (defvar width 4.0)
- (defvar i-max 80)
- (defvar j-max 60)
- (defvar n 100)
- (defvar r-max 2.0)
- (defvar file "mandelbrot.pgm")
- (defvar colour-max 255)
- (defvar pixel-size (/ width i-max))
- (defvar x-offset (- x-centre (* 0.5 pixel-size (+ i-max 1))))
- (defvar y-offset (+ y-centre (* 0.5 pixel-size (+ j-max 1))))
+ (defvarl x-centre -0.5)
+ (defvarl y-centre 0.0)
+ (defvarl width 4.0)
+ (defvarl i-max 80)
+ (defvarl j-max 60)
+ (defvarl n 100)
+ (defvarl r-max 2.0)
+ (defvarl pixel-size (/ width i-max))
+ (defvarl x-offset (- x-centre (* 0.5 pixel-size (+ i-max 1))))
+ (defvarl y-offset (+ y-centre (* 0.5 pixel-size (+ j-max 1))))
;; complex number library
(macro-time
diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl
new file mode 100644
index 00000000..6d071f3d
--- /dev/null
+++ b/tests/011/patmatch.tl
@@ -0,0 +1,619 @@
+(load "../common")
+
+(mtest
+ (if-match 1 1 'yes 'no) yes
+ (if-match 1 0 'yes 'no) no)
+
+(test (let ((sym 'a))
+ (list (if-match a sym 'yes 'no)
+ (if-match b sym 'yes 'no)))
+ (yes no))
+
+(mtest
+ (when-match @a 42 (list a)) (42)
+ (when-match (@nil) '(1) 'yes) yes
+ (when-match (@a @b @c) '(1 2 3) (list c b a)) (3 2 1)
+ (if-match (@a @b @c . @d) '(1 2 3 . 4) (list d c b a)) (4 3 2 1))
+
+(test (if-match (@(oddp @a) @b @c . @d) '(2 x y z)
+ (list a b c d)
+ :no-match)
+ :no-match)
+
+(mtest
+ (if-match (1 2 . @a) '(1 2 3 4) a) (3 4)
+ (if-match ((1 2 @a) @b) '((1 2 3) 4) (list a b)) (3 4)
+ (if-match #() #() :yes :no) :yes
+ (if-match #() #(1) :yes :no) :no
+ (if-match #((1 @a) #(3 @b)) #((1 2) #(3 4)) (list a b)) (2 4))
+
+(test (when-match @(struct time year 2021 month @m) #S(time year 2021 month 1)
+ m)
+ 1)
+
+(defstruct widget ()
+ name
+ value)
+
+(defstruct grommet ()
+ name
+ value)
+
+(vtest (append-each ((obj (list (new grommet name "foo" value :grom)
+ (new widget name "foo" value :widg))))
+ (when-match @(struct @type name "foo" value @v) obj
+ (list (list type v))))
+ ^((,(find-struct-type 'grommet) :grom)
+ (,(find-struct-type 'widget) :widg)))
+
+(mtest
+ (when-match @(as w (@a @b @c)) '(1 2 3) (list w a b c)) ((1 2 3) 1 2 3)
+ (when-match @(require (+ @a @b) (equal a b)) '(+ z z) (list a b)) (z z))
+
+(test (if-match @(require (+ @a @b) (equal a b)) '(+ y z)
+ (list a b)
+ :no-match)
+ :no-match)
+
+(test (when-match @(all (x @a @b)) '((x 1 a) (x 2 b) (x 3 c))
+ (list a b))
+ ((1 2 3) (a b c)))
+
+(test (when-match (@x @(all @x)) '(1 (1 1 1 1)) x) 1)
+
+(test (when-match (@x @(all @x)) '(1 (1 1 1 2)) x) nil)
+
+(test (when-match @(some (x @a @b)) '((y 1 a) (x 2 b) (z 3 c))
+ (list a b))
+ (2 b))
+
+(test (when-match @(coll (x @a @b)) '((y 1 a) (x 2 b) (z 3 c) (x 4 d))
+ (list a b))
+ ((2 4) (b d)))
+
+(test (if-match @(and (@x 2 3) (1 @y 3) (1 2 @z)) '(1 2 3)
+ (list x y z))
+ (1 2 3))
+
+(test (if-match @(and (@x 1) (1 @x)) '(1 1) x) 1)
+(test (if-match @(and (@x 1) (1 @x)) '(1 2) x) nil)
+
+(test (when-match @(all @(or (@x @y) @z)) '((1 2) (3 4)) (list x y z))
+ ((1 3) (2 4) (nil nil)))
+
+(test (let ((a 1) (b 2) (c 3))
+ (if-match @(or @a @b @c) 2
+ (list a b c)))
+ (1 2 3))
+
+(test (when-match @(or @(all @x)) '(1 2 3) x) (1 2 3))
+
+(test (when-match (foo @(all @x)) '(bar (1 2 . 3)) x) nil)
+
+(test (when-match (@(or foo) @(all @x)) '(bar (1 2 . 3)) x) nil)
+
+(test (when-match (@(oddp) @(all @x)) '(2 (1 2 . 3)) x) nil)
+
+(mtest
+ (if-match @(or (@x 3 3) (1 @x 3) (1 2 @x)) '(1 2 3) x) 2
+ (if-match @(<= 10 @a 13) 11 :yes :no) :yes
+ (when-match @(as x @(<= 10 @a 13)) 11 x) 11
+ (when-match (@(evenp) @(oddp @x)) '(2 3) x) 3
+ (when-match @(<= 1 @x 10) 4 x) 4
+ (when-match @(@d (chr-digit @c)) #\5 (list d c)) (5 #\5)
+ (when-match @(or @(require @a (oddp a)) @b @c) 2 (list a b c)) (nil 2 nil)
+ (when-match @(@x (< . @sym)) '(1 2 3) (list x sym)) (t (1 2 3))
+ (when-match @(@x (< . @sym)) '(3 2 1) (list x sym)) nil
+ (let ((x t))
+ (when-match @(@x (< . @sym)) '(1 2 3) (list x sym))) (t (1 2 3))
+ (let ((x nil))
+ (when-match @(@x (< . @sym)) '(1 2 3) (list x sym))) nil
+ (if-match (@(or @a) @a) '(1 2) a :no) :no
+ (if-match (@(and @a) @a) '(1 2) a :no) :no)
+
+
+(test
+ (collect-each ((obj (list '(1 2 3)
+ '(4 5)
+ '(3 5)
+ #S(time year 2021 month 1 day 1)
+ #(vec tor))))
+ (match-case obj
+ (@(struct time year @y) y)
+ (#(@x @y) (list x y))
+ ((@nil @nil @x) x)
+ ((4 @x) x)
+ ((@x 5) x)))
+ (3 5 3 2021 (vec tor)))
+
+(test (when-match (@(and @a @b) (x . @c)) '(1 (x 2 3 4)) c) (2 3 4))
+
+(test (when-match (@(some @a) . @b) '((1 2 3) 2) (list a b)) (1 (2)))
+
+(set *print-circle* t)
+
+(test (when-match @(as a @(some @a)) '#1=(1 2 #1# 3) :yes) :yes)
+
+(test (when-match (@a @(as a @(some @a))) '(#1=(1 2 #1# 3) #1#) :yes) :yes)
+
+(test (when-match (@a @(as a @(or x @a))) '(#1=(1 2 #1# 3) #1#) :yes) :yes)
+
+(test (when-match (@(with @a x 42) @b @c) '(1 2 3) (list a b c x))
+ (1 2 3 42))
+
+(test (let ((o 3))
+ (when-match (@(evenp @x) @(with @z @(oddp @y) o)) '(4 6)
+ (list x y z)))
+ (4 3 6))
+
+(test (let ((o 3))
+ (when-match (@(evenp @x) @(with @(oddp @y) o)) '(4 6)
+ (list x y)))
+ (4 3))
+
+(defstruct node ()
+ left right)
+
+(mlet ((n (lnew node left (new node left n))))
+ (test (when-match @(as x @(struct node
+ left @(struct node left @x)))
+ n :yes)
+ :yes))
+
+(test
+ (collect-each ((obj (list '(1 2 3)
+ '(4 5)
+ '(3 5)
+ '(6 2 6)
+ #(11 12)
+ #S(time year 2021 month 1 day 2)
+ #S(time year 2020 month 1 day 1)
+ #(vec tor))))
+ (match-case obj
+ (@(struct @s year 2021 day @d) (list d (struct-type-name s)))
+ (@(struct time year @y month @x day @x) (list y x))
+ (#(@(integerp @x) @(require @y (succ x))) (list x y))
+ (#(@x @y) (list x y))
+ ((@x @nil @x) x)
+ ((@nil @nil @x) x)
+ ((4 @x) x)
+ ((@x 5) x)))
+ (3 5 3 6 (11 12) (2 time) (2020 1) (vec tor)))
+
+(test (when-match @(hash (x @y) (@y @datum)) #H(() (x k) (k 42)) datum)
+ 42)
+
+(test (when-match @(hash (x @y) (@(symbolp @y) @datum)) #H(() (x k) (k 42)) datum)
+ (42))
+
+(mtest
+ (when-match @(hash (a)) #H(() (a b)) t) t
+ (when-match @(hash (c)) #H(() (a b)) t) nil
+ (let ((x 'a)) (when-match @(hash (@x)) #H(() (a b)) t)) t
+ (let ((x 'd)) (when-match @(hash (@x)) #H(() (a b)) t)) nil
+ (when-match @(hash (@x)) #H(() (a b)) x) (a))
+
+(mtest
+ (if-match #R(10 20) 10..20 :yes :no) :yes
+ (if-match #R(10 20) #R(10 20) :yes :no) :yes
+ (if-match #R(10 20) #R(1 2) :yes :no) :no
+ (when-match #R(@a @b) 1..2 (list a b)) (1 2)
+ (when-match #R(@a 2) 1..2 a) 1
+ (when-match #R(1 @a) 1..2 a) 2
+ (when-match #R(2 @a) 1..2 a) nil
+ (when-match #R(@a 1) 1..2 a) nil)
+
+(mtest
+ (when-match @a..@b '1..2 (list a b)) (1 2)
+ (when-match (rcons @a @b) '(rcons 1 2) (list a b)) (1 2))
+
+(test (let ((h #H(() (a 1) (b 2))))
+ (when-match @[h @x] 'a x))
+ a)
+
+(test (let ((h #H(() (a 1) (b 2))))
+ (when-match @(@y [h @x]) 'a (list x y)))
+ (a 1))
+
+(test
+ (let ((f (lambda-match
+ (() (list 0 :args))
+ ((@a) (list 1 :arg a))
+ ((@a @b) (list 2 :args a b))
+ ((@a @b . @c) (list* '> 2 :args a b c)))))
+ (list [f] [f 1] [f 1 2] [f 1 2 3]))
+ ((0 :args) (1 :arg 1) (2 :args 1 2) (> 2 :args 1 2 3)))
+
+(test
+ [(lambda-match
+ ((0 1) :zero-one)
+ ((1 0) :one-zero)
+ ((@x @y) :no-match)) 1 0]
+ :one-zero)
+
+(test
+ [(lambda-match
+ ((0 1) :zero-one)
+ ((1 0) :one-zero)
+ ((@x @y) :no-match)) 1 1]
+ :no-match)
+
+(compile-only
+ (eval-only
+ (test
+ [(lambda-match
+ ((0 1) :zero-one)
+ ((1 0) :one-zero)
+ ((@x @y) :no-match)) 1 2 3]
+ :error)))
+
+(test
+ [(lambda-match
+ ((@a @b) (list a b))
+ ((@x . @y) (list x y)))
+ 1 2 3]
+ (1 (2 3)))
+
+(test
+ [(lambda-match
+ ((@a @b) (list a b))
+ (@x x))
+ 1 2 3]
+ (1 2 3))
+
+(defun-match fib
+ ((0) 1)
+ ((1) 1)
+ ((@x) (+ (fib (pred x)) (fib (ppred x)))))
+
+(mtest
+ (fib 0) 1
+ (fib 1) 1
+ (fib 2) 2
+ (fib 3) 3
+ (fib 4) 5
+ (fib 5) 8)
+
+(defun-match ack
+ ((0 @n) (+ n 1))
+ ((@m 0) (ack (- m 1) 1))
+ ((@m @n) (ack (- m 1) (ack m (- n 1)))))
+
+(mtest
+ (ack 1 1) 3
+ (ack 2 2) 7)
+
+(defun x-x-y (list x)
+ (when-match (@x @x @y) list y))
+
+(mtest
+ (x-x-y '(1 1 2) 1) 2
+ (x-x-y '(1 2 3) 1) nil
+ (x-x-y '(1 1 2 r2) 1) nil)
+
+(test (let ((a 3) (x 0))
+ (match-case '(3 2 1)
+ ((@x 2 @b) ^(1 ,b))
+ ((@a 2 @b) ^(2 ,a))))
+ (2 3))
+
+(test
+ (let ((a 3) (x 0))
+ (labels ((local (:match)
+ ((@x 2 @b) ^(1 ,b))
+ ((@a 2 @b) ^(2 ,a))))
+ (local 3 2 1)))
+ (2 3))
+
+(test
+ (when-match @(sme (1 2) (3 4) (5 . 6) m e)
+ '(1 2 3 4 5 . 6)
+ (list m e))
+ ((3 4 5 . 6) (5 . 6)))
+
+(test
+ (when-match @(sme (1 2) (3 4) (5 . 6) m d)
+ '(1 2 abc 3 4 def 5 . 6)
+ (list m d))
+ ((3 4 def 5 . 6) (5 . 6)))
+
+(test
+ (when-match @(sme (1 2 @x . @y) (4 @z) 6)
+ '(1 2 abc 3 4 def 5 . 6)
+ (list x y z))
+ (abc (3 4 def 5 . 6) def))
+
+(mtest
+ (when-match @(sme (1 2) (2 3) (4)) '(1 2 3 4) t) nil
+ (when-match @(sme (1 2) (3 4) (4)) '(1 2 3 4) t) nil
+ (when-match @(sme (1 2) (2 3) (3 4)) '(1 2 3 4) t) nil
+ (when-match @(sme (1 2 . @x) (3 . @y) (4)) '(1 2 3 4) t) t
+ (when-match @(sme (1 2 . @x) (3 . @y) ()) '(1 2 3 4) t) t
+ (when-match @(sme (1 2 . @x) (3 . @y) ()) '(1 2 3 4 . 5) t) nil)
+
+(test (when-match @(sme (1 @y) (@z @x @y @z) (@x @y)) '(1 2 3 1 2 3 1 2)
+ (list x y z))
+ (1 2 3))
+
+(test (when-match @(and @(sme (1 @x) (3) (7) m n)
+ @(with @(coll @(oddp @y)) (ldiff m n)))
+ '(1 2 3 4 5 6 7)
+ (list x y))
+ (2 (3 5)))
+
+(test (when-match @(sme () () 5) 5 t) t)
+
+(mtest
+ (when-match @(end 3 x) 3 x) 3
+ (when-match @(end (2 @x) y) '(1 2 3) (list x y)) (3 (2 3))
+ (when-match @(end (2 . @x) y) '(1 2 . 3) (list x y)) (3 (2 . 3)))
+
+(test (when-match @(as z @(end (2 @x) y)) '(1 2 3) (list x y z))
+ (3 (2 3) (1 2 3)))
+
+(defmatch env (var :env e)
+ ^@(with ,var ',e))
+
+(test (when-match @(and @a @(env e) @b) 42
+ (list a (env-vbindings e) (lexical-var-p e 'a) (lexical-var-p e 'b) b))
+ (42 ((a . sys:special)) t nil 42))
+
+(defmatch var= (sym :env e)
+ (if (lexical-var-p e sym)
+ (with-gensyms (obj)
+ ^@(require (sys:var ,obj) (= ,sym ,obj)))
+ ^(sys:var ,sym)))
+
+(test (when-match (@(var= a) @(var= a)) '(1 1.0) a) 1)
+
+(mtest
+ (when-match `` "" t) t
+ (when-match `abc` "abc" t) t
+ (when-match `abc` "abcdef" t) nil
+ (when-match `@a` "abc" a) "abc"
+ (let ((x "foo")) (when-match `@x` "foobar" t)) nil
+ (let ((x "foo")) (when-match `@x` "foo" x)) "foo")
+
+(mtest
+ (when-match `@a@b` "abc" a) :error
+ (when-match `@nil@b` "abc" a) :error
+ (when-match `@nil@nil` "abc" a) :error
+ (when-match `@a@nil` "abc" a) :error)
+
+(mtest
+ (when-match `@a-$` "a-$" a) "a"
+ (when-match `#@a-$` "#a-$" a) "a"
+ (when-match `#@a-$` "#a-$$" a) nil
+ (when-match `#@a-$` "#a-" a) nil
+ (when-match `#@a-@b` "#a-$" (list a b)) ("a" "$")
+ (when-match `#@{a #/ab*c/}` "#abbbc" a) "abbbc"
+ (when-match `#@{a #/ab*c/}d` "#abbbcd" a) "abbbc"
+ (when-match `#@{nil #/ab*c/}` "#abbbc" t) t
+ (when-match `#@{nil #/ab*c/}d` "#abbbcd" t) t
+ (when-match `#@{a 3}@b` "#abb" a) "abb"
+ (when-match `#@{a 3}@b` "#abbbc" (list a b)) ("abb" "bc")
+ (when-match `#@{a 4}@b` "#abb" a) nil
+ (when-match `#@{a 3}` "#abb" a) "abb"
+ (when-match `#@{a 2}` "#abb" a) nil
+ (when-match `#@{a 4}` "#abb" a) nil)
+
+(let ((z 0))
+ (mtest
+ (when-match `@z#@a-$` "0#a-$" a) "a"
+ (when-match `@z#@a-$` "0#a-$$" a) nil
+ (when-match `@z#@a-$` "0#a-" a) nil
+ (when-match `@z#@a-@b` "0#a-$" (list a b)) ("a" "$")
+ (when-match `@z#@{a #/ab*c/}` "0#abbbc" a) "abbbc"
+ (when-match `@z#@{a #/ab*c/}d` "0#abbbcd" a) "abbbc"
+ (when-match `@z#@{a 3}@b` "0#abb" a) "abb"
+ (when-match `@z#@{a 3}@b` "0#abbbc" (list a b)) ("abb" "bc")
+ (when-match `@z#@{a 4}@b` "0#abb" a) nil
+ (when-match `@z#@{a 3}` "0#abb" a) "abb"
+ (when-match `@z#@{a 2}` "0#abb" a) nil
+ (when-match `@z#@{a 4}` "0#abb" a) nil))
+
+(test (when-match `#@{a 4 5}` "#abb" a) :error)
+
+(let ((b "bcd"))
+ (mtest
+ (when-match `@a@b` "abcd" a) "a"
+ (when-match `@a@{b [1..:]}` "acd" a) "a"
+ (when-match `@a@{b [1..:]}` "abcd" a) "ab"
+ (when-match `@a@{b [0..1]}` "abcd" a) nil
+ (when-match `@a@{b [0..2]}d` "abcd" a) "a"))
+
+(let ((x 123) (z 0))
+ (mtest
+ (when-match `^@{x 5}$` "^123 $" t) t
+ (when-match `^@{x -5}$` "^ 123$" t) t
+ (when-match `@x@x` "123123" t) t
+ (when-match `@x@{x [1..:]}` "12323" t) t
+ (when-match `@z^@{x 5}$` "0^123 $" t) t
+ (when-match `@z^@{x -5}$` "0^ 123$" t) t
+ (when-match `@z@x@x` "0123123" t) t
+ (when-match `@z@x@{x [1..:]}` "012323" t) t))
+
+(let ((a "$"))
+ (test (when-match `@a-@b` "$-@" b) "@"))
+
+(mtest
+ (when-match `@{a #/\d+/}-@{a #/\d+/}` "123-123" a) "123"
+ (when-match `@{a #/\d+/}-@{a #/\d+/}-` "123-123-" a) "123"
+ (when-match `@{a #/\d+/}-@{a #/\d+/}` "123-1234" a) nil
+ (when-match `@{a #/\d+/}-@{a #/\d+/}-` "123-1234-" a) nil)
+
+(test
+ (build
+ (each-match (`(@a) @b-@c` '("x"
+ ""
+ "(311) 555-5353"
+ "(604) 923-2323"
+ "133"
+ "4-5-6-7")
+ @x 1)
+ (add (list x a b c))))
+ ((3 "311" "555" "5353") (4 "604" "923" "2323")))
+
+(test
+ (append-matches ((:foo @y) '((:foo a) (:bar b) (:foo c) (:foo d))
+ (@x :bar) '((1 :bar) (2 :bar) (3 :bar) (4 :foo)))
+ (list x y))
+ (1 a 3 c))
+
+(test
+ (append-matches (@x '((1) (2) (3) 4)) x)
+ (1 2 3 . 4))
+
+(test
+ (keep-matches ((:foo @y) '((:foo a) (:bar b) (:foo c) (:foo d))
+ (@x :bar) '((1 :bar) (2 :bar) (3 :bar) (4 :foo)))
+ (list x y))
+ ((1 a) (3 c)))
+
+(test
+ (build
+ (each-match-product (`(@a) @b-@c` '("x"
+ ""
+ "(311) 555-5353"
+ "(604) 923-2323"
+ "133"
+ "4-5-6-7")
+ @(oddp @x) '(1 2 3))
+ (add (list x a b c))))
+ ((1 "311" "555" "5353") (3 "311" "555" "5353")
+ (1 "604" "923" "2323") (3 "604" "923" "2323")))
+
+(test
+ (append-match-products (@(oddp @x) (range 1 5)
+ @(evenp @y) (range 1 5))
+ (list x y))
+ (1 2 1 4 3 2 3 4 5 2 5 4))
+
+(test
+ (keep-match-products (@(oddp @x) (range 1 5)
+ @(evenp @y) (range 1 5))
+ (list x y))
+ ((1 2) (1 4) (3 2) (3 4) (5 2) (5 4)))
+
+(test
+ (each-match (@a '(1 2 3)) (return 42)) 42)
+
+(mtest
+ (when-match ^(,a ,b) '(1 2) (list a b)) (1 2)
+ (when-match ^(,(oddp @a) ,(evenp @b)) '(1 2) (list a b)) (1 2)
+ (when-match ^#(,a ,b) #(1 2) (list a b)) (1 2)
+ (when-match ^#S(,type year ,y) #S(time year 2021)
+ (list (struct-type-name type) y)) (time 2021)
+ (when-match ^#H(() (x ,y) (,(symbolp @y) ,datum))
+ #H(() (x k) (k 42))
+ datum) (42))
+
+(mtest
+ (when-match ^#J~a 42.0 a) 42.0
+ (when-match ^#J[~a, ~b] #J[true, false] (list a b)) (t nil)
+ (when-match ^#J{"x" : ~y, ~(symbolp @y) : ~datum}
+ #J{"x" : true, true : 42}
+ datum) (42.0)
+ (when-match ^#J{"foo" : {"x" : ~val}} #J{"foo" : {"x" : "y"}} val) "y")
+
+(test
+ (let ((a '(1 2 3 4)))
+ (build
+ (while-match @(true @x) (pop a)
+ (add (* 10 x)))))
+ (10 20 30 40))
+
+(test
+ (let ((a '(1 (2 3) 4 (5 6))))
+ (build
+ (while-match-case (pop a)
+ ((@x @y) (add :pair x y))
+ (@(numberp @x) (add :num x)))))
+ (:num 1 :pair 2 3 :num 4 :pair 5 6))
+
+(test
+ (let ((a '(1 (2 3) 4 (5 6))))
+ (build
+ (while-true-match-case (pop a)
+ ((@x @y) (add :pair x y))
+ (@(evenp @x) (add :even x))
+ (@(oddp @x) (add :odd x))
+ (@else (error "unhandled case")))))
+ (:odd 1 :pair 2 3 :even 4 :pair 5 6))
+
+(mtest
+ (match (@a @b) '(1 2) (list a b)) (1 2)
+ (match (@a @b) '(1 2 3) (list a b)) :error)
+
+(mtest
+ (match-ecase 42) :error
+ (match-ecase 42 (@a a)) 42
+ (match-ecase '(1 2) ((@a) a)) :error)
+
+(mtest
+ (match @`foo-@a` "foo-abc" a) "abc"
+ (match ^(,`foo-@a`) '("foo-abc") a) "abc"
+ (match ^#J[~`foo-@a`] #("foo-abc") a) "abc")
+
+(mtest
+ (match @(< @nil 0) -1 42) 42
+ (match @(> 0 @nil) -1 42) 42
+ (if-match @(< @nil 0) 1 :y :n) :n
+ (if-match @(< @nil 2) 1 :y :n) :y
+ (match @(@nil (< @x 0)) -1 x) -1
+ (match @(@nil (< @nil 0)) -1 t) t)
+
+(mtest
+ (match ^(foo) '(foo) t) t
+ (match ^#H() #H(() (a b)) t) t
+ (match ^#H(()) #H(() (a b)) t) t
+ (match ^#S(time) #S(time year 2023) t) t)
+
+(mtest
+ (match-cond (t)) :error
+ (match-cond (t t)) t
+ (match-cond (t t nil)) nil
+ (match-cond (t t t)) t
+ (let ((x 42))
+ (match-cond
+ (`@x-73` "73-73" :a)
+ (`@x-@y` "42-24" y))) "24"
+ (let ((x 42)
+ (y 24))
+ (match-cond
+ (`@x-24` `42-@y`))) "42-24")
+
+(mtest
+ (symacrolet ((x 3))
+ (match @x 4 x)) :error
+ (symacrolet ((x 3))
+ (match @x 3 x)) 3
+ (let ((x 3))
+ (match @x 4 x)) :error
+ (let ((x 3))
+ (match @x 3 x)) 3)
+
+(defvar dv :dv)
+(defsymacro gs :gs)
+
+(mtest
+ (match @dv 0 dv) :error
+ (match @dv :dv dv) :dv
+ (match @gs 0 gs) :error
+ (match @gs :gs gs) :gs)
+
+(mtest
+ (match @(end @x) '(1 . 2) x) 2
+ (match @(end @(evenp @x)) '(1 . 2) x) 2
+ (match @(end (@z . @x)) '(1 . 2) (list z x)) (1 2)
+ (match @(end (@z . @(evenp @x))) '(1 . 2) (list z x)) (1 2))
+
+(mtest
+ (match @(sme (@a) (@b) @x) '(0 1 . 2) (list a b x)) (0 1 2)
+ (match @(sme (@a) (@b) @(evenp @x)) '(0 1 . 2) (list a b x)) (0 1 2))
+
+(compile-only
+ (eval-only
+ (with-compile-opts (nil unused)
+ (compile-file (base-name *load-path*) "temp.tlo"))
+ (remove-path "temp.tlo")))
diff --git a/tests/011/place.tl b/tests/011/place.tl
new file mode 100644
index 00000000..eb0dcb46
--- /dev/null
+++ b/tests/011/place.tl
@@ -0,0 +1,9 @@
+(load "../common")
+
+(defvar h (hash))
+
+(mtest
+ (let ((x 0)) (ensure (gethash h (pinc x)) "a") x) 1
+ [h 0] "a"
+ (let ((x 0)) (ensure (gethash h 0) (pinc x)) x) 0
+ [h 0] "a")
diff --git a/tests/011/tree-bind.tl b/tests/011/tree-bind.tl
new file mode 100644
index 00000000..ac55cc07
--- /dev/null
+++ b/tests/011/tree-bind.tl
@@ -0,0 +1,20 @@
+(load "../common")
+
+(mtest
+ (tree-bind b '(1 2) b) (1 2)
+ (tree-bind (t b) '(1 2) b) 2
+ (tree-bind (t . b) '(1 2) b) (2)
+ (tree-bind (b t) '(1 2) b) 1
+ (tree-bind (b . t) '(1 2) b) 1
+ (tree-bind t '(1 2) 3) 3
+ (tree-bind (t : b) '(1 2) b) 2
+ (tree-bind (b : t) '(1) b) 1
+ (tree-bind (b : (t 2)) '(1) b) 1
+ (tree-bind (#:b : (a 2 t)) '(1) a) 2
+ (let ((i 0)) (tree-bind (b : (t (inc i) t)) '(1) (cons i b))) (1 . 1)
+ (let ((i 0)) (tree-bind (b : (t (inc i) t)) '(1 2) (cons i b))) (0 . 1))
+
+(compile-only
+ (eval-only
+ (compile-file (base-name *load-path*) "temp.tlo")
+ (remove-path "temp.tlo")))
diff --git a/tests/011/txr-case.expected b/tests/011/txr-case.expected
index 4af473e5..e7582780 100644
--- a/tests/011/txr-case.expected
+++ b/tests/011/txr-case.expected
@@ -2,3 +2,4 @@ no match for 09-10-20
match: year 2009, month 10, day 20
no match for July-15-2014
no match for foo
+match: year 2021, month 06, day 16, foo:bar
diff --git a/tests/011/txr-case.txr b/tests/011/txr-case.txr
index 1aa80478..d6d8d788 100644
--- a/tests/011/txr-case.txr
+++ b/tests/011/txr-case.txr
@@ -1,4 +1,5 @@
@(load `@{stdlib}txr-case`)
+@(include "../common")
@(define date (year month day))
@{year /\d\d\d\d/}-@{month /\d\d/}-@{day /\d\d/}
@(end)
@@ -7,3 +8,19 @@
(txr-if date (y m d) date
(put-line `match: year @y, month @m, day @d`)
(put-line `no match for @date`))))
+@(define notmatch ())
+blah
+@(end)
+@(define stuff (year month day a b))
+@(date year month day)
+@a @b
+@(end)
+@(do (txr-case (make-strlist-input-stream '("2021-06-16"
+ "foo bar"))
+
+ (notmatch () (put-line "notexpected"))
+ (stuff (y m d a b) (put-line `match: year @y, month @m, day @d, @a:@b`)))
+ (mtest
+ (match-fboundp 'notmatch) t
+ (match-fboundp 'stuff) t
+ (match-fboundp 'xyzzy) nil))
diff --git a/tests/012/aseq.expected b/tests/012/aseq.expected
deleted file mode 100644
index e69de29b..00000000
--- a/tests/012/aseq.expected
+++ /dev/null
diff --git a/tests/012/aseq.tl b/tests/012/aseq.tl
index dfb20118..e1a55fb8 100644
--- a/tests/012/aseq.tl
+++ b/tests/012/aseq.tl
@@ -8,7 +8,11 @@
(:method lambda (me i)
(if (rangep i)
(mapcar (op + me.n) [me.list i])
- (+ me.n (ref me.list i)))))
+ (+ me.n (ref me.list i))))
+ (:method lambda-set (me i nv)
+ (if (rangep i)
+ (set [me.list i] (mapcar (lop - me.n) nv))
+ (set [me.list i] (- nv me.n)))))
(defvarl o (new (add 3 (range 10 100 10))))
@@ -16,3 +20,8 @@
(test (cadr o) 23)
(test [o 4] 53)
(test (cadr (last o)) nil)
+
+(test (set [o 0..3] '(1003 1103 1203)) (1003 1103 1203))
+(test o.list (1000 1100 1200 40 50 60 70 80 90 100))
+(test (del [o 1..4]) (1103 1203 43))
+(test o.list (1000 50 60 70 80 90 100))
diff --git a/tests/012/ashwin.expected b/tests/012/ashwin.expected
deleted file mode 100644
index e69de29b..00000000
--- a/tests/012/ashwin.expected
+++ /dev/null
diff --git a/tests/012/binding.tl b/tests/012/binding.tl
new file mode 100644
index 00000000..59c1ff04
--- /dev/null
+++ b/tests/012/binding.tl
@@ -0,0 +1,5 @@
+(load "../common")
+
+(test
+ (mac-env-param-bind '(foo) 42 (:env e :form f x y) '(1 2) (list x y e f))
+ (1 2 42 (foo)))
diff --git a/tests/012/buf.tl b/tests/012/buf.tl
new file mode 100644
index 00000000..01a510ab
--- /dev/null
+++ b/tests/012/buf.tl
@@ -0,0 +1,28 @@
+(load "../common")
+
+(vtest (uint-buf (make-buf 8 255 16)) (pred (expt 2 64)))
+(test (int-buf (make-buf 8 255 16)) -1)
+
+(mtest
+ (str-buf #b'E6BC') "\xDCE6\xDCBC"
+ (buf-str "\xDCE6\xDCBC") #b'E6BC'
+ (str-buf #b'E6') "\xDCE6"
+ (buf-str "\xDCE6") #b'E6')
+
+(when (fboundp 'usr:buf-compress)
+ (mtest
+ (< (len (buf-compress (make-buf 1024))) 100) t
+ (buf-compress (make-buf 1024) -2) :error
+ (buf-compress (make-buf 1024) 10) :error)
+
+ (each ((i 0..65535))
+ (let* ((buf (ffi-put i (ffi uint16)))
+ (zbuf (buf-compress buf)))
+ (vtest (buf-decompress zbuf) buf)))
+
+ (let ((buf (random-buf 65536)))
+ (vtest (buf-decompress (buf-compress buf)) buf))
+
+ (mtest
+ (buf-decompress (make-buf 1024)) :error
+ (buf-decompress (make-buf 1024 255)) :error))
diff --git a/tests/012/cadr.tl b/tests/012/cadr.tl
new file mode 100644
index 00000000..509590f7
--- /dev/null
+++ b/tests/012/cadr.tl
@@ -0,0 +1,14 @@
+(load "../common")
+
+(mtest
+ (cxr 1 42) 42
+ (cxr #b11 '(a . b)) a
+ (cxr #b10 '(a . b)) b
+ (cxr #b11000 '(1 2 3 4 5)) 4
+ (cyr #b100001 '(1 2 3 4 5)) 5
+ (cyr #b1111 '(((a)))) a
+ (cyr #b111 '(a)) :error)
+
+(let ((r (range* 0 100)))
+ (vtest (mapcar (op cyr (succ (expt 2 (succ @1))) r) 0..100) r)
+ (vtest (mapcar (op cxr (* 3 (expt 2 @1)) r) 0..100) r))
diff --git a/tests/012/callable.tl b/tests/012/callable.tl
new file mode 100644
index 00000000..9e88b955
--- /dev/null
+++ b/tests/012/callable.tl
@@ -0,0 +1,31 @@
+(load "../common")
+
+(mtest
+ [0 '(1 2 3)] 1
+ [1 '(1 2 3)] 2
+ [2 '(1 2 3)] 3)
+
+(mtest
+ [0 "abc"] #\a
+ [1 "abc"] #\b
+ [2 "abc"] #\c)
+
+(mtest
+ [0..1 '(1 2 3)] (1)
+ [1..3 '(1 2 3)] (2 3))
+
+(mtest
+ [0..0 "abc"] ""
+ [0..2 "abc"] "ab"
+ [-1..: "abc"] "c")
+
+(test (mapcar [callf list* 2 0 1 3..:] '((A B C X) (D E F Y) (G H I Z)))
+ ((C A B X) (F D E Y) (I G H Z)))
+
+(mtest
+ (set [1 1] 2) :error
+ (set [1 1..2] 2) :error
+ (set [1..2 1] 2) :error
+ (set [1..2 1..2] 2) :error
+ (let ((abc "abc")) (set [1..2 abc] "42") abc) "a42c"
+ (let ((abc "abc")) (set [1 abc] #\d) abc) "adc")
diff --git a/tests/012/case.tl b/tests/012/case.tl
new file mode 100644
index 00000000..856ac56c
--- /dev/null
+++ b/tests/012/case.tl
@@ -0,0 +1,32 @@
+(load "../common")
+
+(mtest
+ (caseq 0 (1 :match)) nil
+ (caseq 0 ((1) :match)) nil
+ (caseq 1 (1 :match)) :match
+ (caseq 1 ((1) :match)) :match
+ (caseq 1 ((0 1) :match)) :match
+ (caseq 1 ((0 2) :match)) nil
+ (caseq 1 (t :match)) :match
+ (caseq 1 ((t) :match)) nil
+ (caseq t ((t) :match)) :match)
+
+(defvar o 1)
+(defvar y t)
+
+(mtest
+ (caseq* 0 (o :match)) nil
+ (caseq* 0 ((o) :match)) nil
+ (caseq* 1 (o :match)) :match
+ (caseq* 1 ((o) :match)) :match
+ (caseq* 1 ((0 o) :match)) :match
+ (caseq* 1 ((0 2) :match)) nil
+ (caseq* 1 (t :match)) :match
+ (caseq* 1 (y :match)) nil
+ (caseq* 1 ((t) :match)) nil
+ (caseq* t ((t) :match)) :match
+ (caseq* t ((y) :match)) :match)
+
+(test (casequal '(a b c d)
+ (((a b c d)) :match))
+ :match)
diff --git a/tests/012/circ.tl b/tests/012/circ.tl
index 4b6e9990..82abe745 100644
--- a/tests/012/circ.tl
+++ b/tests/012/circ.tl
@@ -5,9 +5,9 @@
(print me.a stream pretty-p)
(put-string "]]" stream)))
-(defvar x (let* ((l (list "a"))
- (c (new circ-print a l)))
- (list l c)))
+(defvarl x (let* ((l (list "a"))
+ (c (new circ-print a l)))
+ (list l c)))
(let ((*print-circle* t))
(prinl (new circ-print a "a"))
diff --git a/tests/012/compile.tl b/tests/012/compile.tl
new file mode 100644
index 00000000..b79d92f4
--- /dev/null
+++ b/tests/012/compile.tl
@@ -0,0 +1,15 @@
+(defparml %this-dir% (dir-name *load-path*))
+(defparml %expected-file% `@(m^ #/.*[.]/ *load-path*)expected`)
+
+(file-put-string %expected-file% "")
+
+(each ((f '#"aseq ashwin circ cont defset except \
+ fini ifa man-or-boy oop-mi oop-seq oop \
+ parse syms quasi quine seq stslot const type"))
+ (let ((exf `@{%this-dir%}/@f.expected`))
+ (when (path-exists-p exf)
+ (file-append-string %expected-file%
+ (file-get-string exf))))
+ (with-compile-opts (nil unused)
+ (compile-file `@f.tl` "temp.tlo"))
+ (remove-path "temp.tlo"))
diff --git a/tests/012/cons.tl b/tests/012/cons.tl
new file mode 100644
index 00000000..98267290
--- /dev/null
+++ b/tests/012/cons.tl
@@ -0,0 +1,35 @@
+(load "../common")
+
+(mtest
+ (tree-find "abc" "abc") t
+ (tree-find "abc" "abc" (fun eq)) nil
+ (tree-find "b" '("a" "b" "c")) t
+ (tree-find "b" '("a" "b" "c") (fun eq)) nil
+ (tree-find "b" '(("b") "a" "c")) t
+ (tree-find "b" '("a" ("b") "c")) t
+ (tree-find "b" '("a" (("b")) "c")) t
+ (tree-find "d" '("a" (("b")) "c")) nil
+ (tree-find nil '("a" (("b")) "c")) nil)
+
+(mtest
+ (cons-find "abc" "abc") t
+ (cons-find "abc" "ABC" (fun eq)) nil
+ (cons-find "b" '("a" "b" "c")) t
+ (cons-find "b" '("a" "b" "c") (fun eq)) nil
+ (cons-find "b" '(("b") "a" "c")) t
+ (cons-find "b" '("a" ("b") "c")) t
+ (cons-find "b" '("a" (("b")) "c")) t
+ (cons-find "d" '("a" (("b")) "c")) nil
+ (cons-find "d" '("a" (("b")) "c" . "d")) t
+ (cons-find "d" '("a" (("b") . "d") "c")) t
+ (cons-find "d" '("a" . "d")) t
+ (cons-find nil '("a" (("b")) "c")) t)
+
+(mtest
+ (cons-count "abc" "abc") 1
+ (cons-count "abc" "abc" (fun eq)) 0
+ (cons-count "b" '("b" . "b")) 2
+ (cons-count "b" '(3 . "b")) 1
+ (cons-count "b" '("b" . 3)) 1
+ (cons-count "b" '(("b" . "b") ("b" . "b"))) 4
+ (cons-count nil '(1 (2 3 (4)))) 3)
diff --git a/tests/012/const.tl b/tests/012/const.tl
new file mode 100644
index 00000000..e0235e30
--- /dev/null
+++ b/tests/012/const.tl
@@ -0,0 +1,23 @@
+(load "../common")
+
+(mtest
+ (constantp nil) t
+ (constantp t) t
+ (constantp :key) t
+ (constantp 'a) nil)
+
+(mtest
+ (constantp ''a) t
+ (constantp '(+)) t
+ (constantp '(+ 2)) t
+ (constantp '(+ 2 2)) t)
+
+(mtest
+ (constantp '(+ a)) nil
+ (constantp '(+ (* 2 2) (* 3 3))) t
+ (constantp '(+ (* 2 2) (* 3 a))) nil)
+
+(mtest
+ (constantp '(list 1 2 3)) nil
+ (constantp '(symacrolet ((a 1)) (+ a))) t
+ (constantp '(let ((a 1)) (+ a))) nil)
diff --git a/tests/012/cont.expected b/tests/012/cont.expected
deleted file mode 100644
index e69de29b..00000000
--- a/tests/012/cont.expected
+++ /dev/null
diff --git a/tests/012/cont.tl b/tests/012/cont.tl
index 0a728ff9..f6724439 100644
--- a/tests/012/cont.tl
+++ b/tests/012/cont.tl
@@ -24,8 +24,8 @@
(defun amb (. args)
(suspend amb-scope cont
(each ((a args))
- (when (and a (call cont a))
- (return-from amb a)))))
+ (whenlet ((res (and a (call cont a))))
+ (return-from amb-scope res)))))
(test (amb-scope
(let ((w1 (amb "the" "that" "a"))
@@ -37,3 +37,16 @@
(eql [w3 -1] [w4 0])))
(list w1 w2 w3 w4)))
("that" "thing" "grows" "slowly"))
+
+(unless (>= (sizeof wchar) 4)
+ (exit 0))
+
+(test (amb-scope
+ (let ((🍌 [apply amb (range 95795 95805)])
+ (🍏 [apply amb (range 217510 217520)])
+ (🍉 [apply amb (range 414555 414570)])
+ (🍒 [apply amb (range 422470 422485)]))
+ (amb (= (+ (expt 🍌 4) (expt 🍏 4) (expt 🍉 4))
+ (expt 🍒 4)))
+ (list 🍌 🍏 🍉 🍒)))
+ (95800 217519 414560 422481))
diff --git a/tests/012/defset.expected b/tests/012/defset.expected
deleted file mode 100644
index e69de29b..00000000
--- a/tests/012/defset.expected
+++ /dev/null
diff --git a/tests/012/defset.tl b/tests/012/defset.tl
index 110f3c64..917c0a9c 100644
--- a/tests/012/defset.tl
+++ b/tests/012/defset.tl
@@ -19,3 +19,15 @@
(expand '(inc (foo 1 2 :a 3 :b 4) 5))
^(let ((,%new-val-sym% (+ (foo 1 2 :a 3 :b 4) 5)))
(bar 1 2 3 4 () 4 ,%new-val-sym%)))
+
+(defvarl %data% (vec 0 0 0 0 0 0 0 0 0 1))
+(defun getd (a b c) [%data% (+ a b c)])
+(defun setd (a b c v) (set [%data% (+ a b c)] v))
+(define-accessor getd setd)
+
+(mtest
+ (getd 2 3 4) 1
+ (set (getd 2 3 4) 2) 2
+ [%data% 9] 2
+ (inc (getd 2 3 4) 3) 5
+ [%data% 9] 5)
diff --git a/tests/012/fini.expected b/tests/012/fini.expected
index 5e967eb2..72fdc948 100644
--- a/tests/012/fini.expected
+++ b/tests/012/fini.expected
@@ -2,44 +2,64 @@ inside with-objects
base:21 finalized
derived:1 derived fini
derived:1 finalized
+derived:1 derived postfini
derived:2 derived fini
derived:2 finalized
+derived:2 derived postfini
derived:3 derived fini
derived:3 finalized
+derived:3 derived postfini
derived:4 derived fini
derived:4 finalized
+derived:4 derived postfini
derived:5 derived fini
derived:5 finalized
+derived:5 derived postfini
derived:6 derived fini
derived:6 finalized
+derived:6 derived postfini
derived:7 derived fini
derived:7 finalized
+derived:7 derived postfini
derived:8 derived fini
derived:8 finalized
+derived:8 derived postfini
derived:9 derived fini
derived:9 finalized
+derived:9 derived postfini
derived:10 derived fini
derived:10 finalized
+derived:10 derived postfini
derived:11 derived fini
derived:11 finalized
+derived:11 derived postfini
derived:12 derived fini
derived:12 finalized
+derived:12 derived postfini
derived:13 derived fini
derived:13 finalized
+derived:13 derived postfini
derived:14 derived fini
derived:14 finalized
+derived:14 derived postfini
derived:15 derived fini
derived:15 finalized
+derived:15 derived postfini
derived:16 derived fini
derived:16 finalized
+derived:16 derived postfini
derived:17 derived fini
derived:17 finalized
+derived:17 derived postfini
derived:18 derived fini
derived:18 finalized
+derived:18 derived postfini
derived:19 derived fini
derived:19 finalized
+derived:19 derived postfini
derived:20 derived fini
derived:20 finalized
+derived:20 derived postfini
after with-objects
derived:41 derived fini
derived:41 finalized
@@ -81,3 +101,31 @@ derived:23 derived fini
derived:23 finalized
derived:22 derived fini
derived:22 finalized
+derived:22 derived postfini
+derived:23 derived postfini
+derived:24 derived postfini
+derived:25 derived postfini
+derived:26 derived postfini
+derived:27 derived postfini
+derived:28 derived postfini
+derived:29 derived postfini
+derived:30 derived postfini
+derived:31 derived postfini
+derived:32 derived postfini
+derived:33 derived postfini
+derived:34 derived postfini
+derived:35 derived postfini
+derived:36 derived postfini
+derived:37 derived postfini
+derived:38 derived postfini
+derived:39 derived postfini
+derived:40 derived postfini
+derived:41 derived postfini
+multi :init: 1
+multi :init: 2
+multi :postinit: 1
+multi :postinit: 2
+multi :fini: 2
+multi :fini: 1
+multi :postfini: 1
+multi :postfini: 2
diff --git a/tests/012/fini.tl b/tests/012/fini.tl
index 3aa581f9..506b4c9e 100644
--- a/tests/012/fini.tl
+++ b/tests/012/fini.tl
@@ -11,7 +11,9 @@
(defstruct derived base
(:fini (me)
- (put-line `@(typeof me):@{me.id} derived fini`)))
+ (put-line `@(typeof me):@{me.id} derived fini`))
+ (:postfini (me)
+ (put-line `@(typeof me):@{me.id} derived postfini`)))
(unwind-protect
(with-objects ((b (new base others (mapcar (ret (new derived)) (range 1 20)))))
@@ -19,4 +21,24 @@
(put-line "after with-objects"))
(mapcar (ret (new derived)) (range 1 20))
-(sys:gc)
+(sys:gc t)
+
+(defstruct multi ()
+ (:init (me)
+ (put-line `@{%fun%}: 1`))
+ (:init (me)
+ (put-line `@{%fun%}: 2`))
+ (:postinit (me)
+ (put-line `@{%fun%}: 1`))
+ (:postinit (me)
+ (put-line `@{%fun%}: 2`))
+ (:fini (me)
+ (put-line `@{%fun%}: 1`))
+ (:fini (me)
+ (put-line `@{%fun%}: 2`))
+ (:postfini (me)
+ (put-line `@{%fun%}: 1`))
+ (:postfini (me)
+ (put-line `@{%fun%}: 2`)))
+
+(with-objects ((m (new multi))))
diff --git a/tests/012/ifa.expected b/tests/012/ifa.expected
deleted file mode 100644
index e69de29b..00000000
--- a/tests/012/ifa.expected
+++ /dev/null
diff --git a/tests/012/ifa.tl b/tests/012/ifa.tl
index d669244d..45a2939b 100644
--- a/tests/012/ifa.tl
+++ b/tests/012/ifa.tl
@@ -10,8 +10,11 @@
(isqrt it)))
7)
-;; ambiguous: is "it" x or is "it" y?
-(test (let (x y) (ifa (> x y) (print it))) :error)
+;; no it-candidates: "it" is leftmost arg x.
+(test (let ((x 1) (y 0)) (ifa (> x y) it)) 1)
+
+;; multiple it-candidates: error
+(test (let (x y) (ifa (> (* x x) (* y y)) it)) :error)
;; "it" is (+ 3 (* 2 x))
(test (let ((x 5))
diff --git a/tests/012/iter.tl b/tests/012/iter.tl
new file mode 100644
index 00000000..1b1bfd1e
--- /dev/null
+++ b/tests/012/iter.tl
@@ -0,0 +1,92 @@
+(load "../common")
+
+(mtest
+ [mapcar identity "A".."D"] ("A" "B" "C" "D")
+ [mapcar identity "A1".."C2"] ("A1" "A2" "B1" "B2" "C1" "C2")
+ [mapcar identity "D".."A"] ("D" "C" "B" "A")
+ [mapcar identity "C2".."A1"] ("C2" "C1" "B2" "B1" "A2" "A1"))
+
+(test
+ [maprod append "AA".."DD" "01".."19"]
+ ("AA01" "AA02" "AA03" "AA04" "AA05" "AA06" "AA07" "AA08" "AA09"
+ "AA11" "AA12" "AA13" "AA14" "AA15" "AA16" "AA17" "AA18" "AA19"
+ "AB01" "AB02" "AB03" "AB04" "AB05" "AB06" "AB07" "AB08" "AB09"
+ "AB11" "AB12" "AB13" "AB14" "AB15" "AB16" "AB17" "AB18" "AB19"
+ "AC01" "AC02" "AC03" "AC04" "AC05" "AC06" "AC07" "AC08" "AC09"
+ "AC11" "AC12" "AC13" "AC14" "AC15" "AC16" "AC17" "AC18" "AC19"
+ "AD01" "AD02" "AD03" "AD04" "AD05" "AD06" "AD07" "AD08" "AD09"
+ "AD11" "AD12" "AD13" "AD14" "AD15" "AD16" "AD17" "AD18" "AD19"
+ "BA01" "BA02" "BA03" "BA04" "BA05" "BA06" "BA07" "BA08" "BA09"
+ "BA11" "BA12" "BA13" "BA14" "BA15" "BA16" "BA17" "BA18" "BA19"
+ "BB01" "BB02" "BB03" "BB04" "BB05" "BB06" "BB07" "BB08" "BB09"
+ "BB11" "BB12" "BB13" "BB14" "BB15" "BB16" "BB17" "BB18" "BB19"
+ "BC01" "BC02" "BC03" "BC04" "BC05" "BC06" "BC07" "BC08" "BC09"
+ "BC11" "BC12" "BC13" "BC14" "BC15" "BC16" "BC17" "BC18" "BC19"
+ "BD01" "BD02" "BD03" "BD04" "BD05" "BD06" "BD07" "BD08" "BD09"
+ "BD11" "BD12" "BD13" "BD14" "BD15" "BD16" "BD17" "BD18" "BD19"
+ "CA01" "CA02" "CA03" "CA04" "CA05" "CA06" "CA07" "CA08" "CA09"
+ "CA11" "CA12" "CA13" "CA14" "CA15" "CA16" "CA17" "CA18" "CA19"
+ "CB01" "CB02" "CB03" "CB04" "CB05" "CB06" "CB07" "CB08" "CB09"
+ "CB11" "CB12" "CB13" "CB14" "CB15" "CB16" "CB17" "CB18" "CB19"
+ "CC01" "CC02" "CC03" "CC04" "CC05" "CC06" "CC07" "CC08" "CC09"
+ "CC11" "CC12" "CC13" "CC14" "CC15" "CC16" "CC17" "CC18" "CC19"
+ "CD01" "CD02" "CD03" "CD04" "CD05" "CD06" "CD07" "CD08" "CD09"
+ "CD11" "CD12" "CD13" "CD14" "CD15" "CD16" "CD17" "CD18" "CD19"
+ "DA01" "DA02" "DA03" "DA04" "DA05" "DA06" "DA07" "DA08" "DA09"
+ "DA11" "DA12" "DA13" "DA14" "DA15" "DA16" "DA17" "DA18" "DA19"
+ "DB01" "DB02" "DB03" "DB04" "DB05" "DB06" "DB07" "DB08" "DB09"
+ "DB11" "DB12" "DB13" "DB14" "DB15" "DB16" "DB17" "DB18" "DB19"
+ "DC01" "DC02" "DC03" "DC04" "DC05" "DC06" "DC07" "DC08" "DC09"
+ "DC11" "DC12" "DC13" "DC14" "DC15" "DC16" "DC17" "DC18" "DC19"
+ "DD01" "DD02" "DD03" "DD04" "DD05" "DD06" "DD07" "DD08" "DD09"
+ "DD11" "DD12" "DD13" "DD14" "DD15" "DD16" "DD17" "DD18" "DD19"))
+
+(mtest
+ [maprod append "A".."F" (drop 1 "00".."15")]
+ ("A01" "A02" "A03" "A04" "A05" "A10" "A11" "A12" "A13" "A14" "A15"
+ "B01" "B02" "B03" "B04" "B05" "B10" "B11" "B12" "B13" "B14" "B15"
+ "C01" "C02" "C03" "C04" "C05" "C10" "C11" "C12" "C13" "C14" "C15"
+ "D01" "D02" "D03" "D04" "D05" "D10" "D11" "D12" "D13" "D14" "D15"
+ "E01" "E02" "E03" "E04" "E05" "E10" "E11" "E12" "E13" "E14" "E15"
+ "F01" "F02" "F03" "F04" "F05" "F10" "F11" "F12" "F13" "F14" "F15")
+ [maprod append "A".."F" [1..11 "00".."99"]]
+ ("A01" "A02" "A03" "A04" "A05" "A06" "A07" "A08" "A09" "A10" "B01"
+ "B02" "B03" "B04" "B05" "B06" "B07" "B08" "B09" "B10" "C01" "C02"
+ "C03" "C04" "C05" "C06" "C07" "C08" "C09" "C10" "D01" "D02" "D03"
+ "D04" "D05" "D06" "D07" "D08" "D09" "D10" "E01" "E02" "E03" "E04"
+ "E05" "E06" "E07" "E08" "E09" "E10" "F01" "F02" "F03" "F04" "F05"
+ "F06" "F07" "F08" "F09" "F10"))
+
+(test
+ [mapcar identity [3..6 0..10]] (3 4 5))
+
+;; iterating from fixnum to bignum was rejected in up to txr-269.
+(test (each ((x fixnum-max..(* 5 fixnum-max))) (return 42)) 42)
+
+(test (progn (each ((x "A".."Z")) (sys:gc)) 42) 42)
+
+(let ((big (* fixnum-max 8)))
+ (test (progn (each ((x big..(+ 10 big))) (sys:gc)) 42) 42))
+
+(mtest
+ (list-seq 0..5) (0 1 2 3 4)
+ (list-seq 5..0) (4 3 2 1 0)
+ (list-seq 0..5.0) (0 1 2 3 4)
+ (list-seq 5..0.0) (4 3 2 1 0)
+ (list-seq 0.0..5.0) (0.0 1.0 2.0 3.0 4.0)
+ (list-seq 5.0..0.0) (4.0 3.0 2.0 1.0 0.0)
+ (list-seq 0.0..5) (0.0 1.0 2.0 3.0 4.0)
+ (list-seq 5.0..0) (4.0 3.0 2.0 1.0 0.0)
+ (list-seq 0.0..5.1) (0.0 1.0 2.0 3.0 4.0 5.0)
+ (list-seq 0.5..5) (0.5 1.5 2.5 3.5 4.5)
+ (list-seq (expt 2 256)..(ssucc (expt 2 256)))
+ (115792089237316195423570985008687907853269984665640564039457584007913129639936
+ 115792089237316195423570985008687907853269984665640564039457584007913129639937)
+ (list-seq (expt 2 256)..(ppred (expt 2 256)))
+ (115792089237316195423570985008687907853269984665640564039457584007913129639935
+ 115792089237316195423570985008687907853269984665640564039457584007913129639934)
+ (take 3 (list-seq (expt 2 256)..0))
+ (115792089237316195423570985008687907853269984665640564039457584007913129639935
+ 115792089237316195423570985008687907853269984665640564039457584007913129639934
+ 115792089237316195423570985008687907853269984665640564039457584007913129639933))
+
diff --git a/tests/012/lambda.tl b/tests/012/lambda.tl
new file mode 100644
index 00000000..811dbcfc
--- /dev/null
+++ b/tests/012/lambda.tl
@@ -0,0 +1,162 @@
+(load "../common")
+
+(defun call-lambda (fn . args)
+ [fn . args])
+
+(defun call-lambda-fixed (fn . args)
+ (tree-case args
+ (() [fn])
+ ((a1) [fn a1])
+ ((a1 a2) [fn a1 a2])
+ ((a1 a2 a3) [fn a1 a2 a3])
+ ((a1 a2 a3 a4) [fn a1 a2 a3 a4])
+ ((a1 a2 a3 a4 a5) [fn a1 a2 a3 a4 a5])
+ ((a1 . r) [fn a1 . r])
+ ((a1 a2 . r) [fn a1 a2 . r])
+ ((a1 a2 a3 . r) [fn a1 a2 a3 . r])
+ ((a1 a2 a3 a4 . r) [fn a1 a2 a3 a4 . r])
+ ((a1 a2 a3 a4 a5 . r) [fn a1 a2 a3 a4 a5 . r])
+ (r [fn . r])))
+
+(defmacro ltest (:match :form f)
+ (([(lambda . @rest) . @args] @expected)
+ (if *compile-test*
+ ^(progn
+ (test [(lambda ,*rest) ,*args] ,expected)
+ (test (call-lambda (lambda ,*rest) ,*args) ,expected)
+ (test (call-lambda-fixed (lambda ,*rest) ,*args) ,expected))
+ ^(test [(lambda ,*rest) ,*args] ,expected)))
+ ((@else . rest) (compile-error f "bad syntax")))
+
+(defmacro mltest (. pairs)
+ ^(progn ,*(mapcar (op cons 'ltest) (tuples 2 pairs))))
+
+(mltest
+ [(lambda ())] nil
+ [(lambda ()) 1] :error
+ [(lambda (a) a)] :error
+ [(lambda (a) a) 1] 1
+ [(lambda (a) a) 1 2] :error
+ [(lambda (a b) (list a b)) 1] :error
+ [(lambda (a b) (list a b)) 1 2] (1 2)
+ [(lambda (a b) (list a b)) 1 2 3] :error
+ [(lambda (a b c) (list a b c)) 1 2] :error
+ [(lambda (a b c) (list a b c)) 1 2 3] (1 2 3)
+ [(lambda (a b c) (list a b c)) 1 2 3 4] :error)
+
+(mltest
+ [(lambda (: a) a)] nil
+ [(lambda (: (a 1)) a)] 1
+ [(lambda (: (a 1)) a) 2] 2
+ [(lambda (: (a 1)) a) 2 3] :error
+ [(lambda (: (a 1 a-p)) (list a a-p))] (1 nil)
+ [(lambda (: (a 1 a-p)) (list a a-p)) 2] (2 t))
+
+(mltest
+ [(lambda (x : a) (list x a))] :error
+ [(lambda (x : (a 1)) (list x a))] :error
+ [(lambda (x : (a 1)) (list x a)) 2] (2 1)
+ [(lambda (x : (a 1)) (list x a)) 2 3] (2 3)
+ [(lambda (x : (a 1)) (list x a)) 2 3 4] :error
+ [(lambda (x : (a 1 a-p)) (list x a a-p))] :error
+ [(lambda (x : (a 1 a-p)) (list x a a-p)) 2] (2 1 nil))
+
+(mltest
+ [(lambda (x : a) (list x a)) 0] (0 nil)
+ [(lambda (x : (a 1)) (list x a)) 0] (0 1)
+ [(lambda (x : (a 1)) (list x a)) 0 2] (0 2)
+ [(lambda (x : (a 1 a-p)) (list x a a-p)) 0] (0 1 nil)
+ [(lambda (x : (a 1 a-p)) (list x a a-p)) 0 2] (0 2 t))
+
+(mltest
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r))] :error
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1] :error
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2] (1 2 3 4 nil)
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 8] (1 2 8 4 nil)
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 8 9] (1 2 8 9 nil)
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 8 9 0] (1 2 8 9 (0)))
+
+(defvarl vs '(a))
+
+(mltest
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) . vs] :error
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 . vs] (1 a 3 4 nil)
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 . vs] (1 2 a 4 nil)
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 3 . vs] (1 2 3 a nil)
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 3 4 . vs] (1 2 3 4 (a)))
+
+(mltest
+ [(lambda (x y : (a 3) (b 4)) (list x y a b)) . vs] :error
+ [(lambda (x y : (a 3) (b 4)) (list x y a b)) 1 . vs] (1 a 3 4)
+ [(lambda (x y : (a 3) (b 4)) (list x y a b)) 1 2 . vs] (1 2 a 4)
+ [(lambda (x y : (a 3) (b 4)) (list x y a b)) 1 2 3 . vs] (1 2 3 a)
+ [(lambda (x y : (a 3) (b 4)) (list x y a b)) 1 2 3 4 . vs] :error)
+
+(test
+ [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) . vs] :error)
+
+(mltest
+ [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 . vs]
+ (1 a 3 nil 4 nil nil)
+ [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 2 . vs]
+ (1 2 a t 4 nil nil)
+ [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 2 3 . vs]
+ (1 2 3 t a t nil)
+ [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 2 3 4 . vs]
+ (1 2 3 t 4 t (a))
+ [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 2 3 4 5 . vs]
+ (1 2 3 t 4 t (5 a))
+ [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 2 : 4 . vs]
+ (1 2 3 nil 4 t (a))
+ [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 2 3 : . vs]
+ (1 2 3 t 4 nil (a)))
+
+(defvarl vl '(a b c d))
+
+(mltest
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) . vl] (a b c d nil)
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 . vl] (1 a b c (d))
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 . vl] (1 2 a b (c d))
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 3 . vl] (1 2 3 a (b c d))
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 3 4 . vl] (1 2 3 4 (a b c d))
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 3 4 5 . vl] (1 2 3 4 (5 a b c d)))
+
+(mltest
+ [(lambda (x y : (a 3) (b 4)) (list x y a b)) . vl] (a b c d)
+ [(lambda (x y : (a 3) (b 4)) (list x y a b)) 1 . vl] :error)
+
+(mltest
+ [(lambda (x : y) (list x y)) 1 :] (1 nil)
+ [(lambda (x : y z) (list x y z)) 1 :] (1 nil nil)
+ [(lambda (x : y z) (list x y z)) 1 2 :] (1 2 nil)
+ [(lambda (x : y z) (list x y z)) 1 nil :] (1 nil nil)
+ [(lambda (x : y z) (list x y z)) 1 nil nil] (1 nil nil))
+
+(mltest
+ [(lambda (x : (y nil)) (list x y)) 1 :] (1 nil)
+ [(lambda (x : (y nil) (z)) (list x y z)) 1 :] (1 nil nil)
+ [(lambda (x : (y nil) (z)) (list x y z)) 1 2 :] (1 2 nil)
+ [(lambda (x : (y nil) (z)) (list x y z)) 1 nil :] (1 nil nil)
+ [(lambda (x : (y nil) (z)) (list x y z)) 1 nil nil] (1 nil nil))
+
+(defvarl vc '(: : : :))
+
+(mltest
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) . vc] (: : 3 4 nil)
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 . vc] (1 : 3 4 (:))
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 . vc] (1 2 3 4 (: :))
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 0 . vc] (1 2 0 4 (: : :))
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 0 0 . vc] (1 2 0 0 (: : : :))
+ [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 0 0 5 . vc] (1 2 0 0 (5 : : : :)))
+
+(test (functionp (lambda (: (n n)) n)) t)
+
+(defvarl n)
+
+(ltest
+ [(lambda (: (n n)) n)] nil)
+
+(cond
+ (*compile-test* (exit t))
+ (t (set *compile-test* t)
+ (load (base-name *load-path*))))
diff --git a/tests/012/lazy.tl b/tests/012/lazy.tl
new file mode 100644
index 00000000..be04412a
--- /dev/null
+++ b/tests/012/lazy.tl
@@ -0,0 +1,6 @@
+(load "../common")
+
+(test [mapcar* list nil] nil)
+(test [mapcar* list '(1)] ((1)))
+(test [mapcar* list '(1 2 3)] ((1) (2) (3)))
+(test [mapcar* list '(1 2 3) '(a b c)] ((1 a) (2 b) (3 c)))
diff --git a/tests/012/less.tl b/tests/012/less.tl
new file mode 100644
index 00000000..11748c7f
--- /dev/null
+++ b/tests/012/less.tl
@@ -0,0 +1,21 @@
+(load "../common")
+
+(mtest
+ (less #() #(a)) t
+ (greater #() #(a)) nil
+ (less #(0) #(1)) t
+ (greater #(0) #(1)) nil
+ (less #(1) #(0)) nil
+ (greater #(1) #(0)) t
+ (less #(0) #(0 0)) t
+ (less #(1) #(0 0)) nil
+ (less #(0 0) #(0 1)) t
+ (less #(0 0) #(0 0)) nil
+ (less #(0 0) #(0 0 0)) t)
+
+(mtest
+ (less '() #()) t
+ (less '(0) #(0)) t
+ (less "a" #(#\a)) t
+ (less #() #b'') t
+ (less #(0) #b'00') t)
diff --git a/tests/012/oop-dsc.tl b/tests/012/oop-dsc.tl
new file mode 100644
index 00000000..7885f386
--- /dev/null
+++ b/tests/012/oop-dsc.tl
@@ -0,0 +1,80 @@
+(load "../common")
+
+(define-struct-clause :nothing (. ignored-args))
+
+(defstruct s0 ()
+ (:nothing 1 "foo" :junk)
+ x)
+
+(test (new s0) #S(s0 x nil))
+
+(define-struct-clause :multi (init-val . names)
+ (mapcar (lop list init-val) names))
+
+(defstruct s1 ()
+ (:multi 0 a b c))
+
+(test (new s1) #S(s1 a 0 b 0 c 0))
+
+(define-struct-clause :getset (slot getter setter : init-val)
+ ^((,slot ,init-val)
+ (:method ,getter (obj) obj.,slot)
+ (:method ,setter (obj new) (set obj.,slot new))))
+
+(defstruct s2 ()
+ (:getset a get-a set-a 0)
+ (:getset b get-b set-b 0))
+
+(let ((s2 (new s2)))
+ (mtest
+ s2.a 0
+ s2.b 0
+ s2.(get-a) 0
+ s2.(get-b) 0
+ s2.(set-a 42) 42
+ s2.(set-b 73) 73
+ s2.a 42
+ s2.b 73
+ s2.(get-a) 42
+ s2.(get-b) 73))
+
+(define-struct-clause :hash (hash-name by-slot)
+ ^((:static ,hash-name (hash))
+ (:postinit (me)
+ (set [me.,hash-name me.,by-slot] me))
+ (:postfini (me)
+ (del [me.,hash-name me.,by-slot]))))
+
+(defstruct s3 ()
+ a b
+ (:hash a-hash a)
+ (:hash b-hash b))
+
+(let* ((s3-list (list (new s3 a "one" b 1)
+ (new s3 a "two" b 2)
+ (new s3 a "three" b 3)))
+ (s3 (first s3-list)))
+ (mtest
+ [s3.a-hash "one"].a "one"
+ [s3.a-hash "two"].b 2
+ [s3.a-hash "three"].b 3
+ [s3.b-hash 1].a "one"
+ [s3.b-hash 2].b 2
+ [s3.b-hash 3].a "three")
+ (call-finalizers s3)
+ (test [s3.a-hash "one"] nil))
+
+(define-struct-clause :s3 ()
+ '((:inherit s3)
+ (:inherit passwd group)))
+
+(defstruct s4 (time)
+ (:s3))
+
+(let ((s4 (new s4 a "x" b 999)))
+ (mtest
+ [s4.a-hash "two"].a "two"
+ [s4.a-hash "x"].a "x"
+ [s4.b-hash 999].a "x"
+ s4.uid nil
+ s4.gid nil))
diff --git a/tests/012/oop-mac.tl b/tests/012/oop-mac.tl
new file mode 100644
index 00000000..d3c3e480
--- /dev/null
+++ b/tests/012/oop-mac.tl
@@ -0,0 +1,18 @@
+(load "../common")
+
+(test (with-resources ((a nil (list a))
+ (b nil)
+ (c nil (list c)))
+ (list a b c))
+ (nil nil nil))
+
+(test (build
+ (catch
+ (with-resources ((a 1 (add a))
+ (x nil)
+ (b 2 (add b))
+ (y (throw 'out))
+ (z nil t)
+ (c 3 (add c))))
+ (out () (add 4))))
+ (2 1 4))
diff --git a/tests/012/oop-mi.expected b/tests/012/oop-mi.expected
index 6d112c2e..ebc807f3 100644
--- a/tests/012/oop-mi.expected
+++ b/tests/012/oop-mi.expected
@@ -1,7 +1,7 @@
-#S(der0 gx gx gy dgy x dx y dy z dz)
+#S(der0 li (b1 b2 g) gx gx gy dgy x dx y dy z dz)
dgs0
gs1-b1
-#S(der1 x b3x gx b3gx gy gy y b2y)
+#S(der1 x b3x gx b3gx li (b1 b2 g) gy gy y b2y)
gs0
gs1-b1
(meth base3 b3m0)
@@ -15,3 +15,11 @@ gm
base1
base2
grand
+(b1 b2 g)
+(gf b2f b1f b1 b2 g)
+(b1 b2 g)
+(gf b2f b1f b1 b2 g)
+(b1 b2 g)
+(gf b2f b1f b1 b2 g)
+(b2 b1 g)
+(gf b1f b2f b2 b1 g)
diff --git a/tests/012/oop-mi.tl b/tests/012/oop-mi.tl
index 4431f23d..0e54086a 100644
--- a/tests/012/oop-mi.tl
+++ b/tests/012/oop-mi.tl
@@ -1,8 +1,11 @@
(load "../common")
(defstruct grand nil
+ (li 'nil)
(gx 'gx)
(gy 'gy)
+ (:init (me) (push 'g me.li))
+ (:fini (me) (push 'gf me.li))
(:static gs0 'gs0)
(:static gs1 'gs1)
(:method gm (me) 'gm))
@@ -12,11 +15,15 @@
(defstruct base1 grand
(x 'b1x)
+ (:init (me) (push 'b1 me.li))
+ (:fini (me) (push 'b1f me.li))
(:static gs1 'gs1-b1)
(:method m (me) 'm1))
(defstruct base2 grand
(y 'b2y)
+ (:init (me) (push 'b2 me.li))
+ (:fini (me) (push 'b2f me.li))
(:static gs1 'gs1-b2)
(:method m (me) 'm2))
@@ -63,3 +70,9 @@
(prinl (static-slot-home 'der2 'm))
(prinl (static-slot-home 'der3 'm))
(prinl (static-slot-home 'der3 'gm))
+
+(each ((ty '(der0 der1 der2 der3)))
+ (let ((ob (new* ty)))
+ (prinl ob.li)
+ (call-finalizers ob)
+ (prinl ob.li)))
diff --git a/tests/012/oop-prelude.expected b/tests/012/oop-prelude.expected
new file mode 100644
index 00000000..daf379e0
--- /dev/null
+++ b/tests/012/oop-prelude.expected
@@ -0,0 +1,5 @@
+#S(fox) created
+#S(bear) created
+inside with-object
+#S(bear) finalized
+#S(fox) finalized
diff --git a/tests/012/oop-prelude.tl b/tests/012/oop-prelude.tl
new file mode 100644
index 00000000..bb0b3d44
--- /dev/null
+++ b/tests/012/oop-prelude.tl
@@ -0,0 +1,13 @@
+(load "../common")
+
+(define-struct-prelude init-fini-log (fox bear)
+ (:init (me) (put-line `@me created`))
+ (:fini (me) (put-line `@me finalized`)))
+
+(defstruct fox ())
+
+(defstruct bear ())
+
+(with-objects ((f (new fox))
+ (b (new bear)))
+ (put-line "inside with-object"))
diff --git a/tests/012/oop-seq.tl b/tests/012/oop-seq.tl
new file mode 100644
index 00000000..17463e96
--- /dev/null
+++ b/tests/012/oop-seq.tl
@@ -0,0 +1,87 @@
+(load "../common")
+
+(defstruct counter-iter-fast ()
+ cur-val
+ step
+ limit
+ (:method iter-item (me)
+ me.cur-val)
+ (:method iter-step (me)
+ (inc me.cur-val me.step)
+ (if (< me.cur-val me.limit) me)))
+
+(defstruct counter-fast ()
+ init
+ step
+ limit
+ (:method iter-begin (me)
+ (if (< me.init me.limit)
+ (new counter-iter-fast
+ cur-val me.init
+ step me.step
+ limit me.limit))))
+
+(defstruct counter-iter-canon ()
+ cur-val
+ step
+ limit
+ (:method iter-item (me)
+ me.cur-val)
+ (:method iter-more (me)
+ (< me.cur-val me.limit))
+ (:method iter-step (me)
+ (inc me.cur-val me.step)
+ me))
+
+(defstruct counter-canon ()
+ init
+ step
+ limit
+ (:method iter-begin (me)
+ (new counter-iter-canon
+ cur-val me.init
+ step me.step
+ limit me.limit)))
+
+(test (list-seq (new counter-canon init 0 step 2 limit 10))
+ (0 2 4 6 8))
+
+(test (list-seq (new counter-fast init 0 step 2 limit 10))
+ (0 2 4 6 8))
+
+(test (list-seq (new counter-canon init 0 step 1 limit 0))
+ nil)
+
+(test (list-seq (new counter-fast init 0 step 1 limit 0))
+ nil)
+
+(defstruct integers ()
+ item to next
+ (:method length-< (me len)
+ (cond
+ ((<= len 1) nil)
+ (me.next me.next.(length-< (pred len)))
+ (t)))
+ (:postinit (me)
+ (if (< me.item me.to)
+ (set me.next (lnew integers to me.to item (succ me.item))))))
+
+(let ((ints (new integers item 1 to 10)))
+ (mtest
+ (length-< ints 11) t)
+ (length-< ints 10) nil
+ (length-< ints 9) nil)
+
+;; The following reproduced a segfault when the change was made to allow del to
+;; work with structs that have lambda and lambda-set.
+
+(defstruct blah ()
+ (:method lambda-set (me . args)))
+
+(defparm o (new blah))
+
+(set [o 1..20] 42)
+
+(defmeth blah lambda (me . args))
+
+(set [o 1..20] 42)
diff --git a/tests/012/oop.tl b/tests/012/oop.tl
index 51dadbf3..5cdd3ec3 100644
--- a/tests/012/oop.tl
+++ b/tests/012/oop.tl
@@ -2,7 +2,7 @@
(defstruct animal nil
(:function whoami () "n/a")
- (:method print (self stream : pretty-p) (put-string self.[whoami] stream)))
+ (:method print (self stream : pretty-p) (put-string [self.whoami] stream)))
(defstruct dog animal
(:function whoami () "dog"))
@@ -77,3 +77,75 @@
(prinl d)
(prinl (list b.sa b.sb b.sc b.x b.y))
(prinl (list d.sa d.sb d.sc d.x d.y)))
+
+(defstruct (ab a : b) () a b)
+
+(defvar foo)
+
+(mtest
+ (new* (foo 'ab) a 1) :error
+ (new* ((find-struct-type 'ab)) a 1) #S(ab a 1 b nil)
+ (new* [find-struct-type 'ab] a 1) #S(ab a 1 b nil)
+ (new* ([find-struct-type 'ab] 1 2)) #S(ab a 1 b 2)
+ (new* ((find-struct-type 'ab) 1 2)) #S(ab a 1 b 2)
+ (new* ([find-struct-type 'ab] 1) b 2) #S(ab a 1 b 2)
+ (let ((type (find-struct-type 'ab)))
+ (new* type a 3 b 4)) #S(ab a 3 b 4)
+ (let ((type (find-struct-type 'ab)))
+ (new* (type 3 4))) #S(ab a 3 b 4))
+
+(defstruct worker ()
+ name
+ (:method work (me) `worker @{me.name} works`)
+ (:method relax (me : (min 15)) `worker @{me.name} relaxes for @min min`))
+
+(defstruct contractor ()
+ sub
+ (:delegate work (me) me.sub.sub)
+ (:delegate break (me : min) me.sub.sub relax)
+ (:delegate break20 (me : (min 20)) me.sub.sub relax))
+
+(let ((co (new contractor sub (new contractor sub (new worker name "foo")))))
+ (mtest co.(work) "worker foo works"
+ co.(break) "worker foo relaxes for 15 min"
+ co.(break 5) "worker foo relaxes for 5 min"
+ co.(break20 5) "worker foo relaxes for 5 min"
+ co.(break20) "worker foo relaxes for 20 min"))
+
+(test
+ (defstruct bad-delegate ()
+ (:delegate del (x : (y z w))))
+ :error)
+
+(defstruct api-x ()
+ (:method get (x a b : c . d) ^(api-x get ,x ,a ,b ,c ,d))
+ (:method put (x s) ^(api-x put ,x ,s)))
+
+(defstruct api-y ()
+ (:method frob (y r : s) ^(api-y frob ,y ,r ,s))
+ (:method tweak (y) ^(api-y tweak ,y)))
+
+(defstruct api-z ()
+ (:method decrement (z n) ^(api-z decrement ,z ,n))
+ (:method increment (z n) ^(api-z increment ,z ,n)))
+
+(defstruct component ()
+ (ax (new api-x))
+ (ay (new api-y))
+ (az (new api-z))
+ (:mass-delegate o o.ax api-x *)
+ (:mass-delegate o o.ay api-y frob)
+ (:mass-delegate o o.az api-z * decrement))
+
+(let ((c (new component)))
+ (mtest
+ c.(get 1 2 3 . 4) (api-x get #S(api-x) 1 2 3 4)
+ c.(put 5) (api-x put #S(api-x) 5)
+ c.(get) :error
+ c.(put 5 6) :error
+ c.(frob 7 8) (api-y frob #S(api-y) 7 8)
+ c.(frob 9) (api-y frob #S(api-y) 9 nil)
+ c.(frob 7 8 9) :error
+ c.(tweak) :error
+ c.(increment 1) (api-z increment #S(api-z) 1)
+ c.(decrement) :error))
diff --git a/tests/012/op.tl b/tests/012/op.tl
new file mode 100644
index 00000000..47f1f80d
--- /dev/null
+++ b/tests/012/op.tl
@@ -0,0 +1,127 @@
+(load "../common")
+
+(defun fi (fun)
+ (assert (zerop (fun-optparam-count fun)))
+ (list (fun-fixparam-count fun)
+ (fun-variadic fun)))
+
+(mtest
+ (fi (op)) :error
+ (fi (op list)) (0 t)
+ (fi (op list @1)) (1 t)
+ (fi (op list @2)) (2 t)
+ (fi (op list @42)) (42 t)
+ (fi (op list @rest)) (0 t)
+ (fi (op list @1 @rest)) (1 t)
+ (fi (op list @2 @rest)) (2 t)
+ (fi (op list @42 @rest)) (42 t)
+ (fi (op list @1 @3 @rest @2)) (3 t))
+
+(mtest
+ (fi (do)) :error
+ (fi (do progn)) (1 t)
+ (fi (do progn @1)) (1 t)
+ (fi (do progn @2)) (2 t)
+ (fi (do progn @42)) (42 t)
+ (fi (do progn @rest)) (0 t)
+ (fi (do progn @1 @rest)) (1 t)
+ (fi (do progn @2 @rest)) (2 t)
+ (fi (do progn @42 @rest)) (42 t)
+ (fi (do progn @1 @3 @rest @2)) (3 t))
+
+(mtest
+ (fi (do if)) (1 t)
+ (fi (do if @1)) (1 t)
+ (fi (do if @2)) (2 t)
+ (fi (do if @42)) (42 t)
+ (fi (do if @rest)) (0 t)
+ (fi (do if @1 @rest)) (1 t)
+ (fi (do if @2 @rest)) (2 t)
+ (fi (do if @42 @rest)) (42 t)
+ (fi (do if @1 @3 @rest @2)) (3 t))
+
+(mtest
+ [(do quote x) 3] :error
+ [(do quote @1) 3] :error
+ (do pop a) :error)
+
+(defun y (f)
+ [(op @1 @1)
+ (op f (op [@@1 @@1]))])
+
+(defun fac (f)
+ (do if (zerop @1)
+ 1
+ (* @1 [f (- @1 1)])))
+
+(defun fac-y (n)
+ [(y (do do if (zerop @1)
+ 1
+ (* @1 [@@1 (- @1 1)]))) n])
+
+(defun fac-r (n)
+ [(do if (zerop @1) 1 (* @1 [@rec (pred @1)])) n])
+
+(defun fac-r2 (n)
+ [(do if (zerop @1) 1 (* @1 @(rec (pred @1)))) n])
+
+(mtest
+ [[y fac] 4] 24
+ (fac-y 4) 24
+ (fac-r 4) 24
+ (fac-r2 4) 24)
+
+(mtest
+ (flow 1 (+ 2) [dup *] (let ((x @1)) x)) 9
+ (flow #S(time year 2021) .year succ) 2022)
+
+(mtest
+ [[(do op list)] 2] :error
+ [[(do op list) 2]] (2)
+ [[(do op list @@1) 1] 2] (1 2)
+ [[(do op list @1)] 2] :error
+ [[(do op list @1) 1] 2] (2 1)
+ [[(do op list @@1 @1) 1] 2] (1 2))
+
+(mtest
+ [[[[(do do do op list @1) 1] 2] 3] 4] (4 1 2 3)
+ [[[[(do do do op list @@1) 1] 2] 3] 4] (3 1 2 4)
+ [[[[(do do do op list @@@1) 1] 2] 3] 4] (2 1 3 4)
+ [[[[(do do do op list @@@@1) 1] 2] 3] 4] (1 2 3 4))
+
+(mtest
+ [[[[(do do do op list) 1] 2] 3] 4] (1 2 3 4)
+ [[[[(do do do op list @1 @@1 @@@1 @@@@1) 1] 2] 3] 4] (4 3 2 1)
+ [[[[(do do do op list @@@@1 @@@1 @@1 @1) 1] 2] 3] 4] (1 2 3 4))
+
+(test (flow (range 1000 9999)
+ (keep-if (opip digits (ap > (+ @2 @3) (+ @1 @4))))
+ (partition-if (op neq 1 (- @2 @1)))
+ (find-max-key @1 : len))
+ 80)
+
+(mtest
+ (flow 1 (+ 1) (let x) (+ 2) (let y) (+ 3) (list x y @1)) (2 4 7)
+ (flow 10 (+ 1) (let (x @1) (y (* x 2))) (+ x y)) 44
+ (flow 10 (+ 1) (let ((x @1) (y (* @1 2))) (+ x y))) 33
+ (flow 10 (+ 1) (let ((x @1) (y (* @1 2))))) nil)
+
+(mtest
+ (lflow 10 (- 1) (- 1)) 8
+ (lflow 10 (op - 100) (+ 1)) 91)
+
+(mtest
+ (remove-if (opf orf (< 10) (> 5)) (range 0 20)) (5 6 7 8 9 10)
+ (remove-if (lopf orf (> 10) (< 5)) (range 0 20)) (5 6 7 8 9 10))
+
+(test
+ (let ((x 0) (y 0))
+ (list (flow x
+ (+ 2)
+ (tap inc y @1)
+ (* 4)
+ (tap inc y @1)
+ (+ 5)
+ (tap inc y @1))
+ y))
+ (13 23))
diff --git a/tests/012/parse.tl b/tests/012/parse.tl
new file mode 100644
index 00000000..6d091b00
--- /dev/null
+++ b/tests/012/parse.tl
@@ -0,0 +1,66 @@
+(load "../common")
+
+(unless (< (sizeof wchar) 4)
+ (test (read `"@(str-buf #b'EDB081')"`)
+ "\xDCED\xDCB0\xDC81")
+
+ (test (read `"@(str-buf #b'F3FF')"`)
+ "\xDCF3\xDCFF")
+
+ (test (regex-parse (str-buf #b'EDB081'))
+ (compound "\xDCED\xDCB0\xDC81"))
+
+ (test (regex-parse (str-buf #b'F3FF'))
+ (compound #\xDCF3 #\xDCFF)))
+
+(mtest
+ (read "0") 0
+ (read "0x") 0x
+ (read "a") a
+ (read "abc") abc
+ (read "abc.def") abc.def
+ (read "(1 2 3)") (1 2 3)
+ (read "#;(1 2 3) 4") 4
+ (read "#;(1 2 3) #; a.b 4") 4
+ (read "0 ") 0
+ (read "0x ") 0x
+ (read "a ") a
+ (read "abc ") abc
+ (read "abc.def ") abc.def
+ (read "(1 2 3) ") (1 2 3)
+ (read "#;(1 2 3) 4 ") 4
+ (read "#;(1 2 3) #; a.b 4 ") 4
+ (read "0,") :error
+ (read "0x,") :error
+ (read "a,") :error
+ (read "abc,") :error
+ (read "abc.def,") :error
+ (read "(1 2 3),") :error
+ (read "#;(1 2 3) 4,") :error
+ (read "#;(1 2 3) #; a.b 4,") :error)
+
+(mtest
+ (iread "0") 0
+ (iread "0x") 0x
+ (iread "a") a
+ (iread "abc") abc
+ (iread "abc.def") abc
+ (iread "(1 2 3)") (1 2 3)
+ (iread "#;(1 2 3) 4") 4
+ (iread "#;(1 2 3) #; a.b 4") .b
+ (iread "0 ") 0
+ (iread "0x ") 0x
+ (iread "a ") a
+ (iread "abc ") abc
+ (iread "abc.def ") abc
+ (iread "(1 2 3) ") (1 2 3)
+ (iread "#;(1 2 3) 4 ") 4
+ (iread "#;(1 2 3) #; a.b 4 ") .b
+ (iread "0,") 0
+ (iread "0x,") 0x
+ (iread "a,") a
+ (iread "abc,") abc
+ (iread "abc.def,") abc
+ (iread "(1 2 3),") (1 2 3)
+ (iread "#;(1 2 3) 4,") 4
+ (iread "#;(1 2 3) #; a.b 4,") .b)
diff --git a/tests/012/quasi.expected b/tests/012/quasi.expected
deleted file mode 100644
index e69de29b..00000000
--- a/tests/012/quasi.expected
+++ /dev/null
diff --git a/tests/012/quasi.tl b/tests/012/quasi.tl
index 276d5395..1cb24578 100644
--- a/tests/012/quasi.tl
+++ b/tests/012/quasi.tl
@@ -36,3 +36,18 @@
(let ((s))
(mapcar (ret `<@{(push (inc @1) s) d}>`) (range 0 2))))
("<1>" "<2-1>" "<3-2-1>"))
+
+(test
+ (symacrolet ((two 2))
+ `@{two}abc`)
+ "2abc")
+
+(test
+ (macrolet ((two () 2))
+ `@(two)abc`)
+ "2abc")
+
+(compile-only
+ (eval-only
+ (compile-file (base-name *load-path*) "temp.tlo")
+ (remove-path "temp.tlo")))
diff --git a/tests/012/quine.expected b/tests/012/quine.expected
deleted file mode 100644
index e69de29b..00000000
--- a/tests/012/quine.expected
+++ /dev/null
diff --git a/tests/012/readprint.tl b/tests/012/readprint.tl
new file mode 100644
index 00000000..4298a85b
--- /dev/null
+++ b/tests/012/readprint.tl
@@ -0,0 +1,13 @@
+(load "../common")
+
+(mstest
+ '[ . a] "[. a]"
+ '[. a] "[. a]"
+ '[ . @a] "[. @a]"
+ '[. @a] "[. @a]"
+ '[] "[]"
+ '[. 3] "[. 3]"
+ '[3 . 4] "[3 . 4]"
+ '(dwim) "[]"
+ '(dwim . 3) "[. 3]"
+ '(dwim 3 . 4) "[3 . 4]")
diff --git a/tests/012/seq.expected b/tests/012/seq.expected
deleted file mode 100644
index e69de29b..00000000
--- a/tests/012/seq.expected
+++ /dev/null
diff --git a/tests/012/seq.tl b/tests/012/seq.tl
index 9c3821d1..262c7739 100644
--- a/tests/012/seq.tl
+++ b/tests/012/seq.tl
@@ -13,7 +13,873 @@
(test (build (add 1) (add 2) (pend (get) (get))) (1 2 1 2 1 2))
(test (build (add 1) (add 2) (pend* (get) (get))) (1 2 1 2 1 2))
+(mtest
+ (build (add 1 2) (oust)) nil
+ (build (add 1 2) (oust '(3 4)) (add 5)) (3 4 5)
+ (build (add 1 2) (oust '(3 4) '(5)) (add 6)) (3 4 5 6))
+
(set *print-circle* t)
(stest (build (add 1) (add 2) (ncon (get))) "#1=(1 2 . #1#)")
(stest (build (add 1) (add 2) (ncon* (get))) "#1=(1 2 . #1#)")
+
+(test (mapcar (lambda (. args) (list . args)) '#(1 2 3) '#(4 5 6))
+ #((1 4) (2 5) (3 6)))
+
+(test [window-map 2 '(x x) list '(a b c d e f g)]
+ ((x x a b c) (x a b c d) (a b c d e)
+ (b c d e f) (c d e f g) (d e f g nil)
+ (e f g nil nil)))
+
+(test [window-map 2 '(x x y y) list '(a b c d e f g)]
+ ((x x a b c) (x a b c d) (a b c d e)
+ (b c d e f) (c d e f g) (d e f g y)
+ (e f g y y)))
+
+(test [window-map 2 nil list '(a b c d e f g)]
+ ((nil nil a b c) (nil a b c d) (a b c d e)
+ (b c d e f) (c d e f g)
+ (d e f g nil) (e f g nil nil)))
+
+(test [window-map 2 :wrap list '(a b c d e f g)]
+ ((f g a b c) (g a b c d) (a b c d e) (b c d e f)
+ (c d e f g) (d e f g a) (e f g a b)))
+
+(test [window-map 2 :reflect list '(a b c d e f g)]
+ ((b a a b c) (a a b c d) (a b c d e) (b c d e f)
+ (c d e f g) (d e f g g) (e f g g f)))
+
+(test [window-map 7 :wrap list '(a b c)]
+ ((c a b c a b c a b c a b c a b)
+ (a b c a b c a b c a b c a b c)
+ (b c a b c a b c a b c a b c a)))
+
+(test [window-map 7 :reflect list '(a b c)]
+ ((a c b a c b a a b c c b a c b)
+ (c b a c b a a b c c b a c b a)
+ (b a c b a a b c c b a c b a c)))
+
+(test [window-map 1 nil (lambda (x y z)
+ (if (and (eq x #\<)
+ (eq z #\>))
+ (chr-toupper y)
+ y))
+ "ab<c>de<f>g"]
+ "ab<C>de<F>g")
+
+(test [window-mappend 1 :reflect (lambda (x y z)
+ (if (< x y z)
+ (list y)))
+ '(1 2 1 3 4 2 1 9 7 5 7 8 5)]
+ (3 7))
+
+(test [window-map 2 #(0 0 0 0)
+ (lambda (. args) (/ (sum args) 5))
+ #(4 7 9 13 5 1 6 11 10 3 8)]
+ #(4.0 6.6 7.6 7.0 6.8 7.2 6.6 6.2 7.6 6.4 4.2))
+
+(mtest
+ [reduce-left + () 0] 0
+ [reduce-left + ()] 0
+ [reduce-left cons ()] :error
+ [reduce-left cons '(1)] 1
+ [reduce-left cons #(1)] 1
+ [reduce-left cons #(1) : (op * 10)] 10
+ [reduce-left cons #(1) 2 (op * 10)] (2 . 10)
+ [reduce-left cons #(2 3) 10 (op * 10)] ((10 . 20) . 30))
+
+(mtest
+ (starts-with "" "") t
+ (starts-with "" "a") t
+ (starts-with "a" "") nil
+ (starts-with "a" "a") t
+ (starts-with "" "abc") t
+ (starts-with "abc" "") nil
+ (starts-with "abc" "abc") t
+ (starts-with "ab" "abc") t
+ (starts-with "bc" "abc") nil
+ )
+
+(mtest
+ (ends-with "" "") t
+ (ends-with "" "a") t
+ (ends-with "a" "") nil
+ (ends-with "a" "a") t
+ (ends-with "" "abc") t
+ (ends-with "abc" "") nil
+ (ends-with "abc" "abc") t
+ (ends-with "ab" "abc") nil
+ (ends-with "bc" "abc") t)
+
+(mtest
+ (rmismatch #() #()) nil
+ (rmismatch #(1) #()) -1
+ (rmismatch #() #(1)) -1
+ (rmismatch #(1) #(1)) nil
+ (rmismatch #(1 2) #(1 2)) nil
+ (rmismatch #(2 2) #(1 2)) -2
+ (rmismatch #(1 2) #(2 2)) -2
+ (rmismatch #(3 2 1) #(1 1)) -2
+ (rmismatch #(1 1) #(3 2 1)) -2
+ (rmismatch #(3 2 1) #(2 1)) -3
+ (rmismatch #(2 1) #(3 2 1)) -3)
+
+(mtest
+ (rmismatch '() '()) nil
+ (rmismatch '(1) '()) -1
+ (rmismatch '() '(1)) -1
+ (rmismatch '(1) '(1)) nil
+ (rmismatch '(1 2) '(1 2)) nil
+ (rmismatch '(2 2) '(1 2)) -2
+ (rmismatch '(1 2) '(2 2)) -2
+ (rmismatch '(3 2 1) '(1 1)) -2
+ (rmismatch '(1 1) '(3 2 1)) -2
+ (rmismatch '(3 2 1) '(2 1)) -3
+ (rmismatch '(2 1) '(3 2 1)) -3)
+
+(mtest
+ (rmismatch '() #()) nil
+ (rmismatch '(1) #()) -1
+ (rmismatch '() #(1)) -1
+ (rmismatch '(1) #(1)) nil
+ (rmismatch '(1 2) #(1 2)) nil
+ (rmismatch '(2 2) #(1 2)) -2
+ (rmismatch '(1 2) #(2 2)) -2
+ (rmismatch '(3 2 1) #(1 1)) -2
+ (rmismatch '(1 1) #(3 2 1)) -2
+ (rmismatch '(3 2 1) #(2 1)) -3
+ (rmismatch '(2 1) #(3 2 1)) -3)
+
+(mtest
+ (rmismatch #() '()) nil
+ (rmismatch #(1) '()) -1
+ (rmismatch #() '(1)) -1
+ (rmismatch #(1) '(1)) nil
+ (rmismatch #(1 2) '(1 2)) nil
+ (rmismatch #(2 2) '(1 2)) -2
+ (rmismatch #(1 2) '(2 2)) -2
+ (rmismatch #(3 2 1) '(1 1)) -2
+ (rmismatch #(1 1) '(3 2 1)) -2
+ (rmismatch #(3 2 1) '(2 1)) -3
+ (rmismatch #(2 1) '(3 2 1)) -3)
+
+(mtest
+ (rmismatch "" "") nil
+ (rmismatch "1" "") -1
+ (rmismatch "" "1") -1
+ (rmismatch "1" "1") nil
+ (rmismatch "12" "12") nil
+ (rmismatch "22" "12") -2
+ (rmismatch "12" "22") -2
+ (rmismatch "321" "11") -2
+ (rmismatch "11" "321") -2
+ (rmismatch "321" "21") -3
+ (rmismatch "21" "321") -3)
+
+(mtest
+ [keep-if oddp (range 1 10)] (1 3 5 7 9)
+ [keep-if oddp nil] nil
+ [keep-if oddp #()] #()
+ [keep-if oddp #(1)] #(1)
+ [keep-if oddp #(2)] #()
+ [keep-if chr-isalpha "a1b2c3d"] "abcd"
+ [keep-if chr-isalpha ""] ""
+ [keep-if chr-isalpha "abc"] "abc"
+ [keep-if chr-isalpha "1234"] "")
+
+(mtest
+ [remove-if oddp (range 1 10)] (2 4 6 8 10)
+ [remove-if oddp nil] nil
+ [remove-if oddp #()] #()
+ [remove-if oddp #(1)] #()
+ [remove-if oddp #(2)] #(2)
+ [remove-if chr-isalpha "a1b2c3d"] "123"
+ [remove-if chr-isalpha ""] ""
+ [remove-if chr-isalpha "1234"] "1234"
+ [remove-if chr-isalpha "abcd"] "")
+
+(mtest
+ [keep-if* chr-isalpha ""] nil
+ [keep-if* chr-isalpha "abcd"] (#\a #\b #\c #\d)
+ (take 3 [keep-if* oddp (range 1)]) (1 3 5))
+
+(mtest
+ [remove-if* chr-isalpha ""] nil
+ [remove-if* chr-isalpha "abcd"] nil
+ [remove-if* chr-isdigit "a1b2c3d4"] (#\a #\b #\c #\d)
+ (take 3 [remove-if* oddp (range 1)]) (2 4 6))
+
+(mtest
+ [separate oddp (range 1 10)] ((1 3 5 7 9) (2 4 6 8 10))
+ [separate integerp (range 1 10)] ((1 2 3 4 5 6 7 8 9 10) ())
+ [separate chrp (range 1 10)] (() (1 2 3 4 5 6 7 8 9 10))
+ [separate oddp (vec-list (range 1 10))] (#(1 3 5 7 9) #(2 4 6 8 10))
+ [separate chr-isalpha "a1b2c3d4"] ("abcd" "1234")
+ [separate chrp "a1b2c3d4"] ("a1b2c3d4" "")
+ [separate integerp "a1b2c3d4"] ("" "a1b2c3d4"))
+
+(mtest
+ (tuples 0 nil) :error
+ (tuples 3.5 '(1 2 3)) :error
+ (tuples -1 "abc") :error)
+
+(mtest
+ (tuples 1 nil) nil
+ (tuples 1 "") nil
+ (tuples 1 #()) nil)
+
+(mtest
+ (tuples 1 '(a)) ((a))
+ (tuples 1 "a") ("a")
+ (tuples 1 #(1)) (#(1)))
+
+(mtest
+ (tuples 1 '(a b c)) ((a) (b) (c))
+ (tuples 1 "abc") ("a" "b" "c")
+ (tuples 1 #(1 2 3)) (#(1) #(2) #(3)))
+
+(mtest
+ (tuples 1 '(a b c) 'd) ((a) (b) (c))
+ (tuples 1 "abc" #\d) ("a" "b" "c")
+ (tuples 1 #(1 2 3) 4) (#(1) #(2) #(3)))
+
+(mtest
+ (tuples 2 '(a b c)) ((a b) (c))
+ (tuples 2 "abc") ("ab" "c")
+ (tuples 2 #(1 2 3)) (#(1 2) #(3)))
+
+(mtest
+ (tuples 3 '(a b c)) ((a b c))
+ (tuples 3 "abc") ("abc")
+ (tuples 3 #(1 2 3)) (#(1 2 3)))
+
+(mtest
+ (tuples 2 '(a b c) 'd) ((a b) (c d))
+ (tuples 2 "abc" #\d) ("ab" "cd")
+ (tuples 2 #(1 2 3) 4) (#(1 2) #(3 4)))
+
+(defun lforce (list)
+ [mapdo identity list]
+ list)
+
+(test
+ (lforce (tuples 2 "abc" 3)) ("ab" (#\c 3)))
+
+(test
+ (take 3 (tuples 3 (range 0))) ((0 1 2) (3 4 5) (6 7 8)))
+
+(mtest
+ (tuples* 0 nil) :error
+ (tuples* 3.5 '(1 2 3)) :error
+ (tuples* -1 "abc") :error)
+
+(mtest
+ (tuples* 1 nil) nil
+ (tuples* 1 "") nil
+ (tuples* 1 #()) nil)
+
+(mtest
+ (tuples* 1 '(a)) ((a))
+ (tuples* 1 "a") ("a")
+ (tuples* 1 #(1)) (#(1)))
+
+(mtest
+ (tuples* 1 '(a b c)) ((a) (b) (c))
+ (tuples* 1 "abc") ("a" "b" "c")
+ (tuples* 1 #(1 2 3)) (#(1) #(2) #(3)))
+
+(mtest
+ (tuples* 1 '(a b c) 'd) ((a) (b) (c))
+ (tuples* 1 "abc" #\d) ("a" "b" "c")
+ (tuples* 1 #(1 2 3) 4) (#(1) #(2) #(3)))
+
+(mtest
+ (tuples* 2 '(a b c)) ((a b) (b c))
+ (tuples* 2 "abc") ("ab" "bc")
+ (tuples* 2 #(1 2 3)) (#(1 2) #(2 3)))
+
+(mtest
+ (tuples* 3 '(a b c)) ((a b c))
+ (tuples* 3 "abc") ("abc")
+ (tuples* 3 #(1 2 3)) (#(1 2 3)))
+
+(mtest
+ (tuples* 3 '(a b) 'c) ((a b c))
+ (tuples* 3 "a" #\c) ("acc")
+ (tuples* 3 #() 1) (#(1 1 1)))
+
+(test
+ (lforce (tuples* 3 "a" 1)) :error)
+
+(mtest
+ (take 3 (tuples* 3 (range 0))) ((0 1 2) (1 2 3) (2 3 4))
+ (take 3 (tuples* 3 0)) ((0 1 2) (1 2 3) (2 3 4)))
+
+(mtest
+ (nrot nil) nil
+ (nrot (vec)) #()
+ (nrot "") ""
+ (nrot nil 2) nil
+ (nrot (vec) 2) #()
+ (nrot "" 2) ""
+ (nrot nil -1) nil
+ (nrot (vec) -1) #()
+ (nrot "" -1) "")
+
+(mtest
+ (let ((s '(a))) (nrot s)) (a)
+ (let ((s (vec 1))) (nrot s) s) #(1)
+ (let ((s "x")) (nrot s) s) "x"
+ (let ((s '(a))) (nrot s -1)) (a)
+ (let ((s (vec 1))) (nrot s -1) s) #(1)
+ (let ((s "x")) (nrot s -1) s) "x")
+
+(mtest
+ (let ((s '(a b))) (nrot s)) (b a)
+ (let ((s (vec 1 2))) (nrot s) s) #(2 1)
+ (let ((s (copy "xy"))) (nrot s) s) "yx"
+ (let ((s '(a b))) (nrot s -1)) (b a)
+ (let ((s (vec 1 2))) (nrot s -1) s) #(2 1)
+ (let ((s (copy "xy"))) (nrot s -1) s) "yx")
+
+(mtest
+ (let ((s '(a b c))) (nrot s)) (b c a)
+ (let ((s (vec 1 2 3))) (nrot s) s) #(2 3 1)
+ (let ((s (copy "xyz"))) (nrot s) s) "yzx"
+ (let ((s '(a b c))) (nrot s -1)) (c a b)
+ (let ((s (vec 1 2 3))) (nrot s -1) s) #(3 1 2)
+ (let ((s (copy "xyz"))) (nrot s -1) s) "zxy")
+
+(mtest
+ (let ((s (list 'a 'b 'c))) (nrot s 33)) (a b c)
+ (let ((s (list 'a 'b 'c))) (nrot s 34)) (b c a))
+
+(mtest
+ (rot nil) nil
+ (rot #()) #()
+ (rot "") ""
+ (rot nil 2) nil
+ (rot #() 2) #()
+ (rot "" 2) ""
+ (rot nil -1) nil
+ (rot #() -1) #()
+ (rot "" -1) "")
+
+(mtest
+ (let ((s '(a))) (list (rot s) s)) ((a) (a))
+ (let ((s #(1))) (list (rot s) s)) (#(1) #(1))
+ (let ((s "x")) (list (rot s) s)) ("x" "x")
+ (let ((s '(a))) (list (rot s -1) s)) ((a) (a))
+ (let ((s #(1))) (list (rot s -1) s)) (#(1) #(1))
+ (let ((s "x")) (list (rot s -1) s)) ("x" "x"))
+
+(mtest
+ (let ((s '(a b))) (list (rot s) s)) ((b a) (a b))
+ (let ((s #(1 2))) (list (rot s) s)) (#(2 1) #(1 2))
+ (let ((s "xy")) (list (rot s) s)) ("yx" "xy")
+ (let ((s '(a b))) (list (rot s -1) s)) ((b a) (a b))
+ (let ((s #(1 2))) (list (rot s -1) s)) (#(2 1) #(1 2))
+ (let ((s "xy")) (list (rot s -1) s)) ("yx" "xy"))
+
+(mtest
+ (let ((s '(a b c))) (list (rot s) s)) ((b c a) (a b c))
+ (let ((s #(1 2 3))) (list (rot s) s)) (#(2 3 1) #(1 2 3))
+ (let ((s "xyz")) (list (rot s) s)) ("yzx" "xyz")
+ (let ((s '(a b c))) (list (rot s -1) s)) ((c a b) (a b c))
+ (let ((s #(1 2 3))) (list (rot s -1) s)) (#(3 1 2) #(1 2 3))
+ (let ((s "xyz")) (list (rot s -1) s)) ("zxy" "xyz"))
+
+(mtest
+ (let ((s '(a b c))) (list (rot s 33) s)) ((a b c) (a b c))
+ (let ((s '(a b c))) (list (rot s 34) s)) ((b c a) (a b c)))
+
+(mtest
+ (subq #\a #\b "") ""
+ (subq #\a #\b "a") "b"
+ (subq #\a #\b "aaa") "bbb"
+ (subq #\a #\b "abc") "bbc")
+
+(mtest
+ (subql #\a #\b "") ""
+ (subql #\a #\b "a") "b"
+ (subql #\a #\b "aaa") "bbb"
+ (subql #\a #\b "abc") "bbc")
+
+(mtest
+ (subqual #\a #\b "") ""
+ (subqual #\a #\b "a") "b"
+ (subqual #\a #\b "aaa") "bbb"
+ (subqual #\a #\b "abc") "bbc")
+
+(mtest
+ (subq 0 1 nil) nil
+ (subq 0 1 '(0)) (1)
+ (subq 0 1 '(0 0 0)) (1 1 1)
+ (subq 0 1 '(0 1 2)) (1 1 2))
+
+(mtest
+ (subql 0 1 nil) nil
+ (subql 0 1 '(0)) (1)
+ (subql 0 1 '(0 0 0)) (1 1 1)
+ (subql 0 1 '(0 1 2)) (1 1 2))
+
+(mtest
+ (subqual 0 1 nil) nil
+ (subqual 0 1 '(0)) (1)
+ (subqual 0 1 '(0 0 0)) (1 1 1)
+ (subqual 0 1 '(0 1 2)) (1 1 2))
+
+(mtest
+ (subqual "foo" "bar" nil) nil
+ (subqual "foo" "bar" '#"foo") #"bar"
+ (subqual "foo" "bar" '#"foo foo foo") #"bar bar bar"
+ (subqual "foo" "bar" '#"xyzzy foo quuz") #"xyzzy bar quuz")
+
+(mtest
+ (subqual "brown" "black" #("how" "now" "brown" "cow")) #("how" "now" "black" "cow")
+ (subst "brown" "black" #("how" "now" "brown" "cow")) #("how" "now" "black" "cow"))
+
+(mtest
+ [subst "brown" "black" #("how" "now" "BROWN" "cow") : downcase-str] #("how" "now" "black" "cow")
+ [subst 5 0 '(1 2 3 4 5 6 7 8 9 10) <] (1 2 3 4 5 0 0 0 0 0))
+
+(mtest
+ (pairlis nil nil) nil
+ (pairlis "abc" #(1 2 3 4)) ((#\a . 1) (#\b . 2) (#\c . 3))
+ (pairlis "abcd" #(1 2 3)) ((#\a . 1) (#\b . 2) (#\c . 3))
+ (pairlis "" #(1 2 3)) nil
+ (pairlis "abcd" #()) nil
+ (pairlis '(1 2 3) '(a b c) '(4 5 6)) ((1 . a) (2 . b) (3 . c) 4 5 6))
+
+(mtest
+ (find-max nil) nil
+ [find-max '("alpha" "charlie" "aardvark" "bravo") less] "aardvark"
+ [find-max '("alpha" "charlie" "aardvark" "bravo") less reverse] "alpha"
+ [find-max '("alpha" "charlie" "aardvark" "bravo") : reverse] "bravo"
+ (find-max 1..10) 9
+ [find-max #H(() (a 1) (b 2) (c 3)) : cdr] (c . 3))
+
+(mtest
+ (find-max-key nil) nil
+ [find-max-key '("alpha" "charlie" "aardvark" "bravo") less upcase-str] "AARDVARK"
+ [find-max-key #H(() (a 1) (b 2) (c 3)) : cdr] 3)
+
+(defvarl fn (do and
+ (chr-isdigit @1)
+ (not (chr-isdigit @2))))
+
+(mtest
+ [partition-if tf nil] nil
+ [partition-if tf "abc"] ("a" "b" "c")
+ [partition-if nilf "abc"] ("abc")
+ [partition-if neql "aaaabbcdee"] ("aaaa" "bb" "c" "d" "ee")
+ (partition-if fn "a13cd9foo42z") ("a13" "cd9" "foo42" "z"))
+
+(mtest
+ (partition-if (op /= (- @2 @1) 1)
+ '(1 3 4 5 7 8 9 10 9 8 6 5 3 2))
+ ((1) (3 4 5) (7 8 9 10) (9) (8) (6) (5) (3) (2))
+ (partition-if (op > (abs (- @2 @1)) 1)
+ '(1 3 4 5 7 8 9 10 9 8 6 5 3 2))
+ ((1) (3 4 5) (7 8 9 10 9 8) (6 5) (3 2)))
+
+(mtest
+ [partition-if neql "aaaabbcdee" 2] ("aaaa" "bb" "cdee")
+ [partition-if neql "aaaabbcdee" 1] ("aaaa" "bbcdee")
+ [partition-if fn "a13cd9foo42z" 2] ("a13" "cd9" "foo42z")
+ [partition-if fn "a13cd9foo42z" 1] ("a13" "cd9foo42z")
+ [partition-if fn "a13cd9foo42z" 0] ("a13cd9foo42z"))
+
+(mtest
+ [count 1 nil] 0
+ [count 1 '(1 2 3 4 1 5)] 2
+ [count "abc" '("foo" "bar" "ABC" "abc" "def" "abc")] 2
+ [count "ABC" '("foo" "bar" "ABC" "abc" "def" "abc") : upcase-str] 3)
+
+(compile-only
+ (test
+ [count #1="abc" '("abc" "abc" "abc" #1# "abc" #1#" abc") eq] 2))
+
+(mtest
+ (search "" "") 0
+ (search "abcde" "ab") 0
+ (search "abcde" "bc") 1
+ (search "abcde" "cd") 2
+ (search "abcde" "de") 3
+ (search "abcde" "e") 4
+ (search "abcde" "") 0
+ (search "abcde" "x") nil)
+
+(mtest
+ (search nil nil) 0
+ (search '#"a b c d e" '#"a b") 0
+ (search '#"a b c d e" '#"b c") 1
+ (search '#"a b c d e" '#"c d") 2
+ (search '#"a b c d e" '#"d e") 3
+ (search '#"a b c d e" '#"e") 4
+ (search '#"a b c d e" nil) 0
+ (search '#"a b c d e" '#"x") nil)
+
+(mtest
+ (rsearch nil nil) 0
+ (rsearch "abcde" "ab") 0
+ (rsearch "abcde" "bc") 1
+ (rsearch "abcde" "cd") 2
+ (rsearch "abcde" "de") 3
+ (rsearch "abcde" "e") 4
+ (rsearch "abcde" "") 5
+ (rsearch "abcde" "x") nil)
+
+(mtest
+ (rsearch '#"a b c d e" '#"a b") 0
+ (rsearch '#"a b c d e" '#"b c") 1
+ (rsearch '#"a b c d e" '#"c d") 2
+ (rsearch '#"a b c d e" '#"d e") 3
+ (rsearch '#"a b c d e" '#"e") 4
+ (rsearch '#"a b c d e" nil) 5
+ (rsearch '#"a b c d e" '#"x") nil)
+
+(mtest
+ (search-all "" "") (0)
+ (search-all "xxxxx" "y") nil
+ (search-all "xxxxx" "x") (0 1 2 3 4)
+ (search-all "xxx" "") (0 1 2 3))
+
+(mtest
+ (search-all nil nil) (0)
+ (search-all '#"x x x x x" '#"y") nil
+ (search-all '#"x x x x x" '#"x") (0 1 2 3 4)
+ (search-all '#"x x x" "") (0 1 2 3))
+
+(mtest
+ [keep-keys-if evenp (range 1 20) square] (4 16 36 64 100 144 196 256 324 400)
+ [keep-keys-if chr-isupper "foo bar" chr-toupper] "FOOBAR"
+ [keep-keys-if evenp (vec-list (range 1 20)) square] #(4 16 36 64 100 144 196 256 324 400))
+
+
+(mtest
+ [separate-keys evenp (range 1 20) square] ((4 16 36 64 100 144 196 256 324 400)
+ (1 9 25 49 81 121 169 225 289 361))
+ [separate-keys chr-isupper "foo bar" chr-toupper] ("FOOBAR" " ")
+ [separate-keys evenp (vec-list (range 1 20)) square] (#(4 16 36 64 100 144 196 256 324 400)
+ #(1 9 25 49 81 121 169 225 289 361)))
+
+(mtest
+ (flatten '()) ()
+ (flatten '(nil)) ()
+ (flatten '(a)) (a)
+ (flatten '(a b)) (a b)
+ (flatten '(nil b)) (b)
+ (flatten '(a nil)) (a)
+
+ (flatten '((nil))) ()
+ (flatten '((a))) (a)
+ (flatten '((a) (b))) (a b)
+ (flatten '((nil) (b))) (b)
+ (flatten '((a) (nil))) (a)
+
+ (flatten '((a b))) (a b)
+ (flatten '((nil b))) (b)
+ (flatten '((a nil))) (a)
+
+ (flatten '(((())))) nil
+ (flatten '(((())) a)) (a)
+ (flatten '(((()) a))) (a)
+ (flatten '(((() a)))) (a)
+ (flatten '((((a))))) (a)
+
+ (flatten 3) (3)
+ (flatten '(1 . 2)) :error
+ (flatten '(1 2 . 3)) :error
+ (flatten '(1 (2 . 3))) :error)
+
+(mtest
+ (flatten* '()) ()
+ (flatten* '(nil)) ()
+ (flatten* '(a)) (a)
+ (flatten* '(a b)) (a b)
+ (flatten* '(nil b)) (b)
+ (flatten* '(a nil)) (a)
+
+ (flatten* '((nil))) ()
+ (flatten* '((a))) (a)
+ (flatten* '((a) (b))) (a b)
+ (flatten* '((nil) (b))) (b)
+ (flatten* '((a) (nil))) (a)
+
+ (flatten* '((a b))) (a b)
+ (flatten* '((nil b))) (b)
+ (flatten* '((a nil))) (a)
+
+ (flatten* '(((())))) nil
+ (flatten* '(((())) a)) (a)
+ (flatten* '(((()) a))) (a)
+ (flatten* '(((() a)))) (a)
+ (flatten* '((((a))))) (a)
+
+ (flatten* 3) (3)
+ (lforce (flatten* '(1 . 2))) :error
+ (lforce (flatten* '(1 2 . 3))) :error
+ (lforce (flatten* '(1 (2 . 3)))) :error)
+
+(mtest
+ (flatcar ()) (nil)
+ (flatcar 'a) (a)
+ (flatcar '(a . b)) (a b)
+ (flatcar '(nil . nil)) (nil)
+ (flatcar '(nil . b)) (nil b)
+ (flatcar '(b . nil)) (b)
+ (flatcar '(a b . c)) (a b c)
+ (flatcar '(() b . c)) (nil b c)
+ (flatcar '((()) b . c)) (nil b c)
+ (flatcar '(((a)) b . c)) (a b c))
+
+(mtest
+ (flatcar* ()) (nil)
+ (flatcar* 'a) (a)
+ (flatcar* '(a . b)) (a b)
+ (flatcar* '(nil . nil)) (nil)
+ (flatcar* '(nil . b)) (nil b)
+ (flatcar* '(b . nil)) (b)
+ (flatcar* '(a b . c)) (a b c)
+ (flatcar* '(() b . c)) (nil b c)
+ (flatcar* '((()) b . c)) (nil b c)
+ (flatcar* '(((a)) b . c)) (a b c))
+
+(mtest
+ (length-< nil 0) nil
+ (length-< nil 1) t
+ (length-< '(a) 1) nil
+ (length-< '(a) 2) t
+ (length-< '(a . b) 1) nil
+ (length-< '(a . b) 2) t)
+
+(mtest
+ (length-< "" 0) nil
+ (length-< "" 1) t
+ (length-< "a" 1) nil
+ (length-< "a" 2) t)
+
+(mtest
+ (length-< #() 0) nil
+ (length-< #() 1) t
+ (length-< #(a) 1) nil
+ (length-< #(a) 2) t)
+
+(let ((l (list 1 2 3 4)))
+ (del (ref l 1))
+ (test l (1 3 4))
+ (del (second l))
+ (test l (1 4)))
+
+(let ((nl (list (list (list 1 2)
+ (list 3 4)
+ (list 5 6))
+ (list (list 7 8)
+ (list 9 10)
+ (list 11 12)))))
+ (mtest
+ (mref nl 0 0 0) 1
+ (mref nl 0 0 1) 2
+ (mref nl 0 1 0) 3
+ (mref nl 0 1 1) 4
+ (mref nl 0 2 0) 5
+ (mref nl 0 2 1) 6
+ (mref nl 1 0 0) 7
+ (mref nl 1 0 1) 8
+ (mref nl 1 1 0) 9
+ (mref nl 1 1 1) 10
+ (mref nl 1 2 0) 11
+ (mref nl 0 2 1) 6)
+
+ (mtest
+ (set (mref nl 0 0 0) 101) 101
+ (mref nl 0 0 0) 101
+
+ (del (mref nl 0 0 0..:)) (101 2)
+ nl ((nil (3 4) (5 6)) ((7 8) (9 10) (11 12)))
+
+ (set (mref nl 1 0..2) '(4)) (4)
+ nl ((nil (3 4) (5 6)) (4 (11 12)))
+
+ (del (mref nl 1)) (4 (11 12))
+ nl ((nil (3 4) (5 6)))
+
+ (set (mref nl 1..:) '(a b c)) (a b c)
+ nl ((nil (3 4) (5 6)) a b c)
+
+ (set (mref nl 1..3) '(e f)) (e f)
+ nl ((nil (3 4) (5 6)) e f c)))
+
+(flet ((get-vec () (vec 1 2 3))
+ (get-list () (list 1 2 3)))
+ (mtest
+ (inc (mref (get-vec) 0)) 2
+ (set (mref (get-vec) 0) 10) 10
+ (inc (mref (get-list) 0)) 2
+ (set (mref (get-list) 0) 10) 10
+ (push 3 (mref (get-vec) 1..2)) (3 . #(2))
+ (set (mref (get-vec) 1..2) '(30)) (30)
+ (push 3 (mref (get-list) 1..2)) :error
+ (set (mref (get-list) 1..2) '(30)) :error))
+
+
+(let ((nv (nested-vec 4 4 4)))
+ (let ((x 0))
+ (each-prod ((i 0..4)
+ (j 0..4)
+ (k 0..4))
+ (vtest (set (mref nv i j k) (inc x)) (succ x))))
+ (mtest
+ nv #(#(#( 1 2 3 4) #( 5 6 7 8) #( 9 10 11 12) #(13 14 15 16))
+ #(#(17 18 19 20) #(21 22 23 24) #(25 26 27 28) #(29 30 31 32))
+ #(#(33 34 35 36) #(37 38 39 40) #(41 42 43 44) #(45 46 47 48))
+ #(#(49 50 51 52) #(53 54 55 56) #(57 58 59 60) #(61 62 63 64)))
+ (set (mref nv 0 0 1..3) #(20 30)) #(20 30)
+ nv #(#(#( 1 20 30 4) #( 5 6 7 8) #( 9 10 11 12) #(13 14 15 16))
+ #(#(17 18 19 20) #(21 22 23 24) #(25 26 27 28) #(29 30 31 32))
+ #(#(33 34 35 36) #(37 38 39 40) #(41 42 43 44) #(45 46 47 48))
+ #(#(49 50 51 52) #(53 54 55 56) #(57 58 59 60) #(61 62 63 64)))
+ (set (mref nv 1 1..3) "AB") "AB"
+ nv #(#(#( 1 20 30 4) #( 5 6 7 8) #( 9 10 11 12) #(13 14 15 16))
+ #(#(17 18 19 20) #\A #\B #(29 30 31 32))
+ #(#(33 34 35 36) #(37 38 39 40) #(41 42 43 44) #(45 46 47 48))
+ #(#(49 50 51 52) #(53 54 55 56) #(57 58 59 60) #(61 62 63 64)))
+ (set (mref nv 1..3) '(B C)) (B C)
+ nv #(#(#( 1 20 30 4) #( 5 6 7 8) #( 9 10 11 12) #(13 14 15 16))
+ B
+ C
+ #(#(49 50 51 52) #(53 54 55 56) #(57 58 59 60) #(61 62 63 64)))))
+
+(let ((cf (lambda (x)
+ (lambda (y)
+ (lambda (z)
+ (+ x y z))))))
+ (test [mref cf 1 2 3] 6))
+
+(test
+ (zip) nil)
+
+(mtest
+ (zip '()) nil
+ (zip #()) #()
+ (zip "") ""
+ (zip #b'') #b'')
+
+(mtest
+ (zip '(a)) ((a))
+ (zip '(a b)) ((a) (b))
+ (zip '(a b c)) ((a) (b) (c)))
+
+(mtest
+ (zip #(a)) #(#(a))
+ (zip #(a b)) #(#(a) #(b))
+ (zip #(a b c)) #(#(a) #(b) #(c)))
+
+(mtest
+ (zip "a") ("a")
+ (zip "ab") ("a" "b")
+ (zip "abc") ("a" "b" "c"))
+
+(mtest
+ (zip #b'aa') (#b'aa')
+ (zip #b'aabb') (#b'aa' #b'bb')
+ (zip #b'aabbcc') (#b'aa' #b'bb' #b'cc'))
+
+(mtest
+ (zip '(a) '(b)) ((a b))
+ (zip '(a c) '(b d)) ((a b) (c d))
+ (zip '(a c e) '(b d f)) ((a b) (c d) (e f))
+ (zip '(a d) '(b e) '(c f)) ((a b c) (d e f)))
+
+(mtest
+ (zip #(a) #(b)) #(#(a b))
+ (zip #(a c) #(b d)) #(#(a b) #(c d))
+ (zip #(a c e) #(b d f)) #(#(a b) #(c d) #(e f))
+ (zip #(a d) #(b e) #(c f)) #(#(a b c) #(d e f)))
+
+(mtest
+ (zip #(a) #(b)) #(#(a b))
+ (zip #(a c) #(b d)) #(#(a b) #(c d))
+ (zip #(a c e) #(b d f)) #(#(a b) #(c d) #(e f))
+ (zip #(a d) #(b e) #(c f)) #(#(a b c) #(d e f)))
+
+(mtest
+ (zip "a" "b") ("ab")
+ (zip "ac" "bd") ("ab" "cd")
+ (zip "ace" "bdf") ("ab" "cd" "ef")
+ (zip "ad" "bef" "cf") ("abc" "def"))
+
+(mtest
+ (zip #b'aa' #b'bb') (#b'aabb')
+ (zip #b'aacc' #b'bbdd') (#b'aabb' #b'ccdd')
+ (zip #b'aaccee' #b'bbddff') (#b'aabb' #b'ccdd' #b'eeff')
+ (zip #b'aaddee' #b'bbeeff' #b'ccff') (#b'aabbcc' #b'ddeeff'))
+
+(test
+ (zip "ab" "ijklm" "xy") ("aix" "bjy"))
+
+(test
+ (zip "ab" '(#\i #\j) #("x" "y")) ("aix" "bjy"))
+
+(vtest
+ [apply mapcar join (list-seq "aaa".."zzz")]
+ (transpose (list-seq "aaa".."zzz")))
+
+(eval-only (set *compile-opts*.constant-throws nil))
+
+(mtest
+ (ref "a".."z" 0) :error
+ (ref (rcons 'foo 'bar) 0) :error)
+
+(mtest
+ (ref 1..6 0) 1
+ (ref 1..6 1) 2
+ (ref 1..6 4) 5
+ (ref 1..6 5) :error
+ (ref 1..6 -1) 5
+ (ref 1..6 -2) 4
+ (ref 1..6 -5) 1
+ (ref 1..6 -6) :error)
+
+(mtest
+ (ref 1..: 0) 1
+ (ref 1..: 1) 2
+ (ref 1..: 4) 5
+ (ref 1..: -1) :error
+ (ref 1..: -2) :error)
+
+(mtest
+ (ref 1..t 0) 1
+ (ref 1..t 1) 2
+ (ref 1..t 4) 5
+ (ref 1..t -1) :error
+ (ref 1..: -2) :error)
+
+(mtest
+ (ref #\a..#\f 0) #\a
+ (ref #\a..#\f 1) #\b
+ (ref #\a..#\f 4) #\e
+ (ref #\a..#\f 5) :error
+ (ref #\a..#\f -1) #\e
+ (ref #\a..#\f -2) #\d
+ (ref #\a..#\f -5) #\a
+ (ref #\a..#\f -6) :error)
+
+(mtest
+ (ref #\a..: 0) #\a
+ (ref #\a..: 1) #\b
+ (ref #\a..: 4) #\e
+ (ref #\a..: -1) :error
+ (ref #\a..: -2) :error)
+
+(mtest
+ (ref #\a..t 0) #\a
+ (ref #\a..t 1) #\b
+ (ref #\a..t 4) #\e
+ (ref #\a..t -1) :error
+ (ref #\a..: -2) :error)
+
+
+(mtest
+ (ref 1..6 0.0) (1.0 2.0 3.0 4.0 5.0))
diff --git a/tests/012/sort.tl b/tests/012/sort.tl
new file mode 100644
index 00000000..bca4a3d8
--- /dev/null
+++ b/tests/012/sort.tl
@@ -0,0 +1,98 @@
+(load "../common")
+
+(test (sort ()) nil)
+
+(let* ((list (conses '(1 2 3 4 5 6 7 8)))
+ (sp (uniq [mapcar sort (perm list (len list))])))
+ (mvtest (len sp) 1
+ (car sp) list))
+
+(test (sort #()) #())
+
+(let* ((vec (conses #(1 2 3 4 5 6 7 8)))
+ (sp (uniq [mapcar sort (perm vec (len vec))])))
+ (mvtest (len sp) 1
+ (car sp) vec))
+
+(let* ((list (range* 0 1000))
+ (slist (shuffle list))
+ (vec (vec-list list))
+ (svec (vec-list slist)))
+ (mvtest
+ (sort list) list
+ (sort slist) list
+ (sort list (fun greater)) (reverse list)
+ (sort slist (fun greater)) (reverse list))
+ (mvtest
+ (sort vec) vec
+ (sort svec) vec
+ (sort vec (fun greater)) (reverse vec)
+ (sort svec (fun greater)) (reverse vec))
+ (mvtest
+ (csort list) list
+ (csort slist) list
+ (csort list (fun greater)) (reverse list)
+ (csort slist (fun greater)) (reverse list))
+ (mvtest
+ (csort vec) vec
+ (csort svec) vec
+ (csort vec (fun greater)) (reverse vec)
+ (csort svec (fun greater)) (reverse vec)))
+
+
+(test (ssort ()) nil)
+
+(let* ((list (conses '(1 2 3 4 5 6 7 8)))
+ (sp (uniq [mapcar ssort (perm list (len list))])))
+ (mvtest (len sp) 1
+ (car sp) list))
+
+(test (ssort #()) #())
+
+(let* ((vec (conses #(1 2 3 4 5 6 7 8)))
+ (sp (uniq [mapcar ssort (perm vec (len vec))])))
+ (mvtest (len sp) 1
+ (car sp) vec))
+
+(let* ((list (range* 0 1000))
+ (slist (shuffle list))
+ (vec (vec-list list))
+ (svec (vec-list slist)))
+ (mvtest
+ (ssort list) list
+ (ssort slist) list
+ (ssort list (fun greater)) (reverse list)
+ (ssort slist (fun greater)) (reverse list))
+ (mvtest
+ (ssort vec) vec
+ (ssort svec) vec
+ (ssort vec (fun greater)) (reverse vec)
+ (ssort svec (fun greater)) (reverse vec))
+ (mvtest
+ (cssort list) list
+ (cssort slist) list
+ (cssort list (fun greater)) (reverse list)
+ (cssort slist (fun greater)) (reverse list))
+ (mvtest
+ (cssort vec) vec
+ (cssort svec) vec
+ (cssort vec (fun greater)) (reverse vec)
+ (cssort svec (fun greater)) (reverse vec)))
+
+(mtest
+ [sort-group '((a 1) (b 1) (a 2) (b 2) (a 3) (c 2) (c 1) (a 4)) car]
+ (((a 1) (a 2) (a 3) (a 4))
+ ((b 1) (b 2))
+ ((c 2) (c 1)))
+ [csort-group '((a 1) (b 1) (a 2) (b 2) (a 3) (c 2) (c 1) (a 4)) car]
+ (((a 1) (a 2) (a 3) (a 4))
+ ((b 1) (b 2))
+ ((c 2) (c 1))))
+
+(mtest
+ (hist-sort nil) nil
+ (hist-sort '(3 4 5)) ((3 . 1) (4 . 1) (5 . 1))
+ (hist-sort '("a" "b" "c" "a" "b" "a" "b" "a")) (("a" . 4) ("b" . 3) ("c" . 1)))
+
+(test
+ [hist-sort-by upcase-str '("a" "b" "c" "a" "b" "a" "b" "a")] (("A" . 4) ("B" . 3) ("C" . 1)))
diff --git a/tests/012/stack.tl b/tests/012/stack.tl
new file mode 100644
index 00000000..b3cea078
--- /dev/null
+++ b/tests/012/stack.tl
@@ -0,0 +1,50 @@
+(load "../common")
+
+(defvarl stack-limited (set-stack-limit 32768))
+
+(defun recur () (recur))
+
+(defmacro so (expr)
+ ^(catch ,expr
+ (stack-overflow (exc) :so)))
+
+(test (so (recur)) :so)
+
+(if (fboundp 'setrlimit)
+ (test (let ((pid (fork)))
+ (cond
+ ((zerop pid)
+ (set-stack-limit 0)
+ (let ((rlim (getrlimit rlimit-stack)))
+ (set rlim.cur 32768)
+ (setrlimit rlimit-stack rlim))
+ (recur))
+ (t (let ((status (wait pid)))
+ (w-ifsignaled status)))))
+ t))
+
+(defmacro infexp ()
+ ^(foo (infexp)))
+
+(test (so (expand '(infexp))) :so)
+
+(defvarl orig (get-stack-limit))
+
+(mvtest
+ (set-stack-limit nil) orig
+ (set-stack-limit orig) nil
+ (set-stack-limit 0) orig
+ (set-stack-limit orig) nil
+ (set-stack-limit 65536) orig
+ (set-stack-limit orig) 65536)
+
+(set-sig-handler sig-segv
+ (lambda (signal async-p)
+ (assert (null (get-stack-limit)))
+ (throw 'out)))
+
+(test
+ (catch
+ (raise sig-segv)
+ (out () :sig))
+ :sig)
diff --git a/tests/012/stack2.expected b/tests/012/stack2.expected
new file mode 100644
index 00000000..cad99e12
--- /dev/null
+++ b/tests/012/stack2.expected
@@ -0,0 +1 @@
+caught
diff --git a/tests/012/stack2.txr b/tests/012/stack2.txr
new file mode 100644
index 00000000..3652a764
--- /dev/null
+++ b/tests/012/stack2.txr
@@ -0,0 +1,9 @@
+@(define recur ())
+@(recur)
+@(end)
+@(do (set-stack-limit 32768))
+@(try)
+@(recur)
+@(catch stack-overflow (arg))
+@(do (put-line "caught"))
+@(end)
diff --git a/tests/012/struct.expected b/tests/012/struct.expected
deleted file mode 100644
index e69de29b..00000000
--- a/tests/012/struct.expected
+++ /dev/null
diff --git a/tests/012/struct.tl b/tests/012/struct.tl
index 9de3f832..33431780 100644
--- a/tests/012/struct.tl
+++ b/tests/012/struct.tl
@@ -16,7 +16,7 @@
(test (expand '^#S(bar b ,(+ 2 2)))
(sys:make-struct-lit 'bar (list 'b (+ 2 2))))
-(defvar s (eval ^#S(bar b ,(+ 2 2))))
+(defvarl s (eval ^#S(bar b ,(+ 2 2))))
(test (set (slot s 'a) 100)
100)
@@ -28,32 +28,36 @@
(slot (slot (slot a 'b)
'c) 'd))
-(test (expand 's.a)
+(defmacro get-current-menv (:env e) e)
+(defvarl menv (let (s a b c d) (macro-time (get-current-menv))))
+
+(test (expand 's.a menv)
(slot s 'a))
-(test (expand 's.[a])
- [(slot s 'a)])
-(test (expand 's.[a b c])
- [(slot s 'a) b c])
+(test (expand 's.[a] menv)
+ [(slot s 'a) s])
+(test (expand 's.[a b c] menv)
+ [(slot s 'a) s b c])
(set *gensym-counter* 0)
-(stest (ignwarn (expand 's.(a)))
+
+(stest (ignwarn (expand 's.(a) menv))
"(call (slot s 'a)\n \
\ s)")
(set *gensym-counter* 0)
-(stest (ignwarn (expand 's.(a b c)))
+(stest (ignwarn (expand 's.(a b c) menv))
"(call (slot s 'a)\n \
\ s b c)")
-(test (expand 's.[a].d)
- (slot [(slot s 'a)] 'd))
-(test (expand 's.[a b c].d)
- (slot [(slot s 'a) b c] 'd))
+(test (expand 's.[a].b menv)
+ (slot [(slot s 'a) s] 'b))
+(test (expand 's.[a b c].b menv)
+ (slot [(slot s 'a) s b c] 'b))
(set *gensym-counter* 0)
-(stest (ignwarn (expand 's.(a).d))
+(stest (ignwarn (expand 's.(a).d menv))
"(slot (call (slot s 'a)\n \
\ s)\n \
\ 'd)")
(set *gensym-counter* 0)
-(stest (ignwarn (expand 's.(a b c).d))
+(stest (ignwarn (expand 's.(a b c).d menv))
"(slot (call (slot s 'a)\n \
\ s b c)\n \
\ 'd)")
@@ -62,7 +66,7 @@
(test (new foo) #S(foo a 42))
-(set *gensym-counter* 0)
+(set *gensym-counter* 4)
(stest (expand '(defstruct (boa x y) nil
(x 0) (y 0)))
"(sys:make-struct-type 'boa '() '()\n \
@@ -104,7 +108,7 @@
(stest bz
"#S(baz array #(1 2 3) increment #<interpreted fun: lambda (self which delta)>)")
-(test bz.[array 2] 3)
+(test [bz.array 2] 3)
(test bz.(increment 0 42) 43)
(test bz.array #(43 2 3))
(test [(meth bz increment) 1 5] 7)
@@ -133,3 +137,11 @@
(test (equal #S(foo) #S(foo)) t)
(test (equal #S(foo a 0) #S(foo a 1)) nil)
(test (equal #S(bar a 3 b 3) #S(bar a 3 b 3)) t)
+
+(defstruct eqsub ()
+ key
+ (:method equal (me) me.key))
+
+(test (equal (new eqsub key '(1 2))
+ (new eqsub key '(1 2)))
+ t)
diff --git a/tests/012/stslot.expected b/tests/012/stslot.expected
deleted file mode 100644
index e69de29b..00000000
--- a/tests/012/stslot.expected
+++ /dev/null
diff --git a/tests/012/syms.expected b/tests/012/syms.expected
new file mode 100644
index 00000000..bfe9f694
--- /dev/null
+++ b/tests/012/syms.expected
@@ -0,0 +1,6 @@
+(loc-0 loc-1 loc-2 cons)
+(loc-0 loc-1 loc-2 cons)
+(fb-2:loc-0 fb-2:loc-1 loc-2 cons)
+(loc-0 loc-1 loc-2 cons)
+(fb-2:loc-0 fb-2:loc-1 loc-2 cons)
+(fb-1:loc-0 loc-1 loc-2 cons)
diff --git a/tests/012/syms.tl b/tests/012/syms.tl
new file mode 100644
index 00000000..007125e2
--- /dev/null
+++ b/tests/012/syms.tl
@@ -0,0 +1,28 @@
+(load "../common")
+
+(defpackage fb-2
+ (:local loc-0 loc-1 loc-2)
+ (:fallback usr))
+
+(defpackage fb-1
+ (:local loc-0 loc-1)
+ (:fallback fb-2 usr))
+
+(defpackage main
+ (:local loc-0)
+ (:fallback fb-1 fb-2 usr))
+
+(in-package fb-2)
+
+(prinl '(loc-0 loc-1 loc-2 cons))
+
+(in-package fb-1)
+
+(prinl '(loc-0 loc-1 loc-2 cons))
+(prinl '(fb-2:loc-0 fb-2:loc-1 fb-2:loc-2 fb-2:cons))
+
+(in-package main)
+
+(prinl '(loc-0 loc-1 loc-2 cons))
+(prinl '(fb-2:loc-0 fb-2:loc-1 fb-2:loc-2 fb-2:cons))
+(prinl '(fb-1:loc-0 fb-1:loc-1 fb-1:loc-2 fb-1:cons))
diff --git a/tests/012/syntax.tl b/tests/012/syntax.tl
new file mode 100644
index 00000000..bc7d9668
--- /dev/null
+++ b/tests/012/syntax.tl
@@ -0,0 +1,74 @@
+(load "../common")
+
+"top level literal"
+
+".."
+
+"."
+
+#;(commented out list)
+#;3.14
+#;abc
+#;.foo
+#; .foo
+#;a.b
+
+'(#;.foo)
+'(#; .foo)
+
+(test
+ #;(commented out list)
+ #;3.14
+ #;abc
+ #;.foo
+ #; .foo
+ #;a.b
+ 42 42)
+
+(mtest
+ '(#;abc) nil
+ '(#; abc 1) (1)
+ '(0 #; abc 1) (0 1)
+ '(0 #; abc) (0))
+
+(mtest
+ '(#; .abc) nil
+ '(#; .abc 1) (1)
+ '(0 #; .abc 1) (0 1)
+ '(0 #; .abc) (0))
+
+(mtest
+ '(-,1) (- (sys:unquote 1))
+ 1,2 12
+ 1,,2 12
+ 1,,,2 12
+ 1,2,3 1,2,3
+ -0,1 -1
+ '(1,a) (1 (sys:unquote a)))
+
+(mtest
+ (read "#x,ff") :error
+ (read "#o,1") :error
+ (read "#b,1") :error
+ '(#xff,ff,z) (65535 (sys:unquote z))
+ '(#xff,ff,a) (1048570))
+
+(mtest
+ #xff,ff 65535
+ #o7,7,7 511
+ #b1101,1110 #xDE)
+
+(mtest
+ 1,234,567.890,123E13 1234567.890123E13
+ '(1.234,e+12) (1.234 (sys:unquote e+12))
+ '(1.,234) (1.0 (sys:unquote 234)))
+
+(mtest
+ (read "0..1") (rcons 0 1)
+ (read "0..1..2") (rcons 0 (rcons 1 2)))
+
+(mtest
+ (tostring '(rcons 0 1)) "0..1"
+ (tostring '(rcons 0 (rcons 1 2))) "0..1..2"
+ (tostring '(rcons (rcons 0 1) 2)) "(rcons 0..1 2)"
+ (tostring '(rcons (rcons 0 1) (rcons 2 3))) "(rcons 0..1 2..3)")
diff --git a/tests/012/type.tl b/tests/012/type.tl
new file mode 100644
index 00000000..97007b3c
--- /dev/null
+++ b/tests/012/type.tl
@@ -0,0 +1,68 @@
+(load "../common")
+
+(mtest
+ (subtypep 'a 'a) t
+ (subtypep t t) t
+ (subtypep nil t) t
+ (subtypep t nil) nil
+ (subtypep nil nil) t
+ (subtypep 'null nil) nil
+ (subtypep nil 'null) t
+ (subtypep 'null t) t
+ (subtypep 'null 'a) nil
+ (subtypep 'a 'null) nil
+ (subtypep nil 'a) t
+ (subtypep 'a nil) nil
+ (subtypep 'a t) t)
+
+(mtest
+ (subtypep 'stream 'stdio-stream) nil
+ (subtypep 'stdio-stream 'stream) t)
+
+(defstruct xtime time)
+(defstruct nottime nil)
+
+(mtest
+ (typep #S(time) 'time) t
+ (typep #S(time) (find-struct-type 'time)) t
+ (typep #S(xtime) 'time) t
+ (typep #S(xtime) (find-struct-type 'time)) t
+ (typep #S(nottime) 'time) nil
+ (typep #S(nottime) (find-struct-type 'time)) nil)
+
+(mtest
+ (subtypep (find-struct-type 'time) (find-struct-type 'time)) t
+ (subtypep (find-struct-type 'time) 'time) t
+ (subtypep 'time (find-struct-type 'time)) t)
+
+(mtest
+ (subtypep (find-struct-type 'xtime) (find-struct-type 'time)) t
+ (subtypep (find-struct-type 'xtime) 'time) t
+ (subtypep 'xtime (find-struct-type 'time)) t)
+
+(mtest
+ (subtypep (find-struct-type 'time) (find-struct-type 'xtime)) nil
+ (subtypep (find-struct-type 'time) 'xtime) nil
+ (subtypep 'time (find-struct-type 'xtime)) nil)
+
+(mtest
+ (subtypep 'time 'struct) t
+ (subtypep (find-struct-type 'time) 'struct) t
+ (subtypep 'hash 'struct) nil)
+
+(defstruct listlike nil
+ (:method car (me)))
+
+(defstruct veclike nil
+ (:method length (me)))
+
+(mtest
+ (subtypep 'listlike 'sequence) t
+ (subtypep (find-struct-type 'listlike) 'sequence) t
+ (subtypep 'veclike 'sequence) t
+ (subtypep (find-struct-type 'veclike) 'sequence) t
+ (subtypep 'time 'sequence) nil
+ (subtypep 'hash 'sequence) nil
+ (subtypep 'str 'sequence) t
+ (subtypep 'string 'sequence) t
+ (subtypep 'vec 'sequence) t)
diff --git a/tests/012/typecase.tl b/tests/012/typecase.tl
new file mode 100644
index 00000000..97b3da48
--- /dev/null
+++ b/tests/012/typecase.tl
@@ -0,0 +1,18 @@
+(load "../common")
+
+(mtest
+ (typecase) :error
+ (typecase nil) nil
+ (typecase nil a) :error
+ (typecase 0 (symbol 1)) nil
+ (typecase 0 (integer 1)) 1
+ (typecase 0 (integer 1) (integer 2)) 1
+ (typecase 0 (t 3) (integer 1)) 3)
+
+(mtest
+ (etypecase) :error
+ (etypecase nil) :error
+ (etypecase nil a) :error
+ (etypecase 0 (string 1)) :error
+ (etypecase 0 (string 1) (integer 2)) 2
+ (etypecase 0 (string 1) (t 2)) 2)
diff --git a/tests/012/use-as.tl b/tests/012/use-as.tl
new file mode 100644
index 00000000..eb736d9d
--- /dev/null
+++ b/tests/012/use-as.tl
@@ -0,0 +1,39 @@
+(load "../common")
+
+(defpackage lottery
+ (:local draw)
+ (:fallback usr))
+
+(defpackage graphics
+ (:local draw)
+ (:fallback usr))
+
+(defpackage gui-lottery
+ (:fallback lottery graphics usr pub)
+ (:use-syms-as lottery:draw ldraw
+ graphics:draw gdraw))
+
+(in-package gui-lottery)
+
+(mtest
+ (package-name (symbol-package 'ldraw)) "lottery"
+ (package-name (symbol-package 'gdraw)) "graphics"
+ (symbol-name 'ldraw) "draw"
+ (symbol-name 'gdraw) "draw")
+
+(mtest
+ (tostring 'ldraw) "draw"
+ (tostring 'gdraw) "graphics:draw")
+
+(mtest
+ (use-sym-as 3 '#:foo) :error
+ (use-sym-as 'ldraw 3) :error
+ (use-sym-as 'x 'x) x)
+
+(mtest
+ (find-symbol "ldraw") lottery:draw
+ (find-symbol "gdraw") graphics:draw
+ (unuse-sym 'ldraw) lottery:draw
+ (unuse-sym 'gdraw) graphics:draw
+ (find-symbol "ldraw") nil
+ (find-symbol "gdraw") nil)
diff --git a/tests/013/chksum.tl b/tests/013/chksum.tl
new file mode 100644
index 00000000..6c9e7add
--- /dev/null
+++ b/tests/013/chksum.tl
@@ -0,0 +1,40 @@
+(load "../common")
+
+(mtest
+ (crc32 "") 0
+ (sha1 "") #b'da39a3ee 5e6b4b0d 3255bfef 95601890 afd80709'
+ (sha256 "") #b'e3b0c442 98fc1c14 9afbf4c8 996fb924 27ae41e4 649b934c a495991b 7852b855'
+ (md5 "") #b'd41d8cd9 8f00b204 e9800998 ecf8427e')
+
+(mtest
+ (crc32 "abc") #x352441c2
+ (sha1 "abc") #b'a9993e36 4706816a ba3e2571 7850c26c 9cd0d89d'
+ (sha256 "abc") #b'ba7816bf 8f01cfea 414140de 5dae2223 b00361a3 96177a9c b410ff61 f20015ad'
+ (md5 "abc") #b'90015098 3cd24fb0 d6963f7d 28e17f72')
+
+(defvarl algs (list
+ [list sha1 sha1-begin sha1-hash sha1-end sha1-stream]
+ [list sha256 sha256-begin sha256-hash sha256-end sha256-stream]
+ [list md5 md5-begin md5-hash md5-end md5-stream]))
+
+(defvarl testbuf (make-buf 20000 #xAA))
+
+(test
+ (crc32 testbuf) #xf35324f0)
+
+(each-match ((@hashfn @begfn @updatefn @endfn @streamfn) algs)
+ (let ((h0 [hashfn testbuf])
+ (h1 (let ((ctx [begfn]))
+ (each ((piece (tuples 1 testbuf)))
+ [updatefn ctx piece])
+ [endfn ctx]))
+ (h2 (let ((ctx [begfn]))
+ (each ((piece (tuples 100 testbuf)))
+ [updatefn ctx piece])
+ [endfn ctx]))
+ (h3 (let ((s (make-buf-stream testbuf)))
+ [streamfn s])))
+ (mtest
+ (equal h0 h1) t
+ (equal h0 h2) t
+ (equal h0 h3) t)))
diff --git a/tests/013/maze.expected b/tests/013/maze.expected
index b9c26ae0..8cf588e4 100644
--- a/tests/013/maze.expected
+++ b/tests/013/maze.expected
@@ -1,61 +1,61 @@
+ +----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+
-| | | | | | | | |
-| | | | | | | | |
-+----+ + +----+ + + + + + +----+----+ + +----+----+ +----+ + +
-| | | | | | | | | | | | | |
-| | | | | | | | | | | | | |
-+ +----+ +----+----+----+ +----+----+ + + + + + + + + +----+ +
-| | | | | | | | |
-| | | | | | | | |
-+----+----+----+----+----+ +----+ +----+----+----+ +----+ + +----+----+----+ +----+
-| | | | | | | | | |
-| | | | | | | | | |
-+ + +----+----+----+----+ +----+----+ + +----+ + + +----+----+ +----+ +
-| | | | | | | | | | | | |
-| | | | | | | | | | | | |
-+ + + + +----+ + + + + + + +----+----+ +----+ + +----+----+
-| | | | | | | | | | | | |
-| | | | | | | | | | | | |
-+----+----+ +----+ + + +----+----+----+ +----+----+ +----+ +----+----+ + +
-| | | | | | | | | |
-| | | | | | | | | |
-+ +----+----+ +----+ +----+ +----+ +----+ +----+----+ + + +----+----+ +
-| | | | | | | | | | | | |
-| | | | | | | | | | | | |
-+----+ + +----+ + + +----+ +----+ +----+ + +----+ + +----+ + +
-| | | | | | | | | | | |
-| | | | | | | | | | | |
-+ +----+----+ + + +----+ + + +----+ +----+----+ +----+----+----+----+ +
-| | | | | | | | | | |
-| | | | | | | | | | |
-+----+----+ +----+----+----+ + + + + + +----+ +----+ + + + +----+
-| | | | | | | | | | | | | | |
-| | | | | | | | | | | | | | |
-+ + + + + +----+----+ + + + +----+ +----+----+----+----+ + + +
-| | | | | | | | | | | |
-| | | | | | | | | | | |
-+----+ + + +----+----+ + +----+----+----+ +----+----+ +----+----+ +----+ +
-| | | | | | | | | | | | |
-| | | | | | | | | | | | |
-+ +----+ + +----+ + + +----+ + + + + +----+ + +----+ + +
-| | | | | | | | | | | | | |
-| | | | | | | | | | | | | |
-+ +----+----+ + +----+ + + +----+ +----+----+ +----+ + + +----+ +
-| | | | | | | | | | | |
-| | | | | | | | | | | |
-+----+ + + +----+ +----+----+ +----+----+----+----+----+ + + +----+----+ +
-| | | | | | | | | |
-| | | | | | | | | |
-+ + +----+----+ +----+ + +----+ +----+----+ + + + +----+ + + +
-| | | | | | | | | | | | | |
-| | | | | | | | | | | | | |
-+ + +----+----+----+ + +----+ +----+----+ + + + +----+----+----+ + +
-| | | | | | | | | | | |
-| | | | | | | | | | | |
-+ +----+ + + +----+----+----+ +----+----+ + +----+----+ + + + +----+
-| | | | | | | | | | | | |
-| | | | | | | | | | | | |
-+ +----+----+ +----+ +----+----+ + + +----+----+ + +----+ + +----+ +
-| | | | | |
-| | | | | |
+| | | | | | | |
+| | | | | | | |
++ +----+----+ + +----+ + +----+ +----+----+ +----+ +----+----+ +----+ +
+| | | | | | | | | | |
+| | | | | | | | | | |
++ + +----+----+----+ +----+----+ +----+ + +----+----+----+ +----+----+ + +
+| | | | | | | | | | |
+| | | | | | | | | | |
++ +----+ + +----+ + +----+----+----+----+ + + + +----+ + +----+ +
+| | | | | | | | | |
+| | | | | | | | | |
++----+----+----+----+ + +----+ +----+ +----+----+ + +----+ + +----+----+ +
+| | | | | | | | | | |
+| | | | | | | | | | |
++ + + +----+----+ + +----+ + +----+ + +----+ +----+ +----+----+ +
+| | | | | | | | | | | |
+| | | | | | | | | | | |
++----+ +----+ +----+----+ +----+----+ + +----+ +----+----+----+----+----+ +----+
+| | | | | | | | |
+| | | | | | | | |
++ +----+ +----+ + + +----+ + +----+----+----+----+ +----+ +----+ +----+
+| | | | | | | | | | | | |
+| | | | | | | | | | | | |
++ + +----+ + + +----+----+ +----+ + +----+ + + +----+----+----+ +
+| | | | | | | | | | | |
+| | | | | | | | | | | |
++ + +----+----+ + +----+----+----+ + + + +----+ +----+ + +----+ +
+| | | | | | | | | | | |
+| | | | | | | | | | | |
++ +----+----+----+ + +----+ +----+ + + + +----+----+ + + +----+----+
+| | | | | | | | | | | | |
+| | | | | | | | | | | | |
++ + + + + +----+----+----+ + +----+ +----+ + +----+ +----+----+ +
+| | | | | | | | | | | |
+| | | | | | | | | | | |
++ +----+ +----+----+ + +----+----+ + + + +----+ + +----+ +----+ +
+| | | | | | | | | | | | | |
+| | | | | | | | | | | | | |
++----+ +----+ + + +----+----+ +----+ + + + + + + + + + +
+| | | | | | | | | | | | | | | | | |
+| | | | | | | | | | | | | | | | | |
++ +----+ +----+ +----+ + +----+ + + + + + + + + + +----+
+| | | | | | | | | | | | | |
+| | | | | | | | | | | | | |
++ + +----+ +----+ +----+ + +----+----+----+----+ + +----+ + +----+ +
+| | | | | | | | | | | |
+| | | | | | | | | | | |
++ + + +----+ + + + + +----+----+----+----+----+----+ + +----+----+ +
+| | | | | | | | | |
+| | | | | | | | | |
++----+----+ + +----+----+ + +----+----+----+----+----+ + +----+----+ + +----+
+| | | | | | | | | | |
+| | | | | | | | | | |
++ +----+ + +----+----+----+ + +----+ + + + +----+ + +----+----+ +
+| | | | | | | | | | | | |
+| | | | | | | | | | | | |
++ +----+----+----+ + + +----+ +----+----+ +----+ + +----+ + + + +
+| | | | | | |
+| | | | | | |
+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+ +
diff --git a/tests/013/maze.tl b/tests/013/maze.tl
index 5cb989d6..38dca3e3 100644
--- a/tests/013/maze.tl
+++ b/tests/013/maze.tl
@@ -1,7 +1,3 @@
-(defvar vi) ;; visited hash
-(defvar pa) ;; path connectivity hash
-(defvar sc) ;; count, derived from straightness fator
-
(defun scramble (list)
(let ((out ()))
(each ((item list))
@@ -18,7 +14,7 @@
(list (- x 1)..y (+ x 1)..y
x..(- y 1) x..(+ y 1))))
-(defun make-maze-impl (cu)
+(defun make-maze-impl (vi pa sc cu)
(let ((fr (hash :equal-based))
(q (list cu))
(c sc))
@@ -38,16 +34,16 @@
(pop q)))))))
(defun make-maze (w h sf)
- (let ((vi (hash :equal-based))
- (pa (hash :equal-based))
- (sc (max 1 (int-flo (trunc (* sf w h) 100.0)))))
+ (let ((vi (hash :equal-based)) ;; visited hash
+ (pa (hash :equal-based)) ;; path connectivity hash
+ (sc (max 1 (int-flo (trunc (* sf w h) 100.0))))) ;; go straight count
(each ((x (range -1 w)))
(set [vi x..-1] t)
(set [vi x..h] t))
(each ((y (range* 0 h)))
(set [vi -1..y] t)
(set [vi w..y] t))
- (make-maze-impl 0..0)
+ (make-maze-impl vi pa sc 0..0)
;; Open start and end
(push 0..-1 [pa 0..0])
(push (- w 1)..(- h 1) [pa (- w 1)..h])
@@ -78,7 +74,7 @@
(let ((invocation (ldiff *full-args* *args*)))
(put-line "usage: ")
(put-line `@invocation <width> <height> [<straightness>]`)
- (put-line "straightness-factor is a percentage, defaulting to 15")
+ (put-line "straightness is a percentage, defaulting to 15")
(exit 1)))
(let ((args [mapcar num-str *args*]))
diff --git a/tests/013/rand.tl b/tests/013/rand.tl
new file mode 100644
index 00000000..f593c39c
--- /dev/null
+++ b/tests/013/rand.tl
@@ -0,0 +1,84 @@
+(load "../common")
+
+(mtest
+ (random-state-get-vec (make-random-state #b'' 0))
+ #(740765398 1304255849 3309840409 338361566 4155223728 1162561521
+ 4236628653 446542199 639181595 1801947880 2890206840 2695457564
+ 2292665861 3251351234 2171649709 704313206 0)
+ (random-state-get-vec (make-random-state #b'FF' 0))
+ #(4278190080 1304255849 3309840409 338361566 4155223728 1162561521
+ 4236628653 446542199 639181595 1801947880 2890206840 2695457564
+ 2292665861 3251351234 2171649709 704313206 0)
+ (random-state-get-vec (make-random-state #b'FFFF' 0))
+ #(4294901760 1304255849 3309840409 338361566 4155223728 1162561521
+ 4236628653 446542199 639181595 1801947880 2890206840 2695457564
+ 2292665861 3251351234 2171649709 704313206 0)
+ (random-state-get-vec (make-random-state #b'FFFFFF' 0))
+ #(4294967040 1304255849 3309840409 338361566 4155223728 1162561521
+ 4236628653 446542199 639181595 1801947880 2890206840 2695457564
+ 2292665861 3251351234 2171649709 704313206 0)
+ (random-state-get-vec (make-random-state #b'FFFFFFFF' 0))
+ #(4294967295 1304255849 3309840409 338361566 4155223728 1162561521
+ 4236628653 446542199 639181595 1801947880 2890206840 2695457564
+ 2292665861 3251351234 2171649709 704313206 0)
+ (random-state-get-vec (make-random-state #b'FFFFFFFFFF' 0))
+ #(4294967295 4278190080 3309840409 338361566 4155223728 1162561521
+ 4236628653 446542199 639181595 1801947880 2890206840 2695457564
+ 2292665861 3251351234 2171649709 704313206 0)
+ (random-state-get-vec (make-random-state (make-buf (* 4 16) #xff) 0))
+ #(4294967295 4294967295 4294967295 4294967295 4294967295 4294967295
+ 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295
+ 4294967295 4294967295 4294967295 4294967295 0)
+ (random-state-get-vec (make-random-state (make-buf (* 5 16) #xff) 0))
+ #(4294967295 4294967295 4294967295 4294967295 4294967295 4294967295
+ 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295
+ 4294967295 4294967295 4294967295 4294967295 0))
+
+(mtest
+ (random-state-get-vec (make-random-state 0 0))
+ #(740765398 1304255849 3309840409 338361566 4155223728 1162561521
+ 4236628653 446542199 639181595 1801947880 2890206840 2695457564
+ 2292665861 3251351234 2171649709 704313206 0)
+ (random-state-get-vec (make-random-state #xFF 0))
+ #(255 1304255849 3309840409 338361566 4155223728 1162561521 4236628653
+ 446542199 639181595 1801947880 2890206840 2695457564 2292665861
+ 3251351234 2171649709 704313206 0)
+ (random-state-get-vec (make-random-state #xFFFF 0))
+ #(65535 1304255849 3309840409 338361566 4155223728 1162561521 4236628653
+ 446542199 639181595 1801947880 2890206840 2695457564 2292665861
+ 3251351234 2171649709 704313206 0)
+ (random-state-get-vec (make-random-state #xFFFFFF 0))
+ #(16777215 1304255849 3309840409 338361566 4155223728 1162561521
+ 4236628653 446542199 639181595 1801947880 2890206840 2695457564
+ 2292665861 3251351234 2171649709 704313206 0)
+ (random-state-get-vec (make-random-state #xFFFFFFFF 0))
+ #(4294967295 1304255849 3309840409 338361566 4155223728 1162561521
+ 4236628653 446542199 639181595 1801947880 2890206840 2695457564
+ 2292665861 3251351234 2171649709 704313206 0)
+ (random-state-get-vec (make-random-state #xFFFFFFFFFF 0))
+ #(4294967295 255 3309840409 338361566 4155223728 1162561521 4236628653
+ 446542199 639181595 1801947880 2890206840 2695457564 2292665861
+ 3251351234 2171649709 704313206 0)
+ (random-state-get-vec (make-random-state (expt 2 (* 8 4 16)) 0))
+ #(740765398 1304255849 3309840409 338361566 4155223728 1162561521
+ 4236628653 446542199 639181595 1801947880 2890206840 2695457564
+ 2292665861 3251351234 2171649709 704313206 0)
+ (random-state-get-vec (make-random-state (pred (expt 2 (* 8 4 16))) 0))
+ #(4294967295 4294967295 4294967295 4294967295 4294967295 4294967295
+ 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295
+ 4294967295 4294967295 4294967295 4294967295 0)
+ (random-state-get-vec (make-random-state (pred (expt 2 (* 8 4 17))) 0))
+ #(4294967295 4294967295 4294967295 4294967295 4294967295 4294967295
+ 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295
+ 4294967295 4294967295 4294967295 4294967295 0))
+
+(mtest
+ (random-state-get-vec (make-random-state
+ #(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 0 0)
+ (random-state-get-vec (make-random-state
+ #(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17)))
+ #(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17)
+ (random-state-get-vec (make-random-state
+ #(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17) 10))
+ #(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17))
diff --git a/tests/013/well512a.expected b/tests/013/well512a.expected
new file mode 100644
index 00000000..ecde9a65
--- /dev/null
+++ b/tests/013/well512a.expected
@@ -0,0 +1,16 @@
+419341993
+1818026447
+3020103184
+3141358934
+187862696
+512541134
+1416267688
+4256491982
+731233432
+1852014262
+1248293699
+206481201
+750755084
+1094637740
+2806919360
+2752871950
diff --git a/tests/013/well512a.tl b/tests/013/well512a.tl
new file mode 100644
index 00000000..3f238925
--- /dev/null
+++ b/tests/013/well512a.tl
@@ -0,0 +1,8 @@
+(let ((rs (make-random-state #(#x01010101 #x11111111 #x22222222 #x33333333
+ #x44444444 #x55555555 #x66666666 #x77777777
+ #x88888888 #x99999999 #xAAAAAAAA #xBBBBBBBB
+ #xCCCCCCCC #xDDDDDDDD #xEEEEEEEE #xFFFFFFFF
+ 0)))
+ (mod (expt 2 32)))
+ (for ((i 0)) ((< i 16)) ((inc i))
+ (pprinl (rand mod rs))))
diff --git a/tests/014/dgram-stream.expected b/tests/014/dgram-stream.expected
deleted file mode 100644
index e69de29b..00000000
--- a/tests/014/dgram-stream.expected
+++ /dev/null
diff --git a/tests/014/dgram-stream.tl b/tests/014/dgram-stream.tl
index 5902a84d..6890e300 100644
--- a/tests/014/dgram-stream.tl
+++ b/tests/014/dgram-stream.tl
@@ -1,7 +1,7 @@
(load "../common.tl")
(load "../sock-common.tl")
-(defvar family)
+(defvar *family*)
(defun server (svc-sock)
(whilet ((acc-sock (sock-accept svc-sock))
@@ -10,7 +10,7 @@
(close-stream acc-sock)))
(defun client (addr)
- (with-stream (cli-sock (open-socket family sock-dgram))
+ (with-stream (cli-sock (open-socket *family* sock-dgram))
(sock-connect cli-sock addr)
(dotimes (i 1000)
(print i cli-sock)
@@ -22,7 +22,7 @@
(flush-stream cli-sock)))
(defun dgram-test ()
- (let* ((svc-sock (open-socket family sock-dgram))
+ (let* ((svc-sock (open-socket *family* sock-dgram))
(svc-addr (bindfree svc-sock 1025 65535))
(server-pid (fork)))
(cond
@@ -37,6 +37,6 @@
(fboundp 'fork))
(let ((maybe-ipv6 (if (memq (os-symbol) '(:linux :macos :cygwin :cygnal))
(list af-inet6))))
- (each ((family ^(,af-inet ,*maybe-ipv6)))
+ (each ((*family* ^(,af-inet ,*maybe-ipv6)))
(unless (dgram-test)
(error "test failed")))))
diff --git a/tests/014/in6addr-str.tl b/tests/014/in6addr-str.tl
new file mode 100644
index 00000000..a85da416
--- /dev/null
+++ b/tests/014/in6addr-str.tl
@@ -0,0 +1,120 @@
+(load "../common.tl")
+
+(test (in6addr-str "junk") :error)
+
+(test (in6addr-str "0:0:0:0:0:0:0:0:0") :error)
+(test (in6addr-str "0:0:0:0:0:0") :error)
+(test (in6addr-str "0:0:0:0") :error)
+(test (in6addr-str "") :error)
+
+(test (in6addr-str "0:0:0:0:0:0:0:x:0") :error)
+
+(test (in6addr-str ":0:0:0:0:0:0:0:0:0") :error)
+(test (in6addr-str "0:0:0:0:0:0:0:0:0:") :error)
+
+(test (in6addr-str "0:0:0:0:0:0:0:0:FFFFF") :error)
+(test (in6addr-str "0:0:0:0:0:0:0:FFFFF:0") :error)
+(test (in6addr-str "0:0:0:0:0:0:FFFFF:0:0") :error)
+(test (in6addr-str "0:0:0:0:0:FFFFF:0:0:0") :error)
+(test (in6addr-str "0:0:0:0:FFFFF:0:0:0:0") :error)
+(test (in6addr-str "0:0:0:FFFFF:0:0:0:0:0") :error)
+(test (in6addr-str "0:0:FFFFF:0:0:0:0:0:0") :error)
+(test (in6addr-str "0:FFFFF:0:0:0:0:0:0:0") :error)
+(test (in6addr-str "FFFFF:0:0:0:0:0:0:0:0") :error)
+
+(test (in6addr-str "0:0:0:0:0:0:0:0/") :error)
+(test (in6addr-str "0:0:0:0:0:0:0:0/129") :error)
+(test (in6addr-str "[0:0:0:0:0:0:0:0]:") :error)
+(test (in6addr-str "[0:0:0:0:0:0:0:0]:65536") :error)
+
+(test (in6addr-str "0:0:0:0:0:0:0:0")
+ #S(sockaddr-in6 addr 0
+ port 0 flow-info 0 scope-id 0 prefix 128))
+(test (in6addr-str "1111:2222:3333:4444:5555:6666:7777:8888")
+ #S(sockaddr-in6 addr 22685837286468424649968941046919825544
+ port 0 flow-info 0 scope-id 0 prefix 128))
+(test (in6addr-str "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF")
+ #S(sockaddr-in6 addr 340282366920938463463374607431768211455
+ port 0 flow-info 0 scope-id 0 prefix 128))
+
+(test (in6addr-str "[0:0:0:0:0:0:0:0]:42")
+ #S(sockaddr-in6 addr 0
+ port 42 flow-info 0 scope-id 0 prefix 128))
+(test (in6addr-str "[1111:2222:3333:4444:5555:6666:7777:8888]:42")
+ #S(sockaddr-in6 addr 22685837286468424649968941046919825544
+ port 42 flow-info 0 scope-id 0 prefix 128))
+(test (in6addr-str "[FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF]:42")
+ #S(sockaddr-in6 addr 340282366920938463463374607431768211455
+ port 42 flow-info 0 scope-id 0 prefix 128))
+
+(test (in6addr-str "0:0:0:0:0:0:0:0/16")
+ #S(sockaddr-in6 addr 0
+ port 0 flow-info 0 scope-id 0 prefix 16))
+(test (in6addr-str "1111:2222:3333:4444:5555:6666:7777:8888/16")
+ #S(sockaddr-in6 addr 22685144974938661909049738462362599424
+ port 0 flow-info 0 scope-id 0 prefix 16))
+(test (in6addr-str "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF/16")
+ #S(sockaddr-in6 addr 340277174624079928635746076935438991360
+ port 0 flow-info 0 scope-id 0 prefix 16))
+(test (in6addr-str "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff/16")
+ #S(sockaddr-in6 addr 340277174624079928635746076935438991360
+ port 0 flow-info 0 scope-id 0 prefix 16))
+
+(test (in6addr-str "[0:0:0:0:0:0:0:0/16]:42")
+ #S(sockaddr-in6 addr 0
+ port 42 flow-info 0 scope-id 0 prefix 16))
+(test (in6addr-str "[1111:2222:3333:4444:5555:6666:7777:8888/16]:42")
+ #S(sockaddr-in6 addr 22685144974938661909049738462362599424
+ port 42 flow-info 0 scope-id 0 prefix 16))
+(test (in6addr-str "[FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF/16]:42")
+ #S(sockaddr-in6 addr 340277174624079928635746076935438991360
+ port 42 flow-info 0 scope-id 0 prefix 16))
+
+(test (in6addr-str "1:2:3:4:5:6::7:8:9") :error)
+(test (in6addr-str "1:2:3:4:5:6::7:8:9") :error)
+(test (in6addr-str "1:2:3:4:5:6::7:8") :error)
+
+(test (in6addr-str "::1")
+ #S(sockaddr-in6 addr 1
+ port 0 flow-info 0 scope-id 0 prefix 128))
+
+(test (in6addr-str "1::")
+ #S(sockaddr-in6 addr 5192296858534827628530496329220096
+ port 0 flow-info 0 scope-id 0 prefix 128))
+
+(test (in6addr-str "1::1")
+ #S(sockaddr-in6 addr 5192296858534827628530496329220097
+ port 0 flow-info 0 scope-id 0 prefix 128))
+
+(test (in6addr-str "1:2::3:4")
+ #S(sockaddr-in6 addr 5192455314859856157205683417317380
+ port 0 flow-info 0 scope-id 0 prefix 128))
+
+(test (in6addr-str "::ffff:1.2.3.4.5") :error)
+(test (in6addr-str "::ffff:1.2.3.4:5") :error)
+(test (in6addr-str "::ffff:1.2.3") :error)
+(test (in6addr-str "::ffff:1.2.3:4") :error)
+
+(test (in6addr-str "::ffff:1.2.3.4")
+ #S(sockaddr-in6 addr 281470698652420
+ port 0 flow-info 0 scope-id 0 prefix 128))
+
+(test (in6addr-str "::FFFF:1.2.3.4")
+ #S(sockaddr-in6 addr 281470698652420
+ port 0 flow-info 0 scope-id 0 prefix 128))
+
+(test (in6addr-str "::FfFf:1.2.3.4")
+ #S(sockaddr-in6 addr 281470698652420
+ port 0 flow-info 0 scope-id 0 prefix 128))
+
+(test (in6addr-str "::FFFF:1.2.3.4/96")
+ #S(sockaddr-in6 addr 281470681743360
+ port 0 flow-info 0 scope-id 0 prefix 96))
+
+(test (in6addr-str "[::ffff:1.2.3.4]:42")
+ #S(sockaddr-in6 addr 281470698652420
+ port 42 flow-info 0 scope-id 0 prefix 128))
+
+(test (in6addr-str "[::FFFF:1.2.3.4/96]:42")
+ #S(sockaddr-in6 addr 281470681743360
+ port 42 flow-info 0 scope-id 0 prefix 96))
diff --git a/tests/014/inaddr-str.tl b/tests/014/inaddr-str.tl
new file mode 100644
index 00000000..67283188
--- /dev/null
+++ b/tests/014/inaddr-str.tl
@@ -0,0 +1,78 @@
+(load "../common.tl")
+
+(test (inaddr-str "junk") :error)
+(test (inaddr-str "0.0.0.0.0") :error)
+(test (inaddr-str "0.0.0") :error)
+(test (inaddr-str "0") :error)
+(test (inaddr-str "") :error)
+(test (inaddr-str "0.0.0.nnn") :error)
+(test (inaddr-str "0.0.0.256") :error)
+(test (inaddr-str "0.0.256.0") :error)
+(test (inaddr-str "0.256.0.0") :error)
+(test (inaddr-str "256.0.0.0") :error)
+(test (inaddr-str "0.0.0.0:65537") :error)
+(test (inaddr-str "0.0.0.0/33") :error)
+(test (inaddr-str "0.0.0.0/32:65537") :error)
+(test (inaddr-str "0.0.0.0/33:0") :error)
+(test (inaddr-str "0.0.0.0:0/0") :error)
+(test (inaddr-str "0.0.0.") :error)
+(test (inaddr-str "0.0..0") :error)
+(test (inaddr-str "0..0.0") :error)
+(test (inaddr-str ".0.0.0") :error)
+(test (inaddr-str "0.0.0.0:") :error)
+
+(test (inaddr-str "0.0.0.0")
+ #S(sockaddr-in addr 0 port 0 prefix 32))
+(test (inaddr-str "1.2.3.4")
+ #S(sockaddr-in addr 16909060 port 0 prefix 32))
+(test (inaddr-str "255.255.255.255")
+ #S(sockaddr-in addr 4294967295 port 0 prefix 32))
+
+(test (inaddr-str "0.0.0.0:0")
+ #S(sockaddr-in addr 0 port 0 prefix 32))
+(test (inaddr-str "1.2.3.4:5")
+ #S(sockaddr-in addr 16909060 port 5 prefix 32))
+(test (inaddr-str "255.255.255.255:65535")
+ #S(sockaddr-in addr 4294967295 port 65535 prefix 32))
+
+(test (inaddr-str "0.0.0.0/0")
+ #S(sockaddr-in addr 0 port 0 prefix 0))
+(test (inaddr-str "1.2.3.4/8")
+ #S(sockaddr-in addr 16777216 port 0 prefix 8))
+(test (inaddr-str "255.255.255.255/24")
+ #S(sockaddr-in addr 4294967040 port 0 prefix 24))
+
+(test (inaddr-str "0.0.0/0")
+ #S(sockaddr-in addr 0 port 0 prefix 0))
+(test (inaddr-str "0.0/0")
+ #S(sockaddr-in addr 0 port 0 prefix 0))
+(test (inaddr-str "0/0")
+ #S(sockaddr-in addr 0 port 0 prefix 0))
+
+(test (inaddr-str "1.2.3/8")
+ #S(sockaddr-in addr 16777216 port 0 prefix 8))
+(test (inaddr-str "1.2/8")
+ #S(sockaddr-in addr 16777216 port 0 prefix 8))
+(test (inaddr-str "1/8")
+ #S(sockaddr-in addr 16777216 port 0 prefix 8))
+
+(test (inaddr-str "0.0.0.0/0:1234")
+ #S(sockaddr-in addr 0 port 1234 prefix 0))
+(test (inaddr-str "1.2.3.4/8:1234")
+ #S(sockaddr-in addr 16777216 port 1234 prefix 8))
+(test (inaddr-str "255.255.255.255/24:1234")
+ #S(sockaddr-in addr 4294967040 port 1234 prefix 24))
+
+(test (inaddr-str "0.0.0/0:1234")
+ #S(sockaddr-in addr 0 port 1234 prefix 0))
+(test (inaddr-str "0.0/0:1234")
+ #S(sockaddr-in addr 0 port 1234 prefix 0))
+(test (inaddr-str "0/0:1234")
+ #S(sockaddr-in addr 0 port 1234 prefix 0))
+
+(test (inaddr-str "1.2.3/8:1234")
+ #S(sockaddr-in addr 16777216 port 1234 prefix 8))
+(test (inaddr-str "1.2/8:1234")
+ #S(sockaddr-in addr 16777216 port 1234 prefix 8))
+(test (inaddr-str "1/8:1234")
+ #S(sockaddr-in addr 16777216 port 1234 prefix 8))
diff --git a/tests/014/sockaddr-str.tl b/tests/014/sockaddr-str.tl
new file mode 100644
index 00000000..183c1a02
--- /dev/null
+++ b/tests/014/sockaddr-str.tl
@@ -0,0 +1,49 @@
+(load "../common.tl")
+
+(mtest
+ (sockaddr-str "") :error
+ (sockaddr-str "1") :error
+ (sockaddr-str "x") :error
+ (sockaddr-str "1:2") :error
+ (sockaddr-str "[]:") :error)
+
+(mtest
+ (sockaddr-str "[::1]:-1") :error
+ (sockaddr-str "[::1]:65536") :error
+ (sockaddr-str "1.2.3.4:-1") :error
+ (sockaddr-str "1.2.3.4:65536") :error
+ (sockaddr-str "1:2/8") :error)
+
+(mtest
+ (sockaddr-str "/") #S(sockaddr-un canonname nil path "/")
+ (sockaddr-str "/abc") #S(sockaddr-un canonname nil path "/abc"))
+
+(mtest
+ (sockaddr-str "[::1]:2") #S(sockaddr-in6 addr 1 port 2)
+ (sockaddr-str "[::1/1]:2") #S(sockaddr-in6 addr 0 port 2 prefix 1))
+
+(mtest
+ (sockaddr-str "::1") #S(sockaddr-in6 addr 1)
+ (sockaddr-str "::1/1") #S(sockaddr-in6 addr 0 prefix 1))
+
+(mtest
+ (sockaddr-str "::ffff:1.2.3.4") #S(sockaddr-in6 addr 281470698652420)
+ (sockaddr-str "::ffff:1.2.3.4/96") #S(sockaddr-in6 addr 281470681743360 prefix 96))
+
+(mtest
+ (sockaddr-str "1.2.3.4") #S(sockaddr-in addr 16909060)
+ (sockaddr-str "1.2.3.4/8") #S(sockaddr-in addr 16777216 prefix 8)
+ (sockaddr-str "1.2.3.4:16") #S(sockaddr-in addr 16909060 port 16)
+ (sockaddr-str "1.2.3.4/8:16") #S(sockaddr-in addr 16777216 prefix 8 port 16))
+
+(mtest
+ (sockaddr-str "1/8") #S(sockaddr-in addr 16777216 prefix 8)
+ (sockaddr-str "1.2/8") #S(sockaddr-in addr 16777216 prefix 8)
+ (sockaddr-str "1/8:5") #S(sockaddr-in addr 16777216 prefix 8 port 5)
+ (sockaddr-str "1.2/8:5") #S(sockaddr-in addr 16777216 prefix 8 port 5))
+
+(mtest
+ (sockaddr-str "1:2:3:4:5:6:7:8/127")
+ #S(sockaddr-in6 addr 5192455318486707404433266433261576 prefix 127)
+ (sockaddr-str "[1:2:3:4:5:6:7:8/127]:5")
+ #S(sockaddr-in6 addr 5192455318486707404433266433261576 prefix 127 port 5))
diff --git a/tests/014/socket-basic.expected b/tests/014/socket-basic.expected
deleted file mode 100644
index e69de29b..00000000
--- a/tests/014/socket-basic.expected
+++ /dev/null
diff --git a/tests/014/socket-basic.tl b/tests/014/socket-basic.tl
index efeed2d6..2e4d57a0 100644
--- a/tests/014/socket-basic.tl
+++ b/tests/014/socket-basic.tl
@@ -1,22 +1,25 @@
(load "../sock-common.tl")
+(load "../common.tl")
-(defvar socktype)
+(defvar *socktype*)
+
+(defvarl %iters% (if (meql (os-symbol) :macos :bsd :openbsd) 2000 5000))
(defun client (addr)
- (with-stream (cli-sock (open-socket af-inet socktype))
+ (with-stream (cli-sock (open-socket af-inet *socktype*))
(sock-connect cli-sock addr)
(put-string "5000" cli-sock)
(sock-shutdown cli-sock)
- (equal (read cli-sock) (range 1 5000))))
+ (equal (read cli-sock) (range 1 %iters%))))
(defun server (svc-sock)
(let* ((acc-sock (sock-accept svc-sock))
(query (read acc-sock)))
- (print (range 1 5000) acc-sock)
+ (print (range 1 %iters%) acc-sock)
(close-stream acc-sock)))
-(defun test ()
- (let* ((svc-sock (open-socket af-inet socktype))
+(defun sock-test ()
+ (let* ((svc-sock (open-socket af-inet *socktype*))
(svc-addr (bindfree svc-sock 1025 65535))
(child-pid (fork)))
(cond
@@ -26,6 +29,6 @@
(if (and (fboundp 'open-socket)
(fboundp 'fork))
- (each ((socktype (list sock-dgram sock-stream)))
- (unless (test)
+ (each ((*socktype* (list sock-dgram sock-stream)))
+ (unless (sock-test)
(error "test failed"))))
diff --git a/tests/014/socket-misc.tl b/tests/014/socket-misc.tl
new file mode 100644
index 00000000..5f533529
--- /dev/null
+++ b/tests/014/socket-misc.tl
@@ -0,0 +1,20 @@
+(load "../sock-common")
+(load "../common")
+
+(defmacro set-and-get (:env env place val)
+ (with-update-expander (getter setter) place env
+ ^(progn (,setter ,val) (,getter))))
+
+(with-stream (s (open-socket af-inet (logior sock-dgram sock-nonblock)))
+ (test (sock-listen s) t)
+ (let* ((orig #S(sockaddr-in))
+ (addr orig))
+ (rotate addr (sock-peer s))
+ (vtest (sock-peer s) orig)))
+
+(with-stream (s (open-socket af-inet sock-stream))
+ (test (nzerop (set-and-get (sock-opt s sol-socket so-reuseaddr) 1)) t)
+ (test (set-and-get (sock-opt s sol-socket so-reuseaddr (ffi int)) 0) 0)
+ (whenlet ((addr (bindfree s 1025 65535)))
+ ;; sock-bind enables so-reuseaddr.
+ (test (nzerop (sock-opt s sol-socket so-reuseaddr)) t)))
diff --git a/tests/014/str-addr.tl b/tests/014/str-addr.tl
new file mode 100644
index 00000000..49bc844a
--- /dev/null
+++ b/tests/014/str-addr.tl
@@ -0,0 +1,68 @@
+(load "../common.tl")
+
+(mtest
+ #S(sockaddr-un path "/foo").(str-addr) "/foo"
+ #S(sockaddr-un path nil).(str-addr) :error)
+
+(mtest
+ #S(sockaddr-in addr 0).(str-addr) "0.0.0.0"
+ #S(sockaddr-in addr #x01020304).(str-addr) "1.2.3.4"
+ #S(sockaddr-in addr #x01020304 prefix 8).(str-addr) "1.2.3.4/8"
+ #S(sockaddr-in addr #x01020304 prefix 16).(str-addr) "1.2.3.4/16"
+ #S(sockaddr-in addr #x01020304 prefix 24).(str-addr) "1.2.3.4/24"
+ #S(sockaddr-in addr #x01020304 prefix 31).(str-addr) "1.2.3.4/31"
+ #S(sockaddr-in addr #x01020304 prefix 32).(str-addr) "1.2.3.4"
+ #S(sockaddr-in addr #x01000000 prefix 8).(str-addr) "1/8"
+ #S(sockaddr-in addr #x01000000 prefix 16).(str-addr) "1/16"
+ #S(sockaddr-in addr #x01020000 prefix 16).(str-addr) "1.2/16"
+ #S(sockaddr-in addr #x01000000 prefix 24).(str-addr) "1/24"
+ #S(sockaddr-in addr #x01020000 prefix 24).(str-addr) "1.2/24"
+ #S(sockaddr-in addr #x01020300 prefix 24).(str-addr) "1.2.3/24"
+ #S(sockaddr-in addr #x01000000 prefix 31).(str-addr) "1/31"
+ #S(sockaddr-in addr 0 port 123).(str-addr) "0.0.0.0:123"
+ #S(sockaddr-in addr #x01020304 port 123).(str-addr) "1.2.3.4:123"
+ #S(sockaddr-in addr #x01020304 port 123 prefix 8).(str-addr) "1.2.3.4/8:123"
+ #S(sockaddr-in addr #x01020304 port 123 prefix 16).(str-addr) "1.2.3.4/16:123"
+ #S(sockaddr-in addr #x01020304 port 123 prefix 24).(str-addr) "1.2.3.4/24:123"
+ #S(sockaddr-in addr #x01020304 port 123 prefix 24).(str-addr) "1.2.3.4/24:123"
+ #S(sockaddr-in addr #x01020304 port 123 prefix 31).(str-addr) "1.2.3.4/31:123"
+ #S(sockaddr-in addr #x01020304 port 123 prefix 32).(str-addr) "1.2.3.4:123"
+ #S(sockaddr-in addr #x01000000 port 123 prefix 8).(str-addr) "1/8:123"
+ #S(sockaddr-in addr #x01000000 port 123 prefix 16).(str-addr) "1/16:123"
+ #S(sockaddr-in addr #x01020000 port 123 prefix 16).(str-addr) "1.2/16:123"
+ #S(sockaddr-in addr #x01000000 port 123 prefix 24).(str-addr) "1/24:123"
+ #S(sockaddr-in addr #x01020000 port 123 prefix 24).(str-addr) "1.2/24:123"
+ #S(sockaddr-in addr #x01020300 port 123 prefix 24).(str-addr) "1.2.3/24:123"
+ #S(sockaddr-in addr #x01000000 port 123 prefix 31).(str-addr) "1/31:123")
+
+(mtest
+ #S(sockaddr-in6 addr 0).(str-addr) "::"
+ #S(sockaddr-in6 addr #x80000000000000000000000000000001).(str-addr) "8000::1"
+ #S(sockaddr-in6 addr #x00000000000000000000000000000001).(str-addr) "::1"
+ #S(sockaddr-in6 addr #x80000000000000000000000000000000).(str-addr) "8000::"
+ #S(sockaddr-in6 addr #x00008000000000000000000000000001).(str-addr) "0:8000::1"
+ #S(sockaddr-in6 addr #x00000000000000000000000000010000).(str-addr) "::1:0"
+ #S(sockaddr-in6 addr #x00008000000000000000000000010000).(str-addr) "0:8000::1:0"
+ #S(sockaddr-in6 addr #x000000000000abcd0000000000000000).(str-addr) "0:0:0:abcd::"
+ #S(sockaddr-in6 addr #x0000000000000000abcd000000000000).(str-addr) "::abcd:0:0:0"
+ #S(sockaddr-in6 addr #x11112222333344445555666677778888).(str-addr) "1111:2222:3333:4444:5555:6666:7777:8888"
+ #S(sockaddr-in6 addr #x01000200030004000500060007000800).(str-addr) "100:200:300:400:500:600:700:800"
+ #S(sockaddr-in6 addr #x00008000000000000000000000010000 port 0).(str-addr) "0:8000::1:0"
+ #S(sockaddr-in6 addr #x00008000000000000000000000010000 port 123).(str-addr) "[0:8000::1:0]:123"
+ #S(sockaddr-in6 addr #x00008000000000000000000000010000 prefix 128).(str-addr) "0:8000::1:0"
+ #S(sockaddr-in6 addr #x00008000000000000000000000010000 prefix 127).(str-addr) "0:8000::1:0/127"
+ #S(sockaddr-in6 addr #x00008000000000000000000000010000 port 123 prefix 127).(str-addr) "[0:8000::1:0/127]:123")
+
+(mtest
+ #S(sockaddr-in6 addr #xffff00000000).(str-addr) "::ffff:0.0.0.0"
+ #S(sockaddr-in6 addr #xffff00000000 prefix 24).(str-addr) "::ffff:0/24"
+ #S(sockaddr-in6 addr #xffff01000000 prefix 24).(str-addr) "::ffff:1/24"
+ #S(sockaddr-in6 addr #xffff01020000 prefix 24).(str-addr) "::ffff:1.2/24"
+ #S(sockaddr-in6 addr #xffff01020300 prefix 24).(str-addr) "::ffff:1.2.3/24"
+ #S(sockaddr-in6 addr #xffff01020304 prefix 24).(str-addr) "::ffff:1.2.3.4/24"
+ #S(sockaddr-in6 addr #xffff00000000 port 123 ).(str-addr) "[::ffff:0.0.0.0]:123"
+ #S(sockaddr-in6 addr #xffff00000000 port 123 prefix 24).(str-addr) "[::ffff:0/24]:123"
+ #S(sockaddr-in6 addr #xffff01000000 port 123 prefix 24).(str-addr) "[::ffff:1/24]:123"
+ #S(sockaddr-in6 addr #xffff01020000 port 123 prefix 24).(str-addr) "[::ffff:1.2/24]:123"
+ #S(sockaddr-in6 addr #xffff01020300 port 123 prefix 24).(str-addr) "[::ffff:1.2.3/24]:123"
+ #S(sockaddr-in6 addr #xffff01020304 port 123 prefix 24).(str-addr) "[::ffff:1.2.3.4/24]:123")
diff --git a/tests/015/awk-fconv.tl b/tests/015/awk-fconv.tl
new file mode 100644
index 00000000..2affa4e0
--- /dev/null
+++ b/tests/015/awk-fconv.tl
@@ -0,0 +1,21 @@
+(load "../common")
+
+(defvarl inputs '("10E3 junk 20E3 30E3 40E3 50E3"))
+
+(defmacro tfconv (fconv expected)
+ ^(test (awk (:inputs inputs)
+ (t (fconv ,*fconv))
+ (:end f))
+ ,expected))
+
+(tfconv (i) (10 "junk" "20E3" "30E3" "40E3" "50E3"))
+(tfconv (: : i) ("10E3" "junk" "20E3" "30E3" "40E3" 50))
+(tfconv (: : o) ("10E3" "junk" "20E3" "30E3" "40E3" 40))
+(tfconv (: : x) ("10E3" "junk" "20E3" "30E3" "40E3" #x50E3))
+(tfconv (: x) (#x10E3 nil #x20E3 #x30E3 #x40E3 #x50E3))
+(tfconv (: r) (10000.0 nil 20000.0 30000.0 40000.0 50000.0))
+(tfconv (: b) (2 nil nil nil nil nil))
+(tfconv (: bz) (2 0 0 0 0 0))
+(tfconv (i : : x) (10 "junk" "20E3" "30E3" "40E3" #x50E3))
+(tfconv (- : i : -) ("10E3" nil 20 30 40 "50E3"))
+(tfconv (i : o r : x) (10 nil 20000.0 #o30 40000.0 #x50E3))
diff --git a/tests/015/awk-fields.tl b/tests/015/awk-fields.tl
new file mode 100644
index 00000000..7bb2f599
--- /dev/null
+++ b/tests/015/awk-fields.tl
@@ -0,0 +1,37 @@
+(load "../common")
+
+(mtest
+ (awk (:fields) (:begin (return-from awk))) nil
+ (awk (:fields t) (:begin (return-from awk))) :error
+ (awk (:fields nil) (:begin (return-from awk))) :error
+ (awk (:fields - -) (:begin (return-from awk))) nil
+ (awk (:fields a - - b) (:begin (return-from awk))) nil
+ (awk (:fields (a foo) - - (a bar)) (:begin (return-from awk))) :error
+ (awk (:fields (a foo) - - (b bar)) (:begin (return-from awk))) nil
+ (awk (:fields (a foo) (-) - (b bar)) (:begin (return-from awk))) :error
+ (awk (:fields (a foo) (- i) - (b bar)) (:begin (return-from awk))) :error
+ (awk (:fields a) (:fields b) (:begin (return-from awk))) :error)
+
+(test
+ (build
+ (awk
+ (:inputs '("How now brown cow"))
+ (:fields h n - c)
+ (t (add h n c))))
+ ("How" "now" "cow"))
+
+(test
+ (build
+ (awk
+ (:inputs '("1 x 2" "a x 1" "4 x b"))
+ (:fields (foo iz) - (bar iz))
+ (t (add (+ foo bar)))))
+ (3 1 4))
+
+(test
+ (build
+ (awk
+ (:inputs '("1"))
+ (:fields (a iz) - (c iz))
+ (t (add (+ a c) nf))))
+ (1 3))
diff --git a/tests/015/awk-misc.tl b/tests/015/awk-misc.tl
new file mode 100644
index 00000000..af61857d
--- /dev/null
+++ b/tests/015/awk-misc.tl
@@ -0,0 +1,10 @@
+(load "../common")
+
+(let ((*stdout* *stdnull*))
+ (test
+ (build
+ (awk
+ (:inputs '(""))
+ (t (add (prn 1 2 3))
+ (add (prn)))))
+ (nil nil)))
diff --git a/tests/015/awk-redir.tl b/tests/015/awk-redir.tl
new file mode 100644
index 00000000..5359ea2b
--- /dev/null
+++ b/tests/015/awk-redir.tl
@@ -0,0 +1,42 @@
+(load "../common")
+
+(push-after-load
+ (each ((f '#"file1.out file2.out file3.out"))
+ (remove-path f)))
+
+(file-put-lines "file1.out" '("old"))
+(file-put-lines "file2.out" '("old"))
+
+(awk
+ (:begin (->> "file1.out" (prn "abc"))
+ (->> "file1.out" (prn "def"))))
+
+(test
+ (file-get-lines "file1.out")
+ #"old abc def")
+
+(awk
+ (:begin (-> "file2.out" (prn "abc"))
+ (-> "file2.out" (prn "def"))))
+
+(test
+ (file-get-lines "file2.out")
+ #"abc def")
+
+(test
+ (build
+ (awk
+ (:begin (<- "file1.out" (add (get-line)))
+ (<- "file1.out" (add (get-line))))))
+ #"old abc")
+
+
+(awk (:begin (!> "cat > file3.out" (prn "out"))))
+
+(test (file-get-string "file3.out") "out\n")
+
+(test
+ (build
+ (awk
+ (:begin (<! "cat file3.out" (add (get-line))))))
+ #"out")
diff --git a/tests/015/awk-res.tl b/tests/015/awk-res.tl
new file mode 100644
index 00000000..6c919320
--- /dev/null
+++ b/tests/015/awk-res.tl
@@ -0,0 +1,8 @@
+(load "../common")
+
+(test
+ (build
+ (awk
+ (:inputs '#"How about it now brown cow")
+ (#/.ow/ (add res))))
+ ("How" "now" "row" "cow"))
diff --git a/tests/015/comb.tl b/tests/015/comb.tl
new file mode 100644
index 00000000..9973e94d
--- /dev/null
+++ b/tests/015/comb.tl
@@ -0,0 +1,443 @@
+(load "../common")
+
+(defun normtype (obj)
+ (etypecase obj
+ (null 'list)
+ (cons 'list)
+ (lit 'string)
+ (str 'string)
+ (vec 'vec)))
+
+(defun test-comb (s k)
+ (let ((out (comb s k))
+ (nCk (n-choose-k (len s) k)))
+ (if (> k (len s))
+ (test out nil)
+ (mvtest
+ (len out) nCk
+ (len (uniq out)) nCk))
+ (vtest
+ (sort out) out)
+ (unless (empty out)
+ (let ((stype (normtype s))
+ (otype (normtype (first out))))
+ (vtest stype otype)))))
+
+(defun test-rcomb (s k)
+ (let ((out (rcomb s k))
+ (nCk (n-choose-k (+ (len s) k -1) k)))
+ (if (and (empty s) (plusp k))
+ (test out nil)
+ (mvtest
+ (len out) nCk
+ (len (uniq out)) nCk))
+ (vtest
+ (sort out) out)
+ (unless (empty out)
+ (let ((stype (normtype s))
+ (otype (normtype (first out))))
+ (vtest stype otype)))))
+
+(defun test-perm (s k)
+ (let ((out (perm s k))
+ (nPk (n-perm-k (len s) k)))
+ (if (> k (len s))
+ (test out nil)
+ (mvtest
+ (len out) nPk
+ (len (uniq out)) nPk))
+ (unless (empty out)
+ (let ((stype (normtype s))
+ (otype (normtype (first out))))
+ (vtest stype otype)))))
+
+(defun test-rperm (s k)
+ (let ((out (rperm s k))
+ (exp (expt (len s) k)))
+ (mvtest
+ (len out) exp
+ (len (uniq out)) exp)
+ (vtest
+ (sort out) out)
+ (unless (empty out)
+ (let ((stype (normtype s))
+ (otype (normtype (first out))))
+ (vtest stype otype)))))
+
+(test-comb #() 0)
+(test-comb #() 1)
+(test-comb #(1) 0)
+(test-comb #(1) 1)
+(test-comb #(1) 2)
+(test-comb #(1 2) 0)
+(test-comb #(1 2) 1)
+(test-comb #(1 2) 2)
+(test-comb #(1 2) 3)
+(test-comb #(1 2 3) 0)
+(test-comb #(1 2 3) 1)
+(test-comb #(1 2 3) 2)
+(test-comb #(1 2 3) 3)
+(test-comb #(1 2 3) 4)
+(test-comb #(1 2 3 4) 0)
+(test-comb #(1 2 3 4) 1)
+(test-comb #(1 2 3 4) 2)
+(test-comb #(1 2 3 4) 3)
+(test-comb #(1 2 3 4) 4)
+(test-comb #(1 2 3 4) 5)
+(test-comb #(1 2 3 4 5) 0)
+(test-comb #(1 2 3 4 5) 1)
+(test-comb #(1 2 3 4 5) 2)
+(test-comb #(1 2 3 4 5) 3)
+(test-comb #(1 2 3 4 5) 4)
+(test-comb #(1 2 3 4 5) 5)
+(test-comb #(1 2 3 4 5) 5)
+
+(test-comb '() 0)
+(test-comb '() 1)
+(test-comb '(1) 0)
+(test-comb '(1) 1)
+(test-comb '(1) 2)
+(test-comb '(1 2) 0)
+(test-comb '(1 2) 1)
+(test-comb '(1 2) 2)
+(test-comb '(1 2) 3)
+(test-comb '(1 2 3) 0)
+(test-comb '(1 2 3) 1)
+(test-comb '(1 2 3) 2)
+(test-comb '(1 2 3) 3)
+(test-comb '(1 2 3) 4)
+(test-comb '(1 2 3 4) 0)
+(test-comb '(1 2 3 4) 1)
+(test-comb '(1 2 3 4) 2)
+(test-comb '(1 2 3 4) 3)
+(test-comb '(1 2 3 4) 4)
+(test-comb '(1 2 3 4) 5)
+(test-comb '(1 2 3 4 5) 0)
+(test-comb '(1 2 3 4 5) 1)
+(test-comb '(1 2 3 4 5) 2)
+(test-comb '(1 2 3 4 5) 3)
+(test-comb '(1 2 3 4 5) 4)
+(test-comb '(1 2 3 4 5) 5)
+(test-comb '(1 2 3 4 5) 5)
+
+(test-comb "" 0)
+(test-comb "" 1)
+(test-comb "1" 0)
+(test-comb "1" 1)
+(test-comb "1" 2)
+(test-comb "12" 0)
+(test-comb "12" 1)
+(test-comb "12" 2)
+(test-comb "12" 3)
+(test-comb "123" 0)
+(test-comb "123" 1)
+(test-comb "123" 2)
+(test-comb "123" 3)
+(test-comb "123" 4)
+(test-comb "1234" 0)
+(test-comb "1234" 1)
+(test-comb "1234" 2)
+(test-comb "1234" 3)
+(test-comb "1234" 4)
+(test-comb "1234" 5)
+(test-comb "12345" 0)
+(test-comb "12345" 1)
+(test-comb "12345" 2)
+(test-comb "12345" 3)
+(test-comb "12345" 4)
+(test-comb "12345" 5)
+(test-comb "12345" 5)
+
+(mtest
+ (comb #() -1) :error
+ (comb #(1) -1) :error
+ (comb () -1) :error
+ (comb '(1) -1) :error
+ (comb "" -1) :error
+ (comb "a" -1) :error)
+
+(test-rcomb #() 0)
+(test-rcomb #() 1)
+(test-rcomb #(1) 0)
+(test-rcomb #(1) 1)
+(test-rcomb #(1) 2)
+(test-rcomb #(1 2) 0)
+(test-rcomb #(1 2) 1)
+(test-rcomb #(1 2) 2)
+(test-rcomb #(1 2) 3)
+(test-rcomb #(1 2 3) 0)
+(test-rcomb #(1 2 3) 1)
+(test-rcomb #(1 2 3) 2)
+(test-rcomb #(1 2 3) 3)
+(test-rcomb #(1 2 3) 4)
+(test-rcomb #(1 2 3 4) 0)
+(test-rcomb #(1 2 3 4) 1)
+(test-rcomb #(1 2 3 4) 2)
+(test-rcomb #(1 2 3 4) 3)
+(test-rcomb #(1 2 3 4) 4)
+(test-rcomb #(1 2 3 4) 5)
+(test-rcomb #(1 2 3 4 5) 0)
+(test-rcomb #(1 2 3 4 5) 1)
+(test-rcomb #(1 2 3 4 5) 2)
+(test-rcomb #(1 2 3 4 5) 3)
+(test-rcomb #(1 2 3 4 5) 4)
+(test-rcomb #(1 2 3 4 5) 5)
+(test-rcomb #(1 2 3 4 5) 5)
+
+(test-rcomb '() 0)
+(test-rcomb '() 1)
+(test-rcomb '(1) 0)
+(test-rcomb '(1) 1)
+(test-rcomb '(1) 2)
+(test-rcomb '(1 2) 0)
+(test-rcomb '(1 2) 1)
+(test-rcomb '(1 2) 2)
+(test-rcomb '(1 2) 3)
+(test-rcomb '(1 2 3) 0)
+(test-rcomb '(1 2 3) 1)
+(test-rcomb '(1 2 3) 2)
+(test-rcomb '(1 2 3) 3)
+(test-rcomb '(1 2 3) 4)
+(test-rcomb '(1 2 3 4) 0)
+(test-rcomb '(1 2 3 4) 1)
+(test-rcomb '(1 2 3 4) 2)
+(test-rcomb '(1 2 3 4) 3)
+(test-rcomb '(1 2 3 4) 4)
+(test-rcomb '(1 2 3 4) 5)
+(test-rcomb '(1 2 3 4 5) 0)
+(test-rcomb '(1 2 3 4 5) 1)
+(test-rcomb '(1 2 3 4 5) 2)
+(test-rcomb '(1 2 3 4 5) 3)
+(test-rcomb '(1 2 3 4 5) 4)
+(test-rcomb '(1 2 3 4 5) 5)
+(test-rcomb '(1 2 3 4 5) 5)
+
+(test-rcomb "" 0)
+(test-rcomb "" 1)
+(test-rcomb "1" 0)
+(test-rcomb "1" 1)
+(test-rcomb "1" 2)
+(test-rcomb "12" 0)
+(test-rcomb "12" 1)
+(test-rcomb "12" 2)
+(test-rcomb "12" 3)
+(test-rcomb "123" 0)
+(test-rcomb "123" 1)
+(test-rcomb "123" 2)
+(test-rcomb "123" 3)
+(test-rcomb "123" 4)
+(test-rcomb "1234" 0)
+(test-rcomb "1234" 1)
+(test-rcomb "1234" 2)
+(test-rcomb "1234" 3)
+(test-rcomb "1234" 4)
+(test-rcomb "1234" 5)
+(test-rcomb "12345" 0)
+(test-rcomb "12345" 1)
+(test-rcomb "12345" 2)
+(test-rcomb "12345" 3)
+(test-rcomb "12345" 4)
+(test-rcomb "12345" 5)
+(test-rcomb "12345" 5)
+
+(mtest
+ (rcomb #() -1) :error
+ (rcomb #(1) -1) :error
+ (rcomb () -1) :error
+ (rcomb '(1) -1) :error
+ (rcomb "" -1) :error
+ (rcomb "a" -1) :error)
+
+(test-perm #() 0)
+(test-perm #() 1)
+(test-perm #(1) 0)
+(test-perm #(1) 1)
+(test-perm #(1) 2)
+(test-perm #(1 2) 0)
+(test-perm #(1 2) 1)
+(test-perm #(1 2) 2)
+(test-perm #(1 2) 3)
+(test-perm #(1 2 3) 0)
+(test-perm #(1 2 3) 1)
+(test-perm #(1 2 3) 2)
+(test-perm #(1 2 3) 3)
+(test-perm #(1 2 3) 4)
+(test-perm #(1 2 3 4) 0)
+(test-perm #(1 2 3 4) 1)
+(test-perm #(1 2 3 4) 2)
+(test-perm #(1 2 3 4) 3)
+(test-perm #(1 2 3 4) 4)
+(test-perm #(1 2 3 4) 5)
+(test-perm #(1 2 3 4 5) 0)
+(test-perm #(1 2 3 4 5) 1)
+(test-perm #(1 2 3 4 5) 2)
+(test-perm #(1 2 3 4 5) 3)
+(test-perm #(1 2 3 4 5) 4)
+(test-perm #(1 2 3 4 5) 5)
+(test-perm #(1 2 3 4 5) 5)
+
+(test-perm '() 0)
+(test-perm '() 1)
+(test-perm '(1) 0)
+(test-perm '(1) 1)
+(test-perm '(1) 2)
+(test-perm '(1 2) 0)
+(test-perm '(1 2) 1)
+(test-perm '(1 2) 2)
+(test-perm '(1 2) 3)
+(test-perm '(1 2 3) 0)
+(test-perm '(1 2 3) 1)
+(test-perm '(1 2 3) 2)
+(test-perm '(1 2 3) 3)
+(test-perm '(1 2 3) 4)
+(test-perm '(1 2 3 4) 0)
+(test-perm '(1 2 3 4) 1)
+(test-perm '(1 2 3 4) 2)
+(test-perm '(1 2 3 4) 3)
+(test-perm '(1 2 3 4) 4)
+(test-perm '(1 2 3 4) 5)
+(test-perm '(1 2 3 4 5) 0)
+(test-perm '(1 2 3 4 5) 1)
+(test-perm '(1 2 3 4 5) 2)
+(test-perm '(1 2 3 4 5) 3)
+(test-perm '(1 2 3 4 5) 4)
+(test-perm '(1 2 3 4 5) 5)
+(test-perm '(1 2 3 4 5) 5)
+
+(test-perm "" 0)
+(test-perm "" 1)
+(test-perm "1" 0)
+(test-perm "1" 1)
+(test-perm "1" 2)
+(test-perm "12" 0)
+(test-perm "12" 1)
+(test-perm "12" 2)
+(test-perm "12" 3)
+(test-perm "123" 0)
+(test-perm "123" 1)
+(test-perm "123" 2)
+(test-perm "123" 3)
+(test-perm "123" 4)
+(test-perm "1234" 0)
+(test-perm "1234" 1)
+(test-perm "1234" 2)
+(test-perm "1234" 3)
+(test-perm "1234" 4)
+(test-perm "1234" 5)
+(test-perm "12345" 0)
+(test-perm "12345" 1)
+(test-perm "12345" 2)
+(test-perm "12345" 3)
+(test-perm "12345" 4)
+(test-perm "12345" 5)
+(test-perm "12345" 5)
+
+(mtest
+ (perm #() -1) :error
+ (perm #(1) -1) :error
+ (perm () -1) :error
+ (perm '(1) -1) :error
+ (perm "" -1) :error
+ (perm "a" -1) :error)
+
+(test-rperm #() 0)
+(test-rperm #() 1)
+(test-rperm #(1) 0)
+(test-rperm #(1) 1)
+(test-rperm #(1) 2)
+(test-rperm #(1 2) 0)
+(test-rperm #(1 2) 1)
+(test-rperm #(1 2) 2)
+(test-rperm #(1 2) 3)
+(test-rperm #(1 2 3) 0)
+(test-rperm #(1 2 3) 1)
+(test-rperm #(1 2 3) 2)
+(test-rperm #(1 2 3) 3)
+(test-rperm #(1 2 3) 4)
+(test-rperm #(1 2 3 4) 0)
+(test-rperm #(1 2 3 4) 1)
+(test-rperm #(1 2 3 4) 2)
+(test-rperm #(1 2 3 4) 3)
+(test-rperm #(1 2 3 4) 4)
+(test-rperm #(1 2 3 4) 5)
+(test-rperm #(1 2 3 4 5) 0)
+(test-rperm #(1 2 3 4 5) 1)
+(test-rperm #(1 2 3 4 5) 2)
+(test-rperm #(1 2 3 4 5) 3)
+(test-rperm #(1 2 3 4 5) 4)
+(test-rperm #(1 2 3 4 5) 5)
+(test-rperm #(1 2 3 4 5) 5)
+
+(test-rperm '() 0)
+(test-rperm '() 1)
+(test-rperm '(1) 0)
+(test-rperm '(1) 1)
+(test-rperm '(1) 2)
+(test-rperm '(1 2) 0)
+(test-rperm '(1 2) 1)
+(test-rperm '(1 2) 2)
+(test-rperm '(1 2) 3)
+(test-rperm '(1 2 3) 0)
+(test-rperm '(1 2 3) 1)
+(test-rperm '(1 2 3) 2)
+(test-rperm '(1 2 3) 3)
+(test-rperm '(1 2 3) 4)
+(test-rperm '(1 2 3 4) 0)
+(test-rperm '(1 2 3 4) 1)
+(test-rperm '(1 2 3 4) 2)
+(test-rperm '(1 2 3 4) 3)
+(test-rperm '(1 2 3 4) 4)
+(test-rperm '(1 2 3 4) 5)
+(test-rperm '(1 2 3 4 5) 0)
+(test-rperm '(1 2 3 4 5) 1)
+(test-rperm '(1 2 3 4 5) 2)
+(test-rperm '(1 2 3 4 5) 3)
+(test-rperm '(1 2 3 4 5) 4)
+(test-rperm '(1 2 3 4 5) 5)
+(test-rperm '(1 2 3 4 5) 5)
+
+(test-rperm "" 0)
+(test-rperm "" 1)
+(test-rperm "1" 0)
+(test-rperm "1" 1)
+(test-rperm "1" 2)
+(test-rperm "12" 0)
+(test-rperm "12" 1)
+(test-rperm "12" 2)
+(test-rperm "12" 3)
+(test-rperm "123" 0)
+(test-rperm "123" 1)
+(test-rperm "123" 2)
+(test-rperm "123" 3)
+(test-rperm "123" 4)
+(test-rperm "1234" 0)
+(test-rperm "1234" 1)
+(test-rperm "1234" 2)
+(test-rperm "1234" 3)
+(test-rperm "1234" 4)
+(test-rperm "1234" 5)
+(test-rperm "12345" 0)
+(test-rperm "12345" 1)
+(test-rperm "12345" 2)
+(test-rperm "12345" 3)
+(test-rperm "12345" 4)
+(test-rperm "12345" 5)
+(test-rperm "12345" 5)
+
+(mtest
+ (rperm #() -1) :error
+ (rperm #(1) -1) :error
+ (rperm () -1) :error
+ (rperm '(1) -1) :error
+ (rperm "" -1) :error
+ (rperm "a" -1) :error)
+
+(mtest
+ (comb "a".."c" 2) (("a" "b") ("a" "c") ("b" "c"))
+ (rcomb "a".."c" 2) (("a" "a") ("a" "b") ("a" "c")
+ ("b" "b") ("b" "c") ("c" "c"))
+ (perm "a".."c" 2) (("a" "b") ("a" "c") ("b" "a")
+ ("b" "c") ("c" "a") ("c" "b"))
+ (rperm "a".."c" 2) (("a" "a") ("a" "b") ("a" "c")
+ ("b" "a") ("b" "b") ("b" "c")
+ ("c" "a") ("c" "b") ("c" "c")))
diff --git a/tests/015/esc.tl b/tests/015/esc.tl
new file mode 100644
index 00000000..cf3619c8
--- /dev/null
+++ b/tests/015/esc.tl
@@ -0,0 +1,39 @@
+(load "../common")
+
+(mtest
+ (str-esc "$*." "~" "") ""
+ (str-esc "$*." "~" "a") "a"
+ (str-esc "$*." "~" "~") "~"
+ (str-esc "$*." "~" "*") "~*"
+ (str-esc "$*." "~" ".") "~.")
+
+(mtest
+ (str-esc "$*." "~" "aa") "aa"
+ (str-esc "$*." "~" "a~") "a~"
+ (str-esc "$*." "~" "a$") "a~$"
+ (str-esc "$*." "~" "a*") "a~*"
+ (str-esc "$*." "~" "a.") "a~.")
+
+(mtest
+ (str-esc "$*." "~" "~a") "~a"
+ (str-esc "$*." "~" "$a") "~$a"
+ (str-esc "$*." "~" "*a") "~*a"
+ (str-esc "$*." "~" ".a") "~.a")
+
+(mtest
+ (str-esc "$*." "~" "a~b") "a~b"
+ (str-esc "$*." "~" "a$b") "a~$b"
+ (str-esc "$*." "~" "a*b") "a~*b"
+ (str-esc "$*." "~" "a.b") "a~.b")
+
+(mtest
+ (str-esc "$*." "~" "~a~") "~a~"
+ (str-esc "$*." "~" "$a$") "~$a~$"
+ (str-esc "$*." "~" "*a*") "~*a~*"
+ (str-esc "$*." "~" ".a.") "~.a~.")
+
+(test
+ (str-esc "$*." "~" "$*.a$*.b") "~$~*~.a~$~*~.b")
+
+(test
+ (str-esc "<>" "<" "(<<>>)") "(<<<<<><>)")
diff --git a/tests/015/lazy-str.tl b/tests/015/lazy-str.tl
new file mode 100644
index 00000000..bfcd6328
--- /dev/null
+++ b/tests/015/lazy-str.tl
@@ -0,0 +1,98 @@
+(load "../common")
+
+(defvarl words '#"the quick")
+
+(defvarl lz0 (lazy-str words))
+
+(test (lazy-str-get-trailing-list (copy lz0) 0) #"the quick")
+(test (lazy-str-get-trailing-list (copy lz0) 1) #"he quick")
+(test (lazy-str-get-trailing-list (copy lz0) 2) #"e quick")
+(test (lazy-str-get-trailing-list (copy lz0) 3) ("" . #"quick"))
+(test (lazy-str-get-trailing-list (copy lz0) 4) #"quick")
+(test (lazy-str-get-trailing-list (copy lz0) 5) #"uick")
+(test (lazy-str-get-trailing-list (copy lz0) 6) #"ick")
+(test (lazy-str-get-trailing-list (copy lz0) 7) #"ck")
+(test (lazy-str-get-trailing-list (copy lz0) 8) #"k")
+(test (lazy-str-get-trailing-list (copy lz0) 9) (""))
+(test (lazy-str-get-trailing-list (copy lz0) 10) ())
+(test (lazy-str-get-trailing-list (copy lz0) 11) ())
+
+(defvarl lz1 (lazy-str words ":"))
+
+(test (lazy-str-get-trailing-list (copy lz1) 0) #"the quick")
+(test (lazy-str-get-trailing-list (copy lz1) 1) #"he quick")
+(test (lazy-str-get-trailing-list (copy lz1) 2) #"e quick")
+(test (lazy-str-get-trailing-list (copy lz1) 3) ("" . #"quick"))
+(test (lazy-str-get-trailing-list (copy lz1) 4) #"quick")
+(test (lazy-str-get-trailing-list (copy lz1) 5) #"uick")
+(test (lazy-str-get-trailing-list (copy lz1) 6) #"ick")
+(test (lazy-str-get-trailing-list (copy lz1) 7) #"ck")
+(test (lazy-str-get-trailing-list (copy lz1) 8) #"k")
+(test (lazy-str-get-trailing-list (copy lz1) 9) (""))
+(test (lazy-str-get-trailing-list (copy lz1) 10) ())
+(test (lazy-str-get-trailing-list (copy lz1) 11) ())
+
+(test [(copy lz1) 0..0] "")
+(test [(copy lz1) 0..1] "t")
+(test [(copy lz1) 0..2] "th")
+(test [(copy lz1) 0..3] "the")
+(test [(copy lz1) 0..4] "the:")
+(test [(copy lz1) 0..5] "the:q")
+(test [(copy lz1) 0..6] "the:qu")
+(test [(copy lz1) 0..7] "the:qui")
+(test [(copy lz1) 0..8] "the:quic")
+(test [(copy lz1) 0..9] "the:quick")
+(test [(copy lz1) 0..10] "the:quick:")
+(test [(copy lz1) 0..11] "the:quick:")
+
+(defvarl lz2 (lazy-str '#"the quick brown fox" ":" 2))
+
+(test (lazy-str-get-trailing-list (copy lz2) 0) #"the quick brown fox")
+(test (lazy-str-get-trailing-list (copy lz2) 1) #"he quick brown fox")
+(test (lazy-str-get-trailing-list (copy lz2) 2) #"e quick brown fox")
+(test (lazy-str-get-trailing-list (copy lz2) 3) ("" . #"quick brown fox"))
+(test (lazy-str-get-trailing-list (copy lz2) 4) #"quick brown fox")
+(test (lazy-str-get-trailing-list (copy lz2) 5) #"uick brown fox")
+(test (lazy-str-get-trailing-list (copy lz2) 6) #"ick brown fox")
+(test (lazy-str-get-trailing-list (copy lz2) 7) #"ck brown fox")
+(test (lazy-str-get-trailing-list (copy lz2) 8) #"k brown fox")
+(test (lazy-str-get-trailing-list (copy lz2) 9) ("" . #"brown fox"))
+(test (lazy-str-get-trailing-list (copy lz2) 10) #"brown fox")
+(test (lazy-str-get-trailing-list (copy lz2) 11) #"brown fox")
+
+(test [(copy lz2) 0..0] "")
+(test [(copy lz2) 0..1] "t")
+(test [(copy lz2) 0..2] "th")
+(test [(copy lz2) 0..3] "the")
+(test [(copy lz2) 0..4] "the:")
+(test [(copy lz2) 0..5] "the:q")
+(test [(copy lz2) 0..6] "the:qu")
+(test [(copy lz2) 0..7] "the:qui")
+(test [(copy lz2) 0..8] "the:quic")
+(test [(copy lz2) 0..9] "the:quick")
+(test [(copy lz2) 0..10] "the:quick:")
+(test [(copy lz2) 0..11] "the:quick:")
+
+(defvarl lz3 (lazy-str words ""))
+
+(test (lazy-str-get-trailing-list (copy lz3) 0) #"t h e quick")
+(test (lazy-str-get-trailing-list (copy lz3) 1) #"h e quick")
+(test (lazy-str-get-trailing-list (copy lz3) 2) #"e quick")
+(test (lazy-str-get-trailing-list (copy lz3) 3) #"q u i c k")
+(test (lazy-str-get-trailing-list (copy lz3) 4) #"u i c k")
+(test (lazy-str-get-trailing-list (copy lz3) 5) #"i c k")
+(test (lazy-str-get-trailing-list (copy lz3) 6) #"c k")
+(test (lazy-str-get-trailing-list (copy lz3) 7) #"k")
+(test (lazy-str-get-trailing-list (copy lz3) 8) ())
+(test (lazy-str-get-trailing-list (copy lz3) 9) ())
+
+(test [(copy lz3) 0..0] "")
+(test [(copy lz3) 0..1] "t")
+(test [(copy lz3) 0..2] "th")
+(test [(copy lz3) 0..3] "the")
+(test [(copy lz3) 0..4] "theq")
+(test [(copy lz3) 0..5] "thequ")
+(test [(copy lz3) 0..6] "thequi")
+(test [(copy lz3) 0..7] "thequic")
+(test [(copy lz3) 0..8] "thequick")
+(test [(copy lz3) 0..9] "thequick")
diff --git a/tests/015/match-str.tl b/tests/015/match-str.tl
new file mode 100644
index 00000000..2ce34b8f
--- /dev/null
+++ b/tests/015/match-str.tl
@@ -0,0 +1,69 @@
+(load "../common")
+
+(defun lz (str)
+ (lazy-str (spl "" str) ""))
+
+(defun lz* (str)
+ (lazy-str (append (spl "" str) 42) ""))
+
+(mtest
+ (match-str "" "") 0
+ (match-str "a" "a") 1
+ (match-str "a" "") 0
+ (match-str "a" "" 1) 1
+ (match-str "a" "" 2) nil
+ (match-str "abc" "c" 2) 3
+ (match-str "abc" "b" 1) 2
+ (match-str "abc" "a" 0) 1
+ (match-str "abc" "b" 2) nil
+ (match-str "abc" "a" 1) nil
+ (match-str "abc" "c" 0) nil
+ (match-str "abc" "c" 3) nil
+ (match-str "abc" "c" 4) nil
+ (match-str "abc" "abcd") nil)
+
+(mtest
+ (match-str (lz* "abc#") "c" 2) 3
+ (match-str "abc#" (lz "c") 2) 3
+ (match-str (lz* "abc#") (lz "c") 2) 3
+ (match-str (lz "abc") (lz "c") 2) 3
+ (match-str (lz "abc") (lz "b") 1) 2
+ (match-str (lz "abc") (lz "a") 0) 1
+ (match-str (lz "abc") (lz "b") 2) nil
+ (match-str (lz "abc") (lz "a") 1) nil
+ (match-str (lz "abc") (lz "c") 0) nil
+ (match-str (lz "abc") (lz "c") 3) nil
+ (match-str (lz "abc") (lz "c") 4) nil
+ (match-str (lz "abc") (lz "abcd")) nil)
+
+(mtest
+ (match-str "" "" -1) nil
+ (match-str "a" "" -1) 1
+ (match-str "a" "a" -1) 0
+ (match-str "ab" "a" -1) nil
+ (match-str "ab" "a" -2) 0
+ (match-str "abc" "abc" -1) 0
+ (match-str "abc" "c" -1) 2
+ (match-str "abc" "b" -2) 1
+ (match-str "abc" "a" -3) 0
+ (match-str "abc" "a" -4) nil
+ (match-str "abcd" "cd" -1) 2
+ (match-str "abcd" "bc" -2) 1
+ (match-str "abcd" "ab" -3) 0
+ (match-str "abcd" "ab" -4) nil
+ (match-str "abcd" "ab" -5) nil
+ (match-str (lz "abcd") "cd" -1) 2
+ (match-str (lz "abcd") "bc" -2) 1
+ (match-str (lz "abcd") "ab" -3) 0
+ (match-str (lz "abcd") "ab" -4) nil
+ (match-str (lz "abcd") "ab" -5) nil
+ (match-str "abcd" (lz "cd") -1) 2
+ (match-str "abcd" (lz "bc") -2) 1
+ (match-str "abcd" (lz "ab") -3) 0
+ (match-str "abcd" (lz "ab") -4) nil
+ (match-str "abcd" (lz "ab") -5) nil
+ (match-str (lz "abcd") (lz "cd") -1) 2
+ (match-str (lz "abcd") (lz "bc") -2) 1
+ (match-str (lz "abcd") (lz "ab") -3) 0
+ (match-str (lz "abcd") (lz "ab") -4) nil
+ (match-str (lz "abcd") (lz "ab") -5) nil)
diff --git a/tests/015/split.expected b/tests/015/split.expected
deleted file mode 100644
index e69de29b..00000000
--- a/tests/015/split.expected
+++ /dev/null
diff --git a/tests/015/split.tl b/tests/015/split.tl
index ae77a642..1cb13647 100644
--- a/tests/015/split.tl
+++ b/tests/015/split.tl
@@ -194,3 +194,120 @@
(mtest
(tok-str "abcacabcac" #/ab?/) #"ab a ab a"
(tok-str "abcacabcac" #/ab?/ t) ("" "ab" "c" "a" "c" "ab" "c" "a" "c"))
+
+(mtest
+ (tok-str "" #/[^,]/ : 0) ()
+ (tok-str "a,b,c" #/[^,]/ : 0) ("a,b,c")
+ (tok-str "a,b,c" #/[^,]/ : 1) ("a" ",b,c")
+ (tok-str "a,b,c" #/[^,]/ : 2) ("a" "b" ",c")
+ (tok-str "a,b,c" #/[^,]/ : 3) #"a b c"
+ (tok-str "a,b,c" #/[^,]/ : 4) #"a b c")
+
+(mtest
+ (tok-str "a,b,c" #/[^,]/ t 0) ("a,b,c")
+ (tok-str "a,b,c" #/[^,]/ t 1) ("" "a" ",b,c")
+ (tok-str "a,b,c" #/[^,]/ t 2) ("" "a" "," "b" ",c")
+ (tok-str "a,b,c" #/[^,]/ t 3) ("" "a" "," "b" "," "c" "")
+ (tok-str "a,b,c" #/[^,]/ t 4) ("" "a" "," "b" "," "c" ""))
+
+(mtest
+ (tok #/[^,]/ "a,b,c") #"a b c"
+ (tokn : #/[^,]/ "a,b,c") :error
+ (tokn nil #/[^,]/ "a,b,c") :error
+ (tokn 0 #/[^,]/ "a,b,c") ("a,b,c")
+ (tokn 1 #/[^,]/ "a,b,c") ("a" ",b,c")
+ (tokn 2 #/[^,]/ "a,b,c") ("a" "b" ",c")
+ (tokn 3 #/[^,]/ "a,b,c") ("a" "b" "c")
+ (tokn 4 #/[^,]/ "a,b,c") ("a" "b" "c"))
+
+(mtest
+ (tokn 0 #/[^,]/ t "a,b,c") ("a,b,c")
+ (tokn 1 #/[^,]/ t "a,b,c") ("" "a" ",b,c")
+ (tokn 2 #/[^,]/ t "a,b,c") ("" "a" "," "b" ",c")
+ (tokn 3 #/[^,]/ t "a,b,c") ("" "a" "," "b" "," "c" "")
+ (tokn 4 #/[^,]/ t "a,b,c") ("" "a" "," "b" "," "c" ""))
+
+(mtest
+ (join) ""
+ (join "") ""
+ (join "" "") ""
+ (join #\a) "a"
+ (join "a") "a"
+ (join #\a "b") "ab"
+ (join "a" #\b) "ab"
+ (join #\a #\b) "ab"
+ (join "a" "b") "ab"
+ (join "a" "b" "cde") "abcde")
+
+(mtest
+ (join-with #\a) ""
+ (join-with #\a #\b) "b"
+ (join-with #\a "b") "b"
+ (join-with "a") ""
+ (join-with "a" #\b) "b"
+ (join-with "a" "b") "b"
+ (join-with "a" "b") "b"
+ (join-with "--" "b" "c" "d") "b--c--d"
+ (join-with #\- "b" "c" "d") "b-c-d")
+
+(mtest
+ (split-str "abc" "" : 0) ("abc")
+ (split-str "abc" "" : 1) ("a" "bc")
+ (split-str "abc" "" : 2) ("a" "b" "c")
+ (split-str "abc" "" : 3) ("a" "b" "c")
+ (split-str "abc" "" : -1) :error)
+
+(mtest
+ (split-str "abc" "" t 0) ("abc")
+ (split-str "abc" "" t 1) ("a" "" "bc")
+ (split-str "abc" "" t 2) ("a" "" "b" "" "c")
+ (split-str "abc" "" t 3) ("a" "" "b" "" "c"))
+
+(mtest
+ (split-str "a,b,c" "," : 0) ("a,b,c")
+ (split-str "a,b,c" "," : 1) ("a" "b,c")
+ (split-str "a,b,c" "," : 2) ("a" "b" "c")
+ (split-str "a,b,c" "," : 3) ("a" "b" "c"))
+
+(mtest
+ (split-str "a,b,c" "," t 0) ("a,b,c")
+ (split-str "a,b,c" "," t 1) ("a" "," "b,c")
+ (split-str "a,b,c" "," t 2) ("a" "," "b" "," "c")
+ (split-str "a,b,c" "," t 3) ("a" "," "b" "," "c"))
+
+(mtest
+ (split-str "a12b34c567d" #/[0-9]+/ : 0) ("a12b34c567d")
+ (split-str "a12b34c567d" #/[0-9]+/ : 1) ("a" "b34c567d")
+ (split-str "a12b34c567d" #/[0-9]+/ : 2) ("a" "b" "c567d")
+ (split-str "a12b34c567d" #/[0-9]+/ : 3) ("a" "b" "c" "d")
+ (split-str "a12b34c567d" #/[0-9]+/ : 4) ("a" "b" "c" "d"))
+
+(mtest
+ (split-str "a12b34c567d" #/[0-9]+/ t 0) ("a12b34c567d")
+ (split-str "a12b34c567d" #/[0-9]+/ t 1) ("a" "12" "b34c567d")
+ (split-str "a12b34c567d" #/[0-9]+/ t 2) ("a" "12" "b" "34" "c567d")
+ (split-str "a12b34c567d" #/[0-9]+/ t 3) ("a" "12" "b" "34" "c" "567" "d")
+ (split-str "a12b34c567d" #/[0-9]+/ t 4) ("a" "12" "b" "34" "c" "567" "d"))
+
+(mtest
+ (spl "," "a,b,c") #"a b c"
+ (spln : "," "a,b,c") :error
+ (spln nil "," "a,b,c") :error
+ (spln 0 "," "a,b,c") ("a,b,c")
+ (spln 1 "," "a,b,c") ("a" "b,c")
+ (spln 2 "," "a,b,c") ("a" "b" "c")
+ (spln 3 "," "a,b,c") ("a" "b" "c")
+ (spln 4 "," "a,b,c") ("a" "b" "c"))
+
+(mtest
+ (cat-str '()) ""
+ (cat-str '() "-") ""
+ (cat-str '(()) "-") ""
+ (cat-str '((()) ()) "-") ""
+ (cat-str '((()) #()) "-") ""
+ (cat-str '((("a" ("b")) #(#\c))) "-") "a-b-c")
+
+(mtest
+ (join-with "--" '()) ""
+ (join-with "--" '(("b"))) "b"
+ (join-with "--" '("b" #(("c") ()) "d")) "b--c--d")
diff --git a/tests/015/str.tl b/tests/015/str.tl
new file mode 100644
index 00000000..c0d8dc58
--- /dev/null
+++ b/tests/015/str.tl
@@ -0,0 +1,28 @@
+(load "../common")
+
+(mtest
+ (str "x") :error
+ (str 0) ""
+ (str 0 5) :error
+ (str 0 "abcd") ""
+ (str 0 "") ""
+ (str 0 #\x) ""
+ (str -1) :error
+ (str -1 #\x) :error
+ (str -1 "") :error
+ (str -1 "abc") :error)
+
+(mtest
+ (str 10) " "
+ (str 10 "") " "
+ (str 10 #\a) "aaaaaaaaaa"
+ (str 10 "a") "aaaaaaaaaa"
+ (str 10 "ab") "ababababab"
+ (str 10 "abc") "abcabcabca"
+ (str 10 "abcd") "abcdabcdab"
+ (str 10 "abcde") "abcdeabcde"
+ (str 10 "abcdef") "abcdefabcd"
+ (str 10 "abcdefghij") "abcdefghij"
+ (str 10 "abcdefghijk") "abcdefghij"
+ (str 10 "abcdefghijklmnopqrst") "abcdefghij"
+ (str 10 "abcdefghijklmnopqrstuvwxyz") "abcdefghij")
diff --git a/tests/015/trie.tl b/tests/015/trie.tl
new file mode 100644
index 00000000..c145c060
--- /dev/null
+++ b/tests/015/trie.tl
@@ -0,0 +1,58 @@
+(load "../common")
+
+(defvarl tr0 (make-trie))
+(defvarl tr1 (make-trie))
+
+(defvarl dat ; '#"aaa aab aac aba abb abc caa cab cac")
+ '("2" "3" "5" "7" "11" "13" "17" "19" "23" "29" "31" "37" "41"
+ "43" "47" "53" "59" "61" "67" "71" "73" "79" "83" "89" "97" "101"
+ "103" "107" "109" "113" "127" "131" "137" "139" "149" "151" "157"
+ "163" "167" "173" "179" "181" "191" "193" "197" "199" "211" "223"
+ "227" "229" "233" "239" "241" "251" "257" "263" "269" "271" "277"
+ "281" "283" "293" "307" "311" "313" "317" "331" "337" "347" "349"
+ "353" "359" "367" "373" "379" "383" "389" "397" "401" "409" "419"
+ "421" "431" "433" "439" "443" "449" "457" "461" "463" "467" "479"
+ "487" "491" "499" "503" "509" "521" "523" "541" "547" "557" "563"
+ "569" "571" "577" "587" "593" "599" "601" "607" "613" "617" "619"
+ "631" "641" "643" "647" "653" "659" "661" "673" "677" "683" "691"
+ "701" "709" "719" "727" "733" "739" "743" "751" "757" "761" "769"
+ "773" "787" "797" "809" "811" "821" "823" "827" "829" "839" "853"
+ "857" "859" "863" "877" "881" "883" "887" "907" "911" "919" "929"
+ "937" "941" "947" "953" "967" "971" "977" "983" "991" "997"))
+
+(defvarl enu [mapcar tostring (range* 0 (len dat))])
+(defvarl ndt [mapcar (op mapcar (op + 64)) dat])
+(defvarl fdt [mapcar (ret `x@{1}y`) dat])
+(defvarl fen [mapcar (ret `x@{1}y`) enu])
+
+(each ((d dat)
+ (n enu))
+ (trie-add tr0 d n)
+ (trie-add tr1 d n))
+
+(trie-compress tr1)
+
+(defvarl rx0 (regex-compile (regex-from-trie tr0)))
+(defvarl rx1 (regex-compile (regex-from-trie tr1)))
+
+(mvtest
+ (build (each ((d dat)) (add (filter-string-tree tr0 d)))) enu
+ (build (each ((x ndt)) (add (filter-string-tree tr0 x)))) ndt
+ (build (each ((f fdt)) (add (filter-string-tree tr0 f)))) fen)
+
+(mvtest
+ (build (each ((d dat)) (add (filter-string-tree tr1 d)))) enu
+ (build (each ((x ndt)) (add (filter-string-tree tr1 x)))) ndt
+ (build (each ((f fdt)) (add (filter-string-tree tr1 f)))) fen)
+
+(mvtest
+ (build (each ((d dat)) (add [rx0 d]))) dat
+ (build (each ((n ndt)) (add [rx0 n]))) (repeat '(nil) (len dat)))
+
+(mvtest
+ (build (each ((d dat)) (add [rx1 d]))) dat
+ (build (each ((n ndt)) (add [rx1 n]))) (repeat '(nil) (len dat)))
+
+(mtest
+ (regex-from-trie (make-trie)) t
+ (regex-from-trie (trie-compress (make-trie))) t)
diff --git a/tests/015/trim.tl b/tests/015/trim.tl
new file mode 100644
index 00000000..da1fc0c1
--- /dev/null
+++ b/tests/015/trim.tl
@@ -0,0 +1,41 @@
+(load "../common")
+
+(mtest
+ (trim-left "" "") ""
+ (trim-left 1 "") :error
+ (trim-left "" 1) :error
+ (trim-left 1 1) :error)
+
+(mtest
+ (trim-left "" "abc") "abc"
+ (trim-left "a" "abc") "bc"
+ (trim-left "ab" "abc") "c"
+ (trim-left "abc" "abc") ""
+ (trim-left "abcd" "abc") "abc"
+ (trim-left "z" "abc") "abc")
+
+(mtest
+ (trim-left #// "abc") "abc"
+ (trim-left #/./ "abc") "bc"
+ (trim-left #/../ "abc") "c"
+ (trim-left #/.../ "abc") ""
+ (trim-left #/.*/ "abc") ""
+ (trim-left #/..../ "abc") "abc"
+ (trim-left #/z/ "abc") "abc")
+
+(mtest
+ (trim-right "" "abc") "abc"
+ (trim-right "c" "abc") "ab"
+ (trim-right "bc" "abc") "a"
+ (trim-right "abc" "abc") ""
+ (trim-right "xabc" "abc") "abc"
+ (trim-right "z" "abc") "abc")
+
+(mtest
+ (trim-right #// "abc") "abc"
+ (trim-right #/./ "abc") "ab"
+ (trim-right #/../ "abc") "a"
+ (trim-right #/.../ "abc") ""
+ (trim-right #/.*/ "abc") ""
+ (trim-right #/..../ "abc") "abc"
+ (trim-right #/z/ "abc") "abc")
diff --git a/tests/016/arith.expected b/tests/016/arith.expected
deleted file mode 100644
index e69de29b..00000000
--- a/tests/016/arith.expected
+++ /dev/null
diff --git a/tests/016/arith.tl b/tests/016/arith.tl
index 6a99b24a..d67b9908 100644
--- a/tests/016/arith.tl
+++ b/tests/016/arith.tl
@@ -71,3 +71,344 @@
(test [apply bracket '(15 10 20 30)] 1)
(test [apply bracket '(25 10 20 30)] 2)
(test [apply bracket '(30 10 20 30)] 3)
+
+(test (typeof fixnum-max) fixnum)
+(test (typeof (succ fixnum-max)) bignum)
+(test (typeof fixnum-min) fixnum)
+(test (typeof (pred fixnum-min)) bignum)
+
+(test (< fixnum-min fixnum-max) t)
+(test (< (pred fixnum-min) fixnum-min) t)
+(test (> (succ fixnum-max) fixnum-max) t)
+
+(test (ffi-put #xA5 (ffi le-int16))
+ #b'A500')
+(test (ffi-put #xA5 (ffi be-int16))
+ #b'00A5')
+(test (mequal (ffi-put #xA5 (ffi int16))
+ #b'A500'
+ #b'00A5') t)
+
+(test (ffi-put #xAABBCC (ffi le-int32))
+ #b'CCBBAA00')
+(test (ffi-put #xAABBCC (ffi be-int32))
+ #b'00AABBCC')
+(test (mequal (ffi-put #xAABBCC (ffi int32))
+ #b'CCBBAA00'
+ #b'00AABBCC') t)
+
+(test (ffi-put #xAABBCCDDEE (ffi le-int64))
+ #b'EEDDCCBBAA000000')
+(test (ffi-put #xAABBCCDDEE (ffi be-int64))
+ #b'000000AABBCCDDEE')
+(test (mequal (ffi-put #xAABBCCDDEE (ffi int64))
+ #b'EEDDCCBBAA000000'
+ #b'000000AABBCCDDEE') t)
+
+(test (ffi-get #b'A500' (ffi le-int16))
+ #xA5)
+(test (ffi-get #b'00A5' (ffi be-int16))
+ #xA5)
+
+
+(test (ffi-get #b'CCBBAA00' (ffi le-int32))
+ #xAABBCC)
+(test (ffi-get #b'00AABBCC' (ffi be-int32))
+ #xAABBCC)
+
+
+(test (ffi-get #b'EEDDCCBBAA000000' (ffi le-int64))
+ #xAABBCCDDEE)
+(test (ffi-get #b'000000AABBCCDDEE' (ffi be-int64))
+ #xAABBCCDDEE)
+
+(test (mequal (ffi-put #x-8000 (ffi int16))
+ #b'0080'
+ #b'8000') t)
+
+(test (ffi-get (ffi-put #x-8000 (ffi int16)) (ffi int16))
+ #x-8000)
+
+(test (mequal (ffi-put #x-80000000 (ffi int32))
+ #b'00000080'
+ #b'80000000') t)
+
+(test (ffi-get (ffi-put #x-80000000 (ffi int32)) (ffi int32))
+ #x-80000000)
+
+(test (mequal (ffi-put #x-8000000000000000 (ffi int64))
+ #b'0000000000000080'
+ #b'8000000000000000') t)
+
+(test (ffi-get (ffi-put #x-8000000000000000 (ffi int64)) (ffi int64))
+ #x-8000000000000000)
+
+(mtest
+ (sum #()) 0
+ (sum #(1)) 1
+ (sum #(1 2)) 3
+ (sum #(1 2 3)) 6
+ (sum #() (op * 10)) 0
+ (sum #(1) (op * 10)) 10
+ (sum #(1 2) (op * 10)) 30
+ (sum #(1 2 3) (op * 10)) 60
+ (sum 1..10) 45
+ (sum 2..10) 44)
+
+(mtest
+ (prod #()) 1
+ (prod #(1)) 1
+ (prod #(1 2)) 2
+ (prod #(1 2 3)) 6
+ (prod #() (op * 10)) 1
+ (prod #(1) (op * 10)) 10
+ (prod #(1 2) (op * 10)) 200
+ (prod #(1 2 3) (op * 10)) 6000
+ (prod 2..8) 5040
+ (prod 3..8) 2520)
+
+(mtest
+ (< 1 2) t
+ (< 2 1) nil
+ (< 1.0 2) t
+ (< 2 1.0) nil
+ (< #\c #\d) t
+ (< #\d #\c) nil
+ (< 1.0 1) nil
+ (< #R(0 0) #R(0 0)) nil
+ (< #R(0 0) #R(0 1)) t
+ (< #R(0 0) #R(1 0)) t
+ (< #R(0 0) #R(1 1)) t
+ (< #R(1 0) #R(1 0)) nil
+ (< #R(1 0) #R(1 1)) t
+ (< 1 #R(1 0)) :error
+ (< #R(1 0) 1) :error
+ (< 1.0 #R(1 0)) :error
+ (< #R(1 0) 1.0) :error
+ (< #\c #R(1 0)) :error
+ (< #R(1 0) #\c) :error
+ (< 1 "abc") :error
+ (< "abc" 1) :error
+ (< 1 nil) :error
+ (< nil 1) :error
+ (< 1 '(1 2 3)) :error
+ (< '(1 2 3) 1) :error
+ (< 1 #(1 2 3)) :error
+ (< #(1 2 3) 1) :error)
+
+(mtest
+ (< #\A 66 67.0) t
+ (> 67.0 66 #\A) t
+ (>= #\A 65.0 65) t)
+
+(mtest
+ (< "abc" "abc") nil
+ (<= "abc" "abc") t
+ (< "abc" "abcd") t
+ (< "abc" "abd") t
+ (< #(1 2 3) #(1 2 3)) nil
+ (< #(1 2 3) #(1 2 3.0)) nil
+ (< #(1 2 3) #(1 2 3 4)) t
+ (< #(1 2 3) #(1 2 4)) t
+ (< #(1 2 3) '(1 2 3)) nil
+ (< #(1 2 3) '(1 2 3.0)) nil
+ (< #(1 2 3) '(1 2 3 4)) t
+ (< #(1 2 3) '(1 2 4)) t
+ (< '(1 2 3) '(1 2 3)) nil
+ (< '(1 2 3) '(1 2 3.0)) nil
+ (< '(1 2 3) '(1 2 3 4)) t
+ (< '(1 2 3) '(1 2 4)) t
+ (< '(1 2 3) #(1 2 3)) nil
+ (< '(1 2 3) #(1 2 3.0)) nil
+ (< '(1 2 3) #(1 2 3 4)) t
+ (< '(1 2 3) #(1 2 4)) t)
+
+(let ((*print-flo-precision* 14))
+ (sstest
+ (let ((q (quantile 0.5)))
+ [q 0.02 0.5 0.74 3.39 0.83]
+ [mapcar q '(22.37 10.15 15.43 38.62 15.92
+ 34.60 10.28 1.47 0.40 0.05 11.39
+ 0.27 0.42 0.09 11.37)])
+ (0.74 0.74 2.0616666666667 4.5517592592593 4.5517592592593 9.1519618055556
+ 9.1519618055556 9.1519618055556 9.1519618055556 6.1797614914021
+ 6.1797614914021 6.1797614914021 6.1797614914021 4.2462394088036
+ 4.2462394088036)))
+
+(test
+ (let ((q (quantile 0)))
+ (cons [q] [mapcar q '(1 2 3 4 5)]))
+ (0.0 1.0 1.5 2.0 2.5 3.0))
+
+(test
+ (let ((q (quantile 0 5 0.5)))
+ [mapcar q '(1.0 2.0 3.0 4.0 5.0
+ 0.0 0.0 0.0 0.0 0.0)])
+ (1.0 1.5 2.0 2.5 3.0
+ 1.5 0.75 0.375 0.1875 0.09375))
+
+(test
+ (let ((q (quantile 0 5 0.5)))
+ [mapcar q '(0.0 0.0 0.0 0.0 0.0
+ 3.0 3.0 3.0 3.0 3.0)])
+ (0.0 0.0 0.0 0.0 0.0
+ 1.5 2.25 2.625 2.8125 2.90625))
+
+(mtest
+ (sum-each ())
+ 0
+ (sum-each ((x nil)))
+ 0
+ (sum-each ((x '(1 2 3))
+ (y '(4 5 6)))
+ (* x y))
+ 32
+ (mul-each ())
+ 1
+ (mul-each ((x nil)))
+ 1
+ (mul-each ((x '(1 2 3))
+ (y '(4 5 6)))
+ (+ x y))
+ 315
+ (sum-each* ((x '(1 2 3))
+ (y (cdr x)))
+ (* x y))
+ 8
+ (mul-each* ((x '(1 2 3))
+ (y (cdr x)))
+ (+ x y))
+ 15
+ (sum-each ((x '(1 2 3))
+ (y (cdr x)))
+ (* x y))
+ :error
+ (mul-each ((x '(1 2 3))
+ (y (cdr x)))
+ (+ x y))
+ :error)
+
+(mtest
+ (sum-each-prod ())
+ 0
+ (sum-each-prod ((x nil)))
+ 0
+ (sum-each-prod ((x '(4))) x)
+ 4
+ (sum-each-prod ((x '(1 2 3))
+ (y '(4 3 2)))
+ (* x y))
+ 54
+ (sum-each-prod* ((x '(1 2 3 4))
+ (y (cdr x)))
+ (* x y))
+ 90
+ (sum-each-prod ((x '(1 2 3 4))
+ (y (cdr x)))
+ (* x y))
+ :error)
+
+(mvtest
+ (mul-each-prod ())
+ 1
+ (mul-each-prod ((x nil)))
+ 1
+ (mul-each-prod ((x '(4))) x)
+ 4
+ (mul-each-prod ((x '(1 2 3))
+ (y '(4 3 2)))
+ (+ x y))
+ (* (+ 1 4) (+ 1 3) (+ 1 2)
+ (+ 2 4) (+ 2 3) (+ 2 2)
+ (+ 3 4) (+ 3 3) (+ 3 2))
+ (mul-each-prod* ((x '(1 2 3))
+ (y (cdr x)))
+ (+ x y))
+ (* (+ 1 2) (+ 1 3)
+ (+ 2 2) (+ 2 3)
+ (+ 3 2) (+ 3 3))
+ (sum-each-prod ((x '(1 2 3))
+ (y (cdr x)))
+ (* x y))
+ :error)
+
+(mtest
+ (each-true ()) t
+ (each-true ((a ()))) t
+ (each-true ((a ())) nil) t
+ (each-true ((a '(1 2 3))) a) 3
+ (each-true ((a '(nil 2 3))) a) nil
+ (each-true ((a '(1 2 3)) (b '(4 5 6))) (< a b)) t
+ (each-true ((a '(1 2 3)) (b '(4 0 6))) (< a b)) nil)
+
+(mtest
+ (some-true ()) nil
+ (some-true ((a ()))) nil
+ (some-true ((a ())) nil) nil
+ (some-true ((a '(1 2 3))) a) 1
+ (some-true ((a '(nil 2 3))) a) 2
+ (some-true ((a '(nil nil nil))) a) nil
+ (some-true ((a '(1 2 3)) (b '(4 5 6))) (< a b)) t
+ (some-true ((a '(1 2 3)) (b '(4 0 6))) (< a b)) t
+ (some-true ((a '(1 2 3)) (b '(0 1 2))) (< a b)) nil)
+
+(mtest
+ (each-false ()) t
+ (each-false ((a ()))) t
+ (each-false ((a ())) t) t
+ (each-false ((a '(1 2 3))) a) nil
+ (each-false ((a '(nil))) a) t
+ (each-false ((a '(nil nil))) a) t
+ (each-false ((a '(1 2 3)) (b '(4 5 6))) (> a b)) t
+ (each-false ((a '(1 2 3)) (b '(4 0 6))) (> a b)) nil)
+
+(mtest
+ (some-false ()) nil
+ (some-false ((a ()))) nil
+ (some-false ((a ())) nil) nil
+ (some-false ((a '(1 2 3))) a) nil
+ (some-false ((a '(nil 2 3))) a) t
+ (some-false ((a '(nil nil nil))) a) t
+ (some-false ((a '(1 2 3)) (b '(4 5 6))) (> a b)) t
+ (some-false ((a '(1 2 3)) (b '(4 0 6))) (> a b)) t
+ (some-false ((a '(1 2 3)) (b '(0 1 2))) (> a b)) nil)
+
+
+(mvtest
+ (gcd 0 0) 0
+ (gcd 0 1) 1
+ (gcd 1 0) 1
+ (gcd 100 0) 100
+ (gcd 0 100) 100
+ (gcd 0 (expt 10 60)) (expt 10 60)
+ (gcd (expt 10 60) 0) (expt 10 60))
+
+(defun power-set (s)
+ (mappend* (op comb s) (range 0 (len s))))
+
+(defun gcd-grind (primes)
+ (each-prod ((lp (cdr (power-set primes)))
+ (rp (cdr (power-set primes))))
+ (let ((ip (isec lp rp)))
+ (vtest (gcd (* . lp) (* . rp)) (* . ip)))))
+
+(each ((x 0..64)
+ (y 0..64))
+ (vtest (gcd (ash 1 x) (ash 1 y)) (ash 1 (min x y)))
+ (vtest (gcd (ash 3 x) (ash 5 y)) (ash 1 (min x y)))
+ (vtest (gcd (ash 6 x) (ash 15 y)) (ash 3 (min x y))))
+
+(gcd-grind '(2 3 5 7 11 13 17 19 23))
+
+(gcd-grind '(2 3 5 4294967291 4294967311 4294967357 4294967371))
+
+(test
+ (build (each-prod* ((i '(b c)) (j (cons 'a i))) (add (list i j))))
+ ((b a) (b b) (b c) (c a) (c b) (c c)))
+
+(mtest
+ (arithp #\a) t
+ (arithp 42) t
+ (arithp 3.14) t
+ (arithp (expt 2 200)) t
+ (arithp #R(nil nil)) t)
diff --git a/tests/016/conv.tl b/tests/016/conv.tl
new file mode 100644
index 00000000..34f5b7c7
--- /dev/null
+++ b/tests/016/conv.tl
@@ -0,0 +1,50 @@
+(load "../common.tl")
+
+(each ((b 2..36))
+ (mtest
+ (int-str "" b) nil
+ (int-str "$" b) nil
+ (int-str "-" b) nil
+ (int-str "+" b) nil
+ (int-str "0" b) 0
+ (int-str "00" b) 0
+ (int-str "0x" b) 0
+ (int-str "0x3" b) 0
+ (int-str "0xz" b) 0))
+
+(mtest
+ (int-str "+123") 123
+ (int-str "-123") -123
+ (int-str "0123") 123
+ (int-str "00123") 123
+ (int-str "999999999999999999999999999999") 999999999999999999999999999999
+ (int-str "+999999999999999999999999999999") 999999999999999999999999999999
+ (int-str "-999999999999999999999999999999") -999999999999999999999999999999)
+
+(let ((c #\c))
+ (mtest
+ (int-str "+123" c) 123
+ (int-str "-123" c) -123
+ (int-str "0123" c) 83
+ (int-str "00123" c) 83
+ (int-str "0x123" c) 291
+ (int-str "-0x123" c) -291
+ (int-str "+0xFFFFFFFFFFFFFFFFFFFF" c) #xFFFFFFFFFFFFFFFFFFFF
+ (int-str "-0xFFFFFFFFFFFFFFFFFFFF" c) #x-FFFFFFFFFFFFFFFFFFFF))
+
+(mtest
+ (int-str "zZz" 35) nil
+ (int-str "zZz" 36) 46655
+ (int-str "-zZz" 36) -46655
+ (int-str "+zZz" 36) 46655
+ (int-str "+0zZz" 36) 46655
+ (int-str "-0zZz" 36) -46655
+ (int-str "0zZz" 36) 46655
+ (int-str "1" 36) 1
+ (int-str "10" 36) 36
+ (int-str "100" 36) 1296
+ (int-str "zzzzzzzzzzzzzzzzzzzzzzzz" 36) 22452257707354557240087211123792674815
+ (int-str "-zzzzzzzzzzzzzzzzzzzzzzzz" 36) -22452257707354557240087211123792674815
+ (int-str "0zzzzzzzzzzzzzzzzzzzzzzzz" 36) 22452257707354557240087211123792674815
+ (int-str "-0zzzzzzzzzzzzzzzzzzzzzzzz" 36) -22452257707354557240087211123792674815
+ (int-str "+0zzzzzzzzzzzzzzzzzzzzzzzz" 36) 22452257707354557240087211123792674815)
diff --git a/tests/016/ud-arith.expected b/tests/016/ud-arith.expected
deleted file mode 100644
index e69de29b..00000000
--- a/tests/016/ud-arith.expected
+++ /dev/null
diff --git a/tests/016/ud-arith.tl b/tests/016/ud-arith.tl
index 052fcaed..8a8e50df 100644
--- a/tests/016/ud-arith.tl
+++ b/tests/016/ud-arith.tl
@@ -65,7 +65,53 @@
(:method ash (me arg) ^(ash ,me.v ,arg))
(:method bit (me arg) ^(bit ,me.v ,arg))
(:method width (me) ^(width ,me.v))
- (:method logcount (me) ^(logcount ,me.v)))
+ (:method logcount (me) ^(logcount ,me.v))
+ (:method cbrt (me) ^(cbrt ,me.v))
+ (:method erf (me) ^(erf ,me.v))
+ (:method erfc (me) ^(erfc ,me.v))
+ (:method exp10 (me) ^(exp10 ,me.v))
+ (:method exp2 (me) ^(exp2 ,me.v))
+ (:method expm1 (me) ^(expm1 ,me.v))
+ (:method gamma (me) ^(gamma ,me.v))
+ (:method j0 (me) ^(j0 ,me.v))
+ (:method j1 (me) ^(j1 ,me.v))
+ (:method lgamma (me) ^(lgamma ,me.v))
+ (:method log1p (me) ^(log1p ,me.v))
+ (:method logb (me) ^(logb ,me.v))
+ (:method nearbyint (me) ^(nearbyint ,me.v))
+ (:method rint (me) ^(rint ,me.v))
+ (:method significand (me) ^(significand ,me.v))
+ (:method tgamma (me) ^(tgamma ,me.v))
+ (:method y0 (me) ^(y0 ,me.v))
+ (:method y1 (me) ^(y1 ,me.v))
+ (:method copysign (me arg) ^(copysign ,me.v ,arg))
+ (:method drem (me arg) ^(drem ,me.v ,arg))
+ (:method fdim (me arg) ^(fdim ,me.v ,arg))
+ (:method fmax (me arg) ^(fmax ,me.v ,arg))
+ (:method fmin (me arg) ^(fmin ,me.v ,arg))
+ (:method hypot (me arg) ^(hypot ,me.v ,arg))
+ (:method jn (me arg) ^(jn ,me.v ,arg))
+ (:method ldexp (me arg) ^(ldexp ,me.v ,arg))
+ (:method nextafter (me arg) ^(nextafter ,me.v ,arg))
+ (:method remainder (me arg) ^(remainder ,me.v ,arg))
+ (:method scalb (me arg) ^(scalb ,me.v ,arg))
+ (:method scalbln (me arg) ^(scalbln ,me.v ,arg))
+ (:method yn (me arg) ^(yn ,me.v ,arg))
+ (:method r-copysign (me arg) ^(copysign ,arg ,me.v))
+ (:method r-drem (me arg) ^(drem ,arg ,me.v))
+ (:method r-fdim (me arg) ^(fdim ,arg ,me.v))
+ (:method r-fmax (me arg) ^(fmax ,arg ,me.v))
+ (:method r-fmin (me arg) ^(fmin ,arg ,me.v))
+ (:method r-hypot (me arg) ^(hypot ,arg ,me.v))
+ (:method r-jn (me arg) ^(jn ,arg ,me.v))
+ (:method r-ldexp (me arg) ^(ldexp ,arg ,me.v))
+ (:method r-nextafter (me arg) ^(nextafter ,arg ,me.v))
+ (:method r-remainder (me arg) ^(remainder ,arg ,me.v))
+ (:method r-scalb (me arg) ^(scalb ,arg ,me.v))
+ (:method r-scalbln (me arg) ^(scalbln ,arg ,me.v))
+ (:method r-yn (me arg) ^(yn ,arg ,me.v))
+ (:method tofloat (me) ^(tofloat ,me.v))
+ (:method toint (me) ^(toint ,me.v)))
(defvarl n (new numbase v 1))
@@ -138,3 +184,51 @@
(test (ash n 0) (ash 1 0))
(test (width n) (width 1))
(test (logcount n) (logcount 1))
+(test (cbrt n) (cbrt 1))
+(test (erf n) (erf 1))
+(test (erfc n) (erfc 1))
+(test (exp10 n) (exp10 1))
+(test (exp2 n) (exp2 1))
+(test (expm1 n) (expm1 1))
+(test (gamma n) (gamma 1))
+(test (j0 n) (j0 1))
+(test (j1 n) (j1 1))
+(test (lgamma n) (lgamma 1))
+(test (log1p n) (log1p 1))
+(test (logb n) (logb 1))
+(test (nearbyint n) (nearbyint 1))
+(test (rint n) (rint 1))
+(test (significand n) (significand 1))
+(test (tgamma n) (tgamma 1))
+(test (y0 n) (y0 1))
+(test (y1 n) (y1 1))
+(test (copysign n 0) (copysign 1 0))
+(test (drem n 0) (drem 1 0))
+(test (fdim n 0) (fdim 1 0))
+(test (fmax n 0) (fmax 1 0))
+(test (fmin n 0) (fmin 1 0))
+(test (hypot n 0) (hypot 1 0))
+(test (jn n 0) (jn 1 0))
+(test (ldexp n 0) (ldexp 1 0))
+(test (nextafter n 0) (nextafter 1 0))
+(test (remainder n 0) (remainder 1 0))
+(test (scalb n 0) (scalb 1 0))
+(test (scalbln n 0) (scalbln 1 0))
+(test (yn n 0) (yn 1 0))
+(test (copysign 0 n) (copysign 0 1))
+(test (drem 0 n) (drem 0 1))
+(test (fdim 0 n) (fdim 0 1))
+(test (fmax 0 n) (fmax 0 1))
+(test (fmin 0 n) (fmin 0 1))
+(test (hypot 0 n) (hypot 0 1))
+(test (jn 0 n) (jn 0 1))
+(test (ldexp 0 n) (ldexp 0 1))
+(test (nextafter 0 n) (nextafter 0 1))
+(test (remainder 0 n) (remainder 0 1))
+(test (scalb 0 n) (scalb 0 1))
+(test (scalbln 0 n) (scalbln 0 1))
+(test (yn 0 n) (yn 0 1))
+(test (tofloat n) (tofloat 1))
+(test (toint n) (toint 1))
+
+(test (arithp n) t)
diff --git a/tests/017/bitfields.tl b/tests/017/bitfields.tl
new file mode 100644
index 00000000..155a8b95
--- /dev/null
+++ b/tests/017/bitfields.tl
@@ -0,0 +1,607 @@
+(load "../common")
+
+(defmacro conv-test (struct buf)
+ (let ((type (typeof struct)))
+ ^(mtest (sizeof ,type) ,(len buf)
+ (ffi-put ,struct (ffi ,type)) ,buf
+ (ffi-get ,buf (ffi ,type)) ,struct)))
+
+(typedef s0 (struct s0
+ (a (bit 1 be-uint32))
+ (nil (bit 0 uint32))
+ (b (bit 1 be-uint32))))
+
+(conv-test #S(s0 a 1 b 1) #b'8000000080000000')
+
+(typedef s1 (struct s1
+ (nil (bit 0 uint32))
+ (b (bit 1 be-uint32))))
+
+(conv-test #S(s1 b 1) #b'80000000')
+
+(typedef s2 (struct s2
+ (a (bit 1 be-uint32))
+ (nil (bit 0 uint32))))
+
+(conv-test #S(s2 a 1) #b'80000000')
+
+(typedef s3 (struct s3
+ (b00 (bit 1 be-uint32)) (b01 (bit 1 be-uint32))
+ (b02 (bit 1 be-uint32)) (b03 (bit 1 be-uint32))
+ (b04 (bit 1 be-uint32)) (b05 (bit 1 be-uint32))
+ (b06 (bit 1 be-uint32)) (b07 (bit 1 be-uint32))
+ (b08 (bit 1 be-uint32)) (b09 (bit 1 be-uint32))
+ (b10 (bit 1 be-uint32)) (b11 (bit 1 be-uint32))
+ (b12 (bit 1 be-uint32)) (b13 (bit 1 be-uint32))
+ (b14 (bit 1 be-uint32)) (b15 (bit 1 be-uint32))
+ (b16 (bit 1 be-uint32)) (b17 (bit 1 be-uint32))
+ (b18 (bit 1 be-uint32)) (b19 (bit 1 be-uint32))
+ (b20 (bit 1 be-uint32)) (b21 (bit 1 be-uint32))
+ (b22 (bit 1 be-uint32)) (b23 (bit 1 be-uint32))
+ (b24 (bit 1 be-uint32)) (b25 (bit 1 be-uint32))
+ (b26 (bit 1 be-uint32)) (b27 (bit 1 be-uint32))
+ (b28 (bit 1 be-uint32)) (b29 (bit 1 be-uint32))
+ (b30 (bit 1 be-uint32)) (b31 (bit 1 be-uint32))))
+
+(conv-test #S(s3 b00 1 b01 1 b02 1 b03 1 b04 1 b05 1 b06 1 b07 1
+ b08 1 b09 1 b10 1 b11 1 b12 1 b13 1 b14 1 b15 1
+ b16 1 b17 1 b18 1 b19 1 b20 1 b21 1 b22 1 b23 1
+ b24 1 b25 1 b26 1 b27 1 b28 1 b29 1 b30 1 b31 1)
+ #b'FFFFFFFF')
+
+(conv-test #S(s3 b00 1 b01 0 b02 1 b03 0 b04 1 b05 0 b06 1 b07 0
+ b08 1 b09 0 b10 1 b11 0 b12 1 b13 0 b14 1 b15 0
+ b16 1 b17 0 b18 1 b19 0 b20 1 b21 0 b22 1 b23 0
+ b24 1 b25 0 b26 1 b27 0 b28 1 b29 0 b30 1 b31 0)
+ #b'AAAAAAAA')
+
+(conv-test #S(s3 b00 0 b01 1 b02 0 b03 1 b04 0 b05 1 b06 0 b07 1
+ b08 0 b09 1 b10 0 b11 1 b12 0 b13 1 b14 0 b15 1
+ b16 0 b17 1 b18 0 b19 1 b20 0 b21 1 b22 0 b23 1
+ b24 0 b25 1 b26 0 b27 1 b28 0 b29 1 b30 0 b31 1)
+ #b'55555555')
+
+(conv-test #S(s3 b00 0 b01 1 b02 0 b03 1 b04 0 b05 1 b06 0 b07 1
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0
+ b16 0 b17 1 b18 0 b19 1 b20 0 b21 1 b22 0 b23 1
+ b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0)
+ #b'55005500')
+
+(conv-test #S(s3 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0
+ b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0)
+ #b'00000000')
+
+(conv-test #S(s3 b00 1 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0
+ b08 1 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0
+ b16 1 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0
+ b24 1 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0)
+ #b'80808080')
+
+(conv-test #S(s3 b00 0 b01 1 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0
+ b08 0 b09 1 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0
+ b16 0 b17 1 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0
+ b24 0 b25 1 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0)
+ #b'40404040')
+
+(conv-test #S(s3 b00 0 b01 0 b02 1 b03 0 b04 0 b05 0 b06 0 b07 0
+ b08 0 b09 0 b10 1 b11 0 b12 0 b13 0 b14 0 b15 0
+ b16 0 b17 0 b18 1 b19 0 b20 0 b21 0 b22 0 b23 0
+ b24 0 b25 0 b26 1 b27 0 b28 0 b29 0 b30 0 b31 0)
+ #b'20202020')
+
+(conv-test #S(s3 b00 0 b01 0 b02 0 b03 1 b04 0 b05 0 b06 0 b07 0
+ b08 0 b09 0 b10 0 b11 1 b12 0 b13 0 b14 0 b15 0
+ b16 0 b17 0 b18 0 b19 1 b20 0 b21 0 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 1 b28 0 b29 0 b30 0 b31 0)
+ #b'10101010')
+
+(conv-test #S(s3 b00 0 b01 0 b02 0 b03 0 b04 1 b05 0 b06 0 b07 0
+ b08 0 b09 0 b10 0 b11 0 b12 1 b13 0 b14 0 b15 0
+ b16 0 b17 0 b18 0 b19 0 b20 1 b21 0 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 0 b28 1 b29 0 b30 0 b31 0)
+ #b'08080808')
+
+(conv-test #S(s3 b00 0 b01 0 b02 0 b03 0 b04 0 b05 1 b06 0 b07 0
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 1 b14 0 b15 0
+ b16 0 b17 0 b18 0 b19 0 b20 0 b21 1 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 0 b28 0 b29 1 b30 0 b31 0)
+ #b'04040404')
+
+(conv-test #S(s3 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 1 b07 0
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 1 b15 0
+ b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 1 b23 0
+ b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 1 b31 0)
+ #b'02020202')
+
+(conv-test #S(s3 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 1
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 1
+ b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 1
+ b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 1)
+ #b'01010101')
+
+(conv-test #S(s3 b00 1 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 1
+ b08 0 b09 1 b10 0 b11 0 b12 0 b13 0 b14 1 b15 0
+ b16 0 b17 0 b18 1 b19 0 b20 0 b21 1 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 1 b28 1 b29 0 b30 0 b31 0)
+ #b'81422418')
+
+(conv-test #S(s3 b00 0 b01 0 b02 0 b03 1 b04 1 b05 0 b06 0 b07 0
+ b08 0 b09 0 b10 1 b11 0 b12 0 b13 1 b14 0 b15 0
+ b16 0 b17 1 b18 0 b19 0 b20 0 b21 0 b22 1 b23 0
+ b24 1 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 1)
+ #b'18244281')
+
+(typedef s4 (struct s4
+ (b00 (bit 1 le-uint32)) (b01 (bit 1 le-uint32))
+ (b02 (bit 1 le-uint32)) (b03 (bit 1 le-uint32))
+ (b04 (bit 1 le-uint32)) (b05 (bit 1 le-uint32))
+ (b06 (bit 1 le-uint32)) (b07 (bit 1 le-uint32))
+ (b08 (bit 1 le-uint32)) (b09 (bit 1 le-uint32))
+ (b10 (bit 1 le-uint32)) (b11 (bit 1 le-uint32))
+ (b12 (bit 1 le-uint32)) (b13 (bit 1 le-uint32))
+ (b14 (bit 1 le-uint32)) (b15 (bit 1 le-uint32))
+ (b16 (bit 1 le-uint32)) (b17 (bit 1 le-uint32))
+ (b18 (bit 1 le-uint32)) (b19 (bit 1 le-uint32))
+ (b20 (bit 1 le-uint32)) (b21 (bit 1 le-uint32))
+ (b22 (bit 1 le-uint32)) (b23 (bit 1 le-uint32))
+ (b24 (bit 1 le-uint32)) (b25 (bit 1 le-uint32))
+ (b26 (bit 1 le-uint32)) (b27 (bit 1 le-uint32))
+ (b28 (bit 1 le-uint32)) (b29 (bit 1 le-uint32))
+ (b30 (bit 1 le-uint32)) (b31 (bit 1 le-uint32))))
+
+(conv-test #S(s4 b00 1 b01 1 b02 1 b03 1 b04 1 b05 1 b06 1 b07 1
+ b08 1 b09 1 b10 1 b11 1 b12 1 b13 1 b14 1 b15 1
+ b16 1 b17 1 b18 1 b19 1 b20 1 b21 1 b22 1 b23 1
+ b24 1 b25 1 b26 1 b27 1 b28 1 b29 1 b30 1 b31 1)
+ #b'FFFFFFFF')
+
+(conv-test #S(s4 b00 1 b01 0 b02 1 b03 0 b04 1 b05 0 b06 1 b07 0
+ b08 1 b09 0 b10 1 b11 0 b12 1 b13 0 b14 1 b15 0
+ b16 1 b17 0 b18 1 b19 0 b20 1 b21 0 b22 1 b23 0
+ b24 1 b25 0 b26 1 b27 0 b28 1 b29 0 b30 1 b31 0)
+ #b'55555555')
+
+(conv-test #S(s4 b00 0 b01 1 b02 0 b03 1 b04 0 b05 1 b06 0 b07 1
+ b08 0 b09 1 b10 0 b11 1 b12 0 b13 1 b14 0 b15 1
+ b16 0 b17 1 b18 0 b19 1 b20 0 b21 1 b22 0 b23 1
+ b24 0 b25 1 b26 0 b27 1 b28 0 b29 1 b30 0 b31 1)
+ #b'AAAAAAAA')
+
+(conv-test #S(s4 b00 0 b01 1 b02 0 b03 1 b04 0 b05 1 b06 0 b07 1
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0
+ b16 0 b17 1 b18 0 b19 1 b20 0 b21 1 b22 0 b23 1
+ b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0)
+ #b'AA00AA00')
+
+(conv-test #S(s4 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0
+ b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0)
+ #b'00000000')
+
+(conv-test #S(s4 b00 1 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0
+ b08 1 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0
+ b16 1 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0
+ b24 1 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0)
+ #b'01010101')
+
+(conv-test #S(s4 b00 0 b01 1 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0
+ b08 0 b09 1 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0
+ b16 0 b17 1 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0
+ b24 0 b25 1 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0)
+ #b'02020202')
+
+(conv-test #S(s4 b00 0 b01 0 b02 1 b03 0 b04 0 b05 0 b06 0 b07 0
+ b08 0 b09 0 b10 1 b11 0 b12 0 b13 0 b14 0 b15 0
+ b16 0 b17 0 b18 1 b19 0 b20 0 b21 0 b22 0 b23 0
+ b24 0 b25 0 b26 1 b27 0 b28 0 b29 0 b30 0 b31 0)
+ #b'04040404')
+
+(conv-test #S(s4 b00 0 b01 0 b02 0 b03 1 b04 0 b05 0 b06 0 b07 0
+ b08 0 b09 0 b10 0 b11 1 b12 0 b13 0 b14 0 b15 0
+ b16 0 b17 0 b18 0 b19 1 b20 0 b21 0 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 1 b28 0 b29 0 b30 0 b31 0)
+ #b'08080808')
+
+(conv-test #S(s4 b00 0 b01 0 b02 0 b03 0 b04 1 b05 0 b06 0 b07 0
+ b08 0 b09 0 b10 0 b11 0 b12 1 b13 0 b14 0 b15 0
+ b16 0 b17 0 b18 0 b19 0 b20 1 b21 0 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 0 b28 1 b29 0 b30 0 b31 0)
+ #b'10101010')
+
+(conv-test #S(s4 b00 0 b01 0 b02 0 b03 0 b04 0 b05 1 b06 0 b07 0
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 1 b14 0 b15 0
+ b16 0 b17 0 b18 0 b19 0 b20 0 b21 1 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 0 b28 0 b29 1 b30 0 b31 0)
+ #b'20202020')
+
+(conv-test #S(s4 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 1 b07 0
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 1 b15 0
+ b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 1 b23 0
+ b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 1 b31 0)
+ #b'40404040')
+
+(conv-test #S(s4 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 1
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 1
+ b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 1
+ b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 1)
+ #b'80808080')
+
+(conv-test #S(s4 b00 1 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 1
+ b08 0 b09 1 b10 0 b11 0 b12 0 b13 0 b14 1 b15 0
+ b16 0 b17 0 b18 1 b19 0 b20 0 b21 1 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 1 b28 1 b29 0 b30 0 b31 0)
+ #b'81422418')
+
+(conv-test #S(s4 b00 0 b01 0 b02 0 b03 1 b04 1 b05 0 b06 0 b07 0
+ b08 0 b09 0 b10 1 b11 0 b12 0 b13 1 b14 0 b15 0
+ b16 0 b17 1 b18 0 b19 0 b20 0 b21 0 b22 1 b23 0
+ b24 1 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 1)
+ #b'18244281')
+
+(typedef s5 (struct s5
+ (b00 (bit 1 be-uint64)) (b01 (bit 1 be-uint64))
+ (b02 (bit 1 be-uint64)) (b03 (bit 1 be-uint64))
+ (b04 (bit 1 be-uint64)) (b05 (bit 1 be-uint64))
+ (b06 (bit 1 be-uint64)) (b07 (bit 1 be-uint64))
+ (b08 (bit 1 be-uint64)) (b09 (bit 1 be-uint64))
+ (b10 (bit 1 be-uint64)) (b11 (bit 1 be-uint64))
+ (b12 (bit 1 be-uint64)) (b13 (bit 1 be-uint64))
+ (b14 (bit 1 be-uint64)) (b15 (bit 1 be-uint64))
+ (b16 (bit 1 be-uint64)) (b17 (bit 1 be-uint64))
+ (b18 (bit 1 be-uint64)) (b19 (bit 1 be-uint64))
+ (b20 (bit 1 be-uint64)) (b21 (bit 1 be-uint64))
+ (b22 (bit 1 be-uint64)) (b23 (bit 1 be-uint64))
+ (b24 (bit 1 be-uint64)) (b25 (bit 1 be-uint64))
+ (b26 (bit 1 be-uint64)) (b27 (bit 1 be-uint64))
+ (b28 (bit 1 be-uint64)) (b29 (bit 1 be-uint64))
+ (b30 (bit 1 be-uint64)) (b31 (bit 1 be-uint64))
+ (b32 (bit 1 be-uint64)) (b33 (bit 1 be-uint64))
+ (b34 (bit 1 be-uint64)) (b35 (bit 1 be-uint64))
+ (b36 (bit 1 be-uint64)) (b37 (bit 1 be-uint64))
+ (b38 (bit 1 be-uint64)) (b39 (bit 1 be-uint64))
+ (b40 (bit 1 be-uint64)) (b41 (bit 1 be-uint64))
+ (b42 (bit 1 be-uint64)) (b43 (bit 1 be-uint64))
+ (b44 (bit 1 be-uint64)) (b45 (bit 1 be-uint64))
+ (b46 (bit 1 be-uint64)) (b47 (bit 1 be-uint64))
+ (b48 (bit 1 be-uint64)) (b49 (bit 1 be-uint64))
+ (b50 (bit 1 be-uint64)) (b51 (bit 1 be-uint64))
+ (b52 (bit 1 be-uint64)) (b53 (bit 1 be-uint64))
+ (b54 (bit 1 be-uint64)) (b55 (bit 1 be-uint64))
+ (b56 (bit 1 be-uint64)) (b57 (bit 1 be-uint64))
+ (b58 (bit 1 be-uint64)) (b59 (bit 1 be-uint64))
+ (b60 (bit 1 be-uint64)) (b61 (bit 1 be-uint64))
+ (b62 (bit 1 be-uint64)) (b63 (bit 1 be-uint64))))
+
+(conv-test #S(s5 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0
+ b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0
+ b32 0 b33 0 b34 0 b35 0 b36 0 b37 0 b38 0 b39 0
+ b40 0 b41 0 b42 0 b43 0 b44 0 b45 0 b46 0 b47 0
+ b48 0 b49 0 b50 0 b51 0 b52 0 b53 0 b54 0 b55 0
+ b56 0 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 0)
+ #b'0000000000000000')
+
+(conv-test #S(s5 b00 1 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0
+ b08 1 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0
+ b16 1 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0
+ b24 1 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0
+ b32 1 b33 0 b34 0 b35 0 b36 0 b37 0 b38 0 b39 0
+ b40 1 b41 0 b42 0 b43 0 b44 0 b45 0 b46 0 b47 0
+ b48 1 b49 0 b50 0 b51 0 b52 0 b53 0 b54 0 b55 0
+ b56 1 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 0)
+ #b'8080808080808080')
+
+(conv-test #S(s5 b00 0 b01 1 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0
+ b08 0 b09 1 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0
+ b16 0 b17 1 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0
+ b24 0 b25 1 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0
+ b32 0 b33 1 b34 0 b35 0 b36 0 b37 0 b38 0 b39 0
+ b40 0 b41 1 b42 0 b43 0 b44 0 b45 0 b46 0 b47 0
+ b48 0 b49 1 b50 0 b51 0 b52 0 b53 0 b54 0 b55 0
+ b56 0 b57 1 b58 0 b59 0 b60 0 b61 0 b62 0 b63 0)
+ #b'4040404040404040')
+
+(conv-test #S(s5 b00 0 b01 0 b02 1 b03 0 b04 0 b05 0 b06 0 b07 0
+ b08 0 b09 0 b10 1 b11 0 b12 0 b13 0 b14 0 b15 0
+ b16 0 b17 0 b18 1 b19 0 b20 0 b21 0 b22 0 b23 0
+ b24 0 b25 0 b26 1 b27 0 b28 0 b29 0 b30 0 b31 0
+ b32 0 b33 0 b34 1 b35 0 b36 0 b37 0 b38 0 b39 0
+ b40 0 b41 0 b42 1 b43 0 b44 0 b45 0 b46 0 b47 0
+ b48 0 b49 0 b50 1 b51 0 b52 0 b53 0 b54 0 b55 0
+ b56 0 b57 0 b58 1 b59 0 b60 0 b61 0 b62 0 b63 0)
+ #b'2020202020202020')
+
+(conv-test #S(s5 b00 0 b01 0 b02 0 b03 1 b04 0 b05 0 b06 0 b07 0
+ b08 0 b09 0 b10 0 b11 1 b12 0 b13 0 b14 0 b15 0
+ b16 0 b17 0 b18 0 b19 1 b20 0 b21 0 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 1 b28 0 b29 0 b30 0 b31 0
+ b32 0 b33 0 b34 0 b35 1 b36 0 b37 0 b38 0 b39 0
+ b40 0 b41 0 b42 0 b43 1 b44 0 b45 0 b46 0 b47 0
+ b48 0 b49 0 b50 0 b51 1 b52 0 b53 0 b54 0 b55 0
+ b56 0 b57 0 b58 0 b59 1 b60 0 b61 0 b62 0 b63 0)
+ #b'1010101010101010')
+
+(conv-test #S(s5 b00 0 b01 0 b02 0 b03 0 b04 1 b05 0 b06 0 b07 0
+ b08 0 b09 0 b10 0 b11 0 b12 1 b13 0 b14 0 b15 0
+ b16 0 b17 0 b18 0 b19 0 b20 1 b21 0 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 0 b28 1 b29 0 b30 0 b31 0
+ b32 0 b33 0 b34 0 b35 0 b36 1 b37 0 b38 0 b39 0
+ b40 0 b41 0 b42 0 b43 0 b44 1 b45 0 b46 0 b47 0
+ b48 0 b49 0 b50 0 b51 0 b52 1 b53 0 b54 0 b55 0
+ b56 0 b57 0 b58 0 b59 0 b60 1 b61 0 b62 0 b63 0)
+ #b'0808080808080808')
+
+(conv-test #S(s5 b00 0 b01 0 b02 0 b03 0 b04 0 b05 1 b06 0 b07 0
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 1 b14 0 b15 0
+ b16 0 b17 0 b18 0 b19 0 b20 0 b21 1 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 0 b28 0 b29 1 b30 0 b31 0
+ b32 0 b33 0 b34 0 b35 0 b36 0 b37 1 b38 0 b39 0
+ b40 0 b41 0 b42 0 b43 0 b44 0 b45 1 b46 0 b47 0
+ b48 0 b49 0 b50 0 b51 0 b52 0 b53 1 b54 0 b55 0
+ b56 0 b57 0 b58 0 b59 0 b60 0 b61 1 b62 0 b63 0)
+ #b'0404040404040404')
+
+(conv-test #S(s5 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 1 b07 0
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 1 b15 0
+ b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 1 b23 0
+ b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 1 b31 0
+ b32 0 b33 0 b34 0 b35 0 b36 0 b37 0 b38 1 b39 0
+ b40 0 b41 0 b42 0 b43 0 b44 0 b45 0 b46 1 b47 0
+ b48 0 b49 0 b50 0 b51 0 b52 0 b53 0 b54 1 b55 0
+ b56 0 b57 0 b58 0 b59 0 b60 0 b61 0 b62 1 b63 0)
+ #b'0202020202020202')
+
+(conv-test #S(s5 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 1
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 1
+ b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 1
+ b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 1
+ b32 0 b33 0 b34 0 b35 0 b36 0 b37 0 b38 0 b39 1
+ b40 0 b41 0 b42 0 b43 0 b44 0 b45 0 b46 0 b47 1
+ b48 0 b49 0 b50 0 b51 0 b52 0 b53 0 b54 0 b55 1
+ b56 0 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 1)
+ #b'0101010101010101')
+
+(conv-test #S(s5 b00 1 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0
+ b08 0 b09 1 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0
+ b16 0 b17 0 b18 1 b19 0 b20 0 b21 0 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 1 b28 0 b29 0 b30 0 b31 0
+ b32 0 b33 0 b34 0 b35 0 b36 1 b37 0 b38 0 b39 0
+ b40 0 b41 0 b42 0 b43 0 b44 0 b45 1 b46 0 b47 0
+ b48 0 b49 0 b50 0 b51 0 b52 0 b53 0 b54 1 b55 0
+ b56 0 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 1)
+ #b'8040201008040201')
+
+(conv-test #S(s5 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 1
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 1 b15 0
+ b16 0 b17 0 b18 0 b19 0 b20 0 b21 1 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 0 b28 1 b29 0 b30 0 b31 0
+ b32 0 b33 0 b34 0 b35 1 b36 0 b37 0 b38 0 b39 0
+ b40 0 b41 0 b42 1 b43 0 b44 0 b45 0 b46 0 b47 0
+ b48 0 b49 1 b50 0 b51 0 b52 0 b53 0 b54 0 b55 0
+ b56 1 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 0)
+ #b'0102040810204080')
+
+(typedef s6 (struct s6
+ (b00 (bit 1 le-uint64)) (b01 (bit 1 le-uint64))
+ (b02 (bit 1 le-uint64)) (b03 (bit 1 le-uint64))
+ (b04 (bit 1 le-uint64)) (b05 (bit 1 le-uint64))
+ (b06 (bit 1 le-uint64)) (b07 (bit 1 le-uint64))
+ (b08 (bit 1 le-uint64)) (b09 (bit 1 le-uint64))
+ (b10 (bit 1 le-uint64)) (b11 (bit 1 le-uint64))
+ (b12 (bit 1 le-uint64)) (b13 (bit 1 le-uint64))
+ (b14 (bit 1 le-uint64)) (b15 (bit 1 le-uint64))
+ (b16 (bit 1 le-uint64)) (b17 (bit 1 le-uint64))
+ (b18 (bit 1 le-uint64)) (b19 (bit 1 le-uint64))
+ (b20 (bit 1 le-uint64)) (b21 (bit 1 le-uint64))
+ (b22 (bit 1 le-uint64)) (b23 (bit 1 le-uint64))
+ (b24 (bit 1 le-uint64)) (b25 (bit 1 le-uint64))
+ (b26 (bit 1 le-uint64)) (b27 (bit 1 le-uint64))
+ (b28 (bit 1 le-uint64)) (b29 (bit 1 le-uint64))
+ (b30 (bit 1 le-uint64)) (b31 (bit 1 le-uint64))
+ (b32 (bit 1 le-uint64)) (b33 (bit 1 le-uint64))
+ (b34 (bit 1 le-uint64)) (b35 (bit 1 le-uint64))
+ (b36 (bit 1 le-uint64)) (b37 (bit 1 le-uint64))
+ (b38 (bit 1 le-uint64)) (b39 (bit 1 le-uint64))
+ (b40 (bit 1 le-uint64)) (b41 (bit 1 le-uint64))
+ (b42 (bit 1 le-uint64)) (b43 (bit 1 le-uint64))
+ (b44 (bit 1 le-uint64)) (b45 (bit 1 le-uint64))
+ (b46 (bit 1 le-uint64)) (b47 (bit 1 le-uint64))
+ (b48 (bit 1 le-uint64)) (b49 (bit 1 le-uint64))
+ (b50 (bit 1 le-uint64)) (b51 (bit 1 le-uint64))
+ (b52 (bit 1 le-uint64)) (b53 (bit 1 le-uint64))
+ (b54 (bit 1 le-uint64)) (b55 (bit 1 le-uint64))
+ (b56 (bit 1 le-uint64)) (b57 (bit 1 le-uint64))
+ (b58 (bit 1 le-uint64)) (b59 (bit 1 le-uint64))
+ (b60 (bit 1 le-uint64)) (b61 (bit 1 le-uint64))
+ (b62 (bit 1 le-uint64)) (b63 (bit 1 le-uint64))))
+
+(conv-test #S(s6 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0
+ b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0
+ b32 0 b33 0 b34 0 b35 0 b36 0 b37 0 b38 0 b39 0
+ b40 0 b41 0 b42 0 b43 0 b44 0 b45 0 b46 0 b47 0
+ b48 0 b49 0 b50 0 b51 0 b52 0 b53 0 b54 0 b55 0
+ b56 0 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 0)
+ #b'0000000000000000')
+
+(conv-test #S(s6 b00 1 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0
+ b08 1 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0
+ b16 1 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0
+ b24 1 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0
+ b32 1 b33 0 b34 0 b35 0 b36 0 b37 0 b38 0 b39 0
+ b40 1 b41 0 b42 0 b43 0 b44 0 b45 0 b46 0 b47 0
+ b48 1 b49 0 b50 0 b51 0 b52 0 b53 0 b54 0 b55 0
+ b56 1 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 0)
+ #b'0101010101010101')
+
+(conv-test #S(s6 b00 0 b01 1 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0
+ b08 0 b09 1 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0
+ b16 0 b17 1 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0
+ b24 0 b25 1 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0
+ b32 0 b33 1 b34 0 b35 0 b36 0 b37 0 b38 0 b39 0
+ b40 0 b41 1 b42 0 b43 0 b44 0 b45 0 b46 0 b47 0
+ b48 0 b49 1 b50 0 b51 0 b52 0 b53 0 b54 0 b55 0
+ b56 0 b57 1 b58 0 b59 0 b60 0 b61 0 b62 0 b63 0)
+ #b'0202020202020202')
+
+(conv-test #S(s6 b00 0 b01 0 b02 1 b03 0 b04 0 b05 0 b06 0 b07 0
+ b08 0 b09 0 b10 1 b11 0 b12 0 b13 0 b14 0 b15 0
+ b16 0 b17 0 b18 1 b19 0 b20 0 b21 0 b22 0 b23 0
+ b24 0 b25 0 b26 1 b27 0 b28 0 b29 0 b30 0 b31 0
+ b32 0 b33 0 b34 1 b35 0 b36 0 b37 0 b38 0 b39 0
+ b40 0 b41 0 b42 1 b43 0 b44 0 b45 0 b46 0 b47 0
+ b48 0 b49 0 b50 1 b51 0 b52 0 b53 0 b54 0 b55 0
+ b56 0 b57 0 b58 1 b59 0 b60 0 b61 0 b62 0 b63 0)
+ #b'0404040404040404')
+
+(conv-test #S(s6 b00 0 b01 0 b02 0 b03 1 b04 0 b05 0 b06 0 b07 0
+ b08 0 b09 0 b10 0 b11 1 b12 0 b13 0 b14 0 b15 0
+ b16 0 b17 0 b18 0 b19 1 b20 0 b21 0 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 1 b28 0 b29 0 b30 0 b31 0
+ b32 0 b33 0 b34 0 b35 1 b36 0 b37 0 b38 0 b39 0
+ b40 0 b41 0 b42 0 b43 1 b44 0 b45 0 b46 0 b47 0
+ b48 0 b49 0 b50 0 b51 1 b52 0 b53 0 b54 0 b55 0
+ b56 0 b57 0 b58 0 b59 1 b60 0 b61 0 b62 0 b63 0)
+ #b'0808080808080808')
+
+(conv-test #S(s6 b00 0 b01 0 b02 0 b03 0 b04 1 b05 0 b06 0 b07 0
+ b08 0 b09 0 b10 0 b11 0 b12 1 b13 0 b14 0 b15 0
+ b16 0 b17 0 b18 0 b19 0 b20 1 b21 0 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 0 b28 1 b29 0 b30 0 b31 0
+ b32 0 b33 0 b34 0 b35 0 b36 1 b37 0 b38 0 b39 0
+ b40 0 b41 0 b42 0 b43 0 b44 1 b45 0 b46 0 b47 0
+ b48 0 b49 0 b50 0 b51 0 b52 1 b53 0 b54 0 b55 0
+ b56 0 b57 0 b58 0 b59 0 b60 1 b61 0 b62 0 b63 0)
+ #b'1010101010101010')
+
+(conv-test #S(s6 b00 0 b01 0 b02 0 b03 0 b04 0 b05 1 b06 0 b07 0
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 1 b14 0 b15 0
+ b16 0 b17 0 b18 0 b19 0 b20 0 b21 1 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 0 b28 0 b29 1 b30 0 b31 0
+ b32 0 b33 0 b34 0 b35 0 b36 0 b37 1 b38 0 b39 0
+ b40 0 b41 0 b42 0 b43 0 b44 0 b45 1 b46 0 b47 0
+ b48 0 b49 0 b50 0 b51 0 b52 0 b53 1 b54 0 b55 0
+ b56 0 b57 0 b58 0 b59 0 b60 0 b61 1 b62 0 b63 0)
+ #b'2020202020202020')
+
+(conv-test #S(s6 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 1 b07 0
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 1 b15 0
+ b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 1 b23 0
+ b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 1 b31 0
+ b32 0 b33 0 b34 0 b35 0 b36 0 b37 0 b38 1 b39 0
+ b40 0 b41 0 b42 0 b43 0 b44 0 b45 0 b46 1 b47 0
+ b48 0 b49 0 b50 0 b51 0 b52 0 b53 0 b54 1 b55 0
+ b56 0 b57 0 b58 0 b59 0 b60 0 b61 0 b62 1 b63 0)
+ #b'4040404040404040')
+
+(conv-test #S(s6 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 1
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 1
+ b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 1
+ b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 1
+ b32 0 b33 0 b34 0 b35 0 b36 0 b37 0 b38 0 b39 1
+ b40 0 b41 0 b42 0 b43 0 b44 0 b45 0 b46 0 b47 1
+ b48 0 b49 0 b50 0 b51 0 b52 0 b53 0 b54 0 b55 1
+ b56 0 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 1)
+ #b'8080808080808080')
+
+(conv-test #S(s6 b00 1 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0
+ b08 0 b09 1 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0
+ b16 0 b17 0 b18 1 b19 0 b20 0 b21 0 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 1 b28 0 b29 0 b30 0 b31 0
+ b32 0 b33 0 b34 0 b35 0 b36 1 b37 0 b38 0 b39 0
+ b40 0 b41 0 b42 0 b43 0 b44 0 b45 1 b46 0 b47 0
+ b48 0 b49 0 b50 0 b51 0 b52 0 b53 0 b54 1 b55 0
+ b56 0 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 1)
+ #b'0102040810204080')
+
+(conv-test #S(s6 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 1
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 1 b15 0
+ b16 0 b17 0 b18 0 b19 0 b20 0 b21 1 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 0 b28 1 b29 0 b30 0 b31 0
+ b32 0 b33 0 b34 0 b35 1 b36 0 b37 0 b38 0 b39 0
+ b40 0 b41 0 b42 1 b43 0 b44 0 b45 0 b46 0 b47 0
+ b48 0 b49 1 b50 0 b51 0 b52 0 b53 0 b54 0 b55 0
+ b56 1 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 0)
+ #b'8040201008040201')
+
+(conv-test #S(s6 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 1
+ b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 1 b15 0
+ b16 0 b17 0 b18 0 b19 0 b20 0 b21 1 b22 0 b23 0
+ b24 0 b25 0 b26 0 b27 0 b28 1 b29 0 b30 0 b31 0
+ b32 0 b33 0 b34 0 b35 1 b36 0 b37 0 b38 0 b39 0
+ b40 0 b41 0 b42 1 b43 0 b44 0 b45 0 b46 0 b47 0
+ b48 0 b49 1 b50 0 b51 0 b52 0 b53 0 b54 0 b55 0
+ b56 1 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 0)
+ #b'8040201008040201')
+
+(typedef s7 (struct s7
+ (x uint8)
+ (b0 (bit 8 uint32)) (b1 (bit 8 uint32))
+ (b2 (bit 8 uint32)) (b3 (bit 8 uint32))))
+
+(conv-test #S(s7 x #xff b0 #xaa b1 #xbb b2 #xcc b3 #xdd) #b'ffaabbccdd000000')
+
+(typedef s8 (pack (struct s8
+ (x uint8)
+ (b0 (bit 8 uint32)) (b1 (bit 8 uint32))
+ (b2 (bit 8 uint32)) (b3 (bit 8 uint32)))))
+
+(conv-test #S(s8 x #xff b0 #xaa b1 #xbb b2 #xcc b3 #xdd) #b'ffaabbccdd')
+
+(typedef s9 (pack (struct s9
+ (x uint8)
+ (b0 (bit 8 uint32)) (b1 (bit 8 uint32))
+ (b2 (bit 8 uint32)))))
+
+(conv-test #S(s9 x #xff b0 #xaa b1 #xbb b2 #xcc) #b'ffaabbcc')
+
+(typedef s10 (struct s10
+ (x uint8)
+ (b0 (bit 8 (pack 2 uint32))) (b1 (bit 8 (pack 2 uint32)))
+ (b2 (bit 8 (pack 2 uint32)))))
+
+(conv-test #S(s10 x #xff b0 #xaa b1 #xbb b2 #xcc) #b'ff00aa00bb00cc00')
+
+(typedef s11 (struct s11
+ (x uint8)
+ (b0 (bit 8 (pack 2 uint32))) (b1 (bit 8 uint32))
+ (b2 (bit 8 uint32))))
+
+(conv-test #S(s11 x #xff b0 #xaa b1 #xbb b2 #xcc) #b'ff00aabbcc000000')
+
+(typedef s12 (struct s12
+ (x (bit 7 le-uint32))
+ (b0 (bit 8 (pack 1 (bit 8 le-uint32))))))
+
+(conv-test #S(s12 x #x7f b0 #xff) #b'ff7f0000')
+
+(typedef s13 (struct s13
+ (x (bit 7 le-uint32))
+ (b0 (bit 8 (pack 1 (align 1 (bit 8 le-uint32)))))))
+
+(conv-test #S(s13 x #x7f b0 #xff) #b'7fff0000')
+
+(typedef s14 (pack (struct s14
+ (a (bit 9 le-uint32))
+ (b (bit 7 le-uint32)))))
+
+(conv-test #S(s14 a #x1ff b #x7f) #b'ffff')
+
+(typedef s15 (pack (struct s15
+ (x uint8)
+ (a (bit 9 le-uint32))
+ (b (bit 7 le-uint32)))))
+
+(conv-test #S(s15 x 0 a #x1ff b #x7f) #b'00ffff')
+
+(typedef s16 (struct s16
+ (x uint8)
+ (a (align 2 (bit 9 le-uint32)))
+ (b (align 2 (bit 7 le-uint32)))))
+
+(conv-test #S(s16 x 0 a #x1ff b #x7f) #b'0000ff017f000000')
diff --git a/tests/017/carray.tl b/tests/017/carray.tl
new file mode 100644
index 00000000..1d450d1a
--- /dev/null
+++ b/tests/017/carray.tl
@@ -0,0 +1,16 @@
+(load "../common")
+
+(let* ((bf (make-buf 16))
+ (ca (carray-buf bf (ffi uchar))))
+ (mtest
+ (buf-put-buf bf (make-buf 8 255) 8) #b'ffffffffffffffff'
+ bf #b'0000000000000000 ffffffffffffffff'
+ (carray-set-length ca 8) nil
+ (set [ca -1..10] #(1 2 3)) #(1 2 3)
+ bf #b'0000000000000001 ffffffffffffffff'
+ (set [ca 2..7] #(1 2 3)) #(1 2 3)
+ bf #b'0000010203010000 ffffffffffffffff'
+ (set [ca 3..4] #(10 11 12)) #(10 11 12)
+ bf #b'0000010A0B0C0301 ffffffffffffffff'
+ (set [ca 3..3] #(9)) #(9)
+ bf #b'000001090A0B0C03 ffffffffffffffff'))
diff --git a/tests/017/ffi-misc.expected b/tests/017/ffi-misc.expected
deleted file mode 100644
index e69de29b..00000000
--- a/tests/017/ffi-misc.expected
+++ /dev/null
diff --git a/tests/017/ffi-misc.tl b/tests/017/ffi-misc.tl
index 1578cd2c..4d7bffab 100644
--- a/tests/017/ffi-misc.tl
+++ b/tests/017/ffi-misc.tl
@@ -9,3 +9,107 @@
(test (ffi-put "\x1234@@@" zar) #b'e188b440404000')
(test (ffi-get (ffi-put "\x1234@@@" zar) zar) "\x1234@@@")
+
+(unless (meq (os-symbol) :cygwin :cygnal)
+ (test (ffi-get #b'EDB08100' (ffi (zarray char)))
+ "\xDCED\xDCB0\xDC81")
+
+ (test (ffi-get #b'ED7F7FEDFF00' (ffi (zarray char)))
+ "\xDCED\x7F\x7F\xDCED\xDCFF"))
+
+(mtest
+ (typeof (ffi (enum a))) ffi-type
+ (typeof (ffi (enum b b0 b1 b2 (b3 -15)))) ffi-type
+ (typeof (ffi (enum c (c0 (expt 2 512))))) :error
+ (typeof (ffi (enum d d0 d0))) :error
+ (typeof (ffi (enum e (e0 0) (e0 1)))) :error)
+
+(mtest
+ (typeof (ffi (enumed uint16 m))) ffi-type
+ (typeof (ffi (enumed uint16 n n0 n1 n2 (n3 15)))) ffi-type
+ (typeof (ffi (enumed uint16 o (o0 (expt 2 512))))) :error
+ (typeof (ffi (enumed uint16 p p0 p0))) :error
+ (typeof (ffi (enumed uint16 q (q0 0) (q0 1)))) :error)
+
+(mtest
+ (typeof (ffi (enumed uint8 e (x 0) (y #xff)))) ffi-type
+ (typeof (ffi (enumed uint8 e (x -1)))) :error
+ (typeof (ffi (enumed uint8 e (x #x100)))) :error)
+
+(mtest
+ (typeof (ffi (enumed uint16 e (x 0) (y #xffff)))) ffi-type
+ (typeof (ffi (enumed uint16 e (x -1)))) :error
+ (typeof (ffi (enumed uint16 e (x #x10000)))) :error)
+
+(mtest
+ (typeof (ffi (enumed uint32 e (x 0) (y #xffffffff)))) ffi-type
+ (typeof (ffi (enumed uint32 e (x -1)))) :error
+ (typeof (ffi (enumed uint32 e (x #x100000000)))) :error)
+
+(mtest
+ (typeof (ffi (enumed uint64 e (x 0) (y #xffffffffffffffff)))) ffi-type
+ ;(typeof (ffi (enumed uint64 e (x -1)))) #:error
+ (typeof (ffi (enumed uint64 e (x #x10000000000000000)))) :error)
+
+(mtest
+ (typeof (ffi (enumed int8 e (x 0) (y #x7f)))) ffi-type
+ (typeof (ffi (enumed int8 e (x #x-81)))) :error
+ (typeof (ffi (enumed int8 e (x #x800)))) :error)
+
+(mtest
+ (typeof (ffi (enumed int16 e (x 0) (y #x7fff)))) ffi-type
+ (typeof (ffi (enumed int16 e (x #x-8001)))) :error
+ (typeof (ffi (enumed int16 e (x #x8000)))) :error)
+
+(mtest
+ (typeof (ffi (enumed int32 e (x 0) (y #x7fffffff)))) ffi-type
+ (typeof (ffi (enumed int32 e (x #x-80000001)))) :error
+ (typeof (ffi (enumed int32 e (x #x80000000)))) :error)
+
+(mtest
+ (typeof (ffi (enumed int64 e (x 0) (y #x7fffffffffffffff)))) ffi-type
+ (typeof (ffi (enumed int64 e (x #x-8000000000000001)))) :error
+ (typeof (ffi (enumed int64 e (x #x8000000000000000)))) :error)
+
+(typedef abc (struct abc
+ (a (enumed (bit 1 uint8) bit fals true))
+ (b (enumed (bit 1 uint8) bit fals true))
+ (c (enumed (bit 1 uint8) bit fals true))))
+
+(mtest
+ (sizeof abc) 1
+ (znew abc) #S(abc a fals b fals c fals))
+
+(each-match ((@a @b @c) (rperm '(fals true) 3))
+ (let ((s (new abc a a b b c c)))
+ (vtest (ffi-get (ffi-put s (ffi abc)) (ffi abc)) s)))
+
+(mstest
+ (copy-cptr (cptr-int 3)) "#<cptr: 3>"
+ (copy (cptr-int 3)) "#<cptr: 3>"
+ (copy-cptr 3) :error)
+
+(ffi (struct flex (x char) (y (zarray char))))
+
+(mtest
+ (ffi-put (new flex x #\a y "bcd") (ffi (struct flex))) #b'6162636400'
+ (ffi-get #b'6162636400' (ffi (struct flex))) #S(flex x #\a y "bcd"))
+
+(defvarl %big-endian% (zerop [(ffi-put #x1 (ffi uint32)) 0]))
+
+(typedef foo
+ (struct foo
+ (x (bit 48 uint64))
+ (y (bit 16 uint64))))
+
+(if %big-endian%
+ (mtest
+ (ffi-put (new foo x 1 y 1) (ffi foo)) #b'0000000000010001'
+ (ffi-put (new foo x #xABCDFFFFB00B y #x1234) (ffi foo)) #b'ABCDFFFFB00B1234')
+ (mtest
+ (ffi-put (new foo x 1 y 1) (ffi foo)) #b'0100000000000100'
+ (ffi-put (new foo x #xABCDFFFFB00B y #x1234) (ffi foo)) #b'0BB0FFFFCDAB3412'))
+
+(mtest
+ (alignof (struct empty)) 1
+ (alignof (union empty)) 1)
diff --git a/tests/017/flexstruct.tl b/tests/017/flexstruct.tl
new file mode 100644
index 00000000..8f91096e
--- /dev/null
+++ b/tests/017/flexstruct.tl
@@ -0,0 +1,73 @@
+(load "../common")
+
+(typedef fs0 (struct fs0
+ (a uint8)
+ (b (array char))))
+
+(mtest
+ (sizeof fs0) 1
+ (ffi-put #S(fs0 a 3 b "ABC") (ffi fs0)) #b'03414243'
+ (ffi-get #b'03414243' (ffi fs0)) #S(fs0 a 3 b ""))
+
+(defmeth fs0 length (s)
+ s.a)
+
+(mtest
+ (ffi-get #b'03414243' (ffi fs0)) #S(fs0 a 3 b "ABC")
+ (ffi-get #b'02e6bca2e5ad97' (ffi fs0)) #S(fs0 a 2 b "\xDCE6\xDCBC")
+ (ffi-get #b'06e6bca2e5ad97' (ffi fs0)) #S(fs0 a 6 b "漢字"))
+
+(typedef fs1 (struct fs1
+ (a uint8)
+ (b (zarray char))))
+
+(mtest
+ (sizeof fs1) 1
+ (ffi-put #S(fs1 a 3 b "ABCDEF") (ffi fs1)) #b'0341424344454600'
+ (ffi-get #b'FF41424300' (ffi fs1)) #S(fs1 a 255 b "ABC"))
+
+(mtest
+ (ffi-get #b'0341424300' (ffi fs1)) #S(fs1 a 3 b "ABC")
+ (ffi-get #b'02e6bc00' (ffi fs1)) #S(fs1 a 2 b "\xDCE6\xDCBC")
+ (ffi-get #b'06e6bca2e5ad9700' (ffi fs1)) #S(fs1 a 6 b "漢字"))
+
+(typedef fs2 (struct fs2
+ (a int8)
+ (b (array int8))))
+
+(mtest
+ (sizeof fs2) 1
+ (ffi-put #S(fs2 a 3 b "ABCD") (ffi fs2)) #b'0341424344'
+ (ffi-put #S(fs2 a 3 b #(65 66 67 68)) (ffi fs2)) #b'0341424344'
+ (ffi-get #b'FF414243' (ffi fs2)) #S(fs2 a 255 b #()))
+
+(defmeth fs2 length (s)
+ s.a)
+
+(mtest
+ (ffi-get #b'03010203' (ffi fs2)) #S(fs2 a 3 b #(1 2 3)))
+
+(typedef fs3 (struct fs3
+ (a int8)
+ (b (array le-int16))))
+
+(mtest
+ (sizeof fs3) 2
+ (ffi-put #S(fs3 a 3 b "ABCD") (ffi fs3)) #b'03004100420043004400'
+ (ffi-put #S(fs3 a 3 b #(65 66 67 68)) (ffi fs3)) #b'03004100420043004400'
+ (ffi-get #b'FF414243' (ffi fs3)) #S(fs3 a 255 b #()))
+
+(defmeth fs3 length (s)
+ s.a)
+
+(mtest
+ (ffi-get #b'0300010002000300' (ffi fs3)) #S(fs3 a 3 b #(1 2 3)))
+
+(typedef fs4 (struct fs4
+ (c int8)
+ (s fs0)))
+
+(mtest
+ (sizeof fs4) 2
+ (ffi-put #S(fs4 c 93 s #S(fs0 a 4 b "ABCD")) (ffi fs4)) #b'5d0441424344'
+ (ffi-get #b'5d0441424344' (ffi fs4)) #S(fs4 c 93 s #S(fs0 a 4 b "ABCD")))
diff --git a/tests/017/glob-carray.tl b/tests/017/glob-carray.tl
index 99660576..8e43266f 100644
--- a/tests/017/glob-carray.tl
+++ b/tests/017/glob-carray.tl
@@ -12,7 +12,7 @@
(nil int)
(pathv (carray str))
(nil (array 4 cptr)))))
- ((:cygnal :cygwin)
+ ((:cygnal :cygwin :android :bsd :openbsd)
(deffi-type glob-t (struct glob-t
(pathc size-t)
(nil size-t)
diff --git a/tests/017/glob-zarray.tl b/tests/017/glob-zarray.tl
index b095e45e..a1e532fb 100644
--- a/tests/017/glob-zarray.tl
+++ b/tests/017/glob-zarray.tl
@@ -12,7 +12,7 @@
(nil int)
(pathv (ptr-out (zarray str)))
(nil (array 4 cptr)))))
- ((:cygnal :cygwin)
+ ((:cygnal :cygwin :android :bsd :openbsd)
(deffi-type glob-t (struct glob-t
(pathc size-t)
(nil size-t)
diff --git a/tests/017/mmap.tl b/tests/017/mmap.tl
new file mode 100644
index 00000000..8ec75364
--- /dev/null
+++ b/tests/017/mmap.tl
@@ -0,0 +1,52 @@
+(load "../common")
+
+(defun parent (wp mm)
+ (with-stream (s (open-fileno wp "w"))
+ (each ((i 0..1024))
+ (set [mm i] i))
+ (put-char #\X s)))
+
+(defun child (rp mm)
+ (let ((s (open-fileno rp "r")))
+ (assert (eq (get-char s) #\X))
+ (each ((i 0..1024))
+ (assert (eql [mm i] i)))))
+
+(let ((mm (mmap (ffi uint32) 4096
+ (logior prot-read prot-write)
+ (logior map-anon map-shared))))
+ (tree-bind (rp . wp) (pipe)
+ (match-ecase (fork)
+ (0 (child rp mm)
+ (exit t))
+ (-1 (error "fork failed"))
+ (@pid (parent wp mm)
+ (tree-bind (p . s) (wait pid)
+ (unless (zerop s)
+ (error "child failed")))))))
+
+(assert (plusp page-size))
+
+(let* ((rndbuf0 (random-buf page-size))
+ (rndbuf1 (random-buf page-size))
+ (fname "rand.bin"))
+ (unwind-protect
+ (progn
+ (file-put-buf fname rndbuf0)
+ (let* ((mm (mmap (ffi uchar) page-size
+ (logior prot-read prot-write)
+ (logior map-shared)
+ fname)))
+ (each ((i 0..page-size))
+ (assert (eq [rndbuf0 i] [mm i]))
+ (set [mm i] [rndbuf1 i]))
+ (msync mm ms-sync)
+ (assert (equal (file-get-buf fname) rndbuf1))
+ (each ((i 0..page-size))
+ (set [mm i] [rndbuf0 i]))
+ (munmap mm))
+ (assert (equal (file-get-buf fname) rndbuf0)))
+ (remove-path fname)))
+
+(unless (meq (os-symbol) :bsd :openbsd)
+ (test (ignerr (mmap (ffi char) 4096 prot-read map-anon)) nil))
diff --git a/tests/017/pack-align.tl b/tests/017/pack-align.tl
new file mode 100644
index 00000000..a1048788
--- /dev/null
+++ b/tests/017/pack-align.tl
@@ -0,0 +1,112 @@
+(load "../common")
+
+(mtest
+ (alignof int) 4
+ (alignof (align int)) 16
+ (alignof (align 1 int)) 4
+ (alignof (align 6 int)) :error
+ (alignof (align 8 int)) 8)
+
+(mtest
+ (alignof (pack int)) 1
+ (alignof (pack 1 int)) 1
+ (alignof (pack 6 int)) :error
+ (alignof (pack 8 int)) 8)
+
+(mtest
+ (alignof (pack 1 (align 8 int))) 8
+ (alignof (align 8 (pack 1 int))) 8)
+
+(typedef s0 (pack (struct s0
+ (a char)
+ (b short)
+ (c int)
+ (d longlong))))
+
+(mtest
+ (alignof s0.a) 1
+ (alignof s0.b) 1
+ (alignof s0.c) 1
+ (alignof s0.d) 1)
+
+(mtest
+ (offsetof s0 a) 0
+ (offsetof s0 b) 1
+ (offsetof s0 c) 3
+ (offsetof s0 d) 7
+ (sizeof s0) 15)
+
+(typedef s1 (pack 2 (struct s1
+ (a char)
+ (b short)
+ (c int)
+ (d longlong))))
+
+(mtest
+ (alignof s1.a) 2
+ (alignof s1.b) 2
+ (alignof s1.c) 2
+ (alignof s1.d) 2)
+
+(mtest
+ (offsetof s1 a) 0
+ (offsetof s1 b) 2
+ (offsetof s1 c) 4
+ (offsetof s1 d) 8
+ (sizeof s1) 16)
+
+(typedef s2 (pack 32 (struct s2
+ (a char)
+ (b short)
+ (c int)
+ (d longlong))))
+
+(mtest
+ (alignof s2.a) 32
+ (alignof s2.b) 32
+ (alignof s2.c) 32
+ (alignof s2.d) 32)
+
+(mtest
+ (offsetof s2 a) 0
+ (offsetof s2 b) 32
+ (offsetof s2 c) 64
+ (offsetof s2 d) 96
+ (sizeof s2) 128)
+
+(typedef s3 (pack 1 (struct s3
+ (a char)
+ (b (align 2 char))
+ (c (align int))
+ (d longlong))))
+
+(mtest
+ (alignof s3.a) 1
+ (alignof s3.b) 2
+ (alignof s3.c) 16
+ (alignof s3.d) 1)
+
+(mtest
+ (offsetof s3 a) 0
+ (offsetof s3 b) 2
+ (offsetof s3 c) 16
+ (offsetof s3 d) 20
+ (sizeof s3) 32)
+
+(typedef s4 (align 256 s3))
+
+(mtest
+ (sizeof s4) 32
+ (alignof s4) 256)
+
+(typedef s5 (pack s3))
+
+(mtest
+ (sizeof s5) 32
+ (alignof s5) 1)
+
+(typedef s6 (pack (struct s3)))
+
+(mtest
+ (sizeof s6) 32
+ (alignof s6) 1)
diff --git a/tests/017/realpath.tl b/tests/017/realpath.tl
index d920825f..68ee7a7f 100644
--- a/tests/017/realpath.tl
+++ b/tests/017/realpath.tl
@@ -1,12 +1,13 @@
(load "../common")
+(when (or (memq (os-symbol) '(:cygwin :solaris :android))
+ (not (path-exists-p "/usr/bin")))
+ (put-string (file-get-string "tests/017/realpath.expected"))
+ (exit 0))
+
(with-dyn-lib (libc)
(deffi realpath-null "realpath" str-d (str str))
(deffi realpath-buf "realpath" str-d (str (ptr-in-d (zarray 8192 char)))))
-(when (memq (os-symbol) '(:cygwin :solaris))
- (put-string (file-get-string "tests/017/realpath.expected"))
- (exit 0))
-
(prinl (realpath-null "/usr/bin" nil))
(prinl (realpath-buf "/usr/bin" (copy "")))
diff --git a/tests/017/setjmp.expected b/tests/017/setjmp.expected
new file mode 100644
index 00000000..3d7a5493
--- /dev/null
+++ b/tests/017/setjmp.expected
@@ -0,0 +1,4 @@
+setjmp
+result 42
+libpng longjmp
+libpng error 42
diff --git a/tests/017/setjmp.tl b/tests/017/setjmp.tl
new file mode 100644
index 00000000..bac25957
--- /dev/null
+++ b/tests/017/setjmp.tl
@@ -0,0 +1,47 @@
+;; test local setjmp
+(let ((jb (jmp-buf)))
+ (setjmp jb result
+ (progn (put-line "setjmp")
+ (longjmp jb 42))
+ (put-line `result @result`)))
+
+(defun png-fake-output ()
+ (put-string "libpng longjmp\nlibpng error 42\n")
+ (exit))
+
+(unless (ignerr (let ((png (dlopen "libpng.so")))
+ (nequal cptr-null (dlsym png "png_set_longjmp_fn"))))
+ (png-fake-output))
+
+;; needed by png-set-longjmp-fn API
+(defvarl libc (dlopen nil))
+(defvarl longjmp-addr (dlsym libc "longjmp"))
+
+(typedef png-structp (cptr png))
+
+(with-dyn-lib "libpng.so"
+ (deffi png-get-header-ver "png_get_header_ver" str (png-structp))
+ (deffi png-create-read-struct "png_create_read_struct" png-structp (str cptr cptr cptr))
+ (deffi png-set-longjmp-fn "png_set_longjmp_fn" (carray uchar) (png-structp (cptr dlsym) size-t))
+ (deffi png-longjmp "png_longjmp" void (png-structp int)))
+
+(defvar png-ver (png-get-header-ver cptr-null))
+
+;; In the png.h header, png_setjmp is a macro only; you cannot
+;; #undef it to get to a function. So we write the macro in
+;; the same way as a Lisp macro, in terms of png-set-longjmp-fn,
+;; whereby we pass the longjmp function, and sizeof (jmp_buf).
+(defmacro png-setjmp (png-ptr)
+ (let ((jmpbuf-size (load-time (len (jmp-buf)))))
+ ^(png-set-longjmp-fn ,png-ptr longjmp-addr ,jmpbuf-size)))
+
+;;; Test
+
+;; get png handle
+(defvar png (png-create-read-struct png-ver cptr-null cptr-null cptr-null))
+
+;; get jmp_buf from png handle, setjmp it, longjmp to it.
+(setjmp (png-setjmp png) err
+ (progn (put-line "libpng longjmp")
+ (png-longjmp png 42))
+ (put-line `libpng error @err`))
diff --git a/tests/017/str-s.tl b/tests/017/str-s.tl
new file mode 100644
index 00000000..00052cbe
--- /dev/null
+++ b/tests/017/str-s.tl
@@ -0,0 +1,11 @@
+(load "../common")
+
+(with-dyn-lib (libc)
+ (deffi strtol "strtol" long (str (ptr-out (array 1 str-s)) int))
+ (deffi bcstol "strtol" long (bstr (ptr-out (array 1 bstr-s)) int))
+ (deffi wcstol "wcstol" long (wstr (ptr-out (array 1 wstr-s)) int)))
+
+(mtest
+ (let ((v (vec nil))) (list (strtol "-345x" v 0) v)) (-345 #("x"))
+ (let ((v (vec nil))) (list (bcstol "-345x" v 0) v)) (-345 #("x"))
+ (let ((v (vec nil))) (list (wcstol "-345x" v 0) v)) (-345 #("x")))
diff --git a/tests/017/variadic.expected b/tests/017/variadic.expected
new file mode 100644
index 00000000..8a918349
--- /dev/null
+++ b/tests/017/variadic.expected
@@ -0,0 +1 @@
+foo-123 = 4.560
diff --git a/tests/017/variadic.tl b/tests/017/variadic.tl
new file mode 100644
index 00000000..6fa464e0
--- /dev/null
+++ b/tests/017/variadic.tl
@@ -0,0 +1,6 @@
+(load "../common")
+
+(with-dyn-lib (libc)
+ (deffi printf-int-double "printf" int (str : int double)))
+
+(printf-int-double "foo-%d = %4.3f\n" 123 4.56)
diff --git a/tests/018/chmod.expected b/tests/018/chmod.expected
deleted file mode 100644
index e69de29b..00000000
--- a/tests/018/chmod.expected
+++ /dev/null
diff --git a/tests/018/chmod.tl b/tests/018/chmod.tl
index ada3f0be..d8663b5e 100644
--- a/tests/018/chmod.tl
+++ b/tests/018/chmod.tl
@@ -7,7 +7,9 @@
(with-stream (s (open-file tgt "w")))
(umask #o022)
-(defvarl test-sticky (progn
+(defvarl os (os-symbol))
+
+(defvarl test-sticky (unless (meq os :bsd :openbsd)
(chmod tgt s-isvtx)
(let ((st (stat tgt)))
(plusp (logand s-isvtx st.mode)))))
@@ -19,19 +21,19 @@
(when (or test-sticky
(not (find #\t `@init@mode@expected`)))
(let ((ini (dec-perm init))
- (exp (dec-perm expected)))
+ (exp (dec-perm expected)))
(chmod tgt ini)
(let* ((st (stat tgt))
- (m (mode-bits st.mode)))
- (unless (eql m ini)
- (error "failed to set initial mode: expected: ~s, actual: ~s "
- init (enc-perm m))))
+ (m (mode-bits st.mode)))
+ (unless (eql m ini)
+ (error "failed to set initial mode: expected: ~s, actual: ~s "
+ init (enc-perm m))))
(chmod tgt mode)
(let* ((st (stat tgt))
- (m (mode-bits st.mode)))
- (unless (eql m exp)
- (error "failed to set mode with ~s: expected ~s, actual ~s"
- mode expected (enc-perm m)))))))
+ (m (mode-bits st.mode)))
+ (unless (eql m exp)
+ (error "failed to set mode with ~s: expected ~s, actual ~s"
+ mode expected (enc-perm m)))))))
(cht "------------" "a+strwx" "sgtrwxrwxrwx")
(cht "------------" "+strwx" "sgtrwxr-xr-x")
@@ -39,15 +41,19 @@
(cht "------------" "g+s" "-g----------")
(cht "------------" "+t" "--t---------")
(cht "sgtrwxrwxrwx" "=" "------------")
-(cht "sgtrwxrwxrwx" "u=" "-gt---rwxrwx")
-(cht "sgtrwxrwxrwx" "g=" "s-trwx---rwx")
-(cht "sgtrwxrwxrwx" "o=" "sg-rwxrwx---")
+;; These tests don't work on Cygwin 3.1.7, Windows 10.
+;; They worked on Cygwin 2.5 on Windows 7.
+(unless (eq os :cygwin)
+ (cht "sgtrwxrwxrwx" "u=" "-gt---rwxrwx")
+ (cht "sgtrwxrwxrwx" "g=" "s-trwx---rwx")
+ (cht "sgtrwxrwxrwx" "o=" "sg-rwxrwx---"))
(cht "------------" "u+s,g+s" "sg----------")
(cht "------------" "u+r,g+r,o+r,+t,+s" "sgtr--r--r--")
(cht "------------" "+rwx,g-r+w,o-r+w" "---rwx-wx-wx")
(cht "---------rwx" "u=rwsx" "s--rwx---rwx")
-(cht "---------rwx" "u=rwsx,g=rwx,go-x" "s--rwxrw-rw-")
-(cht "---------rwx" "g=o,g-w+s,u=g,o-x" "-g-r-xr-xrw-")
+(unless (eq os :cygwin)
+ (cht "---------rwx" "u=rwsx,g=rwx,go-x" "s--rwxrw-rw-")
+ (cht "---------rwx" "g=o,g-w+s,u=g,o-x" "-g-r-xr-xrw-"))
(cht "---------rwx" "o=o" "---------rwx")
(cht "-----x------" "a+X" "-----x--x--x")
(cht "-----x------" "=,a+X" "------------")
diff --git a/tests/018/clean.expected b/tests/018/clean.expected
new file mode 100644
index 00000000..25b0c86c
--- /dev/null
+++ b/tests/018/clean.expected
@@ -0,0 +1,100 @@
+(let ((*load-path*
+ ()))
+ (clean-file "nabuchodonosor.tl"))
+-->
+(remove-path ("nabuchodonosor.tlo" nil)
+ nil)
+(remove-path ("nabuchodonosor.tlo.gz" nil)
+ nil)
+
+(let ((*load-path*
+ ()))
+ (clean-file "nabuchodonosor.txr"))
+-->
+(remove-path ("nabuchodonosor.tlo" nil)
+ nil)
+(remove-path ("nabuchodonosor.tlo.gz" nil)
+ nil)
+
+(let ((*load-path*
+ ()))
+ (clean-file "nabuchodonosor.tlo"))
+-->
+(remove-path ("nabuchodonosor.tlo" nil)
+ nil)
+
+(let ((*load-path*
+ ()))
+ (clean-file "nabuchodonosor.tlo.gz"))
+-->
+(remove-path ("nabuchodonosor.tlo.gz" nil)
+ nil)
+
+(let ((*load-path*
+ ()))
+ (clean-file "nabuchodonosor.abc"))
+-->
+(remove-path ("nabuchodonosor.abc.tlo" nil)
+ nil)
+(remove-path ("nabuchodonosor.abc.tlo.gz" nil)
+ nil)
+
+(let ((*load-path*
+ ()))
+ (clean-file "nabuchodonosor"))
+-->
+(remove-path ("nabuchodonosor.tlo" nil)
+ nil)
+(remove-path ("nabuchodonosor.tlo.gz" nil)
+ nil)
+
+(let ((*load-path*
+ "/tmp/foo.tlo"))
+ (clean-file "nabuchodonosor.tl"))
+-->
+(remove-path ("/tmp/nabuchodonosor.tlo" nil)
+ nil)
+(remove-path ("/tmp/nabuchodonosor.tlo.gz" nil)
+ nil)
+
+(let ((*load-path*
+ "/tmp/foo.tlo"))
+ (clean-file "nabuchodonosor.txr"))
+-->
+(remove-path ("/tmp/nabuchodonosor.tlo" nil)
+ nil)
+(remove-path ("/tmp/nabuchodonosor.tlo.gz" nil)
+ nil)
+
+(let ((*load-path*
+ "/tmp/foo.tlo"))
+ (clean-file "nabuchodonosor.tlo"))
+-->
+(remove-path ("/tmp/nabuchodonosor.tlo" nil)
+ nil)
+
+(let ((*load-path*
+ "/tmp/foo.tlo"))
+ (clean-file "nabuchodonosor.tlo.gz"))
+-->
+(remove-path ("/tmp/nabuchodonosor.tlo.gz" nil)
+ nil)
+
+(let ((*load-path*
+ "/tmp/foo.tlo"))
+ (clean-file "nabuchodonosor.abc"))
+-->
+(remove-path ("/tmp/nabuchodonosor.abc.tlo" nil)
+ nil)
+(remove-path ("/tmp/nabuchodonosor.abc.tlo.gz" nil)
+ nil)
+
+(let ((*load-path*
+ "/tmp/foo.tlo"))
+ (clean-file "nabuchodonosor"))
+-->
+(remove-path ("/tmp/nabuchodonosor.tlo" nil)
+ nil)
+(remove-path ("/tmp/nabuchodonosor.tlo.gz" nil)
+ nil)
+
diff --git a/tests/018/clean.tl b/tests/018/clean.tl
new file mode 100644
index 00000000..ed6f29a3
--- /dev/null
+++ b/tests/018/clean.tl
@@ -0,0 +1,10 @@
+(trace remove-path)
+
+(each ((*load-path* '(nil "/tmp/foo.tlo")))
+ (each ((name '#"nabuchodonosor.tl nabuchodonosor.txr \
+ nabuchodonosor.tlo nabuchodonosor.tlo.gz \
+ nabuchodonosor.abc nabuchodonosor"))
+ (prinl ^(let ((*load-path* , *load-path*)) (clean-file ,name)))
+ (put-line "-->")
+ (clean-file name)
+ (put-line)))
diff --git a/tests/018/close-delegate.expected b/tests/018/close-delegate.expected
new file mode 100644
index 00000000..de68447f
--- /dev/null
+++ b/tests/018/close-delegate.expected
@@ -0,0 +1,6 @@
+close called, count 2
+close called, count 1
+40
+close called, count 2
+close called, count 1
+40
diff --git a/tests/018/close-delegate.tl b/tests/018/close-delegate.tl
new file mode 100644
index 00000000..64a1dc91
--- /dev/null
+++ b/tests/018/close-delegate.tl
@@ -0,0 +1,40 @@
+(load "../common")
+
+(defstruct refcount-close stream-wrap
+ stream
+ (count 1)
+
+ (:method close (me throw-on-error-p)
+ (put-line `close called, count @{me.count}`)
+ (when (plusp me.count)
+ (if (zerop (dec me.count))
+ (close-stream me.stream throw-on-error-p)))))
+
+(flow
+ (with-stream (s (make-struct-delegate-stream
+ (new refcount-close
+ count 2
+ stream (open-file *load-path*))))
+ (get-lines s))
+ len
+ prinl)
+
+(defstruct refcount-close-alt stream-wrap
+ stream
+ (count 1)
+
+ (:method close (me throw-on-error-p)
+ (put-line `close called, count @{me.count}`)
+ (when (plusp me.count)
+ (if (zerop (dec me.count))
+ (close-stream me.stream throw-on-error-p)
+ :))))
+
+(flow
+ (with-stream (s (make-struct-delegate-stream
+ (new refcount-close-alt
+ count 2
+ stream (open-file *load-path*))))
+ (get-lines s))
+ len
+ prinl)
diff --git a/tests/018/close-lazy.tl b/tests/018/close-lazy.tl
new file mode 100644
index 00000000..c6b08e72
--- /dev/null
+++ b/tests/018/close-lazy.tl
@@ -0,0 +1,3 @@
+(dotimes (i 20000)
+ (close-lazy-streams
+ (file-get-lines self-path)))
diff --git a/tests/018/combine-tlo.tl b/tests/018/combine-tlo.tl
new file mode 100644
index 00000000..e2dc0f83
--- /dev/null
+++ b/tests/018/combine-tlo.tl
@@ -0,0 +1,27 @@
+(load "../common")
+
+(push-after-load
+ (remove-path "libfile.tl")
+ (remove-path "libfile.tlo")
+ (remove-path "mainfile.tl")
+ (remove-path "mainfile.tlo")
+ (remove-path "progfile"))
+
+(file-put-lines
+ "libfile.tl"
+ ^(,`#!@{txr-exe-path} --lisp`
+ "(defun libfun ()"
+ " (put-line \"libfun\"))"))
+
+(file-put-lines
+ "mainfile.tl"
+ '("(compile-only (libfun))"))
+
+(compile-file "./libfile")
+(compile-file "./mainfile")
+
+(cat-files "progfile" "libfile.tlo" "mainfile.tlo")
+
+(chmod "progfile" "+x")
+
+(test (command-get-lines "./progfile") ("libfun"))
diff --git a/tests/018/crypt.tl b/tests/018/crypt.tl
new file mode 100644
index 00000000..dc044878
--- /dev/null
+++ b/tests/018/crypt.tl
@@ -0,0 +1,23 @@
+(load "../common")
+
+(if (meq (os-symbol) :android :cygwin)
+ (exit))
+
+(mtest
+ (crypt nil nil) :error)
+
+(if (neq :openbsd (os-symbol))
+ (mtest
+ (crypt "a" "bc") "bcshMw5X24ayQ"
+ (crypt "a" "bcd") "bcshMw5X24ayQ"))
+
+(if (eq :linux (os-symbol))
+ (mtest
+ (crypt "a" "b") :error
+ (crypt "a" "::") :error
+ (crypt "a" "$1$") "$1$$Ij31LCAysPM23KuPlm1wA/"
+ (crypt "a" "$1$bcd$") "$1$bcd$cgz778Ks3pkbWfyW.CWae/"
+ (crypt "a" "$5$") "$5$$QG6CCM7eJAxpUPcBpn0Z2K29NHtaI6Mk1fCpPrpjdj3"
+ (crypt "a" "$5$bcd$") "$5$bcd$OGt98FNCHtKIrT6qWAKLXOQ8eIApFT5dJngrYreMwF3"
+ (crypt "a" "$6$") "$6$$ek/ucQg0IM8SQLyD2D66mpoW0vAF26eA0/pqoN95V.F0nZh1IFuENNo0OikacRkDBk5frNqziMYMdVVrQ0o.51"
+ (crypt "a" "$6$bcd$") "$6$bcd$RK8RFj8wSE1NBJi8s.KDjGQK3EbpI474a6f4UP0LGOkQU50ZQrwykBaSjx7tZFVEpanpL44zd1p6A9q.sy.YH0"))
diff --git a/tests/018/errno.tl b/tests/018/errno.tl
new file mode 100644
index 00000000..ec204b23
--- /dev/null
+++ b/tests/018/errno.tl
@@ -0,0 +1,8 @@
+(load "../common")
+
+(vtest
+ (catch
+ (open-file "/NoNeXiStEnT")
+ (error (msg)
+ (string-get-code msg)))
+ enoent)
diff --git a/tests/018/forkflush.expected b/tests/018/forkflush.expected
new file mode 100644
index 00000000..475f87b1
--- /dev/null
+++ b/tests/018/forkflush.expected
@@ -0,0 +1,12 @@
+A
+B
+C
+D
+E
+F
+G
+H
+I
+J
+K
+L
diff --git a/tests/018/forkflush.tl b/tests/018/forkflush.tl
new file mode 100644
index 00000000..296cec02
--- /dev/null
+++ b/tests/018/forkflush.tl
@@ -0,0 +1,36 @@
+(load "../common")
+
+(defvarl os (os-symbol))
+
+(push-after-load (remove-path "tmpfile"))
+
+(with-stream (*stdout* (open-file "tmpfile" "w"))
+ (cond
+ ((eq os :cygwin)
+ (put-string "A\nB\nC\nD\n"))
+ (t (put-line "A")
+ (sh "echo B")
+ (put-line "C")
+ (sh "echo D"))))
+
+(put-string (file-get-string "tmpfile"))
+
+(with-stream (*stdout* (open-file "tmpfile" "w"))
+ (put-line "E")
+ (with-stream (s (open-process "cat" "w"))
+ (put-line "F" s))
+ (put-line "G")
+ (with-stream (s (open-process "cat" "w"))
+ (put-line "H" s)))
+
+(put-string (file-get-string "tmpfile"))
+
+(with-stream (*stdout* (open-file "tmpfile" "w"))
+ (put-line "I")
+ (with-stream (s (open-command "cat" "w"))
+ (put-line "J" s))
+ (put-line "K")
+ (with-stream (s (open-command "cat" "w"))
+ (put-line "L" s)))
+
+(put-string (file-get-string "tmpfile"))
diff --git a/tests/018/format.tl b/tests/018/format.tl
new file mode 100644
index 00000000..6fc27b4e
--- /dev/null
+++ b/tests/018/format.tl
@@ -0,0 +1,273 @@
+(load "../common")
+
+(mtest
+ (fmt "~x" #b'') ""
+ (fmt "~4x" #b'') " "
+ (fmt "~4,02x" #b'') " 00"
+ (fmt "~x" #b'AF') "af"
+ (fmt "~4x" #b'AF') " af"
+ (fmt "~-4x" #b'AF') "af "
+ (fmt "~4,03x" #b'AF') " 0af"
+ (fmt "~-4,03X" #b'AF') "0AF ")
+
+(mtest
+ (fmt "~x" #\xaf) "af"
+ (fmt "~4x" #\xaf) " af"
+ (fmt "~-4x" #\xaf) "af "
+ (fmt "~4,03x" #\xaf) " 0af"
+ (fmt "~-4,03X" #\xaf) "0AF ")
+
+(mtest
+ (fmt "~x" #xaf) "af"
+ (fmt "~4x" #xaf) " af"
+ (fmt "~-4x" #xaf) "af "
+ (fmt "~4,03x" #xaf) " 0af"
+ (fmt "~-4,03X" #xaf) "0AF ")
+
+(test
+ (fmt "~x" (sha256 "abc"))
+ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad")
+
+(mtest
+ (fmt "~8,02f" 12) " 0012.00"
+ (fmt "~8,+02f" 12) "+0012.00"
+ (fmt "~8,-02f" 12) "00012.00"
+ (fmt "~8, 02f" 12) " 0012.00"
+ (fmt "~8,-02f" -12) "-0012.00"
+ (fmt "~6,02f" 12) " 12.00"
+ (fmt "~6,+02f" 12) "+12.00"
+ (fmt "~6,-02f" 12) "012.00"
+ (fmt "~6,- 2f" 12) " 12.00"
+ (fmt "~6,-02f" -12) "-12.00"
+ (fmt "~5,02f" 12) "12.00"
+ (fmt "~5,+02f" 12) "+12.00"
+ (fmt "~5,-02f" 12) "12.00"
+ (fmt "~5,- 2f" 12) "12.00"
+ (fmt "~5,-02f" -12) "-12.00")
+
+(mtest
+ (fmt "~<8,02f" 12) "0012.00 "
+ (fmt "~<8,+02f" 12) "+0012.00"
+ (fmt "~<8,-02f" 12) "00012.00"
+ (fmt "~<8, 02f" 12) " 0012.00"
+ (fmt "~<8,-02f" -12) "-0012.00"
+ (fmt "~<6,02f" 12) "12.00 "
+ (fmt "~<6,+02f" 12) "+12.00"
+ (fmt "~<6,-02f" 12) "012.00"
+ (fmt "~<6,- 2f" 12) " 12.00"
+ (fmt "~<6,-02f" -12) "-12.00"
+ (fmt "~<5,02f" 12) "12.00"
+ (fmt "~<5,+02f" 12) "+12.00"
+ (fmt "~<5,-02f" 12) "12.00"
+ (fmt "~<5,- 2f" 12) "12.00"
+ (fmt "~<5,-02f" -12) "-12.00")
+
+(mtest
+ (fmt "~<8,2a" 12) "12 "
+ (fmt "~<8,02a" 12) "12 "
+ (fmt "~<8,+02a" 12) "+12 "
+ (fmt "~<8,-02a" 12) "012 "
+ (fmt "~<8, 02a" 12) " 12 "
+ (fmt "~<8,2a" 12.0) "12 "
+ (fmt "~<8,02a" 12.0) "12 "
+ (fmt "~<8,+02a" 12.0) "+12 "
+ (fmt "~<8,-02a" 12.0) "012 "
+ (fmt "~<8, 02a" 12.0) " 12 "
+ (fmt "~<8,4a" 12.0) " 12 "
+ (fmt "~<8,04a" 12.0) "0012 "
+ (fmt "~<8,+04a" 12.0) "+0012 "
+ (fmt "~<8,-04a" 12.0) "00012 "
+ (fmt "~<8, 04a" 12.0) " 0012 "
+ (fmt "~<8,8a" 12.0) " 12 "
+ (fmt "~<8,08a" 12.0) "0000012 "
+ (fmt "~<8,+08a" 12.0) "+0000012"
+ (fmt "~<8,-08a" 12.0) "00000012"
+ (fmt "~<8, 08a" 12.0) " 0000012")
+
+(mtest
+ (fmt "~,04a" 1) "0001"
+ (fmt "~,4a" 1) " 1"
+ (fmt "~4,a" 1) " 1"
+ (fmt "~<8,a" 1) "1 "
+ (fmt "~<8,0a" 1) "1 "
+ (fmt "~<8,4a" 1) " 1 "
+ (fmt "~<8,04a" 1) "0001 "
+ (fmt "~<8,+04a" 1) "+0001 "
+ (fmt "~<,4a" 1) " 1")
+
+(mtest
+ (fmt "~,04a" 1) "0001"
+ (fmt "~,4a" 1) " 1"
+ (fmt "~4,a" 1) " 1"
+ (fmt "~<8,a" 1) "1 "
+ (fmt "~<8,0a" 1) "1 "
+ (fmt "~<8,4a" 1) " 1 "
+ (fmt "~<8,04a" 1) "0001 "
+ (fmt "~<8,+04a" 1) "+0001 "
+ (fmt "~<,4a" 1) " 1")
+
+(mtest
+ (fmt "~e" 1.2e13) "1.200e13"
+ (fmt "~,2e" 1.2e13) "1.20e13"
+ (fmt "~,0e" 1.2e13) "1e13"
+ (fmt "~8,0e" 1.2e13) " 1e13"
+ (fmt "~8,00e" 1.2e13) " 0001e13"
+ (fmt "~8,-0e" 1.2e13) " 01e13"
+ (fmt "~8,-00e" 1.2e13) "00001e13"
+ (fmt "~8, 00e" 1.2e13) " 0001e13"
+ (fmt "~8,+00e" 1.2e13) "+0001e13"
+ (fmt "~8,+00e" -1.2e13) "-0001e13"
+ (fmt "~8,00e" -1.2e13) "-0001e13"
+ (fmt "~<8,0e" 1.2e13) " 1e13 "
+ (fmt "~<8,00e" 1.2e13) "0001e13 "
+ (fmt "~<8,-0e" 1.2e13) " 01e13"
+ (fmt "~<8,-00e" 1.2e13) "00001e13"
+ (fmt "~<8,+00e" 1.2e13) "+0001e13")
+
+(mtest
+ (pic "") ""
+ (pic "~") :error
+ (pic "~z") :error
+ (pic "#") :error
+ (pic "# #" 1) :error
+ (pic "# # #" 1 2) :error
+ (pic "# # #" 1 2 3 4) :warning
+ (pic "~<") "<"
+ (pic "~>") ">"
+ (pic "~|") "|"
+ (pic "~#") "#"
+ (pic "~0") "0"
+ (pic "~+") "+"
+ (pic "~-") "-"
+ (pic "~.") "."
+ (pic "~!") "!"
+ (pic "~~") "~"
+ (pic "x~~y") "x~y"
+ (pic "~~x~~~~y~~") "~x~~y~")
+
+(mtest
+ (pic "<" "a") "a"
+ (pic "<<" "a") "a "
+ (pic "<<<" "a") "a "
+ (pic "~<<~>" "a") "<a>"
+ (pic "~<<<~>" "a") "<a >"
+ (pic "~<<<<~>" "a") "<a >")
+
+(mtest
+ (pic ">" "a") "a"
+ (pic ">>" "a") " a"
+ (pic ">>>" "a") " a"
+ (pic "~>>~<" "a") ">a<"
+ (pic "~>>>~<" "a") "> a<"
+ (pic "~>>>>~<" "a") "> a<")
+
+(mtest
+ (pic "|" "a") "a"
+ (pic "||" "a") "a "
+ (pic "|||" "a") " a "
+ (pic "||||" "a") " a "
+ (pic "|||||" "a") " a "
+ (pic "|||||" "aaa") " aaa "
+ (pic "|||||" "aaaaa") "aaaaa"
+ (pic "|||||" "aaaaaa") "aaaaaa"
+ (pic "~||~|" "a") "|a|"
+ (pic "~|||~|" "a") "|a |"
+ (pic "~||||~|" "a") "| a |")
+
+(mtest
+ (pic "#" 0) "0"
+ (pic "#" 0.0) "0"
+ (pic "#" 0.1) "0"
+ (pic "#" 0.7) "1"
+ (pic "+#" 0.7) "+1"
+ (pic "-#" -0.7) "-1"
+ (pic "+#" -0.7) "-1"
+ (pic "-#" 0.7) " 1")
+
+(mtest
+ (pic "####" 1234) "1234"
+ (pic "####" 1234.1) "1234"
+ (pic "#" 1) "1"
+ (pic "#.#" 1) "1.0"
+ (pic "######" 1234.1) " 1234"
+ (pic "######.#" 1234.1) " 1234.1"
+ (pic "#######.##" 1234.1) " 1234.10"
+ (pic "#######.##" -1234.1) " -1234.10"
+ (pic "0######.##" 1234.1) "0001234.10"
+ (pic "+######.##" 1234.1) " +1234.10"
+ (pic "-######.##" 1234.1) " 1234.10"
+ (pic "+0#####.##" 1234.1) "+001234.10"
+ (pic "-0#####.##" 1234.1) " 001234.10")
+
+(mtest
+ (pic "#!#" 1234) "#.#"
+ (pic "#!#" 123) "#.#"
+ (pic "#.#" 123) "123.0")
+
+(mtest
+ (pic "-##!#" 12) " 12.0"
+ (pic "+##!#" 12) "+12.0"
+ (pic "-##!#" -123) "###.#"
+ (pic "+##!#" 123) "###.#")
+
+(mtest
+ (pic "###!" 123) "123"
+ (pic "###." 123) "123."
+ (pic "###!" 1234) "###")
+
+(mtest
+ (pic "X##.#Y<<<Z>>>W" 1 2 3) "X 1.0Y2 Z 3W"
+ (pic "~###.#~#<<<~#>>>~#" 1 2 3) "# 1.0#2 # 3#")
+
+(mtest
+ (pic "#,#,#,#" 1234) "1,2,3,4"
+ (pic "#,##,#" 1234) "1,23,4"
+ (pic "##,##" 1234) "12,34"
+ (pic "###," 1234) "1234,"
+ (pic ",###" 1234) ",1234"
+ (pic "##,##" 1234.1) "12,34"
+ (pic "#,###,###.###,###" 1234.1) " 1,234.100,000"
+ (pic "#,###,###.##" -1234.1) " -1,234.10"
+ (pic "0,###,###.##" 1234.1) "0,001,234.10"
+ (pic "+#,##,###.##" 234.1) " +234.10"
+ (pic "+#,##,###.##"
+ 123456.7) "+1,23,456.70"
+ (pic "+#,##,###.##" 1234.1) " +1,234.10"
+ (pic "-#,##,###.##" 1234.1) " 1,234.10"
+ (pic "+0,#####.##" 1234.1) "+0,01234.10"
+ (pic "-0,#####.##" 1234.1) " 0,01234.10")
+
+(mtest
+ (pic "$###,###!##" 234567.89) "$234,567.89"
+ (pic "$###,###!##" 1234567.89) "$###,###.##"
+ (pic "#,#,#!" 123) "1,2,3"
+ (pic "#,#,#!" 1234) "#,#,#")
+
+(mtest
+ (pic "(#,###,###.##)" 123456.56) " 123,456.56 "
+ (pic "(#,###,###.##)" 1234566.56) " 1,234,566.56 "
+ (pic "(#,###,###.##)" 12345667.56) "12,345,667.56 "
+ (pic "(#,###,###.##)" 123456678.56) "123,456,678.56"
+ (pic "(#,###,###.##)" -123456.56) "( 123,456.56)"
+ (pic "(#,###,###.##)" -1234566.56) "(1,234,566.56)"
+ (pic "(#,###,###.##)" -12345667.56) "(12,345,667.56)"
+ (pic "(#,###,###.##)" -123456678.56) "(123,456,678.56)")
+
+(mtest
+ (pic "(0,###,###.##)" 123456.56) " 0,123,456.56 "
+ (pic "(0,###,###.##)" 1234566.56) " 1,234,566.56 "
+ (pic "(0,###,###.##)" 12345667.56) "12,345,667.56 "
+ (pic "(0,###,###.##)" 123456678.56) "123,456,678.56"
+ (pic "(0,###,###.##)" -123456.56) "(0,123,456.56)"
+ (pic "(0,###,###.##)" -1234566.56) "(1,234,566.56)"
+ (pic "(0,###,###.##)" -12345667.56) "(12,345,667.56)"
+ (pic "(0,###,###.##)" -123456678.56) "(123,456,678.56)")
+
+(test
+ (let ((a 2) (b "###") (c 13.5))
+ (pic `abc@(+ a a)###.##@b>>>>` c "x"))
+ "abc4 13.50### x")
+
+(test
+ (pic "+0####.## <<<<<" 123 1)
+ "+00123.00 1 ")
diff --git a/tests/018/getput.tl b/tests/018/getput.tl
new file mode 100644
index 00000000..7e8e2be1
--- /dev/null
+++ b/tests/018/getput.tl
@@ -0,0 +1,33 @@
+(load "../common")
+
+(defvarl file "getput.data")
+
+(push-after-load (remove-path file))
+
+(file-put-objects file '(1 2.3 (a . b) "foo"))
+
+(test
+ (file-get-lines file) ("1" "2.3" "(a . b)" "\"foo\""))
+
+(file-append-objects file '(#(nil)))
+
+(mtest
+ (file-get-lines file) ("1" "2.3" "(a . b)" "\"foo\"" "#(nil)")
+ (file-get-objects file) (1 2.3 (a . b) "foo" #(nil)))
+
+(mtest
+ (read-objects "(a . b) #\\c") ((a . b) #\c)
+ (read-objects "(a") :error)
+
+(file-put-string file "(a")
+
+(mtest
+ (file-get file) :error
+ (file-get-objects file) :error)
+
+(let ((errors (with-out-string-stream (err)
+ (ignerr (file-get-objects file : err)))))
+ (mtest
+ (true (contains "syntax error" errors)) t
+ (true (contains "unterminated" errors)) t
+ (true (contains ":1" errors)) t))
diff --git a/tests/018/glob.tl b/tests/018/glob.tl
new file mode 100644
index 00000000..438e4c65
--- /dev/null
+++ b/tests/018/glob.tl
@@ -0,0 +1,142 @@
+(load "../common")
+
+;; Passes on Cygwin, but too slow!
+(if (eq (os-symbol) :cygwin)
+ (exit))
+
+(mtest
+ (sys:brace-expand "~/{Downloads,Pictures}/*.{jpg,gif,png}")
+ #"~/Downloads/*.jpg ~/Downloads/*.gif ~/Downloads/*.png \
+ ~/Pictures/*.jpg ~/Pictures/*.gif ~/Pictures/*.png"
+ (sys:brace-expand "It{{em,alic}iz,erat}e{d,}, please.")
+ ("Itemized, please." "Itemize, please." "Italicized, please."
+ "Italicize, please." "Iterated, please." "Iterate, please.")
+ (sys:brace-expand "{,{,gotta have{ ,\\, again\\, }}more }cowbell!")
+ ("cowbell!" "more cowbell!" "gotta have more cowbell!"
+ "gotta have\\, again\\, more cowbell!")
+ (sys:brace-expand "{}} some }{,{\\\\{ edge, edge} \\,}{ cases, {here} \\\\\\\\\\}")
+ ("{}} some }{,{\\\\ edge \\,}{ cases, {here} \\\\\\\\\\}"
+ "{}} some }{,{\\\\ edge \\,}{ cases, {here} \\\\\\\\\\}"))
+
+(mtest
+ (glob* "tests/**/002") ("tests/002")
+ (glob* "tests/**/{003,004}") ("tests/003" "tests/004"))
+
+(chdir "tests/002/proc")
+
+(mtest
+ (glob* "**")
+ ("1" "1/status" "1/tasks" "103" "103/status" "103/tasks" "1068"
+ "1068/status" "1068/tasks" "1235" "1235/status" "1235/tasks"
+ "1236" "1236/status" "1236/tasks" "15812" "15812/status" "15812/tasks"
+ "16" "16/status" "16/tasks" "1620" "1620/status" "1620/tasks"
+ "1624" "1624/status" "1624/tasks" "16248" "16248/status" "16248/tasks"
+ "16249" "16249/status" "16249/tasks" "1645" "1645/status" "1645/tasks"
+ "16598" "16598/tasks" "1665" "1665/status" "1665/tasks" "1698"
+ "1698/status" "1698/tasks" "17" "17/status" "17/tasks" "175"
+ "175/status" "175/tasks" "1766" "1766/status" "1766/tasks" "1790"
+ "1790/status" "1790/tasks" "1791" "1791/status" "1791/tasks"
+ "1821" "1821/status" "1821/tasks" "1839" "1839/status" "1839/tasks"
+ "1851" "1851/status" "1851/tasks" "186" "186/status" "186/tasks"
+ "18614" "18614/tasks" "1887" "1887/status" "1887/tasks" "1902"
+ "1902/status" "1902/tasks" "1921" "1921/status" "1921/tasks"
+ "1925" "1925/status" "1925/tasks" "1926" "1926/status" "1926/tasks"
+ "1927" "1927/status" "1927/tasks" "1928" "1928/status" "1928/tasks"
+ "1929" "1929/status" "1929/tasks" "1930" "1930/status" "1930/tasks"
+ "1931" "1931/status" "1931/tasks" "1932" "1932/status" "1932/tasks"
+ "1936" "1936/status" "1936/tasks" "1963" "1963/status" "1963/tasks"
+ "1989" "1989/status" "1989/tasks" "2" "2/status" "2/tasks" "2008"
+ "2008/status" "2008/tasks" "2027" "2027/status" "2027/tasks"
+ "2041" "2041/status" "2041/tasks" "2052" "2052/status" "2052/tasks"
+ "2062" "2062/status" "2062/tasks" "2124" "2124/status" "2124/tasks"
+ "2184" "2184/status" "2184/tasks" "2354" "2354/status" "2354/tasks"
+ "24134" "24134/tasks" "2551" "2551/status" "2551/tasks" "2579"
+ "2579/status" "2579/tasks" "2625" "2625/status" "2625/tasks"
+ "2626" "2626/status" "2626/tasks" "2631" "2631/status" "2631/tasks"
+ "2634" "2634/status" "2634/tasks" "2636" "2636/status" "2636/tasks"
+ "2638" "2638/status" "2638/tasks" "2644" "2644/status" "2644/tasks"
+ "2661" "2661/status" "2661/tasks" "2685" "2685/status" "2685/tasks"
+ "2689" "2689/status" "2689/tasks" "2691" "2691/status" "2691/tasks"
+ "2693" "2693/status" "2693/tasks" "2695" "2695/status" "2695/tasks"
+ "2698" "2698/status" "2698/tasks" "2701" "2701/status" "2701/tasks"
+ "2707" "2707/status" "2707/tasks" "27121" "27121/status" "27121/tasks"
+ "2717" "2717/status" "2717/tasks" "2718" "2718/status" "2718/tasks"
+ "2720" "2720/status" "2720/tasks" "2722" "2722/status" "2722/tasks"
+ "27243" "27243/status" "27243/tasks" "2726" "2726/status" "2726/tasks"
+ "2728" "2728/status" "2728/tasks" "27682" "27682/status" "27682/tasks"
+ "27684" "27684/status" "27684/tasks" "27685" "27685/status" "27685/tasks"
+ "28" "28/status" "28/tasks" "29" "29/status" "29/tasks" "29840"
+ "29840/status" "29840/tasks" "3" "3/status" "3/tasks" "30737"
+ "30737/status" "30737/tasks" "31905" "31905/status" "31905/tasks"
+ "31907" "31907/status" "31907/tasks" "31908" "31908/status" "31908/tasks"
+ "32672" "32672/status" "32672/tasks" "32674" "32674/status" "32674/tasks"
+ "32675" "32675/status" "32675/tasks" "4" "4/status" "4/tasks"
+ "5" "5/status" "5/tasks" "870" "870/status" "870/tasks")
+ (glob "**/")
+ ("1/" "103/" "1068/" "1235/" "1236/" "15812/" "16/" "1620/" "1624/"
+ "16248/" "16249/" "1645/" "16598/" "1665/" "1698/" "17/" "175/"
+ "1766/" "1790/" "1791/" "1821/" "1839/" "1851/" "186/" "18614/"
+ "1887/" "1902/" "1921/" "1925/" "1926/" "1927/" "1928/" "1929/"
+ "1930/" "1931/" "1932/" "1936/" "1963/" "1989/" "2/" "2008/"
+ "2027/" "2041/" "2052/" "2062/" "2124/" "2184/" "2354/" "24134/"
+ "2551/" "2579/" "2625/" "2626/" "2631/" "2634/" "2636/" "2638/"
+ "2644/" "2661/" "2685/" "2689/" "2691/" "2693/" "2695/" "2698/"
+ "2701/" "2707/" "27121/" "2717/" "2718/" "2720/" "2722/" "27243/"
+ "2726/" "2728/" "27682/" "27684/" "27685/" "28/" "29/" "29840/"
+ "3/" "30737/" "31905/" "31907/" "31908/" "32672/" "32674/" "32675/"
+ "4/" "5/" "870/"))
+
+(chdir "../..")
+
+(mtest
+ (glob* "**/3*/**")
+ ("002/proc/3/" "002/proc/3/status" "002/proc/3/tasks" "002/proc/30737/"
+ "002/proc/30737/status" "002/proc/30737/tasks" "002/proc/31905/"
+ "002/proc/31905/status" "002/proc/31905/tasks" "002/proc/31907/"
+ "002/proc/31907/status" "002/proc/31907/tasks" "002/proc/31908/"
+ "002/proc/31908/status" "002/proc/31908/tasks" "002/proc/32672/"
+ "002/proc/32672/status" "002/proc/32672/tasks" "002/proc/32674/"
+ "002/proc/32674/status" "002/proc/32674/tasks" "002/proc/32675/"
+ "002/proc/32675/status" "002/proc/32675/tasks")
+ (glob* "**/{3,4,5}*/**")
+ ("002/proc/3/" "002/proc/3/status" "002/proc/3/tasks" "002/proc/30737/"
+ "002/proc/30737/status" "002/proc/30737/tasks" "002/proc/31905/"
+ "002/proc/31905/status" "002/proc/31905/tasks" "002/proc/31907/"
+ "002/proc/31907/status" "002/proc/31907/tasks" "002/proc/31908/"
+ "002/proc/31908/status" "002/proc/31908/tasks" "002/proc/32672/"
+ "002/proc/32672/status" "002/proc/32672/tasks" "002/proc/32674/"
+ "002/proc/32674/status" "002/proc/32674/tasks" "002/proc/32675/"
+ "002/proc/32675/status" "002/proc/32675/tasks" "002/proc/4/"
+ "002/proc/4/status" "002/proc/4/tasks" "002/proc/5/" "002/proc/5/status"
+ "002/proc/5/tasks")
+ (glob* "**/{3,4,5}*/**" glob-xnobrace)
+ nil
+ (len (glob* "**/proc/**/**"))
+ 366)
+
+(if (neq (os-symbol) :solaris)
+ (test
+ (glob* "002/proc\\/**")
+ ("002/proc/1" "002/proc/103" "002/proc/1068" "002/proc/1235" "002/proc/1236"
+ "002/proc/15812" "002/proc/16" "002/proc/1620" "002/proc/1624"
+ "002/proc/16248" "002/proc/16249" "002/proc/1645" "002/proc/16598"
+ "002/proc/1665" "002/proc/1698" "002/proc/17" "002/proc/175"
+ "002/proc/1766" "002/proc/1790" "002/proc/1791" "002/proc/1821"
+ "002/proc/1839" "002/proc/1851" "002/proc/186" "002/proc/18614"
+ "002/proc/1887" "002/proc/1902" "002/proc/1921" "002/proc/1925"
+ "002/proc/1926" "002/proc/1927" "002/proc/1928" "002/proc/1929"
+ "002/proc/1930" "002/proc/1931" "002/proc/1932" "002/proc/1936"
+ "002/proc/1963" "002/proc/1989" "002/proc/2" "002/proc/2008"
+ "002/proc/2027" "002/proc/2041" "002/proc/2052" "002/proc/2062"
+ "002/proc/2124" "002/proc/2184" "002/proc/2354" "002/proc/24134"
+ "002/proc/2551" "002/proc/2579" "002/proc/2625" "002/proc/2626"
+ "002/proc/2631" "002/proc/2634" "002/proc/2636" "002/proc/2638"
+ "002/proc/2644" "002/proc/2661" "002/proc/2685" "002/proc/2689"
+ "002/proc/2691" "002/proc/2693" "002/proc/2695" "002/proc/2698"
+ "002/proc/2701" "002/proc/2707" "002/proc/27121" "002/proc/2717"
+ "002/proc/2718" "002/proc/2720" "002/proc/2722" "002/proc/27243"
+ "002/proc/2726" "002/proc/2728" "002/proc/27682" "002/proc/27684"
+ "002/proc/27685" "002/proc/28" "002/proc/29" "002/proc/29840"
+ "002/proc/3" "002/proc/30737" "002/proc/31905" "002/proc/31907"
+ "002/proc/31908" "002/proc/32672" "002/proc/32674" "002/proc/32675"
+ "002/proc/4" "002/proc/5" "002/proc/870")))
diff --git a/tests/018/gzip.tl b/tests/018/gzip.tl
new file mode 100644
index 00000000..712ade3c
--- /dev/null
+++ b/tests/018/gzip.tl
@@ -0,0 +1,59 @@
+(load "../common")
+
+(if (not (fboundp 'usr:buf-compress))
+ (exit))
+
+(defvarl %have-gzip% (sh "gzip -h > /dev/null 2> /dev/null"))
+
+(defun shchk (cmd)
+ (unless (zerop (sh cmd))
+ (throw `command @cmd failed`)))
+
+(defun gzip (. files)
+ (each ((file files))
+ (file-put-string `@file.gz` (file-get-string file) "z")))
+
+(defun cat (dest . files)
+ (remove-path dest)
+ (each ((file files))
+ (file-append-string dest (file-get-string file))))
+
+(push-after-load
+ (each ((file '#"test-file test-file.gz \
+ test-file-a.tl test-file-a.tlo test-file-a.tlo.gz \
+ test-file-b.tl test-file-b.tlo test-file-b.tlo.gz \
+ test-file-combined.tlo.gz"))
+ (remove-path file)))
+
+(when %have-gzip%
+ (file-put-string "test-file" "Hello, World!")
+ (remove-path "test-file.gz")
+ (cond ((eq (os-symbol) :openbsd)
+ (shchk "gzip -f test-file"))
+ (t (shchk "gzip test-file")))
+ (test (file-get-string "test-file.gz" "z") "Hello, World!")
+
+ (each ((mode (cons "z" (list-seq "z0".."z9"))))
+ (file-put-string "test-file.gz" "Goodbye, World!" mode)
+ (remove-path "test-file")
+ (shchk "gunzip test-file.gz")
+ (test (file-get-string "test-file") "Goodbye, World!"))
+
+ (file-put "test-file-a.tl" '(compile-only (put-line "a")))
+ (file-put "test-file-b.tl" '(compile-only (put-line "b")))
+
+ (compile-update-file "./test-file-a")
+ (compile-update-file "./test-file-b")
+
+ (gzip "test-file-a.tlo" "test-file-b.tlo")
+
+ (cat "test-file-combined.tlo.gz" "test-file-a.tlo.gz" "test-file-b.tlo.gz")
+
+ (test
+ (with-out-string-stream (*stdout*)
+ (load "./test-file-combined.tlo.gz"))
+ "a\nb\n"))
+
+(when %have-gzip%
+ (with-stream (s (open-command "echo abc | gzip -c" "z"))
+ (test (get-line s) "abc")))
diff --git a/tests/018/noclose.expected b/tests/018/noclose.expected
new file mode 100644
index 00000000..cad99e12
--- /dev/null
+++ b/tests/018/noclose.expected
@@ -0,0 +1 @@
+caught
diff --git a/tests/018/noclose.txr b/tests/018/noclose.txr
new file mode 100644
index 00000000..cf39b702
--- /dev/null
+++ b/tests/018/noclose.txr
@@ -0,0 +1,16 @@
+@(next :list [mapcar tostring (range 1 20000)])
+@(collect)
+@num
+@(next self-path)
+@line
+@(end)
+@(try)
+@(next :list [mapcar tostring (range 1 20000)])
+@(collect)
+@num
+@(next "data")
+@line
+@(end)
+@(catch)
+@(do (put-line "caught"))
+@(end)
diff --git a/tests/018/path-equal.tl b/tests/018/path-equal.tl
new file mode 100644
index 00000000..704c414a
--- /dev/null
+++ b/tests/018/path-equal.tl
@@ -0,0 +1,17 @@
+(load "../common")
+
+(mtest
+ (path-equal "a" "a") t
+ (path-equal "a" "b") nil
+ (path-equal "/a" "a") nil
+
+ (path-equal "a" "a/") t
+ (path-equal "a/" "a/") t
+
+ (path-equal "a/b/../c" "a/c") t
+
+ (path-equal "a" "a/././.") t
+ (path-equal "a/." "a/././.") t
+
+ (path-equal "/.." "/") t
+ (path-equal "/../a" "/a/") t)
diff --git a/tests/018/path-safe.tl b/tests/018/path-safe.tl
new file mode 100644
index 00000000..77b92321
--- /dev/null
+++ b/tests/018/path-safe.tl
@@ -0,0 +1,105 @@
+(load "../common")
+
+;; only root can do this test
+(unless (zerop (geteuid))
+ (exit))
+
+(defvarl testdir (mkdtemp `/tmp/txr-path-safe-test`))
+
+(push-after-load (remove-path-rec testdir))
+
+(chmod testdir "a+rX")
+
+(defvarl atestdir (realpath testdir))
+(defvarl tmpdir (path-cat testdir "tmp"))
+
+(mkdir tmpdir)
+(defvarl atmpdir (realpath tmpdir))
+(ensure-dir tmpdir)
+(chmod tmpdir "a+rwt")
+
+(seteuid 10000)
+(touch (path-cat tmpdir "10000"))
+(symlink "/" (path-cat tmpdir "10000-link"))
+(seteuid 0)
+
+(seteuid 20000)
+(touch (path-cat tmpdir "20000"))
+(symlink "/" (path-cat tmpdir "20000-link"))
+(seteuid 0)
+
+(mtest
+ (path-components-safe tmpdir) t
+ (path-components-safe (path-cat tmpdir "10000")) nil
+ (path-components-safe (path-cat tmpdir "10000-link")) nil
+ (path-components-safe (path-cat tmpdir "20000")) nil)
+
+(mtest
+ (path-components-safe atmpdir) t
+ (path-components-safe (path-cat atmpdir "10000")) nil
+ (path-components-safe (path-cat atmpdir "10000-link")) nil
+ (path-components-safe (path-cat atmpdir "20000")) nil)
+
+(seteuid 10000)
+
+(mtest
+ (path-components-safe atmpdir) t
+ (path-components-safe (path-cat tmpdir "10000")) t
+ (path-components-safe (path-cat tmpdir "10000-link")) t
+ (path-components-safe (path-cat tmpdir "20000")) nil
+ (path-components-safe (path-cat tmpdir "20000-link")) nil)
+
+(mtest
+ (path-components-safe atmpdir) t
+ (path-components-safe (path-cat atmpdir "10000")) t
+ (path-components-safe (path-cat atmpdir "10000-link")) t
+ (path-components-safe (path-cat atmpdir "20000")) nil
+ (path-components-safe (path-cat atmpdir "20000-link")) nil)
+
+(symlink "loop/x/y" (path-cat tmpdir "loop"))
+
+(test
+ (path-components-safe (path-cat tmpdir "loop/z")) :error)
+
+(chdir tmpdir)
+(symlink "b/c" "a")
+(ensure-dir "b")
+(symlink "x" "b/c")
+(touch "b/x")
+
+(test
+ (path-components-safe "a") t)
+
+(remove-path "b/c")
+
+(test
+ (path-components-safe "a") :error)
+
+(seteuid 0)
+(seteuid 20000)
+(symlink "x" "z")
+
+(seteuid 0)
+(rename-path "z" "b/c")
+
+(each ((uid '(10000 0)))
+ (mtest
+ (path-components-safe "a") nil
+ (path-components-safe "/proc/1") t
+ (path-components-safe "/proc/1/fd") t
+ (path-components-safe "/proc/sys/../1") t
+ (path-components-safe "/proc/1/cwd") nil
+ (path-components-safe "/proc/1/cwd/foo") nil
+ (path-components-safe "/proc/self/cwd") nil
+ (path-components-safe "/proc/self/cwd/foo") nil
+ (path-components-safe "/proc/1/root") nil
+ (path-components-safe "/proc/1/root/foo") nil
+ (path-components-safe "/proc/1/fd/0") nil
+ (path-components-safe "/proc/1/fd/0/bar") nil
+ (path-components-safe "/proc/1/map_files") nil
+ (path-components-safe "/proc/1/map_files/bar") nil
+ (path-components-safe "/proc/sys/../1/cwd") nil
+ (path-components-safe "/proc/1/task/1") t
+ (path-components-safe "/proc/1/task/1/fd/0") nil
+ (path-components-safe "/proc/1/task/1/cwd") nil
+ (path-components-safe "/proc/1/task/1/root") nil))1
diff --git a/tests/018/path-test.tl b/tests/018/path-test.tl
new file mode 100644
index 00000000..d3aa6dce
--- /dev/null
+++ b/tests/018/path-test.tl
@@ -0,0 +1,22 @@
+(load "../common")
+
+(unless (path-executable-to-me-p "/bin/sh")
+ (exit 0))
+
+(mtest
+ (ends-with "/bin/sh" (path-search "sh")) t
+ (path-search "AlMoStCeRtAiNlLyNoNeXisTenT") nil
+ (path-search "") nil
+ (path-search "sh" nil) nil
+ (path-search "sh" '("AlMoStCeRtAiNlLyNoNeXisTenT")) nil
+ (path-search "sh" '("AlMoStCeRtAiNlLyNoNeXisTenT" "/bin")) "/bin/sh"
+ (path-search "sh" '("/bin")) "/bin/sh"
+ (path-search "sh" "AlMoStCeRtAiNlLyNoNeXisTenT") nil
+ (path-search "sh" "AlMoStCeRtAiNlLyNoNeXisTenT:/bin") "/bin/sh"
+ (path-search "sh" "/bin") "/bin/sh"
+ (path-search "sh" "/bin/") "/bin/sh"
+ (path-search "sh" ":/bin/") "/bin/sh"
+ (path-search "" "/bin") nil
+ (path-search "." "/bin") nil
+ (path-search ".." "/bin") nil
+ (path-search "foo/bar" "/bin") "foo/bar")
diff --git a/tests/018/path.tl b/tests/018/path.tl
new file mode 100644
index 00000000..dd22339f
--- /dev/null
+++ b/tests/018/path.tl
@@ -0,0 +1,320 @@
+(load "../common")
+
+(mtest
+ (short-suffix 42) :error
+ (short-suffix #\a) :error
+ (short-suffix "") nil
+ (short-suffix "" 0) 0
+ (short-suffix "a") nil
+ (short-suffix "a" 0) 0
+ (short-suffix ".") nil
+ (short-suffix "a.") "."
+ (short-suffix "a.b.") "."
+ (short-suffix ".c") nil
+ (short-suffix "a.c") ".c"
+ (short-suffix ".a.c") ".c"
+ (short-suffix "a.b.c") ".c"
+ (short-suffix "foo.txt.gz") ".gz"
+ (short-suffix "txt.gz") ".gz"
+ (short-suffix ".gz") nil)
+
+(mtest
+ (long-suffix 42) :error
+ (long-suffix #\a) :error
+ (long-suffix "") nil
+ (long-suffix "" 0) 0
+ (long-suffix "a") nil
+ (long-suffix "a" 0) 0
+ (long-suffix ".") nil
+ (long-suffix "a.") "."
+ (long-suffix "a.b.") ".b."
+ (long-suffix ".c") nil
+ (long-suffix "a.c") ".c"
+ (long-suffix "a.b.c") ".b.c"
+ (long-suffix "foo.txt.gz") ".txt.gz"
+ (long-suffix ".gz") nil
+ (long-suffix ".txt.gz") ".gz"
+ (long-suffix "/.txt.gz") ".gz"
+ (long-suffix "a/.txt.gz") ".gz"
+ (long-suffix "a/.txt.tar.gz") ".tar.gz")
+
+(mtest
+ (short-suffix "/") nil
+ (short-suffix "a/") nil
+ (short-suffix "/.") nil
+ (short-suffix "a/.") nil
+ (short-suffix ".a/") nil
+ (short-suffix ".a/b") nil
+ (short-suffix ".a/c.b") ".b"
+ (short-suffix ".a/b/") nil
+ (short-suffix ".a/b/.b") nil
+ (short-suffix ".a/b/.b/") nil
+ (short-suffix ".a/b/c.b") ".b"
+ (short-suffix ".a/b/c.b/") ".b"
+ (short-suffix ".a/b/c.b//") ".b"
+ (short-suffix ".a/b/c.b///") ".b"
+ (short-suffix ".a/b/c.") "."
+ (short-suffix ".a/b/c./") "."
+ (short-suffix ".a/b/c.//") "."
+ (short-suffix ".a/b/c.///") ".")
+
+(mtest
+ (long-suffix "/") nil
+ (long-suffix "a/") nil
+ (long-suffix "/.") nil
+ (long-suffix "a/.") nil
+ (long-suffix ".a/") nil
+ (long-suffix ".a/b") nil
+ (long-suffix ".a/b/") nil
+ (long-suffix ".a/b/.b") nil
+ (long-suffix ".a/b/.b/") nil
+ (long-suffix ".a/b/c.b") ".b"
+ (long-suffix ".a/b/c.b/") ".b"
+ (long-suffix "a.b/c.d.e") ".d.e"
+ (long-suffix "a.b/c.d.e/") ".d.e"
+ (long-suffix "a.b/c.d.e/f") nil
+ (long-suffix "a.b/c.d.e/f.g.h") ".g.h"
+ (long-suffix "a.b/c.d.e//") ".d.e"
+ (long-suffix "a.b/c.d.e///") ".d.e"
+ (long-suffix "a.b/c.d.") ".d."
+ (long-suffix "a.b/c.d./") ".d."
+ (long-suffix "a.b/c.d.//") ".d."
+ (long-suffix "a.b/c.d.///") ".d."
+ (long-suffix "a.b/c.") "."
+ (long-suffix "a.b/c./") "."
+ (long-suffix "a.b/c.//") "."
+ (long-suffix "a.b/c.///") ".")
+
+(mtest
+ (trim-short-suffix "") ""
+ (trim-short-suffix ".") "."
+ (trim-short-suffix "/.") "/."
+ (trim-short-suffix ".b") ".b"
+ (trim-short-suffix ".a.b") ".a"
+ (trim-short-suffix ".a.b.c") ".a.b"
+ (trim-short-suffix "/.b") "/.b"
+ (trim-short-suffix "/.b/") "/.b/"
+ (trim-short-suffix "/.b//") "/.b//"
+ (trim-short-suffix "a.b") "a"
+ (trim-short-suffix "/a.b") "/a"
+ (trim-short-suffix "/a.b/") "/a/"
+ (trim-short-suffix "/a.b//") "/a//"
+ (trim-short-suffix "a.") "a"
+ (trim-short-suffix "/a.") "/a"
+ (trim-short-suffix "/a./") "/a/"
+ (trim-short-suffix "/a.//") "/a//")
+
+(mtest
+ (trim-long-suffix "") ""
+ (trim-long-suffix ".") "."
+ (trim-long-suffix "/.") "/."
+ (trim-long-suffix ".b") ".b"
+ (trim-long-suffix ".a.b") ".a"
+ (trim-long-suffix ".a.b.c") ".a"
+ (trim-long-suffix "/.b") "/.b"
+ (trim-long-suffix "/.b/") "/.b/"
+ (trim-long-suffix "/.b//") "/.b//"
+ (trim-long-suffix "a.b") "a"
+ (trim-long-suffix "/a.b") "/a"
+ (trim-long-suffix "/a.b/") "/a/"
+ (trim-long-suffix "/a.b//") "/a//"
+ (trim-long-suffix "/.b.c") "/.b"
+ (trim-long-suffix "/.b.c/") "/.b/"
+ (trim-long-suffix "/.b.c//") "/.b//"
+ (trim-long-suffix "/.b.c.d") "/.b"
+ (trim-long-suffix "/.b.c.d/") "/.b/"
+ (trim-long-suffix "/.b.c.d//") "/.b//"
+ (trim-long-suffix "a.b.c") "a"
+ (trim-long-suffix "/a.b.c") "/a"
+ (trim-long-suffix "/a.b.c/") "/a/"
+ (trim-long-suffix "/a.b.c//") "/a//"
+ (trim-long-suffix "a.") "a"
+ (trim-long-suffix "/a.") "/a"
+ (trim-long-suffix "/a./") "/a/"
+ (trim-long-suffix "/a.//") "/a//")
+
+(mtest
+ (add-suffix "" "") ""
+ (add-suffix "" "a") "a"
+ (add-suffix "." "a") ".a"
+ (add-suffix "." ".a") "..a"
+ (add-suffix "/" ".b") "/.b"
+ (add-suffix "//" ".b") "/.b/"
+ (add-suffix "//" "b") "/b/"
+ (add-suffix "a" "") "a"
+ (add-suffix "a" ".b") "a.b"
+ (add-suffix "a/" ".b") "a.b/"
+ (add-suffix "a//" ".b") "a.b//"
+
+ (add-suffix "c://" "x") "c:/x/"
+ (add-suffix "0://" "x") "0:/x/"
+ (add-suffix "host://" "x") "host://x"
+ (add-suffix "host:///" "x") "host://x/"
+ (add-suffix "1234:///" "x") "1234://x/")
+
+(mtest
+ (base-name "") ""
+ (base-name "/") "/"
+ (base-name ".") "."
+ (base-name "./") "."
+ (base-name "a") "a"
+ (base-name "a/") "a"
+ (base-name "/a") "a"
+ (base-name "/a/") "a"
+ (base-name "/a/b") "b"
+ (base-name "/a/b/") "b"
+ (base-name "/a/b//") "b"
+ (base-name "/a/b///") "b")
+
+(mtest
+ (base-name "" "") ""
+ (base-name "/" "/") "/"
+ (base-name "/" "") "/"
+ (base-name "." ".") "."
+ (base-name "." "") "."
+ (base-name "./" "/") "."
+ (base-name "a" "a") "a"
+ (base-name "a" "") "a"
+ (base-name "a.b" ".b") "a"
+ (base-name "a.b/" ".b") "a"
+ (base-name "a.b/" ".b/") "a.b"
+ (base-name "a.b/" "a.b") "a.b")
+
+(mtest
+ (path-cat "" "") ""
+ (path-cat "" ".") "."
+ (path-cat "." "") "."
+ (path-cat "." ".") "."
+ (path-cat "abc" ".") "abc"
+ (path-cat "." "abc") "abc"
+ (path-cat "./" ".") "./"
+ (path-cat "." "./") "./"
+ (path-cat "abc/" ".") "abc/"
+ (path-cat "./" "abc") "abc"
+ (path-cat "/" ".") "/"
+ (path-cat "/" "abc") "/abc"
+ (path-cat "ab/cd" "ef") "ab/cd/ef"
+ (path-cat "a" "b" "c") "a/b/c"
+ (path-cat "a" "b" "" "c" "/") "a/b/c/")
+
+(mtest
+ (path-cat) "."
+ (path-cat 3) :error
+ (path-cat "") ""
+ (path-cat "/") "/"
+ (path-cat ".") "."
+ (path-cat "" "" "") ""
+ (path-cat "." "" "") "."
+ (path-cat "" "." "") "."
+ (path-cat "" "" ".") "."
+ (path-cat "." "." ".") "."
+ (path-cat "abc/" "/def/" "g") "abc/def/g"
+ (path-cat "abc/" "/def/" "g/") "abc/def/g/"
+ (path-cat "" "abc/" "/def/" "g/") "abc/def/g/")
+
+(mtest
+ (abs-path-p "") nil
+ (abs-path-p "/") t
+ (abs-path-p "/abc") t
+ (abs-path-p "abc") nil
+ (abs-path-p ".") nil)
+
+(if (eql [path-sep-chars 0] #\\)
+ (mtest
+ (abs-path-p "\\abc") t
+ (abs-path-p "a:\\abc") t
+ (abs-path-p "0:\\abc") t
+ (abs-path-p "AB0:\\abc") t
+ (abs-path-p "cd5:\\abc") t
+ (abs-path-p "a:/abc") t
+ (abs-path-p "0:/abc") t
+ (abs-path-p "AB0:/abc") t
+ (abs-path-p "cd5:/abc") t)
+ (mtest
+ (abs-path-p "\\abs") nil
+ (abs-path-p "a:\\abc") nil
+ (abs-path-p "0:\\abc") nil
+ (abs-path-p "AB0:\\abc") nil
+ (abs-path-p "cd5:\\abc") nil
+ (abs-path-p "a:/abc") nil
+ (abs-path-p "0:/abc") nil
+ (abs-path-p "AB0:/abc") nil
+ (abs-path-p "cd5:/abc") nil))
+
+(mtest
+ (portable-abs-path-p "") nil
+ (portable-abs-path-p "/") t
+ (portable-abs-path-p "/abc") t
+ (portable-abs-path-p "\\abc") t
+ (portable-abs-path-p "abc") nil
+ (portable-abs-path-p ".") nil
+ (portable-abs-path-p "\\abc") t
+ (portable-abs-path-p "a:\\abc") t
+ (portable-abs-path-p "0:\\abc") t
+ (portable-abs-path-p "AB0:\\abc") t
+ (portable-abs-path-p "cd5:\\abc") t
+ (portable-abs-path-p "a:/abc") t
+ (portable-abs-path-p "0:/abc") t
+ (portable-abs-path-p "AB0:/abc") t
+ (portable-abs-path-p "cd5:/abc") t)
+
+(mtest
+ (pure-rel-path-p "") t
+ (pure-rel-path-p "/") nil
+ (pure-rel-path-p "\\") nil
+ (pure-rel-path-p "/abc") nil
+ (pure-rel-path-p ".") nil
+ (pure-rel-path-p "./") nil
+ (pure-rel-path-p ".\\") nil
+ (pure-rel-path-p ".abc") t
+ (pure-rel-path-p ".abc/") t
+ (pure-rel-path-p ".abc\\") t
+ (pure-rel-path-p ":") t
+ (pure-rel-path-p "a:") nil
+ (pure-rel-path-p "A:") nil
+ (pure-rel-path-p "0:") nil
+ (pure-rel-path-p "9:") nil
+ (pure-rel-path-p "_:") t
+ (pure-rel-path-p "abc") t
+ (pure-rel-path-p "abc/def") t
+ (pure-rel-path-p "abc/.") t
+ (pure-rel-path-p "abc\\def") t
+ (pure-rel-path-p "abc\\.") t)
+
+(mtest
+ (trim-path-seps "") ""
+ (trim-path-seps "/") "/"
+ (trim-path-seps "//") "/"
+ (trim-path-seps "///") "/"
+ (trim-path-seps "a///") "a"
+ (trim-path-seps "/a///") "/a")
+
+(mtest
+ (trim-path-seps "c:/") "c:/"
+ (trim-path-seps "c://") "c:/"
+ (trim-path-seps "c:///") "c:/"
+ (trim-path-seps "c:a///") "c:a"
+ (trim-path-seps "/c:/a///") "/c:/a"
+ (trim-path-seps "/c://///") "/c:")
+
+(mtest
+ (trim-path-seps "\\") "\\"
+ (trim-path-seps "\\\\") "\\"
+ (trim-path-seps "\\\\\\") "\\"
+ (trim-path-seps "a\\\\\\") "a"
+ (trim-path-seps "\\a\\\\\\") "\\a")
+
+(mtest
+ (trim-path-seps "c:\\") "c:\\"
+ (trim-path-seps "c:\\\\") "c:\\"
+ (trim-path-seps "c:\\\\\\") "c:\\"
+ (trim-path-seps "c:a\\\\\\") "c:a"
+ (trim-path-seps "\\c:\\a\\\\\\") "\\c:\\a"
+ (trim-path-seps "\\c:\\\\\\\\\\") "\\c:")
+
+(mtest
+ (trim-path-seps "/c:\\") "/c:"
+ (trim-path-seps "c:/\\/\\/") "c:/"
+ (trim-path-seps "c:a\\\\\\") "c:a"
+ (trim-path-seps "\\c:\\a/\\\\\\") "\\c:\\a"
+ (trim-path-seps "/c:\\\\\\\\\\") "/c:")
diff --git a/tests/018/process.tl b/tests/018/process.tl
new file mode 100644
index 00000000..58a12fa2
--- /dev/null
+++ b/tests/018/process.tl
@@ -0,0 +1,36 @@
+(load "../common")
+
+(unless (path-executable-to-me-p "/bin/sh")
+ (exit 0))
+
+(defun cmd (c : (m "r"))
+ (with-stream (s (open-command c m))
+ (get-string s)))
+
+(mtest
+ (cmd "echo foo") "foo\n"
+ (cmd "echo foo" ">1n") ""
+ (cmd "echo foo 1>&2" ">21") "foo\n")
+
+(defmacro fcmd (. forms)
+ ^(with-stream (s (open-subprocess nil "r" nil (lambda () ,*forms)))
+ (get-string s)))
+
+(mtest
+ (fcmd (let ((*stdout* *stdnull*)) (sh "echo foo"))) ""
+ (fcmd (let ((*stderr* *stdout*)) (sh "echo foo 1>&2"))) "foo\n")
+
+(caseq (os-symbol)
+ ((:cygwin :cygnal))
+ (t (mtest
+ (let ((*child-env* '("a=b")))
+ (get-lines (open-process "/usr/bin/env" "r")))
+ ("a=b")
+ (let ((*child-env* nil))
+ (get-lines (open-process "/usr/bin/env" "r")))
+ nil)
+ (test
+ (fcmd
+ (let ((*child-env* '("a=b")))
+ (run "/usr/bin/env")))
+ "a=b\n")))
diff --git a/tests/018/rel-path.tl b/tests/018/rel-path.tl
new file mode 100644
index 00000000..11651c17
--- /dev/null
+++ b/tests/018/rel-path.tl
@@ -0,0 +1,25 @@
+(load "../common")
+
+(mtest
+ (rel-path "/abc" "abc") :error
+ (rel-path "abc" "/abc") :error
+ (rel-path "." ".") "."
+ (rel-path "./abc" "abc") "."
+ (rel-path "abc" "./abc") "."
+ (rel-path "./abc" "./abc") "."
+ (rel-path "abc" "abc") "."
+ (rel-path "." "abc") "abc"
+ (rel-path "abc/def" "abc/ghi") "../ghi"
+ (rel-path "xyz/../abc/def" "abc/ghi") "../ghi"
+ (rel-path "abc" "d/e/f/g/h") "../d/e/f/g/h"
+ (rel-path "abc" "d/e/../g/h") "../d/g/h"
+ (rel-path "d/e/../g/h" ".") "../../.."
+ (rel-path "d/e/../g/h" "a/b") "../../../a/b"
+ (rel-path "x" "../../../y") "../../../../y"
+ (rel-path "x///" "x") "."
+ (rel-path "x" "x///") "."
+ (rel-path "///x" "/x") "."
+ (rel-path "../../x" "y") :error
+ (rel-path "" "") "."
+ (rel-path "a" "") ".."
+ (rel-path "" "a") "a")
diff --git a/tests/018/sh-esc.tl b/tests/018/sh-esc.tl
new file mode 100644
index 00000000..f508475e
--- /dev/null
+++ b/tests/018/sh-esc.tl
@@ -0,0 +1,58 @@
+(load "../common")
+
+(mtest
+ (sh-esc "") ""
+ (sh-esc "a") "a")
+
+(mtest
+ (sh-esc "|") "\"|\""
+ (sh-esc "&") "\"&\""
+ (sh-esc ";") "\";\""
+ (sh-esc "<") "\"<\""
+ (sh-esc ">") "\">\""
+ (sh-esc "(") "\"(\""
+ (sh-esc ")") "\")\""
+ (sh-esc " ") "\" \""
+ (sh-esc "\t") "\"\t\""
+ (sh-esc "\n") "\"\n\""
+ (sh-esc "*") "\"*\""
+ (sh-esc "?") "\"?\""
+ (sh-esc "[") "\"[\""
+ (sh-esc "#") "\"#\""
+ (sh-esc "~") "\"~\"")
+
+(mtest
+ (sh-esc "'") "\"'\"")
+
+(mtest
+ (sh-esc "\"") "'\"'"
+ (sh-esc "$") "'$'"
+ (sh-esc "`") "'`'"
+ (sh-esc "\\") "'\\'")
+
+(mtest
+ (sh-esc "=") "="
+ (sh-esc "%") "%"
+ (sh-esc-all "=") "\"=\""
+ (sh-esc-all "%") "\"%\"")
+
+(test
+ (sh-esc "a\"b'c") "'a\"b'\\''c'")
+
+(mtest
+ (sh-esc "|'") "\"|'\""
+ (sh-esc "|\"") "'|\"'"
+ (sh-esc "'$") "''\\''$'")
+
+(mtest
+ (sh-esc-all "|=") "\"|=\""
+ (sh-esc-all "'=") "\"'=\""
+ (sh-esc-all "\"=") "'\"='")
+
+(mtest
+ (sh-esc "|&;<>() \t\n*?[#~") "\"|&;<>() \t\n*?[#~\""
+ (sh-esc "\"$`\\") "'\"$`\\'")
+
+(mtest
+ (sh-esc-dq "$`\\\"\n'abc()*~") "\\$\\`\\\\\\\"\n'abc()*~"
+ (sh-esc-sq "$`\\\"\n'abc()*~") "$`\\\"\n'\\''abc()*~")
diff --git a/tests/019/comp-bugs.tl b/tests/019/comp-bugs.tl
new file mode 100644
index 00000000..c2cb2ad7
--- /dev/null
+++ b/tests/019/comp-bugs.tl
@@ -0,0 +1,6 @@
+(load "../common")
+
+(set *compile-test* t)
+
+(test
+ (prof (for ((i 42)) ((< i 42) i) ())) (42 0 0 0))
diff --git a/tests/019/compile-package.tl b/tests/019/compile-package.tl
new file mode 100644
index 00000000..2028b913
--- /dev/null
+++ b/tests/019/compile-package.tl
@@ -0,0 +1,7 @@
+(defpackage :foo)
+
+(compile-file "data/program.tl")
+
+(delete-package :foo)
+
+(load "data/program.tlo")
diff --git a/tests/019/data/a b/tests/019/data/a
new file mode 100755
index 00000000..8fbed4f6
--- /dev/null
+++ b/tests/019/data/a
@@ -0,0 +1,3 @@
+@(output)
+a
+@(end)
diff --git a/tests/019/data/a.tl b/tests/019/data/a.tl
new file mode 100755
index 00000000..6f25fed5
--- /dev/null
+++ b/tests/019/data/a.tl
@@ -0,0 +1 @@
+(put-line "a.tl")
diff --git a/tests/019/data/a.tlo b/tests/019/data/a.tlo
new file mode 100755
index 00000000..40f39e81
--- /dev/null
+++ b/tests/019/data/a.tlo
@@ -0,0 +1,2 @@
+(7 0 nil)
+((2 3 #b'0200012000000004 02000010' #("a.tlo") #(usr:put-line)))
diff --git a/tests/019/data/a.txr b/tests/019/data/a.txr
new file mode 100755
index 00000000..ceab552d
--- /dev/null
+++ b/tests/019/data/a.txr
@@ -0,0 +1,3 @@
+@(output)
+a.txr
+@(end)
diff --git a/tests/019/data/b.tl b/tests/019/data/b.tl
new file mode 100755
index 00000000..46c6dd30
--- /dev/null
+++ b/tests/019/data/b.tl
@@ -0,0 +1 @@
+(put-line "b.tl")
diff --git a/tests/019/data/b.tlo b/tests/019/data/b.tlo
new file mode 100755
index 00000000..2f432257
--- /dev/null
+++ b/tests/019/data/b.tlo
@@ -0,0 +1,2 @@
+(7 0 nil)
+((2 3 #b'0200012000000004 02000010' #("b.tlo") #(usr:put-line)))
diff --git a/tests/019/data/b.txr b/tests/019/data/b.txr
new file mode 100755
index 00000000..0b8883e0
--- /dev/null
+++ b/tests/019/data/b.txr
@@ -0,0 +1,3 @@
+@(output)
+b.txr
+@(end)
diff --git a/tests/019/data/c.tl b/tests/019/data/c.tl
new file mode 100755
index 00000000..b9e018ea
--- /dev/null
+++ b/tests/019/data/c.tl
@@ -0,0 +1 @@
+(put-line "c.tl")
diff --git a/tests/019/data/c.txr b/tests/019/data/c.txr
new file mode 100755
index 00000000..19995e8a
--- /dev/null
+++ b/tests/019/data/c.txr
@@ -0,0 +1,3 @@
+@(output)
+c.txr
+@(end)
diff --git a/tests/019/data/program.tl b/tests/019/data/program.tl
new file mode 100644
index 00000000..e97acbc5
--- /dev/null
+++ b/tests/019/data/program.tl
@@ -0,0 +1,5 @@
+(defpackage :foo (:fallback usr))
+
+(in-package :foo)
+
+(defun foo:fun ())
diff --git a/tests/019/load-args.tl b/tests/019/load-args.tl
new file mode 100644
index 00000000..bd0037f1
--- /dev/null
+++ b/tests/019/load-args.tl
@@ -0,0 +1,72 @@
+(load "../common")
+
+(defvar *trace*)
+
+(defmacro deftrace (fun)
+ ^(defun ,fun (. args)
+ (push ^(,%fun% ,*args) *trace*)))
+
+(handle
+ (eval '(progn
+ (deftrace load)
+ (deftrace compile-update-file)
+ (deftrace clean-file)))
+ (warning (x . rest)
+ (throw 'continue)))
+
+(defmacro tr (form)
+ ^(let ((*trace* nil))
+ ,form
+ (reverse *trace*)))
+
+(mtest
+ (tr (load-args-recurse '("abc"))) ((load "abc"))
+ (tr (load-args-recurse "abc")) ((load "abc"))
+ (tr (load-args-recurse "abc" "def")) ((load "abc") (load "def"))
+ (tr (load-args-recurse '("abc") "def")) ((load ("abc")) (load "def")))
+
+(let ((*load-args* '(1 2)))
+ (mtest
+ (tr (load-args-recurse '("abc"))) ((load "abc" 1 2))
+ (tr (load-args-recurse "abc")) ((load "abc" 1 2))
+ (tr (load-args-recurse "abc" "def")) ((load "abc" 1 2) (load "def" 1 2))
+ (tr (load-args-recurse '("abc") "def")) ((load ("abc") 1 2) (load "def" 1 2))))
+
+(mtest
+ (tr (load-args-process '("abc"))) ((load "abc"))
+ (tr (load-args-process "abc")) ((load "abc"))
+ (tr (load-args-process "abc" "def")) ((load "abc") (load "def"))
+ (tr (load-args-process '("abc") "def")) ((load ("abc")) (load "def")))
+
+(let ((*load-args* '(1 2)))
+ (mtest
+ (tr (load-args-process '("abc"))) ((load "abc" 1 2))
+ (tr (load-args-process "abc")) ((load "abc" 1 2))
+ (tr (load-args-process "abc" "def")) ((load "abc" 1 2) (load "def" 1 2))
+ (tr (load-args-process '("abc") "def")) ((load ("abc") 1 2) (load "def" 1 2))))
+
+(let ((*load-args* '(:compile)))
+ (mtest
+ (tr (load-args-process '("abc"))) ((compile-update-file "load-args.tl")
+ (compile-update-file "abc"))
+ (tr (load-args-process "abc")) ((compile-update-file "load-args.tl")
+ (compile-update-file "abc"))
+ (tr (load-args-process "abc" "def")) ((compile-update-file "load-args.tl")
+ (compile-update-file "abc")
+ (compile-update-file "def"))
+ (tr (load-args-process '("abc") "def")) ((compile-update-file "load-args.tl")
+ (compile-update-file ("abc"))
+ (compile-update-file "def"))))
+
+(let ((*load-args* '(:clean)))
+ (mtest
+ (tr (load-args-process '("abc"))) ((clean-file "load-args.tl")
+ (clean-file "abc"))
+ (tr (load-args-process "abc")) ((clean-file "load-args.tl")
+ (clean-file "abc"))
+ (tr (load-args-process "abc" "def")) ((clean-file "load-args.tl")
+ (clean-file "abc")
+ (clean-file "def"))
+ (tr (load-args-process '("abc") "def")) ((clean-file "load-args.tl")
+ (clean-file ("abc"))
+ (clean-file "def"))))
diff --git a/tests/019/load-hook.tl b/tests/019/load-hook.tl
new file mode 100644
index 00000000..af0b9860
--- /dev/null
+++ b/tests/019/load-hook.tl
@@ -0,0 +1,28 @@
+(load "../common")
+
+(defvarl %dir% (dir-name *load-path*))
+
+(compile-file "../load-hook")
+(test counter 0)
+
+(push (lambda ()
+ (remove-path (path-cat %dir% "../load-hook.tlo")))
+ *load-hooks*)
+
+(set counter nil)
+(load "../load-hook.tl")
+(test counter 1)
+
+(set counter nil)
+(load "../load-hook.tlo")
+(test counter 1)
+
+(mtest
+ (macroexpand-1 '(push-after-load))
+ (sys:setq *load-hooks* (cons (lambda ()) *load-hooks*))
+
+ (macroexpand-1 '(push-after-load x))
+ (sys:setq *load-hooks* (cons (lambda () x) *load-hooks*))
+
+ (macroexpand-1 '(pop-after-load))
+ (sys:setq *load-hooks* (cdr *load-hooks*)))
diff --git a/tests/019/load-ret.tl b/tests/019/load-ret.tl
new file mode 100644
index 00000000..1c99281f
--- /dev/null
+++ b/tests/019/load-ret.tl
@@ -0,0 +1,23 @@
+(load "../common")
+
+(mtest
+ (load "load-ret/module") 0
+ (load "load-ret/module" 1) 1
+ (load "load-ret/module" 1 2 3) 6)
+
+(mtest
+ (load-for (var abc "load-ret/module2" 'abc)) 0
+ (load-for (var def "load-ret/module2" 'def 1 2 3)) 6
+ (load-for (var abc "load-ret/module2" 'abc)) nil
+ (load-for (var abc "load-ret/module2" 'abc)
+ (var ghi "load-ret/module2" 'ghi 2 3 4)) 9)
+
+(defvarl here (dir-name self-path))
+
+(mtest
+ (sh `@{txr-exe-path} @here/load-ret/script.tl 0`) 0
+ (sh `@{txr-exe-path} @here/load-ret/script.tl 1`) 1
+ (sh `@{txr-exe-path} @here/load-ret/script.tl 7`) 7)
+
+(test
+ (sh `@{txr-exe-path} @here/load-ret/bad.tl 1 2> /dev/null`) 1)
diff --git a/tests/019/load-ret/bad.tl b/tests/019/load-ret/bad.tl
new file mode 100644
index 00000000..2d06f376
--- /dev/null
+++ b/tests/019/load-ret/bad.tl
@@ -0,0 +1 @@
+(
diff --git a/tests/019/load-ret/module.tl b/tests/019/load-ret/module.tl
new file mode 100644
index 00000000..05d69035
--- /dev/null
+++ b/tests/019/load-ret/module.tl
@@ -0,0 +1 @@
+(return-from load [apply + *load-args*])
diff --git a/tests/019/load-ret/module2.tl b/tests/019/load-ret/module2.tl
new file mode 100644
index 00000000..e651c3f5
--- /dev/null
+++ b/tests/019/load-ret/module2.tl
@@ -0,0 +1,2 @@
+(eval ^(defvar ,(pop *load-args*)))
+(return-from load [apply + *load-args*])
diff --git a/tests/019/load-ret/script.tl b/tests/019/load-ret/script.tl
new file mode 100644
index 00000000..8e13dabf
--- /dev/null
+++ b/tests/019/load-ret/script.tl
@@ -0,0 +1 @@
+(return-from load (toint [*args* 0]))
diff --git a/tests/019/load-search.tl b/tests/019/load-search.tl
new file mode 100644
index 00000000..3ba29790
--- /dev/null
+++ b/tests/019/load-search.tl
@@ -0,0 +1,69 @@
+(load "../common")
+
+(defvarl cur (dir-name *load-path*))
+
+(defun txr (. args)
+ (command-get-string `@{txr-exe-path} @{args " "}`))
+
+(defun lod (x)
+ (with-out-string-stream (*stdout*)
+ (load x)))
+
+(mtest
+ (txr `@cur/data/a`) "a\n"
+ (txr `@cur/data/a.txr`) "a.txr\n"
+ (txr `@cur/data/a.tl`) "a.tl\n"
+ (txr `@cur/data/a.tlo`) "a.tlo\n")
+
+(mtest
+ (txr `@cur/data/b`) "b.txr\n"
+ (txr `@cur/data/b.txr`) "b.txr\n"
+ (txr `@cur/data/b.tl`) "b.tl\n"
+ (txr `@cur/data/b.tlo`) "b.tlo\n")
+
+(mtest
+ (txr `@cur/data/c`) "c.txr\n"
+ (txr `@cur/data/c.txr`) "c.txr\n"
+ (txr `@cur/data/c.tl`) "c.tl\n")
+
+(let ((*stderr* *stdnull*))
+ (mtest
+ (txr "--lisp" `@cur/data/a`) ""
+ (txr "--compiled" `@cur/data/a`) ""))
+
+(mtest
+ (txr "--lisp" `@cur/data/b`) "b.tlo\n"
+ (txr "--compiled" `@cur/data/b`) "b.tlo\n")
+
+(mtest
+ (txr "--lisp" `@cur/data/c`) "c.tl\n"
+ (txr "--compiled" `@cur/data/c`) "c.tl\n")
+
+(mtest
+ (length *load-search-dirs*) 1
+ (base-name (car *load-search-dirs*)) "lib")
+
+(set *load-search-dirs* (list `@cur/data`))
+
+(mtest
+ (lod "a") :error
+ (lod "a.tl") "a.tl\n"
+ (lod "c") "c.tl\n")
+
+(push `@cur/nonexistent` *load-search-dirs*)
+
+(mtest
+ (lod "a") :error
+ (lod "a.tl") "a.tl\n"
+ (lod "c") "c.tl\n")
+
+
+(unless (or (meq (os-symbol) :cygwin :cygnal)
+ (zerop (geteuid)))
+ (push `@cur/unreadable` *load-search-dirs*)
+ (push-after-load (rmdir `@cur/unreadable`))
+ (ensure-dir `@cur/unreadable` 0)
+ (mtest
+ (lod "a") :error
+ (lod "a.tl") :error
+ (lod "c") :error))
diff --git a/tests/019/load-time.tl b/tests/019/load-time.tl
new file mode 100644
index 00000000..1a326aa2
--- /dev/null
+++ b/tests/019/load-time.tl
@@ -0,0 +1,30 @@
+(load "../common")
+
+(defvarl list)
+
+(test
+ [(compile-toplevel '(progn
+ (push 0 list)
+ (load-time (push 1 list))
+ list))]
+ (0 1))
+
+(zap list)
+
+(test
+ [(compile-toplevel '(progn
+ (push 0 list)
+ (lambda ()
+ (load-time (push 1 list)))
+ list))]
+ (0 1))
+
+(zap list)
+
+(test
+ [(compile-toplevel '(progn
+ (load-time (push 0 list))
+ (lambda ()
+ (load-time (push 1 list)))
+ list))]
+ (1 0))
diff --git a/tests/019/pct-fun.expected b/tests/019/pct-fun.expected
new file mode 100644
index 00000000..d7da7ee4
--- /dev/null
+++ b/tests/019/pct-fun.expected
@@ -0,0 +1,18 @@
+(foo :init)
+(foo :postinit)
+(foo foo)
+(foo bar)
+(foo :fini)
+(foo :postfini)
+function
+function2
+mac
+(foo :init)
+(foo :postinit)
+(foo foo)
+(foo bar)
+(foo :fini)
+(foo :postfini)
+function
+function2
+mac
diff --git a/tests/019/pct-fun.tl b/tests/019/pct-fun.tl
new file mode 100644
index 00000000..6e45f299
--- /dev/null
+++ b/tests/019/pct-fun.tl
@@ -0,0 +1,42 @@
+(load "../common")
+
+(defstruct foo ()
+ (:init (me) (prinl %fun%))
+ (:fini (me) (prinl %fun%))
+ (:postinit (me) (prinl %fun%))
+ (:postfini (me) (prinl %fun%))
+ (:method foo (me) (prinl %fun%)))
+
+(defmeth foo bar (me)
+ (prinl %fun%))
+
+(defmeth foo pat (:match)
+ (prinl %fun%))
+
+(defun function (: (optarg %fun%))
+ (prinl %fun%))
+
+(defun function2 (: (optarg %fun%))
+ (prinl optarg))
+
+(defmacro mac ()
+ (prinl %fun%)
+ nil)
+
+(with-objects ((f (new foo)))
+ f.(foo)
+ f.(pat)
+ f.(bar))
+
+(function)
+(function2)
+
+(mac)
+
+(test %fun% nil)
+
+(compile-only
+ (eval-only
+ (with-compile-opts (nil unused)
+ (compile-file (base-name *load-path*) "temp.tlo"))
+ (remove-path "temp.tlo")))
diff --git a/tests/019/progv.tl b/tests/019/progv.tl
new file mode 100644
index 00000000..7ab3aafe
--- /dev/null
+++ b/tests/019/progv.tl
@@ -0,0 +1,29 @@
+(load "../common")
+
+(defvar a 42)
+(defvar b 73)
+
+(mtest
+ (progv '(a) '(1) a) 1
+ (progv '(a b) '(1 2) (cons a b)) (1 . 2)
+ (progv '(x) '(1) (let ((x 4)) (symbol-value 'x))) 1)
+
+(let ((n (list 'a 'b))
+ (v (list 1 2)))
+ (mtest
+ (progv n v (cons a b)) (1 . 2)))
+
+(defvarl x)
+
+(let ((x 'lexical)
+ (vars (list 'x))
+ (vals (list 'dynamic)))
+ (test
+ (progv vars vals (list x (symbol-value 'x)))
+ (lexical dynamic)))
+
+(compile-only
+ (eval-only
+ (with-compile-opts (nil unused)
+ (compile-file (base-name *load-path*) "temp.tlo"))
+ (remove-path "temp.tlo")))
diff --git a/tests/019/redef.tl b/tests/019/redef.tl
new file mode 100644
index 00000000..943b5c3a
--- /dev/null
+++ b/tests/019/redef.tl
@@ -0,0 +1,23 @@
+(load "../common")
+
+(defun foo () :foo)
+
+(defvar foov :foov)
+
+(defun bar () (list (foo) foov))
+
+(compile 'bar)
+
+(test (bar) (:foo :foov))
+
+(defun foo () :bar)
+
+(makunbound 'foov)
+
+(defparml foov :barv)
+
+(test (bar) (:bar :barv))
+
+(defsymacro foov 42)
+
+(test (bar) :error)
diff --git a/tests/019/symbol-value.tl b/tests/019/symbol-value.tl
new file mode 100644
index 00000000..ca724f5a
--- /dev/null
+++ b/tests/019/symbol-value.tl
@@ -0,0 +1,24 @@
+(load "../common")
+
+(defparm v 42)
+
+(mtest
+ v 42
+ (symbol-value 'v) 42
+ (set (symbol-value 'v) 73) 73
+ (symbol-value 'v) 73
+ v 73)
+
+(mtest
+ (let ((v 2)) v) 2
+ (let ((v 2)) (symbol-value 'v)) 2
+ (progn (let ((v 2)) (set (symbol-value 'v) 1)) v) 73
+ (let ((v 2)) (set (symbol-value 'v) 1) v) 1
+ v 73)
+
+(test
+ (progn
+ (let ((v 2))
+ (set (symbol-value 'x) 73))
+ x)
+ 73)
diff --git a/tests/common.tl b/tests/common.tl
index 3cd5df63..57f411fa 100644
--- a/tests/common.tl
+++ b/tests/common.tl
@@ -1,18 +1,55 @@
+(defvar *compile-test*)
+
(defmacro error-to-sym (expr)
- ^(catch ,expr
- (error (cond) :error)))
+ ^(catch ,expr
+ (error (cond) :error)
+ (warning (cond) :warning)))
(defmacro vtest (:env env expr expected)
- (catch
- (let ((expr-expn (macroexpand expr env))
- (expval (gensym)))
- ^(let ((,expval ,expected))
- (ifa (not (equal (error-to-sym ,expr-expn) ,expval))
- (error "test case ~s failed: produced ~s; expected ~s"
- ',expr it ,expval))))
- (error (exc)
- (unless (eq expected :error)
- (error "test case ~s failed to expand: expected is ~s" expr expected)))))
+ (if-match (quote @(as sym @(or :error :warning))) expected
+ (set expected sym))
+ (if *compile-test*
+ (with-compile-opts (nil unused)
+ (if (meq expected :error :warning)
+ (with-gensyms (code)
+ ^(let ((,code (catch
+ (compile-toplevel ',expr)
+ (error (exc)
+ (if (eq ,expected :warning)
+ (error "test case ~s produced error during compilation, expected ~s"
+ ',expr ,expected)))
+ (warning (exc)
+ (if (eq ,expected :error)
+ (error "test case ~s warned during compilation, expected ~s"
+ ',expr ,expected))))))
+ (ifa (not (equal (error-to-sym (call ,code)) ,expected))
+ (error "test case ~s failed: produced ~s; expected ~s"
+ ',expr it ,expected))))
+ (with-gensyms (expval)
+ ^(let ((,expval ,expected))
+ (ifa (not (equal (call (compile-toplevel ',expr)) ,expval))
+ (error "test case ~s failed: produced ~s; expected ~s"
+ ',expr it ,expval))))))
+ (if (meq expected :error :warning)
+ (catch
+ (let ((expr-expn (expand expr env)))
+ ^(ifa (not (equal (error-to-sym ,expr-expn) ,expected))
+ (error "test case ~s failed: produced ~s; expected ~s"
+ ',expr it ,expected)))
+ (error (exc)
+ (if (eq expected :warning)
+ (error "test case ~s produced error during expansion, expected ~s"
+ expr expected)))
+ (warning (exc)
+ (if (eq expected :error)
+ (error "test case ~s warned during expansion, expected ~s"
+ expr expected))))
+ (let ((expr-expn (expand expr env))
+ (expval (gensym)))
+ ^(let ((,expval ,expected))
+ (ifa (not (equal ,expr-expn ,expval))
+ (error "test case ~s failed: produced ~s; expected ~s"
+ ',expr it ,expval)))))))
(defmacro test (expr expected)
^(vtest ,expr ',expected))
@@ -20,20 +57,41 @@
(defmacro stest (expr expected)
^(vtest ,^(tostring ,expr) ,expected))
+(defmacro sstest (expr expected)
+ ^(vtest ,^(tostring ,expr) ,(tostring expected)))
+
(defmacro mtest (. pairs)
^(progn ,*(mapcar (op cons 'test) (tuples 2 pairs))))
+(defmacro mvtest (. pairs)
+ ^(progn ,*(mapcar (op cons 'vtest) (tuples 2 pairs))))
+
+(defmacro mstest (. pairs)
+ ^(progn ,*(mapcar (op cons 'stest) (tuples 2 pairs))))
+
(defun os-symbol ()
- (let ((u (uname)))
- [(orf (iff (f^ #/Linux/) (ret :linux))
- (iff (f^ #/SunOS/) (ret :solaris))
- (iff (f^ #/CYGWIN/) (ret :cygwin))
- (iff (f^ #/CYGNAL/) (ret :cygnal))
- (iff (f^ #/Darwin/) (ret :macos))
- (ret :unknown))
- u.sysname]))
+ (if (ignerr (dlsym (dlopen "libandroid.so") "AAsset_close"))
+ :android
+ (let ((u (uname)))
+ [(orf (iff (f^ #/Linux/) (ret :linux))
+ (iff (f^ #/SunOS/) (ret :solaris))
+ (iff (f^ #/CYGWIN/) (ret :cygwin))
+ (iff (f^ #/CYGNAL/) (ret :cygnal))
+ (iff (f^ #/Darwin/) (ret :macos))
+ (iff (f^ #/OpenBSD/) (ret :openbsd))
+ (iff #/BSD/ (ret :bsd))
+ (ret :unknown))
+ u.sysname])))
(defun libc ()
(caseql (os-symbol)
- ((:linux :solaris :macos) (dlopen nil))
- ((:cygwin) (dlopen "cygwin1.dll"))))
+ ((:cygwin :cygnal) (dlopen "cygwin1.dll"))
+ (t (dlopen nil))))
+
+(defmacro with-temp-file ((name-var stream-var prefix) . body)
+ ^(let* ((,stream-var (mkstemp ,prefix))
+ (,name-var (stream-get-prop ,stream-var :name)))
+ (unwind-protect
+ (progn ,*body)
+ (close-stream ,stream-var)
+ (remove-path ,name-var))))
diff --git a/tests/load-hook.tl b/tests/load-hook.tl
new file mode 100644
index 00000000..508e50ad
--- /dev/null
+++ b/tests/load-hook.tl
@@ -0,0 +1,4 @@
+(defparml counter 0)
+(push (lambda () (inc counter)) *load-hooks*)
+(push (lambda () (dec counter)) *load-hooks*)
+(pop *load-hooks*)
diff --git a/time.c b/time.c
new file mode 100644
index 00000000..bf3bbeb5
--- /dev/null
+++ b/time.c
@@ -0,0 +1,591 @@
+/* Copyright 2015-2024
+ * Kaz Kylheku <kaz@kylheku.com>
+ * Vancouver, Canada
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ */
+
+#include <stddef.h>
+#include <time.h>
+#include <sys/time.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <wchar.h>
+#include "config.h"
+#include "alloca.h"
+#include "lib.h"
+#include "gc.h"
+#include "args.h"
+#include "utf8.h"
+#include "sysif.h"
+#include "struct.h"
+#include "eval.h"
+#include "time.h"
+
+struct tm_wrap {
+ struct tm tm;
+#if HAVE_TM_ZONE
+ const char *zone;
+#endif
+};
+
+val time_s, time_local_s, time_utc_s, time_string_s, time_parse_s;
+val year_s, month_s, day_s, hour_s, min_s, sec_s, wday_s, yday_s;
+val dst_s, gmtoff_s, zone_s;
+
+val time_sec(void)
+{
+ struct timeval tv;
+ if (gettimeofday(&tv, 0) == -1)
+ return nil;
+ return num(tv.tv_sec);
+}
+
+val time_sec_usec(void)
+{
+ struct timeval tv;
+ if (gettimeofday(&tv, 0) == -1)
+ return nil;
+ return cons(num_time(tv.tv_sec), num(tv.tv_usec));
+}
+
+val time_sec_nsec(void)
+{
+#if HAVE_CLOCK_GETTIME
+ struct timespec ts;
+ if (clock_gettime(CLOCK_REALTIME, &ts) == -1)
+ return nil;
+ return cons(num_time(ts.tv_sec), num(ts.tv_nsec));
+#else
+ struct timeval tv;
+ if (gettimeofday(&tv, 0) == -1)
+ return nil;
+ return cons(num_time(tv.tv_sec), num(1000 * tv.tv_usec));
+#endif
+}
+
+
+#if !HAVE_GMTIME_R
+struct tm *gmtime_r(const time_t *timep, struct tm *result);
+struct tm *localtime_r(const time_t *timep, struct tm *result);
+
+struct tm *gmtime_r(const time_t *timep, struct tm *result)
+{
+ struct tm *hack = gmtime(timep);
+ *result = *hack;
+ return hack;
+}
+
+struct tm *localtime_r(const time_t *timep, struct tm *result)
+{
+ struct tm *hack = localtime(timep);
+ *result = *hack;
+ return hack;
+}
+#endif
+
+static val string_time(struct tm *(*break_time_fn)(const time_t *, struct tm *),
+ char *format, time_t time)
+{
+ char buffer[512] = "";
+ struct tm broken_out_time;
+
+ if (break_time_fn(&time, &broken_out_time) == 0)
+ return nil;
+
+#if HAVE_TM_ZONE
+ if (strcmp(broken_out_time.TM_ZONE, "GMT") == 0)
+ broken_out_time.TM_ZONE = "UTC";
+#endif
+
+ if (strftime(buffer, sizeof buffer, format, &broken_out_time) == 0)
+ buffer[0] = 0;
+
+ {
+ wchar_t *wctime = utf8_dup_from(buffer);
+ return string_own(wctime);
+ }
+}
+
+val time_string_local(val time, val format)
+{
+ val self = lit("time-string-local");
+ time_t secs = c_time(time, self);
+ const wchar_t *wcfmt = c_str(format, self);
+ char *u8fmt = utf8_dup_to(wcfmt);
+ val timestr = string_time(localtime_r, u8fmt, secs);
+ free(u8fmt);
+ return timestr;
+}
+
+val time_string_utc(val time, val format)
+{
+ val self = lit("time-string-utc");
+ time_t secs = c_time(time, self);
+ const wchar_t *wcfmt = c_str(format, self);
+ char *u8fmt = utf8_dup_to(wcfmt);
+ val timestr = string_time(gmtime_r, u8fmt, secs);
+ free(u8fmt);
+ return timestr;
+}
+
+static val time_str_local(val format, val time_in)
+{
+ val time = default_arg_strict(time_in, time_sec());
+ return time_string_local(time, format);
+}
+
+static val time_str_utc(val format, val time_in)
+{
+ val time = default_arg_strict(time_in, time_sec());
+ return time_string_utc(time, format);
+}
+
+
+static val broken_time_list(struct tm *tms)
+{
+ return list(num(tms->tm_year + 1900),
+ num_fast(tms->tm_mon + 1),
+ num_fast(tms->tm_mday),
+ num_fast(tms->tm_hour),
+ num_fast(tms->tm_min),
+ num_fast(tms->tm_sec),
+ tms->tm_isdst ? t : nil,
+ nao);
+}
+
+static void tm_to_time_struct(val time_struct, struct tm *ptm)
+{
+ slotset(time_struct, year_s, num(ptm->tm_year + 1900));
+ slotset(time_struct, month_s, num_fast(ptm->tm_mon + 1));
+ slotset(time_struct, day_s, num_fast(ptm->tm_mday));
+ slotset(time_struct, hour_s, num_fast(ptm->tm_hour));
+ slotset(time_struct, min_s, num_fast(ptm->tm_min));
+ slotset(time_struct, sec_s, num_fast(ptm->tm_sec));
+ slotset(time_struct, wday_s, num_fast(ptm->tm_wday));
+ slotset(time_struct, yday_s, num_fast(ptm->tm_yday));
+ slotset(time_struct, dst_s, tnil(ptm->tm_isdst));
+#if HAVE_TM_GMTOFF
+ slotset(time_struct, gmtoff_s, num_fast(ptm->TM_GMTOFF));
+#endif
+#if HAVE_TM_ZONE
+ slotset(time_struct, zone_s, if2(ptm->TM_ZONE, string_utf8(ptm->TM_ZONE)));
+#endif
+}
+
+static val broken_time_struct(struct tm *tms)
+{
+ args_decl_constsize(args, ARGS_MIN);
+ val ts = make_struct(time_s, nil, args);
+
+ tm_to_time_struct(ts, tms);
+
+ return ts;
+}
+
+val time_fields_local(val time_in)
+{
+ val self = lit("time-fields-local");
+ struct tm tms;
+ val time = default_arg_strict(time_in, time_sec());
+ time_t secs = c_time(time, self);
+
+ if (localtime_r(&secs, &tms) == 0)
+ return nil;
+
+ return broken_time_list(&tms);
+}
+
+val time_fields_utc(val time_in)
+{
+ val self = lit("time-fields-utc");
+ struct tm tms;
+ val time = default_arg_strict(time_in, time_sec());
+ time_t secs = c_time(time, self);
+
+ if (gmtime_r(&secs, &tms) == 0)
+ return nil;
+
+ return broken_time_list(&tms);
+}
+
+val time_struct_local(val time_in)
+{
+ val self = lit("time-struct-local");
+ struct tm tms;
+ val time = default_arg_strict(time_in, time_sec());
+ time_t secs = c_time(time, self);
+
+ if (localtime_r(&secs, &tms) == 0)
+ return nil;
+
+ return broken_time_struct(&tms);
+}
+
+val time_struct_utc(val time_in)
+{
+ val self = lit("time-struct-utc");
+ struct tm tms;
+ val time = default_arg_strict(time_in, time_sec());
+ time_t secs = c_time(time, self);
+
+ if (gmtime_r(&secs, &tms) == 0)
+ return nil;
+
+ return broken_time_struct(&tms);
+}
+
+static void time_fields_to_tm(struct tm_wrap *ptmw,
+ val year, val month, val day,
+ val hour, val min, val sec,
+ val wday, val yday,
+ val dst, val gmtoff, val zone,
+ val self)
+{
+ struct tm *ptm = &ptmw->tm;
+ uses_or2;
+ ptm->tm_year = c_num(or2(year, zero), self) - 1900;
+ ptm->tm_mon = c_num(or2(month, zero), self) - 1;
+ ptm->tm_mday = c_num(or2(day, zero), self);
+ ptm->tm_hour = c_num(or2(hour, zero), self);
+ ptm->tm_min = c_num(or2(min, zero), self);
+ ptm->tm_sec = c_num(or2(sec, zero), self);
+ ptm->tm_wday = c_num(or2(wday, zero), self);
+ ptm->tm_yday = c_num(or2(yday, zero), self);
+
+ if (!dst)
+ ptm->tm_isdst = 0;
+ else if (dst == auto_k)
+ ptm->tm_isdst = -1;
+ else
+ ptm->tm_isdst = 1;
+
+#if HAVE_TM_GMTOFF
+ ptm->TM_GMTOFF = c_num(or2(gmtoff, zero), self);
+#endif
+#if HAVE_TM_ZONE
+ ptmw->zone = ptm->TM_ZONE = if3(zone, utf8_dup_to(c_str(zone, self)), 0);
+#endif
+}
+
+static void time_fields_cleanup(struct tm_wrap *ptm)
+{
+#if HAVE_TM_ZONE
+ free(strip_qual(char *, ptm->zone));
+#endif
+}
+
+static void time_struct_to_tm(struct tm_wrap *ptmw, val time_struct, val self)
+{
+ val year = slot(time_struct, year_s);
+ val month = slot(time_struct, month_s);
+ val day = slot(time_struct, day_s);
+ val hour = slot(time_struct, hour_s);
+ val min = slot(time_struct, min_s);
+ val sec = slot(time_struct, sec_s);
+ val wday = slot(time_struct, wday_s);
+ val yday = slot(time_struct, yday_s);
+ val dst = slot(time_struct, dst_s);
+ val gmtoff = slot(time_struct, gmtoff_s);
+ val zone = slot(time_struct, zone_s);
+
+ time_fields_to_tm(ptmw, year, month, day, hour, min, sec,
+ wday, yday, dst, gmtoff, zone, self);
+}
+
+static val make_time_impl(time_t (*pmktime)(struct tm *),
+ val year, val month, val day,
+ val hour, val minute, val second,
+ val isdst, val self)
+{
+ struct tm_wrap local = all_zero_init;
+ time_t time;
+
+ time_fields_to_tm(&local, year, month, day,
+ hour, minute, second, nil, nil, isdst, nil, nil, self);
+ time = pmktime(&local.tm);
+ time_fields_cleanup(&local);
+
+ return time == -1 ? nil : num_time(time);
+}
+
+val make_time(val year, val month, val day,
+ val hour, val minute, val second,
+ val isdst)
+{
+ val self = lit("make-time");
+ return make_time_impl(mktime, year, month, day, hour, minute, second,
+ isdst, self);
+}
+
+#if HAVE_STRPTIME
+
+static struct tm epoch_tm(void)
+{
+ struct tm ep = all_zero_init;
+ ep.tm_year = 70;
+ ep.tm_mday = 1;
+ return ep;
+}
+
+static int strptime_wrap(val string, val format, struct tm *ptms)
+{
+ val self = lit("strptime");
+ const wchar_t *w_str = c_str(string, self);
+ const wchar_t *w_fmt = c_str(format, self);
+ char *str = utf8_dup_to(w_str);
+ char *fmt = utf8_dup_to(w_fmt);
+ char *ptr = strptime(str, fmt, ptms);
+ int ret = ptr != 0;
+ free(fmt);
+ free(str);
+ return ret;
+}
+
+val time_parse(val format, val string)
+{
+ struct tm tms = epoch_tm();
+ int ret = strptime_wrap(string, format, &tms);
+ return ret ? broken_time_struct(&tms) : nil;
+}
+
+#endif
+
+#if !HAVE_TIMEGM && HAVE_SETENV
+
+static time_t timegm_hack(struct tm *tm)
+{
+ time_t ret;
+ char *tz;
+
+ tz = getenv("TZ");
+ setenv("TZ", "UTC", 1);
+#if HAVE_TZSET
+ tzset();
+#endif
+ ret = mktime(tm);
+ if (tz)
+ setenv("TZ", tz, 1);
+ else
+ unsetenv("TZ");
+#if HAVE_TZSET
+ tzset();
+#endif
+
+ return ret;
+}
+
+#endif
+
+#if !HAVE_TIMEGM && !HAVE_SETENV
+
+static time_t timegm_hack(struct tm *tm)
+{
+ uw_throw(system_error_s, lit("timegm function missing"));
+}
+
+#endif
+
+val make_time_utc(val year, val month, val day,
+ val hour, val minute, val second,
+ val isdst)
+{
+ val self = lit("make-time-utc");
+#if HAVE_TIMEGM
+ time_t (*pmktime)(struct tm *) = timegm;
+#else
+ time_t (*pmktime)(struct tm *) = timegm_hack;
+#endif
+
+ return make_time_impl(pmktime, year, month, day, hour, minute, second,
+ isdst, self);
+}
+
+static val time_meth(val utc_p, val time_struct)
+{
+ val year = slot(time_struct, year_s);
+ val month = slot(time_struct, month_s);
+ val day = slot(time_struct, day_s);
+ val hour = slot(time_struct, hour_s);
+ val min = slot(time_struct, min_s);
+ val sec = slot(time_struct, sec_s);
+ val dst = slot(time_struct, dst_s);
+ val gmtoff = slot(time_struct, gmtoff_s);
+
+ val out = (utc_p ? make_time_utc : make_time)(year, month, day,
+ hour, min, sec, dst);
+
+ if (gmtoff)
+ out = minus(out, gmtoff);
+
+ return out;
+}
+
+static val time_string_meth(val time_struct, val format)
+{
+ val self = lit("(meth time-string)");
+ struct tm_wrap tms = all_zero_init;
+ char buffer[512] = "";
+ char *fmt = utf8_dup_to(c_str(format, self));
+
+ time_struct_to_tm(&tms, time_struct, self);
+
+ if (strftime(buffer, sizeof buffer, fmt, &tms.tm) == 0)
+ buffer[0] = 0;
+
+ free(fmt);
+ time_fields_cleanup(&tms);
+
+ return string_own(utf8_dup_from(buffer));
+}
+
+#if HAVE_STRPTIME
+
+static val time_parse_meth(val time_struct, val format, val string)
+{
+ val self = lit("(meth time-parse)");
+ struct tm_wrap tms = all_zero_init;
+ val ret = nil;
+
+ time_struct_to_tm(&tms, time_struct, self);
+
+ {
+ const wchar_t *w_str = c_str(string, self);
+ const wchar_t *w_fmt = c_str(format, self);
+ char *str = utf8_dup_to(w_str);
+ char *fmt = utf8_dup_to(w_fmt);
+ char *ptr = strptime(str, fmt, &tms.tm);
+
+ if (ptr != 0) {
+ tm_to_time_struct(time_struct, &tms.tm);
+ ret = string_utf8(ptr);
+ }
+
+ free(fmt);
+ free(str);
+ }
+
+ time_fields_cleanup(&tms);
+
+ return ret;
+}
+
+val time_parse_local(val format, val string)
+{
+ struct tm tms = epoch_tm();
+
+ if (!strptime_wrap(string, format, &tms))
+ return nil;
+#if HAVE_TM_GMTOFF
+ {
+ long gmtoff = tms.TM_GMTOFF;
+ return num(mktime(&tms) - gmtoff);
+ }
+#else
+ return num(mktime(&tms));
+#endif
+}
+
+val time_parse_utc(val format, val string)
+{
+ struct tm tms = epoch_tm();
+ if (!strptime_wrap(string, format, &tms))
+ return nil;
+#if HAVE_TIMEGM && HAVE_TM_GMTOFF
+ {
+ long gmtoff = tms.TM_GMTOFF;
+ return num_time(timegm(&tms) - gmtoff);
+ }
+#elif HAVE_TM_GMTOFF
+ {
+ long gmtoff = tms.TM_GMTOFF;
+ return num_time(timegm_hack(&tms) - tms.gmtoff);
+ }
+#elif HAVE_TIMEGM
+ return num_time(timegm(&tms));
+#else
+ return num_time(timegm_hack(&tms));
+#endif
+}
+
+#endif
+
+void time_init(void)
+{
+ val time_st;
+
+ time_s = intern(lit("time"), user_package);
+ time_local_s = intern(lit("time-local"), user_package);
+ time_utc_s = intern(lit("time-utc"), user_package);
+ time_string_s = intern(lit("time-string"), user_package);
+ time_parse_s = intern(lit("time-parse"), user_package);
+ year_s = intern(lit("year"), user_package);
+ month_s = intern(lit("month"), user_package);
+ day_s = intern(lit("day"), user_package);
+ hour_s = intern(lit("hour"), user_package);
+ min_s = intern(lit("min"), user_package);
+ sec_s = intern(lit("sec"), user_package);
+ wday_s = intern(lit("wday"), user_package);
+ yday_s = intern(lit("yday"), user_package);
+ dst_s = intern(lit("dst"), user_package);
+ gmtoff_s = intern(lit("gmtoff"), user_package);
+ zone_s = intern(lit("zone"), user_package);
+
+ time_st = make_struct_type(time_s, nil,
+ list(time_local_s, time_utc_s,
+ time_string_s, time_parse_s, nao),
+ list(year_s, month_s, day_s,
+ hour_s, min_s, sec_s,
+ wday_s, yday_s,
+ dst_s, gmtoff_s, zone_s, nao),
+ nil, nil, nil, nil);
+
+ static_slot_set(time_st, time_local_s, func_f1(nil, time_meth));
+ static_slot_set(time_st, time_utc_s, func_f1(t, time_meth));
+ static_slot_set(time_st, time_string_s, func_n2(time_string_meth));
+#if HAVE_STRPTIME
+ static_slot_set(time_st, time_parse_s, func_n3(time_parse_meth));
+#endif
+
+ reg_fun(time_s, func_n0(time_sec));
+ reg_fun(intern(lit("time-usec"), user_package), func_n0(time_sec_usec));
+ reg_fun(intern(lit("time-nsec"), user_package), func_n0(time_sec_nsec));
+ reg_fun(intern(lit("time-string-local"), user_package), func_n2(time_string_local));
+ reg_fun(intern(lit("time-string-utc"), user_package), func_n2(time_string_utc));
+ reg_fun(intern(lit("time-str-local"), user_package), func_n2o(time_str_local, 1));
+ reg_fun(intern(lit("time-str-utc"), user_package), func_n2o(time_str_utc, 1));
+ reg_fun(intern(lit("time-fields-local"), user_package), func_n1o(time_fields_local, 0));
+ reg_fun(intern(lit("time-fields-utc"), user_package), func_n1o(time_fields_utc, 0));
+ reg_fun(intern(lit("time-struct-local"), user_package), func_n1o(time_struct_local, 0));
+ reg_fun(intern(lit("time-struct-utc"), user_package), func_n1o(time_struct_utc, 0));
+ reg_fun(intern(lit("make-time"), user_package), func_n7(make_time));
+#if HAVE_TIMEGM || HAVE_SETENV
+ reg_fun(intern(lit("make-time-utc"), user_package), func_n7(make_time_utc));
+#endif
+ reg_fun(intern(lit("time-parse"), user_package), func_n2(time_parse));
+ reg_fun(intern(lit("time-parse-local"), user_package), func_n2(time_parse_local));
+ reg_fun(intern(lit("time-parse-utc"), user_package), func_n2(time_parse_utc));
+}
+
diff --git a/time.h b/time.h
new file mode 100644
index 00000000..27650d9d
--- /dev/null
+++ b/time.h
@@ -0,0 +1,53 @@
+/* Copyright 2015-2024
+ * Kaz Kylheku <kaz@kylheku.com>
+ * Vancouver, Canada
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ */
+
+extern val time_s, time_local_s, time_utc_s, time_string_s, time_parse_s;
+extern val year_s, month_s, day_s, hour_s, min_s, sec_s;
+extern val dst_s, gmtoff_s, zone_s;
+
+val time_sec(void);
+val time_sec_usec(void);
+val time_sec_nsec(void);
+val time_string_local(val time, val format);
+val time_string_utc(val time, val format);
+val time_fields_local(val time);
+val time_fields_utc(val time);
+val time_struct_local(val time);
+val time_struct_utc(val time);
+val make_time(val year, val month, val day,
+ val hour, val minute, val second,
+ val isdst);
+val make_time_utc(val year, val month, val day,
+ val hour, val minute, val second,
+ val isdst);
+#if HAVE_STRPTIME
+val time_parse(val format, val string);
+val time_parse_local(val format, val string);
+val time_parse_utc(val format, val string);
+void time_init(void);
+#endif
diff --git a/tl.vim b/tl.vim
index 4753c384..0c2284df 100644
--- a/tl.vim
+++ b/tl.vim
@@ -20,98 +20,113 @@ syn spell toplevel
setlocal iskeyword=a-z,A-Z,48-57,!,$,%,&,*,+,-,<,=,>,?,\\,_,~,/,^
-syn keyword tl_keyword contained %e% %pi% * *args*
-syn keyword tl_keyword contained *args-eff* *args-full* *filters* *full-args*
-syn keyword tl_keyword contained *gensym-counter* *hash-seed* *lib-version* *listener-greedy-eval-p*
-syn keyword tl_keyword contained *listener-hist-len* *listener-multi-line-p* *listener-pprint-p* *listener-sel-inclusive-p*
-syn keyword tl_keyword contained *load-path* *package* *package-alist* *param-macro*
-syn keyword tl_keyword contained *place-clobber-expander* *place-delete-expander* *place-macro* *place-update-expander*
-syn keyword tl_keyword contained *pprint-flo-format* *print-base* *print-circle* *print-flo-digits*
-syn keyword tl_keyword contained *print-flo-format* *print-flo-precision* *random-state* *random-warmup*
-syn keyword tl_keyword contained *rec-source-loc* *stddebug* *stderr* *stdin*
-syn keyword tl_keyword contained *stdlog* *stdnull* *stdout* *trace-output*
-syn keyword tl_keyword contained *tree-fun-whitelist* *txr-version* *unhandled-hook* +
-syn keyword tl_keyword contained - / /= :
-syn keyword tl_keyword contained :abandoned :addr :all :apf
+syn keyword tl_keyword contained %e% %fun% %pi% *
+syn keyword tl_keyword contained *args* *args-eff* *args-full* *child-env*
+syn keyword tl_keyword contained *compile-opts* *doc-url* *filters* *full-args*
+syn keyword tl_keyword contained *gensym-counter* *hash-seed* *lib-version* *listener-auto-compound-p*
+syn keyword tl_keyword contained *listener-greedy-eval-p* *listener-hist-len* *listener-multi-line-p* *listener-pprint-p*
+syn keyword tl_keyword contained *listener-sel-inclusive-p* *load-args* *load-hooks* *load-path*
+syn keyword tl_keyword contained *load-search-dirs* *match-macro* *opt-level* *package*
+syn keyword tl_keyword contained *package-alist* *param-macro* *place-clobber-expander* *place-delete-expander*
+syn keyword tl_keyword contained *place-macro* *place-update-expander* *pprint-flo-format* *print-base*
+syn keyword tl_keyword contained *print-circle* *print-flo-digits* *print-flo-format* *print-flo-precision*
+syn keyword tl_keyword contained *print-json-format* *random-state* *random-warmup* *read-bad-json*
+syn keyword tl_keyword contained *read-unknown-structs* *rec-source-loc* *stddebug* *stderr*
+syn keyword tl_keyword contained *stdin* *stdlog* *stdnull* *stdout*
+syn keyword tl_keyword contained *struct-clause-expander* *trace-output* *tree-fun-whitelist* *txr-version*
+syn keyword tl_keyword contained *unhandled-hook* + - /
+syn keyword tl_keyword contained /= : :abandoned :abs
+syn keyword tl_keyword contained :addr :all :android :apf
syn keyword tl_keyword contained :append :args :atime :auto
syn keyword tl_keyword contained :awk-again :awk-file :awk-rec :begin
syn keyword tl_keyword contained :begin-file :blksize :blocks :bool
syn keyword tl_keyword contained :byte-oriented :cdigit :chars :cint
-syn keyword tl_keyword contained :close :continue :counter :cspace
-syn keyword tl_keyword contained :ctime :cword-char :dec :decline
-syn keyword tl_keyword contained :dev :digit :downcase :end
-syn keyword tl_keyword contained :end-file :env :eq-based :eql-based
-syn keyword tl_keyword contained :equal-based :explicit-no :fallback :fd
-syn keyword tl_keyword contained :fence :filter :fini :finish
-syn keyword tl_keyword contained :float :form :from-current :from-end
-syn keyword tl_keyword contained :from-start :from_html :frombase64 :fromhtml
+syn keyword tl_keyword contained :clean :close :compile :continue
+syn keyword tl_keyword contained :counter :cspace :ctime :cword-char
+syn keyword tl_keyword contained :cygnal :cygwin :dec :decline
+syn keyword tl_keyword contained :delegate :dev :digit :downcase
+syn keyword tl_keyword contained :end :end-file :env :eq-based
+syn keyword tl_keyword contained :eql-based :equal-based :error :explicit-no
+syn keyword tl_keyword contained :fallback :fd :fence :fields
+syn keyword tl_keyword contained :filter :fini :finish :float
+syn keyword tl_keyword contained :form :from-current :from-end :from-start
+syn keyword tl_keyword contained :from_html :frombase64 :frombase64url :fromhtml
syn keyword tl_keyword contained :frompercent :fromurl :fun :function
syn keyword tl_keyword contained :gap :gid :greedy :hex
-syn keyword tl_keyword contained :hextoint :inf :init :ino
-syn keyword tl_keyword contained :inp :inputs :instance :into
-syn keyword tl_keyword contained :key :let :lfilt :lines
-syn keyword tl_keyword contained :list :lists :local :longest
-syn keyword tl_keyword contained :mandatory :maxgap :maxtimes :method
-syn keyword tl_keyword contained :mid :mingap :mintimes :mode
-syn keyword tl_keyword contained :mtime :name :named :next-spec
-syn keyword tl_keyword contained :nlink :nothrow :oct :outf
-syn keyword tl_keyword contained :outp :output :owner :perms
-syn keyword tl_keyword contained :postinit :prio :rdev :real-time
-syn keyword tl_keyword contained :reflect :repeat-spec :resolve :rfilt
-syn keyword tl_keyword contained :set :set-file :shortest :size
-syn keyword tl_keyword contained :space :static :str :string
-syn keyword tl_keyword contained :symacro :symlinks :text :times
-syn keyword tl_keyword contained :tlist :to_html :tobase64 :tofloat
-syn keyword tl_keyword contained :tohtml :tohtml* :toint :tonumber
-syn keyword tl_keyword contained :topercent :tourl :uid :upcase
-syn keyword tl_keyword contained :use :use-from :use-syms :userdata
-syn keyword tl_keyword contained :var :vars :weak-keys :weak-vals
-syn keyword tl_keyword contained :whole :word-char :wrap <
-syn keyword tl_keyword contained <= = > >=
-syn keyword tl_keyword contained abort abs abs-path-p acons
-syn keyword tl_keyword contained acons-new aconsql-new acos acosh
+syn keyword tl_keyword contained :hextoint :inf :inherit :init
+syn keyword tl_keyword contained :ino :inp :inputs :instance
+syn keyword tl_keyword contained :into :key :let :lfilt
+syn keyword tl_keyword contained :lines :linux :list :lists
+syn keyword tl_keyword contained :local :longest :macos :macro
+syn keyword tl_keyword contained :mandatory :mass-delegate :match :maxgap
+syn keyword tl_keyword contained :maxtimes :method :mid :mingap
+syn keyword tl_keyword contained :mintimes :mode :mtime :name
+syn keyword tl_keyword contained :named :next-spec :nlink :noclose
+syn keyword tl_keyword contained :nothrow :oct :ok :openbsd
+syn keyword tl_keyword contained :outf :outp :output :owner
+syn keyword tl_keyword contained :perms :postfini :postinit :prio
+syn keyword tl_keyword contained :rdev :real-time :reflect :repeat-spec
+syn keyword tl_keyword contained :resolve :rfilt :set :set-file
+syn keyword tl_keyword contained :shortest :size :solaris :solaris10
+syn keyword tl_keyword contained :space :standard :static :str
+syn keyword tl_keyword contained :string :symacro :symlinks :text
+syn keyword tl_keyword contained :times :tlist :to_html :tobase64
+syn keyword tl_keyword contained :tobase64url :tofloat :tohtml :tohtml*
+syn keyword tl_keyword contained :toint :tonumber :topercent :tourl
+syn keyword tl_keyword contained :uid :unknown :upcase :use
+syn keyword tl_keyword contained :use-from :use-syms :use-syms-as :userdata
+syn keyword tl_keyword contained :var :vars :warn :weak-and
+syn keyword tl_keyword contained :weak-keys :weak-or :weak-vals :whole
+syn keyword tl_keyword contained :word-char :wrap < <=
+syn keyword tl_keyword contained = > >= abort
+syn keyword tl_keyword contained abs abs-path-p acons acons-new
+syn keyword tl_keyword contained aconsql-new acos acosh add-suffix
syn keyword tl_keyword contained ado af-inet af-inet6 af-unix
syn keyword tl_keyword contained af-unspec ai-addrconfig ai-all ai-canonname
syn keyword tl_keyword contained ai-numerichost ai-numericserv ai-passive ai-v4mapped
syn keyword tl_keyword contained alet align alignof alist-nremove
syn keyword tl_keyword contained alist-remove all allocate-struct and
syn keyword tl_keyword contained andf ap apf append
-syn keyword tl_keyword contained append* append-each append-each* apply
-syn keyword tl_keyword contained aret array arraysize ash
-syn keyword tl_keyword contained asin asinh assoc assq
-syn keyword tl_keyword contained assql at-exit-call at-exit-do-not-call atan
-syn keyword tl_keyword contained atan2 atanh atom awk
-syn keyword tl_keyword contained base-name base64-decode base64-decode-buf base64-encode
-syn keyword tl_keyword contained base64-stream-dec base64-stream-enc bchar be-double
-syn keyword tl_keyword contained be-float be-int16 be-int32 be-int64
-syn keyword tl_keyword contained be-uint16 be-uint32 be-uint64 bignum-len
-syn keyword tl_keyword contained bignump bindable bit bitset
-syn keyword tl_keyword contained blkcnt-t blksize-t block block*
-syn keyword tl_keyword contained bool boundp bracket break-str
-syn keyword tl_keyword contained brkint bs0 bs1 bsdly
-syn keyword tl_keyword contained bstr bstr-d buf buf-alloc-size
-syn keyword tl_keyword contained buf-carray buf-d buf-get-char buf-get-cptr
-syn keyword tl_keyword contained buf-get-double buf-get-float buf-get-i16 buf-get-i32
-syn keyword tl_keyword contained buf-get-i64 buf-get-i8 buf-get-int buf-get-long
-syn keyword tl_keyword contained buf-get-short buf-get-u16 buf-get-u32 buf-get-u64
-syn keyword tl_keyword contained buf-get-u8 buf-get-uchar buf-get-uint buf-get-ulong
-syn keyword tl_keyword contained buf-get-ushort buf-int buf-list buf-put-buf
-syn keyword tl_keyword contained buf-put-char buf-put-cptr buf-put-double buf-put-float
-syn keyword tl_keyword contained buf-put-i16 buf-put-i32 buf-put-i64 buf-put-i8
-syn keyword tl_keyword contained buf-put-int buf-put-long buf-put-short buf-put-u16
-syn keyword tl_keyword contained buf-put-u32 buf-put-u64 buf-put-u8 buf-put-uchar
-syn keyword tl_keyword contained buf-put-uint buf-put-ulong buf-put-ushort buf-set-length
-syn keyword tl_keyword contained buf-str buf-trim buf-uint bufp
-syn keyword tl_keyword contained build build-list buildn butlast
-syn keyword tl_keyword contained butlastn caaaaar caaaadr caaaar
-syn keyword tl_keyword contained caaadar caaaddr caaadr caaar
-syn keyword tl_keyword contained caadaar caadadr caadar caaddar
-syn keyword tl_keyword contained caadddr caaddr caadr caar
-syn keyword tl_keyword contained cadaaar cadaadr cadaar cadadar
-syn keyword tl_keyword contained cadaddr cadadr cadar caddaar
-syn keyword tl_keyword contained caddadr caddar cadddar caddddr
-syn keyword tl_keyword contained cadddr caddr cadr call
-syn keyword tl_keyword contained call-clobber-expander call-finalizers call-super-fun call-super-method
+syn keyword tl_keyword contained append* append-each append-each* append-each-prod
+syn keyword tl_keyword contained append-each-prod* append-match-products append-matches apply
+syn keyword tl_keyword contained aret arithp array arraysize
+syn keyword tl_keyword contained ash asin asinh assert
+syn keyword tl_keyword contained assoc assq assql at-exit-call
+syn keyword tl_keyword contained at-exit-do-not-call atan atan2 atanh
+syn keyword tl_keyword contained atom awk base-name base64-decode
+syn keyword tl_keyword contained base64-decode-buf base64-encode base64-stream-dec base64-stream-enc
+syn keyword tl_keyword contained base64url-decode base64url-decode-buf base64url-encode base64url-stream-dec
+syn keyword tl_keyword contained base64url-stream-enc bchar be-double be-float
+syn keyword tl_keyword contained be-int16 be-int32 be-int64 be-uint16
+syn keyword tl_keyword contained be-uint32 be-uint64 bignum-len bignump
+syn keyword tl_keyword contained bindable bit bitset blkcnt-t
+syn keyword tl_keyword contained blksize-t block block* bool
+syn keyword tl_keyword contained boundp bracket break-str brkint
+syn keyword tl_keyword contained bs0 bs1 bsdly bstr
+syn keyword tl_keyword contained bstr-d bstr-s buf buf-alloc-size
+syn keyword tl_keyword contained buf-carray buf-compress buf-d buf-decompress
+syn keyword tl_keyword contained buf-get-char buf-get-cptr buf-get-double buf-get-float
+syn keyword tl_keyword contained buf-get-i16 buf-get-i32 buf-get-i64 buf-get-i8
+syn keyword tl_keyword contained buf-get-int buf-get-long buf-get-short buf-get-u16
+syn keyword tl_keyword contained buf-get-u32 buf-get-u64 buf-get-u8 buf-get-uchar
+syn keyword tl_keyword contained buf-get-uint buf-get-ulong buf-get-ushort buf-int
+syn keyword tl_keyword contained buf-list buf-put-buf buf-put-char buf-put-cptr
+syn keyword tl_keyword contained buf-put-double buf-put-float buf-put-i16 buf-put-i32
+syn keyword tl_keyword contained buf-put-i64 buf-put-i8 buf-put-int buf-put-long
+syn keyword tl_keyword contained buf-put-short buf-put-u16 buf-put-u32 buf-put-u64
+syn keyword tl_keyword contained buf-put-u8 buf-put-uchar buf-put-uint buf-put-ulong
+syn keyword tl_keyword contained buf-put-ushort buf-set-length buf-str buf-trim
+syn keyword tl_keyword contained buf-uint bufp build build-list
+syn keyword tl_keyword contained buildn built-in-type-p butlast butlastn
+syn keyword tl_keyword contained caaaaar caaaadr caaaar caaadar
+syn keyword tl_keyword contained caaaddr caaadr caaar caadaar
+syn keyword tl_keyword contained caadadr caadar caaddar caadddr
+syn keyword tl_keyword contained caaddr caadr caar cadaaar
+syn keyword tl_keyword contained cadaadr cadaar cadadar cadaddr
+syn keyword tl_keyword contained cadadr cadar caddaar caddadr
+syn keyword tl_keyword contained caddar cadddar caddddr cadddr
+syn keyword tl_keyword contained caddr cadr call call-clobber-expander
+syn keyword tl_keyword contained call-delete-expander call-finalizers call-super-fun call-super-method
syn keyword tl_keyword contained call-update-expander callf car carray
syn keyword tl_keyword contained carray-blank carray-buf carray-buf-sync carray-cptr
syn keyword tl_keyword contained carray-dup carray-free carray-get carray-getz
@@ -120,67 +135,82 @@ syn keyword tl_keyword contained carray-put carray-putz carray-ref carray-refset
syn keyword tl_keyword contained carray-replace carray-set-length carray-sub carray-type
syn keyword tl_keyword contained carray-uint carray-vec carrayp caseq
syn keyword tl_keyword contained caseq* caseql caseql* casequal
-syn keyword tl_keyword contained casequal* cat-str cat-streams cat-vec
-syn keyword tl_keyword contained catch catch* catch** catenated-stream-p
-syn keyword tl_keyword contained catenated-stream-push cbaud cbaudex cdaaaar
-syn keyword tl_keyword contained cdaaadr cdaaar cdaadar cdaaddr
-syn keyword tl_keyword contained cdaadr cdaar cdadaar cdadadr
-syn keyword tl_keyword contained cdadar cdaddar cdadddr cdaddr
-syn keyword tl_keyword contained cdadr cdar cddaaar cddaadr
-syn keyword tl_keyword contained cddaar cddadar cddaddr cddadr
-syn keyword tl_keyword contained cddar cdddaar cdddadr cdddar
-syn keyword tl_keyword contained cddddar cdddddr cddddr cdddr
-syn keyword tl_keyword contained cddr cdr ceil ceil-rem
-syn keyword tl_keyword contained chain chand char chdir
-syn keyword tl_keyword contained chmod chmod-rec chown chown-rec
-syn keyword tl_keyword contained chr-digit chr-int chr-isalnum chr-isalpha
-syn keyword tl_keyword contained chr-isascii chr-isblank chr-iscntrl chr-isdigit
-syn keyword tl_keyword contained chr-isgraph chr-islower chr-isprint chr-ispunct
-syn keyword tl_keyword contained chr-isspace chr-isunisp chr-isupper chr-isxdigit
-syn keyword tl_keyword contained chr-num chr-str chr-str-set chr-tolower
-syn keyword tl_keyword contained chr-toupper chr-xdigit chrp clamp
-syn keyword tl_keyword contained clear-dirty clear-error clear-struct clearhash
+syn keyword tl_keyword contained casequal* cat-files cat-str cat-streams
+syn keyword tl_keyword contained cat-vec catch catch* catch**
+syn keyword tl_keyword contained catenated-stream-p catenated-stream-push cbaud cbaudex
+syn keyword tl_keyword contained cbrt cdaaaar cdaaadr cdaaar
+syn keyword tl_keyword contained cdaadar cdaaddr cdaadr cdaar
+syn keyword tl_keyword contained cdadaar cdadadr cdadar cdaddar
+syn keyword tl_keyword contained cdadddr cdaddr cdadr cdar
+syn keyword tl_keyword contained cddaaar cddaadr cddaar cddadar
+syn keyword tl_keyword contained cddaddr cddadr cddar cdddaar
+syn keyword tl_keyword contained cdddadr cdddar cddddar cdddddr
+syn keyword tl_keyword contained cddddr cdddr cddr cdr
+syn keyword tl_keyword contained ceil ceil-rem chain chand
+syn keyword tl_keyword contained char chdir chmod chmod-rec
+syn keyword tl_keyword contained chown chown-rec chr-digit chr-int
+syn keyword tl_keyword contained chr-isalnum chr-isalpha chr-isascii chr-isblank
+syn keyword tl_keyword contained chr-iscntrl chr-isdigit chr-isgraph chr-islower
+syn keyword tl_keyword contained chr-isprint chr-ispunct chr-isspace chr-isunisp
+syn keyword tl_keyword contained chr-isupper chr-isxdigit chr-num chr-str
+syn keyword tl_keyword contained chr-str-set chr-tolower chr-toupper chr-xdigit
+syn keyword tl_keyword contained chrp clamp clean-file clear-dirty
+syn keyword tl_keyword contained clear-error clear-mask clear-struct clearhash
syn keyword tl_keyword contained clocal clock-t clockid-t close
-syn keyword tl_keyword contained close-stream closelog closure cmp-str
-syn keyword tl_keyword contained cmspar coded-length collect-each collect-each*
-syn keyword tl_keyword contained comb command-get command-get-buf command-get-lines
-syn keyword tl_keyword contained command-get-string command-put command-put-buf command-put-lines
-syn keyword tl_keyword contained command-put-string compare-swap compile compile-defr-warning
-syn keyword tl_keyword contained compile-error compile-file compile-only compile-toplevel
-syn keyword tl_keyword contained compile-update-file compile-warning compl-span-str cond
-syn keyword tl_keyword contained conda condlet cons conses
-syn keyword tl_keyword contained conses* consp constantp copy
-syn keyword tl_keyword contained copy-alist copy-buf copy-carray copy-cons
-syn keyword tl_keyword contained copy-file copy-files copy-fun copy-hash
-syn keyword tl_keyword contained copy-list copy-path-rec copy-search-tree copy-str
-syn keyword tl_keyword contained copy-struct copy-tnode copy-tree copy-vec
-syn keyword tl_keyword contained cos cosh count-if count-until-match
-syn keyword tl_keyword contained countq countql countqual cptr
-syn keyword tl_keyword contained cptr-buf cptr-cast cptr-free cptr-int
-syn keyword tl_keyword contained cptr-null cptr-obj cptr-size-hint cptr-type
+syn keyword tl_keyword contained close-lazy-streams close-stream closedir closelog
+syn keyword tl_keyword contained closure cmp-str cmspar cnsort
+syn keyword tl_keyword contained coded-length collect-each collect-each* collect-each-prod
+syn keyword tl_keyword contained collect-each-prod* comb command-get command-get-buf
+syn keyword tl_keyword contained command-get-json command-get-jsons command-get-lines command-get-string
+syn keyword tl_keyword contained command-put command-put-buf command-put-json command-put-jsons
+syn keyword tl_keyword contained command-put-lines command-put-string compare-swap compile
+syn keyword tl_keyword contained compile-defr-warning compile-error compile-file compile-only
+syn keyword tl_keyword contained compile-toplevel compile-update-file compile-warning compiler-let
+syn keyword tl_keyword contained compl-span-str cond conda condlet
+syn keyword tl_keyword contained cons cons-count cons-find conses
+syn keyword tl_keyword contained conses* consp constantp contain[s]
+syn keyword tl_keyword contained copy copy-alist copy-buf copy-carray
+syn keyword tl_keyword contained copy-cons copy-cptr copy-file copy-files
+syn keyword tl_keyword contained copy-fun copy-hash copy-list copy-path-rec
+syn keyword tl_keyword contained copy-search-tree copy-str copy-struct copy-tnode
+syn keyword tl_keyword contained copy-tree copy-tree-iter copy-vec copysign
+syn keyword tl_keyword contained cos cosh count count-if
+syn keyword tl_keyword contained count-until-match countq countql countqual
+syn keyword tl_keyword contained cptr cptr-buf cptr-carray cptr-cast
+syn keyword tl_keyword contained cptr-free cptr-get cptr-int cptr-null
+syn keyword tl_keyword contained cptr-obj cptr-out cptr-size-hint cptr-type
syn keyword tl_keyword contained cptr-zap cptrp cr0 cr1
syn keyword tl_keyword contained cr2 cr3 crc32 crc32-stream
syn keyword tl_keyword contained crdly cread crtscts crypt
syn keyword tl_keyword contained cs5 cs6 cs7 cs8
-syn keyword tl_keyword contained csize cstopb cum-norm-dist daemon
-syn keyword tl_keyword contained dec defer-warning defex deffi
-syn keyword tl_keyword contained deffi-cb deffi-cb-unsafe deffi-sym deffi-type
+syn keyword tl_keyword contained csize csnsort csort csort-group
+syn keyword tl_keyword contained cssort cstopb cum-norm-dist cxr
+syn keyword tl_keyword contained cyr daemon dec defer-warning
+syn keyword tl_keyword contained defex deffi deffi-cb deffi-cb-unsafe
+syn keyword tl_keyword contained deffi-struct deffi-sym deffi-type deffi-union
syn keyword tl_keyword contained deffi-var define-accessor define-modify-macro define-option-struct
-syn keyword tl_keyword contained define-param-expander define-place-macro defmacro defmeth
-syn keyword tl_keyword contained defpackage defparm defparml defplace
-syn keyword tl_keyword contained defset defstruct defsymacro defun
+syn keyword tl_keyword contained define-param-expander define-place-macro define-struct-clause define-struct-prelude
+syn keyword tl_keyword contained defmacro defmatch defmeth defpackage
+syn keyword tl_keyword contained defparm defparml defplace defset
+syn keyword tl_keyword contained defstruct defsymacro defun defun-match
syn keyword tl_keyword contained defvar defvarl del delay
-syn keyword tl_keyword contained delete-package dev-t diff digits
-syn keyword tl_keyword contained digpow dir-name disassemble display-width
-syn keyword tl_keyword contained divides dlclose dlopen dlsym
-syn keyword tl_keyword contained dlsym-checked dlvsym dlvsym-checked do
-syn keyword tl_keyword contained dohash doloop doloop* dotimes
-syn keyword tl_keyword contained double downcase-str drop drop-until
-syn keyword tl_keyword contained drop-while dump-compiled-objects dump-deferred-warnings dup
+syn keyword tl_keyword contained delcons delete-package dev-t diff
+syn keyword tl_keyword contained digits digpow dir-name dirstat
+syn keyword tl_keyword contained disassemble display-width divides dlclose
+syn keyword tl_keyword contained dlopen dlsym dlsym-checked dlvsym
+syn keyword tl_keyword contained dlvsym-checked do doc dohash
+syn keyword tl_keyword contained doloop doloop* dotimes double
+syn keyword tl_keyword contained downcase-str drem drop drop-until
+syn keyword tl_keyword contained drop-while dt-blk dt-chr dt-dir
+syn keyword tl_keyword contained dt-fifo dt-lnk dt-reg dt-sock
+syn keyword tl_keyword contained dt-unknown dump-compiled-objects dump-deferred-warnings dup
syn keyword tl_keyword contained dupfd dwim e2big eacces
-syn keyword tl_keyword contained each each* eaddrinuse eaddrnotavail
-syn keyword tl_keyword contained eafnosupport eagain ealready ebadf
-syn keyword tl_keyword contained ebadmsg ebusy ecanceled echild
+syn keyword tl_keyword contained each each* each-false each-match
+syn keyword tl_keyword contained each-match-product each-prod each-prod* each-true
+syn keyword tl_keyword contained eaddrinuse eaddrnotavail eafnosupport eagain
+syn keyword tl_keyword contained ealready ebadf ebadmsg ebusy
+syn keyword tl_keyword contained ecanceled ecaseq ecaseq* ecaseql
+syn keyword tl_keyword contained ecaseql* ecasequal ecasequal* echild
syn keyword tl_keyword contained echo echoctl echoe echok
syn keyword tl_keyword contained echoke echonl echoprt econnaborted
syn keyword tl_keyword contained econnrefused econnreset edeadlk edestaddrreq
@@ -197,429 +227,542 @@ syn keyword tl_keyword contained enoexec enolck enolink enomem
syn keyword tl_keyword contained enomsg enoprotoopt enospc enosr
syn keyword tl_keyword contained enostr enosys enotconn enotdir
syn keyword tl_keyword contained enotempty enotrecoverable enotsock enotsup
-syn keyword tl_keyword contained enotty ensure-dir enum enumed
-syn keyword tl_keyword contained env env-fbind env-fbindings env-hash
-syn keyword tl_keyword contained env-next env-vbind env-vbindings enxio
-syn keyword tl_keyword contained eopnotsupp eoverflow eownerdead eperm
-syn keyword tl_keyword contained epipe eproto eprotonosupport eprototype
-syn keyword tl_keyword contained eq eql equal equot
-syn keyword tl_keyword contained erange erofs errno error
-syn keyword tl_keyword contained espipe esrch estale etime
-syn keyword tl_keyword contained etimedout etxtbsy eval eval-only
+syn keyword tl_keyword contained enotty ensure ensure-dir enum
+syn keyword tl_keyword contained enumed env env-fbind env-fbindings
+syn keyword tl_keyword contained env-hash env-next env-vbind env-vbindings
+syn keyword tl_keyword contained enxio eopnotsupp eoverflow eownerdead
+syn keyword tl_keyword contained eperm epipe eproto eprotonosupport
+syn keyword tl_keyword contained eprototype eq eql equal
+syn keyword tl_keyword contained equot erange erf erfc
+syn keyword tl_keyword contained erofs errno error espipe
+syn keyword tl_keyword contained esrch estale etime etimedout
+syn keyword tl_keyword contained etxtbsy etypecase eval eval-only
syn keyword tl_keyword contained evenp ewouldblock exception-subtype-map exception-subtype-p
syn keyword tl_keyword contained exdev exec exit exit*
-syn keyword tl_keyword contained exp expand expand* expand-left
-syn keyword tl_keyword contained expand-right expand-with-free-refs expt exptmod
+syn keyword tl_keyword contained exp exp10 exp2 expand
+syn keyword tl_keyword contained expand* expand-left expand-right expand-with-free-refs
+syn keyword tl_keyword contained expander-let expm1 expt exptmod
syn keyword tl_keyword contained extproc f$ f-dupfd f-dupfd-cloexec
syn keyword tl_keyword contained f-getfd f-getfl f-getlk f-rdlck
syn keyword tl_keyword contained f-setfd f-setfl f-setlk f-setlkw
syn keyword tl_keyword contained f-unlck f-wrlck f^ f^$
syn keyword tl_keyword contained false fboundp fcntl fd-cloexec
-syn keyword tl_keyword contained ff0 ff1 ffdly ffi
-syn keyword tl_keyword contained ffi-alignof ffi-arraysize ffi-call ffi-elemsize
-syn keyword tl_keyword contained ffi-elemtype ffi-get ffi-in ffi-make-call-desc
-syn keyword tl_keyword contained ffi-make-closure ffi-offsetof ffi-out ffi-put
-syn keyword tl_keyword contained ffi-put-into ffi-size ffi-type-compile ffi-type-operator-p
-syn keyword tl_keyword contained ffi-type-p ffi-typedef fifth file-append
-syn keyword tl_keyword contained file-append-buf file-append-lines file-append-string file-get
-syn keyword tl_keyword contained file-get-buf file-get-lines file-get-string file-place-buf
-syn keyword tl_keyword contained file-put file-put-buf file-put-lines file-put-string
-syn keyword tl_keyword contained fileno fill-buf fill-buf-adjust fill-carray
-syn keyword tl_keyword contained fill-obj filter-equal filter-string-tree finalize
-syn keyword tl_keyword contained find find-frame find-frames find-frames-by-mask
-syn keyword tl_keyword contained find-if find-max find-min find-package
-syn keyword tl_keyword contained find-struct-type find-symbol find-symbol-fb first
-syn keyword tl_keyword contained fixnum-max fixnum-min fixnump flatcar
-syn keyword tl_keyword contained flatcar* flatten flatten* flet
-syn keyword tl_keyword contained flip flipargs flo-dig flo-down
-syn keyword tl_keyword contained flo-epsilon flo-get-round-mode flo-int flo-max
-syn keyword tl_keyword contained flo-max-dig flo-min flo-near flo-set-round-mode
-syn keyword tl_keyword contained flo-str flo-up flo-zero float
-syn keyword tl_keyword contained floatp floor floor-rem flush-stream
-syn keyword tl_keyword contained flusho fmakunbound fmt fnm-casefold
-syn keyword tl_keyword contained fnm-extmatch fnm-leading-dir fnm-noescape fnm-pathname
-syn keyword tl_keyword contained fnm-period fnmatch for for*
-syn keyword tl_keyword contained force force-break fork format
-syn keyword tl_keyword contained fourth fr$ fr^ fr^$
-syn keyword tl_keyword contained from frr fsblkcnt-t fsfilcnt-t
-syn keyword tl_keyword contained fstat ftw ftw-actionretval ftw-chdir
-syn keyword tl_keyword contained ftw-continue ftw-d ftw-depth ftw-dnr
-syn keyword tl_keyword contained ftw-dp ftw-f ftw-mount ftw-ns
-syn keyword tl_keyword contained ftw-phys ftw-skip-siblings ftw-skip-subtree ftw-sl
-syn keyword tl_keyword contained ftw-sln ftw-stop fun fun-fixparam-count
-syn keyword tl_keyword contained fun-optparam-count fun-variadic func-get-env func-get-form
-syn keyword tl_keyword contained func-get-name func-set-env functionp gcd
-syn keyword tl_keyword contained gen gen-hash-seed generate gensym
-syn keyword tl_keyword contained gequal get-buf-from-stream get-byte get-char
-syn keyword tl_keyword contained get-clobber-expander get-delete-expander get-error get-error-str
-syn keyword tl_keyword contained get-frames get-hash-userdata get-indent get-indent-mode
-syn keyword tl_keyword contained get-line get-lines get-list-from-stream get-obj
-syn keyword tl_keyword contained get-sig-handler get-string get-string-from-stream get-update-expander
-syn keyword tl_keyword contained getaddrinfo getegid getenv geteuid
-syn keyword tl_keyword contained getgid getgrent getgrgid getgrnam
-syn keyword tl_keyword contained getgroups gethash getitimer getopts
-syn keyword tl_keyword contained getpid getppid getpwent getpwnam
-syn keyword tl_keyword contained getpwuid getresgid getresuid getuid
-syn keyword tl_keyword contained gid-t ginterate giterate glob
+syn keyword tl_keyword contained fdim ff0 ff1 ffdly
+syn keyword tl_keyword contained ffi ffi-alignof ffi-arraysize ffi-call
+syn keyword tl_keyword contained ffi-elemsize ffi-elemtype ffi-get ffi-in
+syn keyword tl_keyword contained ffi-make-call-desc ffi-make-closure ffi-offsetof ffi-out
+syn keyword tl_keyword contained ffi-put ffi-put-into ffi-size ffi-type-compile
+syn keyword tl_keyword contained ffi-type-operator-p ffi-type-p ffi-typedef fifth
+syn keyword tl_keyword contained file-append file-append-buf file-append-json file-append-jsons
+syn keyword tl_keyword contained file-append-lines file-append-objects file-append-string file-get
+syn keyword tl_keyword contained file-get-buf file-get-json file-get-jsons file-get-lines
+syn keyword tl_keyword contained file-get-objects file-get-string file-place-buf file-put
+syn keyword tl_keyword contained file-put-buf file-put-json file-put-jsons file-put-lines
+syn keyword tl_keyword contained file-put-objects file-put-string fileno fill-buf
+syn keyword tl_keyword contained fill-buf-adjust fill-carray fill-obj fill-vec
+syn keyword tl_keyword contained filter-equal filter-string-tree finalize find
+syn keyword tl_keyword contained find-frame find-frames find-frames-by-mask find-if
+syn keyword tl_keyword contained find-max find-max-key find-min find-min-key
+syn keyword tl_keyword contained find-package find-struct-type find-symbol find-symbol-fb
+syn keyword tl_keyword contained find-true first fixnum-max fixnum-min
+syn keyword tl_keyword contained fixnump flatcar flatcar* flatten
+syn keyword tl_keyword contained flatten* flet flip flipargs
+syn keyword tl_keyword contained flo-dig flo-down flo-epsilon flo-get-round-mode
+syn keyword tl_keyword contained flo-int flo-max flo-max-dig flo-min
+syn keyword tl_keyword contained flo-near flo-set-round-mode flo-str flo-up
+syn keyword tl_keyword contained flo-zero float floatp floor
+syn keyword tl_keyword contained floor-rem flow flush-stream flusho
+syn keyword tl_keyword contained fmakunbound fmax fmin fmt
+syn keyword tl_keyword contained fnm-casefold fnm-extmatch fnm-leading-dir fnm-noescape
+syn keyword tl_keyword contained fnm-pathname fnm-period fnmatch for
+syn keyword tl_keyword contained for* force force-break fork
+syn keyword tl_keyword contained format fourth fr$ fr^
+syn keyword tl_keyword contained fr^$ from frr fsblkcnt-t
+syn keyword tl_keyword contained fsfilcnt-t fstat ftw ftw-actionretval
+syn keyword tl_keyword contained ftw-chdir ftw-continue ftw-d ftw-depth
+syn keyword tl_keyword contained ftw-dnr ftw-dp ftw-f ftw-mount
+syn keyword tl_keyword contained ftw-ns ftw-phys ftw-skip-siblings ftw-skip-subtree
+syn keyword tl_keyword contained ftw-sl ftw-sln ftw-stop fun
+syn keyword tl_keyword contained fun-fixparam-count fun-optparam-count fun-variadic func-get-env
+syn keyword tl_keyword contained func-get-form func-get-name func-set-env functionp
+syn keyword tl_keyword contained gamma gcd gen gen-hash-seed
+syn keyword tl_keyword contained generate gensym gequal get-buf-from-stream
+syn keyword tl_keyword contained get-byte get-char get-clobber-expander get-delete-expander
+syn keyword tl_keyword contained get-error get-error-str get-frames get-hash-userdata
+syn keyword tl_keyword contained get-indent get-indent-mode get-json get-jsons
+syn keyword tl_keyword contained get-line get-line-as-buf get-lines get-list-from-stream
+syn keyword tl_keyword contained get-obj get-sig-handler get-stack-limit get-string
+syn keyword tl_keyword contained get-string-from-stream get-update-expander getaddrinfo getegid
+syn keyword tl_keyword contained getenv geteuid getgid getgrent
+syn keyword tl_keyword contained getgrgid getgrnam getgroups gethash
+syn keyword tl_keyword contained getitimer getopts getpid getppid
+syn keyword tl_keyword contained getpwent getpwnam getpwuid getresgid
+syn keyword tl_keyword contained getresuid getrlimit getuid gid-t
+syn keyword tl_keyword contained ginterate giterate glob glob*
syn keyword tl_keyword contained glob-altdirfunc glob-brace glob-err glob-mark
syn keyword tl_keyword contained glob-nocheck glob-noescape glob-nomagic glob-nosort
syn keyword tl_keyword contained glob-onlydir glob-period glob-tilde glob-tilde-check
-syn keyword tl_keyword contained go grade greater group-by
-syn keyword tl_keyword contained group-reduce gun handle handle*
-syn keyword tl_keyword contained handler-bind hash hash-alist hash-begin
-syn keyword tl_keyword contained hash-construct hash-count hash-diff hash-eql
-syn keyword tl_keyword contained hash-equal hash-from-alist hash-from-pairs hash-invert
-syn keyword tl_keyword contained hash-isec hash-keys hash-list hash-next
-syn keyword tl_keyword contained hash-pairs hash-peek hash-proper-subset hash-reset
-syn keyword tl_keyword contained hash-revget hash-subset hash-symdiff hash-uni
-syn keyword tl_keyword contained hash-update hash-update-1 hash-userdata hash-values
-syn keyword tl_keyword contained hash-zip hashp have hlet
+syn keyword tl_keyword contained glob-xnobrace go grade greater
+syn keyword tl_keyword contained group-by group-map group-reduce gun
+syn keyword tl_keyword contained handle handle* handler-bind hash
+syn keyword tl_keyword contained hash-alist hash-begin hash-construct hash-count
+syn keyword tl_keyword contained hash-diff hash-eql hash-equal hash-from-alist
+syn keyword tl_keyword contained hash-from-pairs hash-invert hash-isec hash-join
+syn keyword tl_keyword contained hash-keys hash-keys-of hash-list hash-map
+syn keyword tl_keyword contained hash-next hash-pairs hash-peek hash-proper-subset
+syn keyword tl_keyword contained hash-props hash-reset hash-revget hash-subset
+syn keyword tl_keyword contained hash-symdiff hash-uni hash-update hash-update-1
+syn keyword tl_keyword contained hash-userdata hash-values hash-zip hashp
+syn keyword tl_keyword contained have hist-sort hist-sort-by hlet
syn keyword tl_keyword contained hlet* html-decode html-encode html-encode*
-syn keyword tl_keyword contained hupcl iapply icanon icrnl
-syn keyword tl_keyword contained id-t identity identity* ido
-syn keyword tl_keyword contained iexten if ifa iff
-syn keyword tl_keyword contained iffi iflet ignbrk igncr
-syn keyword tl_keyword contained ignerr ignpar ignwarn imaxbel
-syn keyword tl_keyword contained improper-plist-to-alist in in-package in-range
-syn keyword tl_keyword contained in-range* in6addr-any in6addr-loopback inaddr-any
-syn keyword tl_keyword contained inaddr-loopback inc inc-indent indent-code
-syn keyword tl_keyword contained indent-data indent-foff indent-off inhash
-syn keyword tl_keyword contained inlcr ino-t inpck int
-syn keyword tl_keyword contained int-buf int-carray int-chr int-cptr
-syn keyword tl_keyword contained int-flo int-ptr-t int-str int16
-syn keyword tl_keyword contained int32 int64 int8 integerp
-syn keyword tl_keyword contained intern intern-fb interp-fun-p interpose
-syn keyword tl_keyword contained inv-cum-norm invoke-catch ip ipf
-syn keyword tl_keyword contained iread isec isig isqrt
-syn keyword tl_keyword contained istrip itimer-prov itimer-real itimer-virtual
-syn keyword tl_keyword contained iuclc iutf8 ixany ixoff
-syn keyword tl_keyword contained ixon juxt keep-if keep-if*
+syn keyword tl_keyword contained hupcl hypot iapply icanon
+syn keyword tl_keyword contained icrnl id-t identity identity*
+syn keyword tl_keyword contained ido iexten if if-match
+syn keyword tl_keyword contained ifa iff iffi iflet
+syn keyword tl_keyword contained ignbrk igncr ignerr ignore
+syn keyword tl_keyword contained ignpar ignwarn imaxbel improper-plist-to-alist
+syn keyword tl_keyword contained in in-package in-range in-range*
+syn keyword tl_keyword contained in6addr-any in6addr-loopback in6addr-str inaddr-any
+syn keyword tl_keyword contained inaddr-loopback inaddr-str inc inc-indent
+syn keyword tl_keyword contained inc-indent-abs indent-code indent-data indent-foff
+syn keyword tl_keyword contained indent-off inhash inlcr ino-t
+syn keyword tl_keyword contained inpck int int-buf int-carray
+syn keyword tl_keyword contained int-chr int-cptr int-flo int-ptr-t
+syn keyword tl_keyword contained int-str int16 int32 int64
+syn keyword tl_keyword contained int8 integerp intern intern-fb
+syn keyword tl_keyword contained interp-fun-p interpose intmax-t inv-cum-norm
+syn keyword tl_keyword contained invoke-catch ip ipf ipproto-ip
+syn keyword tl_keyword contained ipproto-ipv6 ipproto-tcp ipproto-udp ipv6-join-group
+syn keyword tl_keyword contained ipv6-leave-group ipv6-multicast-hops ipv6-multicast-if ipv6-multicast-loop
+syn keyword tl_keyword contained ipv6-unicast-hops ipv6-v6only iread isatty
+syn keyword tl_keyword contained isec isecp isig isqrt
+syn keyword tl_keyword contained istrip iter-begin iter-item iter-more
+syn keyword tl_keyword contained iter-reset iter-step iterable itimer-prof
+syn keyword tl_keyword contained itimer-real itimer-virtual iuclc iutf8
+syn keyword tl_keyword contained ixany ixoff ixon j0
+syn keyword tl_keyword contained j1 jmp-buf jn join
+syn keyword tl_keyword contained join-with json juxt keep-if
+syn keyword tl_keyword contained keep-if* keep-keys-if keep-match-products keep-matches
syn keyword tl_keyword contained keepq keepql keepqual key
syn keyword tl_keyword contained key-t keyword-package keywordp kill
-syn keyword tl_keyword contained labels lambda last lazy-str
-syn keyword tl_keyword contained lazy-str-force lazy-str-force-upto lazy-str-get-trailing-list lazy-stream-cons
-syn keyword tl_keyword contained lazy-stringp lchown lcm lcons
-syn keyword tl_keyword contained lcons-car lcons-cdr lcons-fun lconsp
-syn keyword tl_keyword contained ldiff ldo le-double le-float
-syn keyword tl_keyword contained le-int16 le-int32 le-int64 le-uint16
-syn keyword tl_keyword contained le-uint32 le-uint64 left len
-syn keyword tl_keyword contained length length-buf length-carray length-list
+syn keyword tl_keyword contained labels lambda lambda-match last
+syn keyword tl_keyword contained lazy-str lazy-str-force lazy-str-force-upto lazy-str-get-trailing-list
+syn keyword tl_keyword contained lazy-stream-cons lazy-stringp lchown lcm
+syn keyword tl_keyword contained lcons lcons-car lcons-cdr lcons-fun
+syn keyword tl_keyword contained lconsp ldexp ldiff ldo
+syn keyword tl_keyword contained le-double le-float le-int16 le-int32
+syn keyword tl_keyword contained le-int64 le-uint16 le-uint32 le-uint64
+syn keyword tl_keyword contained left len length length-<
+syn keyword tl_keyword contained length-buf length-carray length-list length-list-<
syn keyword tl_keyword contained length-str length-str-< length-str-<= length-str->
syn keyword tl_keyword contained length-str->= length-vec lequal less
-syn keyword tl_keyword contained let let* lexical-fun-p lexical-lisp1-binding
-syn keyword tl_keyword contained lexical-var-p lib-version link lisp-parse
-syn keyword tl_keyword contained list list* list-carray list-str
-syn keyword tl_keyword contained list-vec list-vector listp lnew
-syn keyword tl_keyword contained lnew* load load-for load-time
-syn keyword tl_keyword contained loff-t log log-alert log-auth
-syn keyword tl_keyword contained log-authpriv log-cons log-crit log-daemon
-syn keyword tl_keyword contained log-debug log-emerg log-err log-info
-syn keyword tl_keyword contained log-ndelay log-notice log-nowait log-odelay
-syn keyword tl_keyword contained log-perror log-pid log-user log-warning
-syn keyword tl_keyword contained log10 log2 logand logcount
+syn keyword tl_keyword contained let let* lexical-binding-kind lexical-fun-binding-kind
+syn keyword tl_keyword contained lexical-fun-p lexical-lisp1-binding lexical-macro-p lexical-symacro-p
+syn keyword tl_keyword contained lexical-var-p lflow lgamma lib-version
+syn keyword tl_keyword contained link lisp-parse list list*
+syn keyword tl_keyword contained list-carray list-seq list-str list-vec
+syn keyword tl_keyword contained list-vector listp lnew lnew*
+syn keyword tl_keyword contained load load-args-process load-args-recurse load-for
+syn keyword tl_keyword contained load-time loand loff-t log
+syn keyword tl_keyword contained log-alert log-auth log-authpriv log-cons
+syn keyword tl_keyword contained log-crit log-daemon log-debug log-emerg
+syn keyword tl_keyword contained log-err log-info log-ndelay log-notice
+syn keyword tl_keyword contained log-nowait log-odelay log-perror log-pid
+syn keyword tl_keyword contained log-user log-warning log10 log1p
+syn keyword tl_keyword contained log2 logand logb logcount
syn keyword tl_keyword contained logior lognot logtest logtrunc
-syn keyword tl_keyword contained logxor long longlong lop
+syn keyword tl_keyword contained logxor long long-suffix longjmp
+syn keyword tl_keyword contained longlong lop lopf lopip
syn keyword tl_keyword contained lset lstat lutimes m$
-syn keyword tl_keyword contained m^ m^$ mac-param-bind macro-ancestor
-syn keyword tl_keyword contained macro-form-p macro-time macroexpand macroexpand-1
-syn keyword tl_keyword contained macroexpand-1-lisp1 macroexpand-lisp1 macrolet major
-syn keyword tl_keyword contained make-buf make-buf-stream make-byte-input-stream make-catenated-stream
-syn keyword tl_keyword contained make-env make-hash make-lazy-cons make-lazy-struct
-syn keyword tl_keyword contained make-like make-package make-random-state make-similar-hash
-syn keyword tl_keyword contained make-string-byte-input-stream make-string-input-stream make-string-output-stream make-strlist-input-stream
-syn keyword tl_keyword contained make-strlist-output-stream make-struct make-struct-delegate-stream make-struct-type
-syn keyword tl_keyword contained make-sym make-time make-time-utc make-trie
-syn keyword tl_keyword contained make-union make-zstruct makedev makunbound
-syn keyword tl_keyword contained mapcar mapcar* mapdo mapf
-syn keyword tl_keyword contained maphash mappend mappend* maprend
-syn keyword tl_keyword contained maprod mask match-fun match-regex
-syn keyword tl_keyword contained match-regex-right match-regst match-regst-right match-str
-syn keyword tl_keyword contained match-str-tree max mboundp md5
-syn keyword tl_keyword contained md5-begin md5-end md5-hash md5-stream
-syn keyword tl_keyword contained member member-if memp memq
-syn keyword tl_keyword contained memql memqual meq meql
-syn keyword tl_keyword contained mequal merge merge-delete-package meth
-syn keyword tl_keyword contained method min minor minusp
-syn keyword tl_keyword contained mismatch mkdir mkfifo mknod
-syn keyword tl_keyword contained mkstring mlet mmakunbound mod
-syn keyword tl_keyword contained mode-t multi multi-sort n-choose-k
-syn keyword tl_keyword contained n-perm-k nconc neg neq
-syn keyword tl_keyword contained neql nequal new new*
-syn keyword tl_keyword contained nexpand-left nil nilf ninth
-syn keyword tl_keyword contained nl0 nl1 nldly nlink-t
-syn keyword tl_keyword contained noflsh none not notf
-syn keyword tl_keyword contained nreconc nreverse nth nthcdr
-syn keyword tl_keyword contained nthlast null nullify num-chr
-syn keyword tl_keyword contained num-str numberp nzerop o-accmode
-syn keyword tl_keyword contained o-append o-async o-cloexec o-creat
-syn keyword tl_keyword contained o-direct o-directory o-noatime o-noctty
-syn keyword tl_keyword contained o-nofollow o-nonblock o-path o-rdonly
-syn keyword tl_keyword contained o-rdwr o-sync o-trunc o-wronly
-syn keyword tl_keyword contained oand obtain obtain* obtain*-block
-syn keyword tl_keyword contained obtain-block ocrnl oddp ofdel
-syn keyword tl_keyword contained off-t offsetof ofill olcuc
-syn keyword tl_keyword contained onlcr onlret onocr op
-syn keyword tl_keyword contained open-command open-directory open-file open-fileno
-syn keyword tl_keyword contained open-files open-files* open-pipe open-process
-syn keyword tl_keyword contained open-socket open-socket-pair open-subprocess open-tail
-syn keyword tl_keyword contained openlog opip opost opt
-syn keyword tl_keyword contained opthelp or orf package-alist
+syn keyword tl_keyword contained m^ m^$ mac-env-param-bind mac-param-bind
+syn keyword tl_keyword contained macro-ancestor macro-form-p macro-time macroexpand
+syn keyword tl_keyword contained macroexpand-1 macroexpand-1-lisp1 macroexpand-1-place macroexpand-lisp1
+syn keyword tl_keyword contained macroexpand-match macroexpand-params macroexpand-place macroexpand-struct-clause
+syn keyword tl_keyword contained macrolet madv-dodump madv-dofork madv-dontdump
+syn keyword tl_keyword contained madv-dontfork madv-dontneed madv-free madv-hugepage
+syn keyword tl_keyword contained madv-hwpoison madv-keeponfork madv-mergeable madv-nohugepage
+syn keyword tl_keyword contained madv-normal madv-random madv-remove madv-sequential
+syn keyword tl_keyword contained madv-unmergeable madv-willneed madv-wipeonfork madvise
+syn keyword tl_keyword contained major make-buf make-buf-stream make-byte-input-stream
+syn keyword tl_keyword contained make-catenated-stream make-env make-hash make-lazy-cons
+syn keyword tl_keyword contained make-lazy-struct make-like make-package make-random-state
+syn keyword tl_keyword contained make-similar-hash make-similar-tree make-string-byte-input-stream make-string-input-stream
+syn keyword tl_keyword contained make-string-output-stream make-strlist-input-stream make-strlist-output-stream make-struct
+syn keyword tl_keyword contained make-struct-delegate-stream make-struct-type make-sym make-time
+syn keyword tl_keyword contained make-time-utc make-trie make-union make-zstruct
+syn keyword tl_keyword contained makedev makunbound map-anon map-fixed
+syn keyword tl_keyword contained map-growsdown map-huge-mask map-huge-shift map-hugetlb
+syn keyword tl_keyword contained map-locked map-nonblock map-noreserve map-populate
+syn keyword tl_keyword contained map-private map-shared map-stack mapcar
+syn keyword tl_keyword contained mapcar* mapdo mapf maphash
+syn keyword tl_keyword contained mappend mappend* maprend maprod
+syn keyword tl_keyword contained maprodo mask match match-case
+syn keyword tl_keyword contained match-cond match-ecase match-error match-fboundp
+syn keyword tl_keyword contained match-fun match-regex match-regex-right match-regst
+syn keyword tl_keyword contained match-regst-right match-str match-str-tree max
+syn keyword tl_keyword contained mboundp md5 md5-begin md5-end
+syn keyword tl_keyword contained md5-hash md5-stream member member-if
+syn keyword tl_keyword contained memp memq memql memqual
+syn keyword tl_keyword contained meq meql mequal merge
+syn keyword tl_keyword contained merge-delete-package meth method min
+syn keyword tl_keyword contained minor minusp mismatch mkdir
+syn keyword tl_keyword contained mkdtemp mkfifo mknod mkstemp
+syn keyword tl_keyword contained mkstring mlet mmakunbound mmap
+syn keyword tl_keyword contained mod mode-t mprotect mref
+syn keyword tl_keyword contained ms-async ms-invalidate ms-sync msync
+syn keyword tl_keyword contained mul-each mul-each* mul-each-prod mul-each-prod*
+syn keyword tl_keyword contained multi multi-sort munmap n-choose-k
+syn keyword tl_keyword contained n-perm-k nand nandf nconc
+syn keyword tl_keyword contained nearbyint neg neq neql
+syn keyword tl_keyword contained nequal nested-vec nested-vec-of new
+syn keyword tl_keyword contained new* nexpand-left nextafter nil
+syn keyword tl_keyword contained nilf ninth nl0 nl1
+syn keyword tl_keyword contained nldly nlink-t noflsh none
+syn keyword tl_keyword contained nor norf not notf
+syn keyword tl_keyword contained nreconc nreverse nrot nshuffle
+syn keyword tl_keyword contained nsort nth nthcdr nthlast
+syn keyword tl_keyword contained null nullify num-chr num-str
+syn keyword tl_keyword contained numberp nzerop o-accmode o-append
+syn keyword tl_keyword contained o-async o-cloexec o-creat o-direct
+syn keyword tl_keyword contained o-directory o-noatime o-noctty o-nofollow
+syn keyword tl_keyword contained o-nonblock o-path o-rdonly o-rdwr
+syn keyword tl_keyword contained o-sync o-trunc o-wronly oand
+syn keyword tl_keyword contained obtain obtain* obtain*-block obtain-block
+syn keyword tl_keyword contained ocrnl oddp ofdel off-t
+syn keyword tl_keyword contained offsetof ofill olcuc onlcr
+syn keyword tl_keyword contained onlret onocr op open-command
+syn keyword tl_keyword contained open-directory open-file open-fileno open-files
+syn keyword tl_keyword contained open-files* open-pipe open-process open-socket
+syn keyword tl_keyword contained open-socket-pair open-subprocess open-tail opendir
+syn keyword tl_keyword contained openlog opf opip opost
+syn keyword tl_keyword contained opt opthelp opthelp-conventions opthelp-types
+syn keyword tl_keyword contained or orf pack package-alist
syn keyword tl_keyword contained package-fallback-list package-foreign-symbols package-local-symbols package-name
-syn keyword tl_keyword contained package-symbols packagep pad parenb
-syn keyword tl_keyword contained parmrk parodd partition partition*
-syn keyword tl_keyword contained partition-by path-blkdev-p path-cat path-chrdev-p
-syn keyword tl_keyword contained path-dir-empty path-dir-p path-executable-to-me-p path-exists-p
-syn keyword tl_keyword contained path-file-p path-mine-p path-my-group-p path-newer
-syn keyword tl_keyword contained path-older path-pipe-p path-private-to-me-p path-read-writable-to-me-p
-syn keyword tl_keyword contained path-readable-to-me-p path-same-object path-sep-chars path-setgid-p
+syn keyword tl_keyword contained package-symbols packagep pad page-size
+syn keyword tl_keyword contained pairlis parenb parmrk parodd
+syn keyword tl_keyword contained parse-errors partition partition* partition-by
+syn keyword tl_keyword contained partition-if path-blkdev-p path-cat path-chrdev-p
+syn keyword tl_keyword contained path-components-safe path-dir-empty path-dir-p path-equal
+syn keyword tl_keyword contained path-executable-to-me-p path-exists-p path-file-p path-mine-p
+syn keyword tl_keyword contained path-my-group-p path-newer path-older path-pipe-p
+syn keyword tl_keyword contained path-private-to-me-p path-read-writable-to-me-p path-readable-to-me-p path-safe-sticky-dir
+syn keyword tl_keyword contained path-same-object path-search path-sep-chars path-setgid-p
syn keyword tl_keyword contained path-setuid-p path-sock-p path-sticky-p path-strictly-private-to-me-p
syn keyword tl_keyword contained path-symlink-p path-writable-to-me-p pdec pendin
-syn keyword tl_keyword contained perm pid-t pinc pipe
-syn keyword tl_keyword contained place-form-p placelet placelet* plist-to-alist
-syn keyword tl_keyword contained plusp poll poll-err poll-in
-syn keyword tl_keyword contained poll-nval poll-out poll-pri poll-rdband
-syn keyword tl_keyword contained poll-rdhup poll-wrband poly pop
-syn keyword tl_keyword contained pos pos-if pos-max pos-min
-syn keyword tl_keyword contained posq posql posqual pppred
-syn keyword tl_keyword contained ppred pprinl pprint pprof
-syn keyword tl_keyword contained pred prinl print prod
-syn keyword tl_keyword contained prof prog prog* prog1
-syn keyword tl_keyword contained progn promisep prop proper-list-p
-syn keyword tl_keyword contained proper-listp pset ptr ptr-in
-syn keyword tl_keyword contained ptr-in-d ptr-out ptr-out-d ptr-out-s
-syn keyword tl_keyword contained ptrdiff-t pub:txr-sym pure-rel-path-p purge-deferred-warning
-syn keyword tl_keyword contained push pushhash pushnew put-buf
-syn keyword tl_keyword contained put-byte put-carray put-char put-line
-syn keyword tl_keyword contained put-lines put-obj put-string put-strings
-syn keyword tl_keyword contained pwd qquote qref quote
-syn keyword tl_keyword contained r$ r^ r^$ raise
-syn keyword tl_keyword contained rand random random-fixnum random-float
+syn keyword tl_keyword contained perm pic pid-t pinc
+syn keyword tl_keyword contained pipe place-form-p placelet placelet*
+syn keyword tl_keyword contained plist-to-alist plusp poll poll-err
+syn keyword tl_keyword contained poll-in poll-nval poll-out poll-pri
+syn keyword tl_keyword contained poll-rdband poll-rdhup poll-wrband poly
+syn keyword tl_keyword contained pop pop-after-load portable-abs-path-p pos
+syn keyword tl_keyword contained pos-if pos-max pos-min posq
+syn keyword tl_keyword contained posql posqual pppred ppred
+syn keyword tl_keyword contained pprinl pprint pprof pred
+syn keyword tl_keyword contained prinl print prod prof
+syn keyword tl_keyword contained prog prog* prog1 prog2
+syn keyword tl_keyword contained progn progv promisep prop
+syn keyword tl_keyword contained proper-list-p proper-listp prot-exec prot-growsdown
+syn keyword tl_keyword contained prot-growsup prot-none prot-read prot-write
+syn keyword tl_keyword contained pset ptr ptr-in ptr-in-d
+syn keyword tl_keyword contained ptr-out ptr-out-d ptr-out-s ptrdiff-t
+syn keyword tl_keyword contained pub:txr-sym pure-rel-path-p purge-deferred-warning push
+syn keyword tl_keyword contained push-after-load pushhash pushnew put-buf
+syn keyword tl_keyword contained put-byte put-carray put-char put-json
+syn keyword tl_keyword contained put-jsonl put-jsons put-line put-lines
+syn keyword tl_keyword contained put-obj put-string put-strings pwd
+syn keyword tl_keyword contained qquote qref quantile quip
+syn keyword tl_keyword contained quote r$ r^ r^$
+syn keyword tl_keyword contained raise rand random random-buf
+syn keyword tl_keyword contained random-fixnum random-float random-float-incl random-sample
syn keyword tl_keyword contained random-state-get-vec random-state-p range range*
-syn keyword tl_keyword contained range-regex rangep rassoc rassq
-syn keyword tl_keyword contained rassql rcomb rcons read
-syn keyword tl_keyword contained read-until-match readlink real-time-stream-p realpath
+syn keyword tl_keyword contained range-regex rangep rangeref rassoc
+syn keyword tl_keyword contained rassq rassql rcomb rcons
+syn keyword tl_keyword contained read read-objects read-once read-until-match
+syn keyword tl_keyword contained readdir readlink real-time-stream-p realpath
syn keyword tl_keyword contained record-adapter reduce-left reduce-right ref
-syn keyword tl_keyword contained refset regex-compile regex-from-trie regex-parse
-syn keyword tl_keyword contained regex-prefix-match regex-source regexp register-exception-subtypes
-syn keyword tl_keyword contained register-tentative-def regsub rehome-sym relate
-syn keyword tl_keyword contained release-deferred-warnings remhash remove-if remove-if*
+syn keyword tl_keyword contained refset regex-compile regex-from-trie regex-optimize
+syn keyword tl_keyword contained regex-parse regex-prefix-match regex-source regexp
+syn keyword tl_keyword contained register-exception-subtypes register-tentative-def regsub rehome-sym
+syn keyword tl_keyword contained reject rel-path relate release-deferred-warnings
+syn keyword tl_keyword contained remainder remhash remove-if remove-if*
syn keyword tl_keyword contained remove-path remove-path-rec remq remq*
syn keyword tl_keyword contained remql remql* remqual remqual*
syn keyword tl_keyword contained rename-path repeat replace replace-buf
-syn keyword tl_keyword contained replace-list replace-str replace-struct replace-vec
-syn keyword tl_keyword contained reset-struct rest ret retf
-syn keyword tl_keyword contained return return* return-from revappend
-syn keyword tl_keyword contained reverse rfind rfind-if right
-syn keyword tl_keyword contained rlcp rlcp-tree rlet rlist
-syn keyword tl_keyword contained rlist* rmdir rmember rmember-if
-syn keyword tl_keyword contained rmemq rmemql rmemqual rmismatch
-syn keyword tl_keyword contained rotate round round-rem rperm
-syn keyword tl_keyword contained rplaca rplacd rpoly rpos
-syn keyword tl_keyword contained rpos-if rposq rposql rposqual
-syn keyword tl_keyword contained rr rra rsearch rslot
-syn keyword tl_keyword contained rtld-deepbind rtld-global rtld-lazy rtld-local
-syn keyword tl_keyword contained rtld-nodelete rtld-noload rtld-now run
-syn keyword tl_keyword contained s-ifblk s-ifchr s-ifdir s-ififo
-syn keyword tl_keyword contained s-iflnk s-ifmt s-ifreg s-ifsock
-syn keyword tl_keyword contained s-irgrp s-iroth s-irusr s-irwxg
-syn keyword tl_keyword contained s-irwxo s-irwxu s-isgid s-isuid
-syn keyword tl_keyword contained s-isvtx s-iwgrp s-iwoth s-iwusr
-syn keyword tl_keyword contained s-ixgrp s-ixoth s-ixusr save-exe
-syn keyword tl_keyword contained sbit scan-until-match search search-regex
-syn keyword tl_keyword contained search-regst search-str search-str-tree second
-syn keyword tl_keyword contained seek-cur seek-end seek-set seek-stream
-syn keyword tl_keyword contained select self-load-path self-path seq-begin
+syn keyword tl_keyword contained replace-env replace-list replace-str replace-struct
+syn keyword tl_keyword contained replace-tree-iter replace-vec reset-struct rest
+syn keyword tl_keyword contained ret retf return return*
+syn keyword tl_keyword contained return-from revappend reverse rfind
+syn keyword tl_keyword contained rfind-if right rint rlcp
+syn keyword tl_keyword contained rlcp-tree rlet rlim-infinity rlim-saved-cur
+syn keyword tl_keyword contained rlim-saved-max rlimit-as rlimit-core rlimit-cpu
+syn keyword tl_keyword contained rlimit-data rlimit-fsize rlimit-nofile rlimit-stack
+syn keyword tl_keyword contained rlink rlist rlist* rmdir
+syn keyword tl_keyword contained rmember rmember-if rmemq rmemql
+syn keyword tl_keyword contained rmemqual rmismatch rot rotate
+syn keyword tl_keyword contained round round-rem rperm rplaca
+syn keyword tl_keyword contained rplacd rpoly rpos rpos-if
+syn keyword tl_keyword contained rposq rposql rposqual rr
+syn keyword tl_keyword contained rra rsearch rslot rtld-deepbind
+syn keyword tl_keyword contained rtld-global rtld-lazy rtld-local rtld-nodelete
+syn keyword tl_keyword contained rtld-noload rtld-now run s-ifblk
+syn keyword tl_keyword contained s-ifchr s-ifdir s-ififo s-iflnk
+syn keyword tl_keyword contained s-ifmt s-ifreg s-ifsock s-irgrp
+syn keyword tl_keyword contained s-iroth s-irusr s-irwxg s-irwxo
+syn keyword tl_keyword contained s-irwxu s-isgid s-isuid s-isvtx
+syn keyword tl_keyword contained s-iwgrp s-iwoth s-iwusr s-ixgrp
+syn keyword tl_keyword contained s-ixoth s-ixusr save-exe sbit
+syn keyword tl_keyword contained scalb scalbln scan-until-match search
+syn keyword tl_keyword contained search-all search-regex search-regst search-str
+syn keyword tl_keyword contained search-str-tree second seek-cur seek-end
+syn keyword tl_keyword contained seek-set seek-stream select self-load-path
+syn keyword tl_keyword contained self-path separate separate-keys seq-begin
syn keyword tl_keyword contained seq-next seq-reset seqp set
syn keyword tl_keyword contained set-diff set-hash-userdata set-indent set-indent-mode
-syn keyword tl_keyword contained set-key set-left set-max-depth set-max-length
-syn keyword tl_keyword contained set-package-fallback-list set-right set-sig-handler setegid
-syn keyword tl_keyword contained setenv seteuid setgid setgrent
-syn keyword tl_keyword contained setgroups sethash setitimer setlogmask
-syn keyword tl_keyword contained setpwent setresgid setresuid setuid
-syn keyword tl_keyword contained seventh sh sha256 sha256-begin
-syn keyword tl_keyword contained sha256-end sha256-hash sha256-stream shift
-syn keyword tl_keyword contained short shuffle sig-abrt sig-alrm
-syn keyword tl_keyword contained sig-atomic-t sig-bus sig-check sig-chld
-syn keyword tl_keyword contained sig-cont sig-fpe sig-hup sig-ill
-syn keyword tl_keyword contained sig-int sig-io sig-iot sig-kill
-syn keyword tl_keyword contained sig-pipe sig-poll sig-prof sig-pwr
-syn keyword tl_keyword contained sig-quit sig-segv sig-stkflt sig-stop
-syn keyword tl_keyword contained sig-sys sig-term sig-trap sig-tstp
-syn keyword tl_keyword contained sig-ttin sig-ttou sig-urg sig-usr1
-syn keyword tl_keyword contained sig-usr2 sig-vtalrm sig-winch sig-xcpu
-syn keyword tl_keyword contained sig-xfsz sign-extend signum sin
-syn keyword tl_keyword contained sinh sixth size-t size-vec
-syn keyword tl_keyword contained sizeof slet slot slotp
-syn keyword tl_keyword contained slots slotset sock-accept sock-bind
-syn keyword tl_keyword contained sock-cloexec sock-connect sock-dgram sock-family
-syn keyword tl_keyword contained sock-listen sock-nonblock sock-peer sock-recv-timeout
-syn keyword tl_keyword contained sock-send-timeout sock-set-peer sock-shutdown sock-stream
-syn keyword tl_keyword contained sock-type some sort sort-group
-syn keyword tl_keyword contained source-loc source-loc-str span-str special-operator-p
-syn keyword tl_keyword contained special-var-p spl splice split
-syn keyword tl_keyword contained split* split-str split-str-set sqrt
-syn keyword tl_keyword contained square ssize-t sssucc ssucc
-syn keyword tl_keyword contained starts-with stat static-slot static-slot-ensure
-syn keyword tl_keyword contained static-slot-home static-slot-p static-slot-set stdlib
-syn keyword tl_keyword contained str str-buf str-d str-in6addr
-syn keyword tl_keyword contained str-in6addr-net str-inaddr str-inaddr-net str<
+syn keyword tl_keyword contained set-key set-left set-mask set-max-depth
+syn keyword tl_keyword contained set-max-length set-package-fallback-list set-right set-sig-handler
+syn keyword tl_keyword contained set-stack-limit setegid setenv seteuid
+syn keyword tl_keyword contained setgid setgrent setgroups sethash
+syn keyword tl_keyword contained setitimer setjmp setlogmask setpwent
+syn keyword tl_keyword contained setresgid setresuid setrlimit setuid
+syn keyword tl_keyword contained seventh sh sh-esc sh-esc-all
+syn keyword tl_keyword contained sh-esc-dq sh-esc-sq sha1 sha1-begin
+syn keyword tl_keyword contained sha1-end sha1-hash sha1-stream sha256
+syn keyword tl_keyword contained sha256-begin sha256-end sha256-hash sha256-stream
+syn keyword tl_keyword contained shift short short-suffix shuffle
+syn keyword tl_keyword contained shut-rd shut-rdwr shut-wr sig-abrt
+syn keyword tl_keyword contained sig-alrm sig-atomic-t sig-bus sig-check
+syn keyword tl_keyword contained sig-chld sig-cont sig-fpe sig-hup
+syn keyword tl_keyword contained sig-ill sig-int sig-io sig-iot
+syn keyword tl_keyword contained sig-kill sig-pipe sig-poll sig-prof
+syn keyword tl_keyword contained sig-pwr sig-quit sig-segv sig-stkflt
+syn keyword tl_keyword contained sig-stop sig-sys sig-term sig-trap
+syn keyword tl_keyword contained sig-tstp sig-ttin sig-ttou sig-urg
+syn keyword tl_keyword contained sig-usr1 sig-usr2 sig-vtalrm sig-winch
+syn keyword tl_keyword contained sig-xcpu sig-xfsz sign-extend significand
+syn keyword tl_keyword contained signum sin sinh sixth
+syn keyword tl_keyword contained size-t size-vec sizeof slet
+syn keyword tl_keyword contained slot slotp slots slotset
+syn keyword tl_keyword contained snsort so-acceptconn so-broadcast so-debug
+syn keyword tl_keyword contained so-dontroute so-error so-keepalive so-linger
+syn keyword tl_keyword contained so-oobinline so-rcvbuf so-rcvlowat so-rcvtimeo
+syn keyword tl_keyword contained so-reuseaddr so-sndbuf so-sndlowat so-sndtimeo
+syn keyword tl_keyword contained so-type sock-accept sock-bind sock-cloexec
+syn keyword tl_keyword contained sock-connect sock-dgram sock-family sock-listen
+syn keyword tl_keyword contained sock-nonblock sock-opt sock-peer sock-recv-timeout
+syn keyword tl_keyword contained sock-send-timeout sock-set-opt sock-set-peer sock-shutdown
+syn keyword tl_keyword contained sock-stream sock-type sockaddr-str socklen-t
+syn keyword tl_keyword contained sol-socket some some-false some-true
+syn keyword tl_keyword contained sort sort-group source-loc source-loc-str
+syn keyword tl_keyword contained span-str special-operator-p special-var-p spl
+syn keyword tl_keyword contained splice split split* split-str
+syn keyword tl_keyword contained split-str-set spln sqrt square
+syn keyword tl_keyword contained ssize-t ssort sspl sssucc
+syn keyword tl_keyword contained ssucc starts-with stat static-slot
+syn keyword tl_keyword contained static-slot-ensure static-slot-home static-slot-p static-slot-set
+syn keyword tl_keyword contained stdlib str str-buf str-d
+syn keyword tl_keyword contained str-esc str-in6addr str-in6addr-net str-inaddr
+syn keyword tl_keyword contained str-inaddr-net str-s str-seq str<
syn keyword tl_keyword contained str<= str= str> str>=
-syn keyword tl_keyword contained stream-get-prop stream-set-prop streamp string-extend
-syn keyword tl_keyword contained string-lt stringp struct struct-from-args
-syn keyword tl_keyword contained struct-from-plist struct-get-initfun struct-get-postinitfun struct-set-initfun
-syn keyword tl_keyword contained struct-set-postinitfun struct-type struct-type-name struct-type-p
-syn keyword tl_keyword contained structp sub sub-buf sub-list
-syn keyword tl_keyword contained sub-str sub-vec subtypep succ
-syn keyword tl_keyword contained sum super super-method suspend
-syn keyword tl_keyword contained swap symacrolet symbol-function symbol-macro
-syn keyword tl_keyword contained symbol-name symbol-package symbol-value symbolp
-syn keyword tl_keyword contained symdiff symlink sys:%backpatch-high16% sys:%backpatch-low16%
-syn keyword tl_keyword contained sys:%big-endian% sys:%bin-op% sys:%bin-ops% sys:%block-using-funs%
-syn keyword tl_keyword contained sys:%call-op% sys:%dbg-command-env% sys:%file-suff-rx% sys:%gcall-op%
-syn keyword tl_keyword contained sys:%imm-width% sys:%lev-bits% sys:%lev-size% sys:%max-lambda-fixed-args%
+syn keyword tl_keyword contained stream-get-prop stream-set-prop streamp strerror
+syn keyword tl_keyword contained string-extend string-finish string-get-code string-lt
+syn keyword tl_keyword contained string-set-code stringp strsignal struct
+syn keyword tl_keyword contained struct-from-args struct-from-plist struct-get-initfun struct-get-postinitfun
+syn keyword tl_keyword contained struct-set-initfun struct-set-postinitfun struct-type struct-type-name
+syn keyword tl_keyword contained struct-type-p structp sub sub-buf
+syn keyword tl_keyword contained sub-list sub-str sub-tree sub-vec
+syn keyword tl_keyword contained subq subql subqual subst
+syn keyword tl_keyword contained subtypep succ sum sum-each
+syn keyword tl_keyword contained sum-each* sum-each-prod sum-each-prod* super
+syn keyword tl_keyword contained super-method suspend swap symacrolet
+syn keyword tl_keyword contained symbol-function symbol-macro symbol-name symbol-package
+syn keyword tl_keyword contained symbol-value symbolp symdiff symlink
+syn keyword tl_keyword contained sys:%backpatch-high16% sys:%backpatch-low16% sys:%big-endian% sys:%bin-op%
+syn keyword tl_keyword contained sys:%bin-ops% sys:%block-using-funs% sys:%call-op% sys:%const-foldable%
+syn keyword tl_keyword contained sys:%const-foldable-funs% sys:%dbg-command-env% sys:%dbg-commands% sys:%effect-free%
+syn keyword tl_keyword contained sys:%effect-free-funs% sys:%eval-cache% sys:%functional% sys:%functional-funs%
+syn keyword tl_keyword contained sys:%gcall-op% sys:%lev-bits% sys:%lev-size% sys:%max-lambda-fixed-args%
syn keyword tl_keyword contained sys:%max-lev% sys:%max-lev-idx% sys:%max-sm-lev% sys:%max-sm-lev-idx%
syn keyword tl_keyword contained sys:%max-v-lev% sys:%nary-ops% sys:%oc-code% sys:%oc-hash%
-syn keyword tl_keyword contained sys:%oc-list-builder% sys:%package-manip% sys:%sm-lev-bits% sys:%sm-lev-size%
+syn keyword tl_keyword contained sys:%oc-list-builder% sys:%package-manip% sys:%param-info% sys:%quip-rand-state%
+syn keyword tl_keyword contained sys:%quips% sys:%shuffled-quips% sys:%sm-lev-bits% sys:%sm-lev-size%
syn keyword tl_keyword contained sys:%test-funs% sys:%test-funs-neg% sys:%test-funs-ops% sys:%test-funs-pos%
-syn keyword tl_keyword contained sys:%test-inv% sys:%test-opcode% sys:%tlo-ver% sys:*dedup*
-syn keyword tl_keyword contained sys:*emit* sys:*eval* sys:*load-recursive* sys:*op-ctx*
-syn keyword tl_keyword contained sys:*pl-env* sys:*pl-form* sys:*trace-hash* sys:*trace-level*
-syn keyword tl_keyword contained sys:abscond* sys:abscond-from sys:analyze-argtypes sys:analyze-params
-syn keyword tl_keyword contained sys:apply sys:asm-error sys:assumed-fun sys:awk%--rng
+syn keyword tl_keyword contained sys:%test-inv% sys:%test-opcode% sys:%tlo-ver% sys:%warning-syms%
+syn keyword tl_keyword contained sys:*dedup* sys:*emit* sys:*eval* sys:*in-compilation-unit*
+syn keyword tl_keyword contained sys:*lazy-streams* sys:*load-recursive* sys:*load-time* sys:*match-form*
+syn keyword tl_keyword contained sys:*op-ctx* sys:*pl-env* sys:*pl-form* sys:*struct-prelude*
+syn keyword tl_keyword contained sys:*struct-prelude-alists* sys:*top-level* sys:*trace-hash* sys:*trace-level*
+syn keyword tl_keyword contained sys:*unchecked-calls* sys:abscond* sys:abscond-from sys:add-neg-parens
+syn keyword tl_keyword contained sys:analyze-argtypes sys:analyze-params sys:apply sys:arith-each
+syn keyword tl_keyword contained sys:asm-error sys:assumed-fun sys:autoload-try-fun sys:awk%--rng
syn keyword tl_keyword contained sys:awk%--rng+ sys:awk%--rng- sys:awk%-rng+ sys:awk%rng+
-syn keyword tl_keyword contained sys:awk-code-move-check sys:awk-error sys:awk-expander sys:awk-fun-let
-syn keyword tl_keyword contained sys:awk-fun-shadowing-env sys:awk-mac-let sys:awk-redir sys:awk-test
-syn keyword tl_keyword contained sys:b* sys:b+ sys:b- sys:b/
-syn keyword tl_keyword contained sys:b< sys:b<= sys:b= sys:b=>
-syn keyword tl_keyword contained sys:b> sys:bad-slot-syntax sys:bind-mac-check sys:bind-mac-error
-syn keyword tl_keyword contained sys:bits sys:bits-to-obj sys:build-expander sys:build-key-list-expr
-syn keyword tl_keyword contained sys:call-delete-expander sys:capture-cont sys:catch sys:check-slot
-syn keyword tl_keyword contained sys:check-struct sys:circref sys:compat sys:compile-file-conditionally
-syn keyword tl_keyword contained sys:compiler-emit-warnings sys:conv sys:conv-expand sys:conv-let
-syn keyword tl_keyword contained sys:ctx-form sys:ctx-name sys:dbg-all sys:dbg-backtrace
-syn keyword tl_keyword contained sys:dbg-clear sys:dbg-enable sys:dbg-restore sys:dbg-set
-syn keyword tl_keyword contained sys:dbg-step sys:debugger sys:dedup sys:deffi-cb-expander
-syn keyword tl_keyword contained sys:define-method sys:defset-expander sys:defset-expander-simple sys:disassemble-cdf
-syn keyword tl_keyword contained sys:dlib-expr sys:do-conv sys:do-copy-obj sys:do-path-test
-syn keyword tl_keyword contained sys:do-tweak-obj sys:dump-to-tlo sys:dvbind sys:dwim-del
-syn keyword tl_keyword contained sys:dwim-set sys:dyn-size sys:each-op sys:enc-small-op
-syn keyword tl_keyword contained sys:ensure-op-arg sys:env-to-let sys:eval-err sys:expand-bind-mac-params
+syn keyword tl_keyword contained sys:awk-code-move-check sys:awk-error sys:awk-expander sys:awk-field-name-code
+syn keyword tl_keyword contained sys:awk-fun-let sys:awk-fun-shadowing-env sys:awk-mac-let sys:awk-mac-let-outer
+syn keyword tl_keyword contained sys:awk-redir sys:awk-symac-let sys:awk-test sys:b*
+syn keyword tl_keyword contained sys:b+ sys:b- sys:b/ sys:b<
+syn keyword tl_keyword contained sys:b<= sys:b= sys:b=> sys:b>
+syn keyword tl_keyword contained sys:bad-slot-syntax sys:bexp-expand sys:bexp-parse sys:bexp-parse-brace
+syn keyword tl_keyword contained sys:bind-mac-check sys:bind-mac-error sys:bindable-check sys:bits
+syn keyword tl_keyword contained sys:bits-to-obj sys:blk sys:brace-expand sys:build-expander
+syn keyword tl_keyword contained sys:cached-sort-body sys:can-inline-chain sys:capture-cont sys:careful-subst-preserve
+syn keyword tl_keyword contained sys:catch sys:check sys:check-slot sys:check-struct
+syn keyword tl_keyword contained sys:check-sym sys:circref sys:comma-positions sys:compat
+syn keyword tl_keyword contained sys:compile-and-match sys:compile-as-match sys:compile-atom-match sys:compile-cons-structure
+syn keyword tl_keyword contained sys:compile-exprs-match sys:compile-file-conditionally sys:compile-hash-match sys:compile-loop-match
+syn keyword tl_keyword contained sys:compile-match sys:compile-new-var-match sys:compile-not-match sys:compile-or-match
+syn keyword tl_keyword contained sys:compile-predicate-match sys:compile-range-match sys:compile-require-match sys:compile-scan-match
+syn keyword tl_keyword contained sys:compile-struct-match sys:compile-var-match sys:compile-vec-match sys:compile-with-match
+syn keyword tl_keyword contained sys:compiler-emit-warnings sys:conv sys:conv-expand sys:conv-expand-sym
+syn keyword tl_keyword contained sys:conv-let sys:ctx-form sys:ctx-name sys:dbg-all
+syn keyword tl_keyword contained sys:dbg-backtrace sys:dbg-clear sys:dbg-enable sys:dbg-restore
+syn keyword tl_keyword contained sys:dbg-set sys:dbg-step sys:debugger sys:debugger-help
+syn keyword tl_keyword contained sys:dedup sys:dedup-labels sys:deffi-cb-expander sys:define-method
+syn keyword tl_keyword contained sys:defset-expander sys:defset-expander-simple sys:detached-run sys:dig
+syn keyword tl_keyword contained sys:disassemble-cdf sys:dlib-expr sys:do-conv sys:do-copy-obj
+syn keyword tl_keyword contained sys:do-path-test sys:do-tweak-obj sys:dump-to-tlo sys:dvbind
+syn keyword tl_keyword contained sys:dwim-del sys:dwim-set sys:dyn-size sys:each-match-expander
+syn keyword tl_keyword contained sys:each-op sys:early-peephole sys:enc-small-op sys:ensure-op-arg
+syn keyword tl_keyword contained sys:env-to-let sys:eq-comparable sys:eql-comparable sys:eval-cache-emit-warnings
+syn keyword tl_keyword contained sys:eval-err sys:expand-and sys:expand-arith-each-prod sys:expand-bind-mac-params
syn keyword tl_keyword contained sys:expand-defmacro sys:expand-defsymacro sys:expand-defun sys:expand-defvarl
-syn keyword tl_keyword contained sys:expand-dohash sys:expand-doloop sys:expand-each sys:expand-handle
-syn keyword tl_keyword contained sys:expand-params sys:expand-quasi sys:expand-quasi-args sys:expand-quasi-mods
-syn keyword tl_keyword contained sys:expand-sym-ref sys:expr sys:extract-keys sys:extract-keys-p
-syn keyword tl_keyword contained sys:fbind sys:fmt-flex sys:fmt-join sys:fmt-simple
-syn keyword tl_keyword contained sys:for-op sys:gc sys:gc-set-delta sys:get-buf-common
-syn keyword tl_keyword contained sys:get-fun-getter-setter sys:get-mb sys:get-parser sys:get-place-macro
-syn keyword tl_keyword contained sys:get-vb sys:getopts-error sys:handle-bad-syntax sys:hlet-expand
-syn keyword tl_keyword contained sys:if-to-cond sys:in6addr-condensed-text sys:is-label sys:l1-setq
-syn keyword tl_keyword contained sys:l1-val sys:lambda-apply-transform sys:lambda-short-apply-list sys:lambda-too-few-args
+syn keyword tl_keyword contained sys:expand-dohash sys:expand-doloop sys:expand-each sys:expand-each-prod
+syn keyword tl_keyword contained sys:expand-each-prod* sys:expand-handle sys:expand-lambda-match sys:expand-neg-parens
+syn keyword tl_keyword contained sys:expand-param-macro sys:expand-params sys:expand-pic sys:expand-pic-align
+syn keyword tl_keyword contained sys:expand-pic-num sys:expand-pic-num-commas sys:expand-quasi sys:expand-quasi-args
+syn keyword tl_keyword contained sys:expand-quasi-match sys:expand-quasi-mods sys:expand-sym-ref sys:expr
+syn keyword tl_keyword contained sys:fbind sys:find-parent sys:fixed-point sys:flatten-or
+syn keyword tl_keyword contained sys:fmt-flex sys:fmt-join sys:fmt-simple sys:for-op
+syn keyword tl_keyword contained sys:gc sys:gc-set-delta sys:get-buf-common sys:get-fun-getter-setter
+syn keyword tl_keyword contained sys:get-mb sys:get-param-info sys:get-place-macro sys:get-var-list
+syn keyword tl_keyword contained sys:get-vars sys:get-vb sys:getopts-error sys:glob-xstar
+syn keyword tl_keyword contained sys:handle-bad-syntax sys:handle-mutated-var-args sys:hlet-expand sys:if-to-cond
+syn keyword tl_keyword contained sys:ign-notfound sys:in6addr-condensed-text sys:inline-chain sys:inline-chain-rec
+syn keyword tl_keyword contained sys:insert-commas sys:is-label sys:l1-setq sys:l1-val
+syn keyword tl_keyword contained sys:lambda-apply-transform sys:lambda-excess-apply-list sys:lambda-short-apply-list sys:lambda-too-few-args
syn keyword tl_keyword contained sys:lambda-too-many-args sys:lbind sys:lisp1-setq sys:lisp1-value
syn keyword tl_keyword contained sys:list-builder-flets sys:list-from-vm-desc sys:load-time-lit sys:loc
-syn keyword tl_keyword contained sys:mac-env-flatten sys:make-anon-package sys:make-copy-path-opts sys:make-struct-lit
-syn keyword tl_keyword contained sys:make-struct-type sys:mark-special sys:maybe-mov sys:misleading-ref-check
-syn keyword tl_keyword contained sys:name-str sys:new-expander sys:new-type sys:null-reg
-syn keyword tl_keyword contained sys:obtain-impl sys:op-alpha-rename sys:op-ensure-rec sys:op-expand
-syn keyword tl_keyword contained sys:op-meta-p sys:op-rec-p sys:open-compile-streams sys:operand-to-exp
-syn keyword tl_keyword contained sys:operand-to-sym sys:opip-expand sys:opt-dash sys:opt-err
-syn keyword tl_keyword contained sys:parse-compound-operand sys:parse-operand sys:parser-eof sys:parser-errors
-syn keyword tl_keyword contained sys:path-access sys:path-examine sys:path-test-mode sys:path-test-type
-syn keyword tl_keyword contained sys:pl-expand sys:placelet-1 sys:print-backtrace sys:propagate-ancestor
-syn keyword tl_keyword contained sys:prune-missing-inits sys:qquote sys:quasi sys:quasilist
-syn keyword tl_keyword contained sys:r-s-let-expander sys:reg-expand-nongreedy sys:reg-optimize sys:register-opcode
-syn keyword tl_keyword contained sys:register-simple-accessor sys:repl sys:rplaca sys:rplacd
-syn keyword tl_keyword contained sys:rslotset sys:rt-defmacro sys:rt-defsymacro sys:rt-defun
-syn keyword tl_keyword contained sys:rt-defvarl sys:rt-load-for sys:rt-pprof sys:set-hash-traversal-limit
-syn keyword tl_keyword contained sys:set-macro-ancestor sys:setq sys:setqf sys:shut-rd
-syn keyword tl_keyword contained sys:shut-rdwr sys:shut-wr sys:slot-types sys:small-op-p
-syn keyword tl_keyword contained sys:small-op-to-sym sys:splice sys:static-slot-types sys:str-inaddr-net-impl
-syn keyword tl_keyword contained sys:struct-lit sys:switch sys:sym-clobber-expander sys:sym-delete-expander
+syn keyword tl_keyword contained sys:loosen sys:mac-env-flatten sys:make-anon-package sys:make-command-env
+syn keyword tl_keyword contained sys:make-copy-path-opts sys:make-struct-lit sys:make-struct-type sys:mark-special
+syn keyword tl_keyword contained sys:match-case-to-casequal sys:match-pat-error sys:maybe-mov sys:meth-lambda
+syn keyword tl_keyword contained sys:misleading-ref-check sys:name-str sys:new-expander sys:new-type
+syn keyword tl_keyword contained sys:no-dvbind-eval sys:non-triv-pat-p sys:null-reg sys:obtain-impl
+syn keyword tl_keyword contained sys:op-alpha-rename sys:op-ensure-rec sys:op-expand sys:op-meta-p
+syn keyword tl_keyword contained sys:op-rec-p sys:open-compile-streams sys:open-url sys:operand-to-exp
+syn keyword tl_keyword contained sys:operand-to-sym sys:opip-expand sys:opip-let-p sys:opip-single-let-p
+syn keyword tl_keyword contained sys:opt-controlled-diag sys:opt-dash sys:opt-err sys:orig-form
+syn keyword tl_keyword contained sys:os-symbol sys:param-check sys:parse-compound-operand sys:parse-lambda-match-clause
+syn keyword tl_keyword contained sys:parse-operand sys:pat-len sys:path-access sys:path-examine
+syn keyword tl_keyword contained sys:path-simplify sys:path-split sys:path-test-mode sys:path-test-type
+syn keyword tl_keyword contained sys:path-volume sys:pic-join-opt sys:placelet-1 sys:print-backtrace
+syn keyword tl_keyword contained sys:propagate-ancestor sys:propagate-perms sys:prune-missing-inits sys:put-objects
+syn keyword tl_keyword contained sys:qquote sys:quasi sys:quasilist sys:r-s-let-expander
+syn keyword tl_keyword contained sys:reduce-constant sys:reduce-lisp sys:reduce-or sys:reg-expand-nongreedy
+syn keyword tl_keyword contained sys:register-opcode sys:register-simple-accessor sys:repl sys:rewrite
+syn keyword tl_keyword contained sys:rewrite-case sys:rplaca sys:rplacd sys:rslotset
+syn keyword tl_keyword contained sys:rt-assert-fail sys:rt-defmacro sys:rt-defsymacro sys:rt-defun
+syn keyword tl_keyword contained sys:rt-defv sys:rt-defvarl sys:rt-load-for sys:rt-pprof
+syn keyword tl_keyword contained sys:rt-progv sys:rt-setjmp sys:safe-abs-path sys:safe-const-eval
+syn keyword tl_keyword contained sys:safe-const-reduce sys:safe-constantp sys:set-hash-traversal-limit sys:set-macro-ancestor
+syn keyword tl_keyword contained sys:set-symbol-value sys:setq sys:setqf sys:simplify-or
+syn keyword tl_keyword contained sys:simplify-variadic-lambda sys:slot-types sys:small-op-p sys:small-op-to-sym
+syn keyword tl_keyword contained sys:splice sys:static-slot-types sys:str-inaddr-net-impl sys:struct-lit
+syn keyword tl_keyword contained sys:subst-preserve sys:switch sys:sym-clobber-expander sys:sym-delete-expander
syn keyword tl_keyword contained sys:sym-update-expander sys:system-symbol-p sys:top-fb sys:top-mb
syn keyword tl_keyword contained sys:top-vb sys:tr* sys:trace sys:trace-canonicalize-name
-syn keyword tl_keyword contained sys:trace-enter sys:trace-leave sys:trace-redefine-check sys:tree-construct
-syn keyword tl_keyword contained sys:trfm sys:try-load sys:txr-case-impl sys:unquote
-syn keyword tl_keyword contained sys:untrace sys:upenv sys:uw-block sys:uw-captured-block
-syn keyword tl_keyword contained sys:uw-catch sys:uw-cont-copy sys:uw-eval sys:uw-expand
-syn keyword tl_keyword contained sys:uw-fcall sys:uw-guard sys:uw-handle sys:uw-menv
-syn keyword tl_keyword contained sys:var sys:vm-closure-desc sys:vm-closure-entry sys:vm-desc-bytecode
-syn keyword tl_keyword contained sys:vm-desc-datavec sys:vm-desc-nlevels sys:vm-desc-nregs sys:vm-desc-symvec
-syn keyword tl_keyword contained sys:vm-execute-toplevel sys:vm-make-desc sys:wdwrap sys:with-dyn-lib-check
+syn keyword tl_keyword contained sys:trace-enter sys:trace-leave sys:trace-redefine-check sys:transform-qquote
+syn keyword tl_keyword contained sys:translate-hash-bang sys:tree-construct sys:trfm sys:true-const-p
+syn keyword tl_keyword contained sys:txr-case-impl sys:typecase-expander sys:unquote sys:untrace
+syn keyword tl_keyword contained sys:upenv sys:uw-block sys:uw-captured-block sys:uw-catch
+syn keyword tl_keyword contained sys:uw-cont-copy sys:uw-eval sys:uw-expand sys:uw-fcall
+syn keyword tl_keyword contained sys:uw-guard sys:uw-handle sys:uw-menv sys:var
+syn keyword tl_keyword contained sys:var-pat-p sys:vars-check sys:vm-closure-desc sys:vm-closure-entry
+syn keyword tl_keyword contained sys:vm-desc-bytecode sys:vm-desc-datavec sys:vm-desc-nlevels sys:vm-desc-nregs
+syn keyword tl_keyword contained sys:vm-desc-symvec sys:vm-execute-toplevel sys:vm-make-desc sys:wdwrap
+syn keyword tl_keyword contained sys:when-exprs-match sys:when-opt sys:with-disabled-debugging sys:with-dyn-lib-check
syn keyword tl_keyword contained syslog system-package t tab0
syn keyword tl_keyword contained tab1 tab2 tab3 tabdly
syn keyword tl_keyword contained tagbody tailp take take-until
-syn keyword tl_keyword contained take-while tan tanh tb
-syn keyword tl_keyword contained tc tcdrain tcflow tcflush
-syn keyword tl_keyword contained tcgetattr tciflush tcioff tcioflush
-syn keyword tl_keyword contained tcion tcoflush tcooff tcoon
-syn keyword tl_keyword contained tcsadrain tcsaflush tcsanow tcsendbreak
-syn keyword tl_keyword contained tcsetattr tentative-def-exists tenth test-clear
-syn keyword tl_keyword contained test-clear-dirty test-dec test-dirty test-inc
-syn keyword tl_keyword contained test-neq-set-indent-mode test-set test-set-indent-mode tf
-syn keyword tl_keyword contained third throw throwf time
-syn keyword tl_keyword contained time-fields-local time-fields-utc time-parse time-parse-local
-syn keyword tl_keyword contained time-parse-utc time-string-local time-string-utc time-struct-local
-syn keyword tl_keyword contained time-struct-utc time-t time-usec tnode
+syn keyword tl_keyword contained take-while tan tanh tap
+syn keyword tl_keyword contained tb tc tcdrain tcflow
+syn keyword tl_keyword contained tcflush tcgetattr tciflush tcioff
+syn keyword tl_keyword contained tcioflush tcion tcoflush tcooff
+syn keyword tl_keyword contained tcoon tcp-nodelay tcsadrain tcsaflush
+syn keyword tl_keyword contained tcsanow tcsendbreak tcsetattr tentative-def-exists
+syn keyword tl_keyword contained tenth test-clear test-clear-dirty test-dec
+syn keyword tl_keyword contained test-dirty test-inc test-neq-set-indent-mode test-set
+syn keyword tl_keyword contained test-set-indent-mode tf tgamma third
+syn keyword tl_keyword contained throw throwf time time-fields-local
+syn keyword tl_keyword contained time-fields-utc time-nsec time-parse time-parse-local
+syn keyword tl_keyword contained time-parse-utc time-str-local time-str-utc time-string-local
+syn keyword tl_keyword contained time-string-utc time-struct-local time-struct-utc time-t
+syn keyword tl_keyword contained time-usec tmpfile tnode tnodep
syn keyword tl_keyword contained to tofloat tofloatz toint
-syn keyword tl_keyword contained tointz tok tok-str tok-where
-syn keyword tl_keyword contained tostop tostring tostringp tprint
-syn keyword tl_keyword contained trace transpose tree tree-begin
-syn keyword tl_keyword contained tree-bind tree-case tree-clear tree-delete
-syn keyword tl_keyword contained tree-delete-node tree-find tree-insert tree-insert-node
-syn keyword tl_keyword contained tree-lookup tree-lookup-node tree-next tree-root
-syn keyword tl_keyword contained treep trie-add trie-compress trie-lookup-begin
-syn keyword tl_keyword contained trie-lookup-feed-char trie-value-at trim-str true
+syn keyword tl_keyword contained tointz tojson tok tok-str
+syn keyword tl_keyword contained tok-where tokn tostop tostring
+syn keyword tl_keyword contained tostringp touch tprint trace
+syn keyword tl_keyword contained transpose tree tree-begin tree-bind
+syn keyword tl_keyword contained tree-case tree-clear tree-count tree-del-min
+syn keyword tl_keyword contained tree-del-min-node tree-delete tree-delete-node tree-delete-specific-node
+syn keyword tl_keyword contained tree-find tree-insert tree-insert-node tree-lookup
+syn keyword tl_keyword contained tree-lookup-node tree-min tree-min-node tree-next
+syn keyword tl_keyword contained tree-peek tree-reset tree-root treep
+syn keyword tl_keyword contained trie-add trie-compress trie-lookup-begin trie-lookup-feed-char
+syn keyword tl_keyword contained trie-value-at trim-left trim-long-suffix trim-path-seps
+syn keyword tl_keyword contained trim-right trim-short-suffix trim-str true
syn keyword tl_keyword contained trunc trunc-rem truncate-stream tuples
-syn keyword tl_keyword contained txr-case txr-exe-path txr-if txr-path
-syn keyword tl_keyword contained txr-version txr-when typecase typedef
-syn keyword tl_keyword contained typeof typep ubit uchar
-syn keyword tl_keyword contained uid-t uint uint-buf uint-carray
-syn keyword tl_keyword contained uint-ptr-t uint16 uint32 uint64
-syn keyword tl_keyword contained uint8 ulong ulonglong umask
-syn keyword tl_keyword contained umeth umethod uname unget-byte
-syn keyword tl_keyword contained unget-char uni unintern union
-syn keyword tl_keyword contained union-get union-in union-members union-out
-syn keyword tl_keyword contained union-put uniq unique unless
-syn keyword tl_keyword contained unquote unsetenv until until*
-syn keyword tl_keyword contained untrace unuse-package unuse-sym unwind-protect
-syn keyword tl_keyword contained upcase-str upd update uref
-syn keyword tl_keyword contained url-decode url-encode use use-package
-syn keyword tl_keyword contained use-sym user-package ushort usl
+syn keyword tl_keyword contained tuples* txr-case txr-exe-path txr-if
+syn keyword tl_keyword contained txr-parse txr-path txr-version txr-when
+syn keyword tl_keyword contained typecase typedef typeof typep
+syn keyword tl_keyword contained ubit uchar uid-t uint
+syn keyword tl_keyword contained uint-buf uint-carray uint-ptr-t uint16
+syn keyword tl_keyword contained uint32 uint64 uint8 uintmax-t
+syn keyword tl_keyword contained ulong ulonglong umask umeth
+syn keyword tl_keyword contained umethod uname unget-byte unget-char
+syn keyword tl_keyword contained uni unintern union union-get
+syn keyword tl_keyword contained union-in union-members union-out union-put
+syn keyword tl_keyword contained uniq unique unless unquote
+syn keyword tl_keyword contained unsetenv until until* untrace
+syn keyword tl_keyword contained unuse-package unuse-sym unwind-protect upcase-str
+syn keyword tl_keyword contained upd update uref url-decode
+syn keyword tl_keyword contained url-encode use use-package use-sym
+syn keyword tl_keyword contained use-sym-as user-package ushort usl
syn keyword tl_keyword contained usleep uslot utimes val
syn keyword tl_keyword contained vdiscard vec vec-carray vec-list
-syn keyword tl_keyword contained vec-push vec-set-length vecref vector
-syn keyword tl_keyword contained vector-list vectorp veof veol
-syn keyword tl_keyword contained veol2 verase vintr vkill
-syn keyword tl_keyword contained vlnext vm-fun-p vmin void
-syn keyword tl_keyword contained vquit vreprint vstart vstop
-syn keyword tl_keyword contained vsusp vswtc vt0 vt1
-syn keyword tl_keyword contained vtdly vtime vwerase w-continued
-syn keyword tl_keyword contained w-coredump w-exitstatus w-ifcontinued w-ifexited
-syn keyword tl_keyword contained w-ifsignaled w-ifstopped w-nohang w-stopsig
-syn keyword tl_keyword contained w-termsig w-untraced wait wchar
-syn keyword tl_keyword contained weave when whena whenlet
-syn keyword tl_keyword contained where while while* whilet
-syn keyword tl_keyword contained width width-check window-map window-mapdo
-syn keyword tl_keyword contained window-mappend wint-t with-clobber-expander with-compilation-unit
-syn keyword tl_keyword contained with-delete-expander with-dyn-lib with-gensyms with-hash-iter
-syn keyword tl_keyword contained with-in-buf-stream with-in-string-byte-stream with-in-string-stream with-objects
-syn keyword tl_keyword contained with-out-buf-stream with-out-string-stream with-out-strlist-stream with-resources
-syn keyword tl_keyword contained with-slots with-stream with-update-expander wrap
-syn keyword tl_keyword contained wrap* wstr wstr-d xcase
-syn keyword tl_keyword contained yield yield-from zap zarray
-syn keyword tl_keyword contained zchar zero-fill zerop zip
-syn keyword tl_keyword contained znew
+syn keyword tl_keyword contained vec-push vec-seq vec-set-length vecref
+syn keyword tl_keyword contained vector vector-list vectorp veof
+syn keyword tl_keyword contained veol veol2 verase vintr
+syn keyword tl_keyword contained vkill vlnext vm-fun-p vmin
+syn keyword tl_keyword contained void vquit vreprint vstart
+syn keyword tl_keyword contained vstop vsusp vswtc vt0
+syn keyword tl_keyword contained vt1 vtdly vtime vwerase
+syn keyword tl_keyword contained w-continued w-coredump w-exitstatus w-ifcontinued
+syn keyword tl_keyword contained w-ifexited w-ifsignaled w-ifstopped w-nohang
+syn keyword tl_keyword contained w-stopsig w-termsig w-untraced wait
+syn keyword tl_keyword contained wchar weave when when-match
+syn keyword tl_keyword contained whena whenlet where while
+syn keyword tl_keyword contained while* while-match while-match-case while-true-match-case
+syn keyword tl_keyword contained whilet width width-check window-map
+syn keyword tl_keyword contained window-mapdo window-mappend wint-t with-clobber-expander
+syn keyword tl_keyword contained with-compilation-unit with-compile-opts with-delete-expander with-dyn-lib
+syn keyword tl_keyword contained with-gensyms with-hash-iter with-in-buf-stream with-in-string-byte-stream
+syn keyword tl_keyword contained with-in-string-stream with-objects with-out-buf-stream with-out-string-stream
+syn keyword tl_keyword contained with-out-strlist-stream with-resources with-slots with-stream
+syn keyword tl_keyword contained with-update-expander wrap wrap* wstr
+syn keyword tl_keyword contained wstr-d wstr-s xcase y0
+syn keyword tl_keyword contained y1 yield yield-from yn
+syn keyword tl_keyword contained zap zarray zchar zero-fill
+syn keyword tl_keyword contained zerop zip znew
syn match txr_nested_error "[^\t ]\+" contained
-syn match txr_variable "\(@[ \t]*\)[*]\?[ \t]*[A-Za-z_][A-Za-z_0-9]*"
-syn match txr_splicevar "@[ \t,*@]*[A-Za-z_][A-Za-z_0-9]*" contained
-syn match txr_metanum "@\+[0-9]\+"
+syn match txr_variable "[*]\?[ \t]*[A-Za-z_][A-Za-z_0-9]*" contained
+syn match txr_splicevar "[ \t,*@]*[A-Za-z_][A-Za-z_0-9]*" contained
+syn match txr_metanum "\(@[ \t]*\)\+[0-9]\+"
syn match txr_badesc "\\." contained
syn match txr_escat "\\@" contained
-syn match txr_stresc "\\[abtnvfre\\ \n"`']" contained
+syn match txr_stresc "\\[abtnvfre\\ "`']" contained
syn match txr_numesc "\\x[0-9A-Fa-f]\+;\?" contained
syn match txr_numesc "\\[0-7]\+;\?" contained
-syn match txr_regesc "\\[abtnvfre\\ \n/sSdDwW()\|.*?+~&%\[\]\-]" contained
+syn match txr_regesc "\\[abtnvfre\\ /sSdDwW()\|.*?+~&%\[\]\-]" contained
-syn match txr_error "#[^HSR]"
+syn match tl_error "#[^HSRTN]"
syn match txr_chr "#\\x[0-9A-Fa-f]\+"
syn match txr_chr "#\\o[0-7]\+"
@@ -629,57 +772,80 @@ syn match txr_ncomment ";.*"
syn match txr_hashbang "\%^#!.*"
+syn match txr_qat "\(@[ \t]*\)" nextgroup=txr_splicevar,txr_metanum,txr_qbracevar,txr_list,txr_bracket,txr_escat,txr_stresc,txr_numesc,txr_badesc contained
syn match txr_dot "\." contained
syn match txr_ident "[A-Za-z_0-9!$%&*+\-<=>?\\_~]*[A-Za-z_!$%&*+\-<=>?\\_~^][A-Za-z_0-9!$%&*+\-<=>?\\_~^]*" contained
-syn match tl_ident "[:@][A-Za-z_0-9!$%&*+\-<=>?\\_~^/]\+"
-syn match txr_braced_ident "[:][A-Za-z_0-9!$%&*+\-<=>?\\_~^/]\+" contained
-syn match tl_ident "[A-Za-z_0-9!$%&*+\-<=>?\\_~/]\+[A-Za-z_0-9!$%&*+\-<=>?\\_~^/#]*"
-syn match txr_pnum "#[xob][+\-]\?[A-Za-z_0-9]\+" contains=txr_xnum,txr_bnum,txr_onum
-syn match txr_xnum "#x[+\-]\?[0-9A-Fa-f]\+" containedin=txr_pnum contained
-syn match txr_onum "#o[+\-]\?[0-7]\+" containedin=txr_pnum contained
-syn match txr_bnum "#b[+\-]\?[01]\+" containedin=txr_pnum contained
-syn match txr_num "[+\-]\?[0-9]\+\([^A-Za-z_0-9!$%&*+\-<=>?\\_~^/#]\|\n\)"me=e-1
-syn match txr_badnum "[+\-]\?[0-9]*[.][0-9]\+\([eE][+\-]\?[0-9]\+\)\?[A-Za-z_!$%&*+\-<=>?\\_~^/#]\+"
-syn match txr_num "[+\-]\?[0-9]*[.][0-9]\+\([eE][+\-]\?[0-9]\+\)\?\([^A-Za-z_0-9!$%&*+\-<=>?\\_~^/#]\|\n\)"me=e-1
-syn match txr_num "[+\-]\?[0-9]\+\([eE][+\-]\?[0-9]\+\)\([^A-Za-z_0-9!$%&*+\-<=>?\\_~^/#]\|\n\)"me=e-1
-syn match tl_ident ":"
+syn match txr_braced_ident "\(#\?:\)\?[[A-Za-z_0-9!$%&*+\-<=>?\\_~^/]\+" contained
+syn match tl_ident "\(#\?:\)\?[A-Za-z_0-9!$%&*+\-<=>?\\_~/]\+[A-Za-z_0-9!$%&*+\-<=>?\\_~^/#]*"
+syn match txr_pnum "#[xob][+\-]\?[A-Za-z_0-9,]\+" contains=txr_xnum,txr_bnum,txr_onum
+syn match txr_xnum "#x[+\-]\?\([0-9A-Fa-f][,0-9A-Fa-f]*[0-9A-Fa-f]\|[0-9A-Fa-f]\)" containedin=txr_pnum contained
+syn match txr_onum "#o[+\-]\?\([0-7][,0-7]*[0-7]\|[0-7]\)" containedin=txr_pnum contained
+syn match txr_bnum "#b[+\-]\?\([01][,01]*[01]\|[01]\)" containedin=txr_pnum contained
+syn match txr_num "[+\-]\?\([0-9][,0-9]*[0-9]\|[0-9]\)"
+syn match txr_num "[+\-]\?\([0-9][,0-9]*[0-9]\|[0-9]\)\?[.]\([0-9][,0-9]*[0-9]\|[0-9]\)\([eE][+\-]\?[0-9]\+\)\?"
+syn match txr_num "[+\-]\?\([0-9][,0-9]*[0-9]\|[0-9]\)[.]\?\([eE][+\-]\?[0-9]\+\)"
+syn match txr_badnum "[+\-]\?\([0-9][,0-9]*[0-9]\|[0-9]\)\?[.]\([0-9][,0-9]*[0-9]\|[0-9]\)\([A-DF-Za-dfz_!$%&*+\-<=>?\\_~^/#]\|[eE][^+\-0-9]\|[eE][+/-]\?$\|[eE][+\-][^0-9]\)"
+syn match txr_badnum "[+\-]\?\([0-9][,0-9]*[0-9]\|[0-9]\)[.]\?\([A-DF-Za-dfz_!$%&*+\-<=>?\\_~^/#]\|[eE][^+\-0-9]\|[eE][+/-]\?$\|[eE][+\-][^0-9]\)"
+syn match tl_ident "#\?:"
syn match tl_splice "[ \t,]\|,[*]"
syn match txr_unquote "," contained
syn match txr_splice ",\*" contained
-syn match txr_quote "'" contained
-syn match txr_quote "\^" contained
+syn match txr_quote "'"
+syn match txr_quote "\^"
syn match txr_dotdot "\.\." contained
-syn match txr_metaat "@" contained
-syn match txr_circ "#[0-9]\+[#=]"
+syn match txr_metaat "@"
syn match txr_buf_error "[^']" contained
syn match txr_buf_interior "\([0-9A-Fa-f][\n\t ]*[0-9A-Fa-f]\|[\n\t ]\+\)" contained
-syn region txr_bracevar matchgroup=Delimiter start="@[ \t]*[*]\?{" matchgroup=Delimiter end="}" contains=txr_num,txr_pnum,tl_ident,tl_splice,tl_metanum,txr_metaat,txr_circ,txr_braced_ident,txr_dot,txr_dotdot,txr_string,txr_list,txr_bracket,txr_mlist,txr_mbracket,txr_regex,txr_quasilit,txr_chr,txr_nested_error
-syn region txr_list matchgroup=Delimiter start="\(#[HSR]\?\)\?(" matchgroup=Delimiter end=")" contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign_par,txr_ign_bkt,txr_list,txr_bracket,txr_mlist,txr_mbracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_ncomment,txr_nested_error
-syn region txr_bracket matchgroup=Delimiter start="\[" matchgroup=Delimiter end="\]" contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign_par,txr_ign_bkt,txr_list,txr_bracket,txr_mlist,txr_mbracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_ncomment,txr_nested_error
-syn region txr_mlist matchgroup=Delimiter start="@[ \t^',]*(" matchgroup=Delimiter end=")" contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign_par,txr_ign_bkt,txr_list,txr_bracket,txr_mlist,txr_mbracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_ncomment,txr_nested_error
-syn region txr_mbracket matchgroup=Delimiter start="@[ \t^',]*\[" matchgroup=Delimiter end="\]" contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign_par,txr_ign_bkt,txr_list,txr_bracket,txr_mlist,txr_mbracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_ncomment,txr_nested_error
-syn region txr_string start=+#\?\*\?"+ end=+["\n]+ contains=txr_stresc,txr_numesc,txr_badesc
-syn region txr_quasilit start=+#\?\*\?`+ end=+[`\n]+ contains=txr_splicevar,txr_metanum,txr_bracevar,txr_mlist,txr_mbracket,txr_escat,txr_stresc,txr_numesc,txr_badesc
-syn region txr_regex start="/" end="[/\n]" contains=txr_regesc,txr_numesc,txr_badesc
-syn region tl_regex start="#/" end="[/\n]" contains=txr_regesc,txr_numesc,txr_badesc
+syn region txr_bracevar contained matchgroup=Delimiter start="[*]\?{" matchgroup=Delimiter end="}" contains=txr_num,txr_pnum,tl_ident,tl_splice,tl_metanum,txr_metaat,txr_circ,txr_braced_ident,txr_dot,txr_dotdot,txr_string,txr_list,txr_bracket,txr_regex,tl_regex,txr_quasilit,txr_chr,txr_nested_error
+syn region txr_qbracevar contained matchgroup=Delimiter start="[*]\?{" matchgroup=Delimiter end="}" contains=txr_num,txr_pnum,tl_ident,tl_splice,tl_metanum,txr_metaat,txr_circ,txr_braced_ident,txr_dot,txr_dotdot,txr_string,txr_list,txr_bracket,txr_regex,tl_regex,txr_quasilit,txr_chr,txr_nested_error
+syn region txr_list matchgroup=Delimiter start="\(#[HSRTN]\?\)\?(" matchgroup=Delimiter end=")" contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign,txr_ign_json,txr_list,txr_bracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_jhash,txr_jarray,txr_jatom,txr_ncomment,tl_error,txr_nested_error
+syn region txr_bracket matchgroup=Delimiter start="\[" matchgroup=Delimiter end="\]" contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign,txr_ign_json,txr_list,txr_bracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_jhash,txr_jarray,txr_jatom,txr_ncomment,tl_error,txr_nested_error
+syn region txr_string start=+#\?\*\?"+ skip=+\\\n+ end=+["\n]+ contains=txr_stresc,txr_numesc,txr_badesc
+syn region txr_quasilit start=+#\?\*\?`+ skip=+\\\n+ end=+[`\n]+ contains=txr_qat,txr_stresc,txr_numesc,txr_badesc
+syn region txr_regex start="/" skip=+\\\n+ end="[/\n]" contains=txr_regesc,txr_numesc,txr_badesc
+syn region tl_regex start="#/" skip=+\\\n+ end="[/\n]" contains=txr_regesc,txr_numesc,txr_badesc
syn region txr_buf matchgroup=txr_buf start="#b'" end="'" contains=txr_buf_interior,txr_buf_error
-syn region txr_ign_par matchgroup=Comment start="#;[ \t',]*\(#[HSR]\?\)\?(" matchgroup=Comment end=")" contains=txr_ign_par_interior,txr_ign_bkt_interior
-syn region txr_ign_bkt matchgroup=Comment start="#;[ \t',]*\(#[HSR]\?\)\?\[" matchgroup=Comment end="\]" contains=txr_ign_par_interior,txr_ign_bkt_interior
-syn region txr_ign_par_interior contained matchgroup=Comment start="(" matchgroup=Comment end=")" contains=txr_ign_par_interior,txr_ign_bkt_interior
-syn region txr_ign_bkt_interior contained matchgroup=Comment start="\[" matchgroup=Comment end="\]" contains=txr_ign_par_interior,txr_ign_bkt_interior
+syn region txr_ign matchgroup=Comment start="#;" end="[ \(\)\[\]]"me=e contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign,txr_ign_json,txr_list,txr_bracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_jhash,txr_jarray,txr_jatom,txr_ncomment,tl_error,txr_nested_error
+syn region txr_ign matchgroup=Comment start="#;[ \t',^@]*\(#[HSRTN]\?\)\?(" matchgroup=Comment end=")" contains=txr_ign_interior
+syn region txr_ign matchgroup=Comment start="#;[ \t',^@]*\(#[HSRTNJ]\?\)\?\[" matchgroup=Comment end="\]" contains=txr_ign_interior
+syn region txr_ign_json matchgroup=Comment start="#;[ \t',^@]*#J[~^]*{" matchgroup=Comment end="}" contains=txr_ign_interior
+syn region txr_ign_json matchgroup=Comment start="#;[ \t',^@]*#J[~^]*\[" matchgroup=Comment end="\]" contains=txr_ign_interior
+syn region txr_ign_json matchgroup=Comment start="#;[ \t',^@]*#J[~^]*(" matchgroup=Comment end=")" contains=txr_ign_interior
+syn region txr_ign_interior contained matchgroup=Comment start="(" matchgroup=Comment end=")" contains=txr_ign_interior
+syn region txr_ign_interior contained matchgroup=Comment start="\[" matchgroup=Comment end="\]" contains=txr_ign_interior
+syn region txr_ign_interior contained matchgroup=Comment start="{" matchgroup=Comment end="}" contains=txr_ign_interior
+
+syn match txr_jerr "." contained
+syn match txr_jpunc "[,: \t\n]" contained
+syn match txr_jesc "\\[bfnrt"\\/]" contained
+syn match txr_juesc "\\u[0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f]" contained
+syn match txr_jnum "-\?\(0\|[1-9][0-9]*\)\([.][0-9]\+\)\?\([Ee][+-]\?[0-9]\+\)\?" contained
+syn match txr_jkeyword "true\|false\|null" contained
+
+syn region txr_jatom matchgroup=Delimiter start="#J\^\?[\t\n ]*"rs=e end="[\t\n ]\|[\])}]"re=e-1 contains=txr_jarray_in,txr_jhash_in,txr_jkeyword,txr_jstring,txr_jnum,txr_jpunc,txr_junqlist,txr_junqbkt,txr_junqtok,txr_circ,txr_jerr
+syn region txr_junqtok contained matchgroup=Delimiter start="\~" end="[ \(\)\[\]{}]"re=s contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign,txr_ign_json,txr_list,txr_bracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_jhash,txr_jarray,txr_jatom,txr_ncomment,tl_error,txr_nested_error
+syn region txr_junqlist contained matchgroup=Delimiter start="\~\*\?#\?(" end=")" contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign,txr_ign_json,txr_list,txr_bracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_jhash,txr_jarray,txr_jatom,txr_ncomment,tl_error,txr_nested_error
+syn region txr_junqbkt contained matchgroup=Delimiter start="\~\*\?\[" end="\]" contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign,txr_ign_json,txr_list,txr_bracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_jhash,txr_jarray,txr_jatom,txr_ncomment,tl_error,txr_nested_error
+syn region txr_jstring contained matchgroup=Delimiter start=+"+ end=+["\n]+ contains=txr_jesc,txr_juesc,txr_badesc
+syn region txr_jarray matchgroup=Delimiter start="#J\^\?[\t\n ]*\[" matchgroup=Delimiter end="\]" contains=txr_jarray_in,txr_jhash_in,txr_jkeyword,txr_jstring,txr_jnum,txr_jpunc,txr_junqlist,txr_junqbkt,txr_junqtok,txr_circ,txr_jerr
+syn region txr_jhash matchgroup=Delimiter start="#J\^\?[\t\n ]*{" matchgroup=Delimiter end="}" contains=txr_jarray_in,txr_jhash_in,txr_jkeyword,txr_jstring,txr_jnum,txr_jpunc,txr_junqlist,txr_junqbkt,txr_junqtok,txr_circ,txr_jerr
+syn region txr_jarray_in contained matchgroup=Delimiter start="\[" end="\]" contains=txr_jarray_in,txr_jhash_in,txr_jkeyword,txr_jstring,txr_jnum,txr_jpunc,txr_junqlist,txr_junqbkt,txr_junqtok,txr_circ,txr_jerr
+syn region txr_jhash_in contained matchgroup=Delimiter start="{" end="}" contains=txr_jarray_in,txr_jhash_in,txr_jkeyword,txr_jstring,txr_jnum,txr_jpunc,txr_junqlist,txr_junqbkt,txr_junqtok,txr_circ,txr_jerr
+
+syn match txr_circ "#[0-9]\+[#=]" contained
hi def link txr_at Special
hi def link txr_atstar Special
hi def link txr_atat Special
+hi def link txr_qat Special
hi def link txr_comment Comment
hi def link txr_ncomment Comment
hi def link txr_hashbang Preproc
hi def link txr_contin Preproc
hi def link txr_char String
-hi def link txr_keyword Keyword
hi def link tl_keyword Type
hi def link txr_string String
hi def link txr_chr String
@@ -713,16 +879,24 @@ hi def link txr_circ Special
hi def link txr_munqspl Special
hi def link tl_splice Special
hi def link txr_error Error
+hi def link tl_error Error
hi def link txr_nested_error Error
hi def link txr_buf String
hi def link txr_buf_interior String
hi def link txr_buf_error Error
-hi def link txr_ign_par Comment
-hi def link txr_ign_bkt_interior Comment
-hi def link txr_ign_par_interior Comment
-hi def link txr_ign_bkt Comment
+hi def link txr_ign_interior Comment
+hi def link txr_ign Comment
+hi def link txr_ign_json Comment
+
+hi def link txr_jkeyword Type
+hi def link txr_jnum Number
+hi def link txr_jstring String
+hi def link txr_jesc Special
+hi def link txr_juesc Special
+hi def link txr_jpunc Special
+hi def link txr_jerr Error
let b:current_syntax = "lisp"
-set lispwords=ado,alet,align,alignof,ap,append-each,append-each*,aret,array,arraysize,awk,bit,block,block*,bool,buf,buf-d,build,buildn,carray,caseq,caseq*,caseql,caseql*,casequal,casequal*,catch,catch*,catch**,collect-each,collect-each*,compare-swap,compile-only,cond,conda,condlet,cptr,dec,defex,deffi,deffi-cb,deffi-cb-unsafe,deffi-sym,deffi-type,deffi-var,define-accessor,define-modify-macro,define-option-struct,define-param-expander,define-place-macro,defmacro,defmeth,defpackage,defparm,defparml,defplace,defset,defstruct,defsymacro,defun,defvar,defvarl,del,delay,do,dohash,doloop,doloop*,dotimes,each,each*,elemsize,elemtype,enum,enumed,equot,eval-only,ffi,flet,flip,for,for*,fun,gen,go,gun,handle,handle*,handler-bind,hlet,hlet*,ido,if,ifa,iflet,ignerr,ignwarn,in-package,ip,labels,lambda,lcons,ldo,let,let*,lnew*,load-for,load-time,lop,lset,mac-param-bind,macro-time,macrolet,mlet,new*,obtain,obtain*,obtain*-block,obtain-block,offsetof,op,pdec,pinc,placelet,placelet*,pop,pprof,prof,prog,prog*,prog1,progn,ptr,ptr-in,ptr-in-d,ptr-out,ptr-out-d,ptr-out-s,push,pushnew,ret,return,return-from,rlet,rslot,sbit,sizeof,slet,splice,struct,suspend,symacrolet,sys:abscond-from,sys:awk-fun-let,sys:awk-mac-let,sys:awk-redir,sys:catch,sys:conv,sys:dlib-expr,sys:dvbind,sys:each-op,sys:expr,sys:fbind,sys:for-op,sys:l1-val,sys:lbind,sys:lisp1-value,sys:load-time-lit,sys:path-examine,sys:placelet-1,sys:splice,sys:struct-lit,sys:switch,sys:txr-case-impl,sys:unquote,sys:upenv,sys:var,tagbody,tb,tc,test-clear,test-dec,test-inc,test-set,trace,tree-bind,tree-case,txr-case,txr-if,txr-when,typecase,typedef,ubit,union,unless,unquote,until,until*,untrace,unwind-protect,upd,uref,when,whena,whenlet,while,while*,whilet,with-clobber-expander,with-compilation-unit,with-delete-expander,with-dyn-lib,with-gensyms,with-hash-iter,with-in-buf-stream,with-in-string-byte-stream,with-in-string-stream,with-objects,with-out-buf-stream,with-out-string-stream,with-out-strlist-stream,with-resources,with-slots,with-stream,with-update-expander,yield,yield-from,zap,zarray,znew,:method,:function,:init,:postinit,:fini
+set lispwords=ado,alet,align,alignof,ap,append-each,append-each*,append-each-prod,append-each-prod*,append-match-products,append-matches,aret,array,arraysize,assert,awk,bit,block,block*,bool,buf,buf-d,build,buildn,carray,caseq,caseq*,caseql,caseql*,casequal,casequal*,catch,catch*,catch**,clear-mask,close-lazy-streams,collect-each,collect-each*,collect-each-prod,collect-each-prod*,compare-swap,compile-only,compiler-let,cond,conda,condlet,cptr,dec,defex,deffi,deffi-cb,deffi-cb-unsafe,deffi-struct,deffi-sym,deffi-type,deffi-union,deffi-var,define-accessor,define-modify-macro,define-option-struct,define-param-expander,define-place-macro,define-struct-clause,define-struct-prelude,defmacro,defmatch,defmeth,defpackage,defparm,defparml,defplace,defset,defstruct,defsymacro,defun,defun-match,defvar,defvarl,del,delay,do,dohash,doloop,doloop*,dotimes,each,each*,each-false,each-match,each-match-product,each-prod,each-prod*,each-true,ecaseq,ecaseq*,ecaseql,ecaseql*,ecasequal,ecasequal*,elemsize,elemtype,ensure,enum,enumed,equot,etypecase,eval-only,expander-let,ffi,flet,flip,flow,for,for*,fun,gen,go,gun,handle,handle*,handler-bind,hlet,hlet*,ido,if,if-match,ifa,iflet,ignerr,ignwarn,in-package,ip,json,keep-match-products,keep-matches,labels,lambda,lambda-match,lcons,ldo,let,let*,lflow,lnew*,load-for,load-time,loand,lop,lopf,lopip,lset,mac-env-param-bind,mac-param-bind,macro-time,macrolet,match,match-case,match-cond,match-ecase,mlet,mul-each,mul-each*,mul-each-prod,mul-each-prod*,nand,new*,nor,obtain,obtain*,obtain*-block,obtain-block,offsetof,op,opf,pack,pdec,pic,pinc,placelet,placelet*,pop,pop-after-load,pprof,prof,prog,prog*,prog1,prog2,progn,progv,ptr,ptr-in,ptr-in-d,ptr-out,ptr-out-d,ptr-out-s,push,push-after-load,pushnew,ret,return,return-from,rlet,rslot,sbit,set-mask,setjmp,sizeof,slet,some-false,some-true,splice,struct,sum-each,sum-each*,sum-each-prod,sum-each-prod*,suspend,symacrolet,sys:abscond-from,sys:arith-each,sys:awk-fun-let,sys:awk-mac-let,sys:awk-mac-let-outer,sys:awk-redir,sys:awk-symac-let,sys:blk,sys:cached-sort-body,sys:catch,sys:conv,sys:conv-expand-sym,sys:dlib-expr,sys:dvbind,sys:each-op,sys:expr,sys:fbind,sys:fixed-point,sys:for-op,sys:ign-notfound,sys:l1-val,sys:lbind,sys:lisp1-value,sys:load-time-lit,sys:meth-lambda,sys:path-examine,sys:placelet-1,sys:rewrite-case,sys:splice,sys:struct-lit,sys:switch,sys:txr-case-impl,sys:unquote,sys:upenv,sys:var,sys:when-exprs-match,sys:when-opt,sys:with-disabled-debugging,tagbody,tap,tb,tc,test-clear,test-dec,test-inc,test-set,trace,tree-bind,tree-case,txr-case,txr-if,txr-when,typecase,typedef,ubit,union,unless,unquote,until,until*,untrace,unwind-protect,upd,uref,when,when-match,whena,whenlet,while,while*,while-match,while-match-case,while-true-match-case,whilet,with-clobber-expander,with-compilation-unit,with-compile-opts,with-delete-expander,with-dyn-lib,with-gensyms,with-hash-iter,with-in-buf-stream,with-in-string-byte-stream,with-in-string-stream,with-objects,with-out-buf-stream,with-out-string-stream,with-out-strlist-stream,with-resources,with-slots,with-stream,with-update-expander,yield,yield-from,zap,zarray,znew,:method,:function,:init,:postinit,:fini
set comments=:\;\;\;,:\;\;,:\;
diff --git a/tree.c b/tree.c
index f4473b88..167d3817 100644
--- a/tree.c
+++ b/tree.c
@@ -1,4 +1,4 @@
-/* Copyright 2019-2020
+/* Copyright 2019-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,47 +6,41 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
-
#include <stddef.h>
#include <stdio.h>
#include <stdarg.h>
#include <stdlib.h>
+#include <string.h>
#include <limits.h>
#include <signal.h>
#include "config.h"
#include "alloca.h"
-#if HAVE_UNISTD_H
-#include <unistd.h>
-#endif
#include "lib.h"
#include "gc.h"
-#include "args.h"
-#include "txr.h"
#include "signal.h"
#include "unwind.h"
#include "stream.h"
#include "eval.h"
-#include "itypes.h"
-#include "arith.h"
#include "hash.h"
#include "tree.h"
@@ -67,10 +61,12 @@ struct tree {
enum tree_iter_state {
tr_visited_nothing,
- tr_visited_left
+ tr_visited_left,
+ tr_find_low_prepared
};
struct tree_iter {
+ val self;
int depth;
enum tree_iter_state state;
val path[TREE_DEPTH_MAX];
@@ -78,14 +74,17 @@ struct tree_iter {
struct tree_diter {
struct tree_iter ti;
- struct tree *tr;
+ val tree;
val lastnode;
+ val highkey;
};
-#define tree_iter_init() { 0, tr_visited_nothing }
+#define tree_iter_init(self) { (self), 0, tr_visited_nothing, { 0 } }
val tree_s, tree_iter_s, tree_fun_whitelist_s;
+struct cobj_class *tree_cls, *tree_iter_cls;
+
val tnode(val key, val left, val right)
{
val obj = make_obj();
@@ -122,29 +121,27 @@ val key(val node)
val set_left(val node, val nleft)
{
type_check(lit("set-left"), node, TNOD);
- node->tn.left = nleft;
+ set(mkloc(node->tn.left, node), nleft);
return node;
}
val set_right(val node, val nright)
{
type_check(lit("set-right"), node, TNOD);
- node->tn.right = nright;
+ set(mkloc(node->tn.right, node), nright);
return node;
}
val set_key(val node, val nkey)
{
type_check(lit("set-key"), node, TNOD);
- node->tn.key = nkey;
+ set(mkloc(node->tn.key, node), nkey);
return node;
}
val copy_tnode(val node)
{
- val obj = (type_check(lit("copy-tnode"), node, TNOD), make_obj());
- obj->tn = node->tn;
- return obj;
+ return (type_check(lit("copy-tnode"), node, TNOD), copy_obj(node));
}
static ucnum tn_size(val node)
@@ -176,7 +173,7 @@ static val tn_lookup(struct tree *tr, val node, val key)
funcall2(tr->equal_fn, key, tr_key))) {
return node;
} else {
- return if2(node->tn.left, tn_lookup(tr, node->tn.left, key));
+ return if2(node->tn.right, tn_lookup(tr, node->tn.right, key));
}
}
@@ -189,7 +186,7 @@ static val tn_find_next(val node, struct tree_iter *trit)
return nil;
while (node->tn.left) {
bug_unless (trit->depth < TREE_DEPTH_MAX);
- trit->path[trit->depth++] = node;
+ set(mkloc(trit->path[trit->depth++], trit->self), node);
node = node->tn.left;
}
trit->state = tr_visited_left;
@@ -197,6 +194,7 @@ static val tn_find_next(val node, struct tree_iter *trit)
case tr_visited_left:
if (node->tn.right) {
trit->state = tr_visited_nothing;
+ set(mkloc(trit->path[trit->depth++], trit->self), node);
node = node->tn.right;
continue;
} else {
@@ -211,12 +209,99 @@ static val tn_find_next(val node, struct tree_iter *trit)
}
return nil;
}
+ case tr_find_low_prepared:
+ trit->state = tr_visited_left;
+ return node;
default:
internal_error("invalid tree iterator state");
}
}
}
+static val tn_peek_next(val node, struct tree_iter *trit)
+{
+ enum tree_iter_state state = trit->state;
+ int depth = trit->depth;
+
+ for (;;) {
+ switch (state) {
+ case tr_visited_nothing:
+ if (!node)
+ return nil;
+ while (node->tn.left)
+ node = node->tn.left;
+ return node;
+ case tr_visited_left:
+ if (node->tn.right) {
+ state = tr_visited_nothing;
+ node = node->tn.right;
+ continue;
+ } else {
+ while (depth > 0) {
+ val parent = trit->path[--depth];
+ if (node == parent->tn.right) {
+ node = parent;
+ continue;
+ }
+ return parent;
+ }
+ return nil;
+ }
+ case tr_find_low_prepared:
+ return node;
+ default:
+ internal_error("invalid tree iterator state");
+ }
+ }
+}
+
+static void tn_find_low(val node, struct tree_diter *tdi,
+ struct tree *tr, val key)
+{
+ struct tree_iter *trit = &tdi->ti;
+
+ if (node == 0) {
+ return;
+ } else {
+ val tr_key = if3(tr->key_fn,
+ funcall1(tr->key_fn, node->tn.key),
+ node->tn.key);
+
+ set(mkloc(trit->path[trit->depth++], trit->self), node);
+
+ if (if3(tr->less_fn,
+ funcall2(tr->less_fn, key, tr_key),
+ less(key, tr_key)))
+ {
+ set(mkloc(tdi->lastnode, tdi->ti.self), node);
+ if (node->tn.left) {
+ tn_find_low(node->tn.left, tdi, tr, key);
+ return;
+ }
+ } else if (if3(tr->equal_fn == nil,
+ equal(key, tr_key),
+ funcall2(tr->equal_fn, key, tr_key))) {
+ set(mkloc(tdi->lastnode, tdi->ti.self), node);
+ if (node->tn.left) {
+ tn_find_low(node->tn.left, tdi, tr, key);
+ return;
+ }
+ } else {
+ if (node->tn.right) {
+ tn_find_low(node->tn.right, tdi, tr, key);
+ return;
+ }
+ }
+
+ if (tdi->lastnode) {
+ while (trit->path[trit->depth - 1] != tdi->lastnode)
+ trit->depth--;
+ trit->depth--;
+ trit->state = tr_find_low_prepared;
+ }
+ }
+}
+
static val tn_flatten(val x, val y)
{
if (x == nil)
@@ -234,44 +319,54 @@ static val tn_build_tree(ucnum n, val x)
val r = tn_build_tree(n / 2, x);
val s = tn_build_tree((n - 1) / 2, r->tn.right);
- r->tn.right = s->tn.left;
- s->tn.left = r;
+ set(mkloc(r->tn.right, r), s->tn.left);
+ set(mkloc(s->tn.left, s), r);
return s;
}
}
-static void tr_rebuild(struct tree *tr, val node, val parent, ucnum size)
+static void tr_rebuild(val tree, struct tree *tr, val node,
+ val parent, ucnum size)
{
- obj_t dummy = { { TNOD } };
+#if CONFIG_GEN_GC
+ obj_t dummy = { { TNOD, 0, 0, { 0 }, 0 } };
+#else
+ obj_t dummy = { { TNOD, { 0 }, 0 } };
+#endif
val flat = tn_flatten(node, &dummy);
val new_root = (tn_build_tree(size, flat), dummy.tn.left);
if (parent) {
if (parent->tn.left == node)
- parent->tn.left = new_root;
+ set(mkloc(parent->tn.left, parent), new_root);
else
- parent->tn.right = new_root;
+ set(mkloc(parent->tn.right, parent), new_root);
} else {
- tr->root = new_root;
+ set(mkloc(tr->root, tree), new_root);
}
}
-static void tr_find_rebuild_scapegoat(struct tree *tr, struct tree_iter *ti,
+static void tr_find_rebuild_scapegoat(val tree, struct tree *tr,
+ struct tree_iter *ti,
val child, ucnum child_size)
{
- val parent = ti->path[--ti->depth];
- ucnum parent_size = tn_size_one_child(parent, child, child_size);
- ucnum sib_size = parent_size - child_size;
-
- if (2 * child_size > parent_size || 2 * sib_size > parent_size)
- tr_rebuild(tr, parent, ti->path[ti->depth - 1], parent_size);
- else
- tr_find_rebuild_scapegoat(tr, ti, parent, parent_size);
+ if (ti->depth > 0) {
+ val parent = ti->path[--ti->depth];
+ ucnum parent_size = tn_size_one_child(parent, child, child_size);
+ ucnum sib_size = parent_size - child_size;
+
+ if (2 * child_size > parent_size || 2 * sib_size > parent_size) {
+ val grandparent = if2(ti->depth > 0, ti->path[ti->depth - 1]);
+ tr_rebuild(tree, tr, parent, grandparent, parent_size);
+ } else {
+ tr_find_rebuild_scapegoat(tree, tr, ti, parent, parent_size);
+ }
+ }
}
-static void tr_insert(struct tree *tr, struct tree_iter *ti,
- val subtree, val node)
+static void tr_insert(val tree, struct tree *tr, struct tree_iter *ti,
+ val subtree, val node, val dup)
{
val tn_key = if3(tr->key_fn,
funcall1(tr->key_fn, node->tn.key),
@@ -285,41 +380,47 @@ static void tr_insert(struct tree *tr, struct tree_iter *ti,
less(tn_key, tr_key)))
{
if (subtree->tn.left) {
- ti->path[ti->depth++] = subtree;
- tr_insert(tr, ti, subtree->tn.left, node);
+ set(mkloc(ti->path[ti->depth++], ti->self), subtree);
+ tr_insert(tree, tr, ti, subtree->tn.left, node, dup);
} else {
int dep = ti->depth + 1;
- subtree->tn.left = node;
- if (subtree->tn.right == nil && (((ucnum) 1) << dep) > tr->size) {
- ti->path[ti->depth++] = subtree;
- tr_find_rebuild_scapegoat(tr, ti, node, 1);
+ set(mkloc(subtree->tn.left, subtree), node);
+ if (++tr->size > tr->max_size)
+ tr->max_size = tr->size;
+ if (subtree->tn.right == nil && (convert(ucnum, 1) << dep) > tr->size) {
+ set(mkloc(ti->path[ti->depth++], ti->self), subtree);
+ tr_find_rebuild_scapegoat(tree, tr, ti, node, 1);
}
}
} else if (if3(tr->equal_fn == nil,
equal(tn_key, tr_key),
- funcall2(tr->equal_fn, tn_key, tr_key))) {
- node->tn.left = subtree->tn.left;
- node->tn.right = subtree->tn.right;
+ funcall2(tr->equal_fn, tn_key, tr_key)) &&
+ !dup)
+ {
+ set(mkloc(node->tn.left, node), subtree->tn.left);
+ set(mkloc(node->tn.right, node), subtree->tn.right);
if (ti->depth > 0) {
val parent = ti->path[ti->depth - 1];
if (parent->tn.left == subtree)
- parent->tn.left = node;
+ set(mkloc(parent->tn.left, parent), node);
else
- parent->tn.right = node;
+ set(mkloc(parent->tn.right, parent), node);
} else {
- tr->root = node;
+ set(mkloc(tr->root, tree), node);
}
} else {
if (subtree->tn.right) {
- ti->path[ti->depth++] = subtree;
- tr_insert(tr, ti, subtree->tn.right, node);
+ set(mkloc(ti->path[ti->depth++], ti->self), subtree);
+ tr_insert(tree, tr, ti, subtree->tn.right, node, dup);
} else {
int dep = ti->depth + 1;
- subtree->tn.right = node;
- if (subtree->tn.left == nil && (((ucnum) 1) << dep) > tr->size) {
- ti->path[ti->depth++] = subtree;
- tr_find_rebuild_scapegoat(tr, ti, node, 1);
+ set(mkloc(subtree->tn.right, subtree), node);
+ if (++tr->size > tr->max_size)
+ tr->max_size = tr->size;
+ if (subtree->tn.left == nil && (convert(ucnum, 1) << dep) > tr->size) {
+ set(mkloc(ti->path[ti->depth++], ti->self), subtree);
+ tr_find_rebuild_scapegoat(tree, tr, ti, node, 1);
}
}
}
@@ -330,7 +431,8 @@ static val tr_lookup(struct tree *tree, val key)
return if2(tree->root, tn_lookup(tree, tree->root, key));
}
-static val tr_do_delete(struct tree *tr, val subtree, val parent, val key)
+static val tr_do_delete(val tree, struct tree *tr, val subtree,
+ val parent, val key)
{
val tr_key = if3(tr->key_fn,
funcall1(tr->key_fn, subtree->tn.key),
@@ -341,7 +443,7 @@ static val tr_do_delete(struct tree *tr, val subtree, val parent, val key)
less(key, tr_key)))
{
if (subtree->tn.left)
- return tr_do_delete(tr, subtree->tn.left, subtree, key);
+ return tr_do_delete(tree, tr, subtree->tn.left, subtree, key);
return nil;
} else if (if3(tr->equal_fn == nil,
equal(key, tr_key),
@@ -350,23 +452,23 @@ static val tr_do_delete(struct tree *tr, val subtree, val parent, val key)
val ri = subtree->tn.right;
if (le && ri) {
- struct tree_iter trit = tree_iter_init();
+ struct tree_iter trit = tree_iter_init(0);
val succ = tn_find_next(ri, &trit);
val succ_par = if3(trit.depth, trit.path[trit.depth - 1], subtree);
if (succ_par == subtree)
- succ_par->tn.right = succ->tn.right;
+ set(mkloc(succ_par->tn.right, succ_par), succ->tn.right);
else
- succ_par->tn.left = succ->tn.right;
+ set(mkloc(succ_par->tn.left, succ_par), succ->tn.right);
- succ->tn.left = subtree->tn.left;
- succ->tn.right = subtree->tn.right;
+ set(mkloc(succ->tn.left, succ), subtree->tn.left);
+ set(mkloc(succ->tn.right, succ), subtree->tn.right);
if (parent) {
if (parent->tn.left == subtree)
- parent->tn.left = succ;
+ set(mkloc(parent->tn.left, parent), succ);
else
- parent->tn.right = succ;
+ set(mkloc(parent->tn.right, parent), succ);
} else {
tr->root = succ;
}
@@ -376,11 +478,11 @@ static val tr_do_delete(struct tree *tr, val subtree, val parent, val key)
if (parent) {
if (parent->tn.left == subtree)
- parent->tn.left = chld;
+ set(mkloc(parent->tn.left, parent), chld);
else
- parent->tn.right = chld;
+ set(mkloc(parent->tn.right, parent), chld);
} else {
- tr->root = chld;
+ set(mkloc(tr->root, tree), chld);
}
}
@@ -388,18 +490,93 @@ static val tr_do_delete(struct tree *tr, val subtree, val parent, val key)
return subtree;
} else {
if (subtree->tn.right)
- return tr_do_delete(tr, subtree->tn.right, subtree, key);
+ return tr_do_delete(tree, tr, subtree->tn.right, subtree, key);
return nil;
}
}
-static val tr_delete(struct tree *tr, val key)
+static val tr_do_delete_specific(val tree, struct tree *tr, val subtree,
+ val parent, val key, val thisnode)
+{
+ if (subtree == nil) {
+ return nil;
+ } else if (subtree == thisnode) {
+ val le = subtree->tn.left;
+ val ri = subtree->tn.right;
+
+ if (le && ri) {
+ struct tree_iter trit = tree_iter_init(0);
+ val succ = tn_find_next(ri, &trit);
+ val succ_par = if3(trit.depth, trit.path[trit.depth - 1], subtree);
+
+ if (succ_par == subtree)
+ set(mkloc(succ_par->tn.right, succ_par), succ->tn.right);
+ else
+ set(mkloc(succ_par->tn.left, succ_par), succ->tn.right);
+
+ set(mkloc(succ->tn.left, succ), subtree->tn.left);
+ set(mkloc(succ->tn.right, succ), subtree->tn.right);
+
+ if (parent) {
+ if (parent->tn.left == subtree)
+ set(mkloc(parent->tn.left, parent), succ);
+ else
+ set(mkloc(parent->tn.right, parent), succ);
+ } else {
+ tr->root = succ;
+ }
+ } else {
+ uses_or2;
+ val chld = or2(le, ri);
+
+ if (parent) {
+ if (parent->tn.left == subtree)
+ set(mkloc(parent->tn.left, parent), chld);
+ else
+ set(mkloc(parent->tn.right, parent), chld);
+ } else {
+ set(mkloc(tr->root, tree), chld);
+ }
+ }
+
+ subtree->tn.left = subtree->tn.right = nil;
+ return subtree;
+ }
+
+ {
+ val tr_key = if3(tr->key_fn,
+ funcall1(tr->key_fn, subtree->tn.key),
+ subtree->tn.key);
+
+ if (if3(tr->less_fn,
+ funcall2(tr->less_fn, key, tr_key),
+ less(key, tr_key)))
+ {
+ val le = subtree->tn.left;
+ return tr_do_delete_specific(tree, tr, le, subtree, key, thisnode);
+ } else if (if3(tr->equal_fn == nil,
+ equal(key, tr_key),
+ funcall2(tr->equal_fn, key, tr_key)))
+ {
+ uses_or2;
+ val le = subtree->tn.left;
+ val ri = subtree->tn.right;
+ return or2(tr_do_delete_specific(tree, tr, le, subtree, key, thisnode),
+ tr_do_delete_specific(tree, tr, ri, subtree, key, thisnode));
+ } else {
+ val ri = subtree->tn.right;
+ return tr_do_delete_specific(tree, tr, ri, subtree, key, thisnode);
+ }
+ }
+}
+
+static val tr_delete(val tree, struct tree *tr, val key)
{
if (tr->root) {
- val node = tr_do_delete(tr, tr->root, nil, key);
+ val node = tr_do_delete(tree, tr, tr->root, nil, key);
if (node) {
if (2 * --tr->size < tr->max_size) {
- tr_rebuild(tr, tr->root, nil, tr->size);
+ tr_rebuild(tree, tr, tr->root, nil, tr->size);
tr->max_size = tr->size;
}
}
@@ -409,10 +586,30 @@ static val tr_delete(struct tree *tr, val key)
return nil;
}
-val tree_insert_node(val tree, val node)
+static val tr_delete_specific(val tree, struct tree *tr, val thisnode)
+{
+ if (tr->root) {
+ val nkey = key(thisnode);
+ val key = if3(tr->key_fn, funcall1(tr->key_fn, nkey), nkey);
+ val node = tr_do_delete_specific(tree, tr, tr->root,
+ nil, key, thisnode);
+ if (node) {
+ if (2 * --tr->size < tr->max_size) {
+ tr_rebuild(tree, tr, tr->root, nil, tr->size);
+ tr->max_size = tr->size;
+ }
+ }
+ return node;
+ }
+
+ return nil;
+}
+
+val tree_insert_node(val tree, val node, val dup_in)
{
val self = lit("tree-insert-node");
- struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_s));
+ struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_cls));
+ val dup = default_null_arg(dup_in);
type_check(self, node, TNOD);
@@ -422,60 +619,124 @@ val tree_insert_node(val tree, val node)
if (tr->root == nil) {
tr->size = 1;
tr->max_size = 1;
- tr->root = node;
+ set(mkloc(tr->root, tree), node);
} else {
- struct tree_iter ti = tree_iter_init();
- if (++tr->size > tr->max_size)
- tr->max_size = tr->size;
- tr_insert(tr, &ti, tr->root, node);
+ struct tree_iter ti = tree_iter_init(0);
+ tr_insert(tree, tr, &ti, tr->root, node, dup);
}
return node;
}
-static val tree_insert(val tree, val key)
+val tree_insert(val tree, val key, val dup_in)
{
- return tree_insert_node(tree, tnode(key, nil, nil));
+ return tree_insert_node(tree, tnode(key, nil, nil), default_null_arg(dup_in));
}
-static val tree_lookup_node(val tree, val key)
+val tree_lookup_node(val tree, val key)
{
val self = lit("tree-lookup-node");
- struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_s));
+ struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_cls));
return tr_lookup(tr, key);
}
-static val tree_lookup(val tree, val key)
+val tree_lookup(val tree, val key)
{
val node = tree_lookup_node(tree, key);
return if2(node, node->tn.key);
}
-static val tree_delete_node(val tree, val key)
+val tree_min_node(val tree)
+{
+ val self = lit("tree-min-node");
+ struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_cls));
+ val node = tr->root;
+
+ while (node != nil) {
+ val le = node->tn.left;
+ if (le == nil)
+ return node;
+ node = le;
+ }
+
+ return nil;
+}
+
+val tree_min(val tree)
+{
+ val node = tree_min_node(tree);
+ return if2(node, node->tn.key);
+}
+
+val tree_delete_node(val tree, val key)
{
val self = lit("tree-delete-node");
- struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_s));
- return tr_delete(tr, key);
+ struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_cls));
+ return tr_delete(tree, tr, key);
}
-static val tree_delete(val tree, val key)
+val tree_delete(val tree, val key)
{
val node = tree_delete_node(tree, key);
return if2(node, node->tn.key);
}
+val tree_delete_specific_node(val tree, val node)
+{
+ val self = lit("tree-delete-node");
+ struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_cls));
+ return tr_delete_specific(tree, tr, node);
+}
+
+val tree_del_min_node(val tree)
+{
+ val self = lit("tree-min-node");
+ struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_cls));
+ val node = tr->root, parent = nil;;
+
+ while (node != nil) {
+ val le = node->tn.left;
+
+ if (le == nil) {
+ val chld = node->tn.right;
+
+ if (parent)
+ set(mkloc(parent->tn.left, parent), chld);
+ else
+ set(mkloc(tr->root, tree), chld);
+
+ if (2 * --tr->size < tr->max_size) {
+ tr_rebuild(tree, tr, tr->root, nil, tr->size);
+ tr->max_size = tr->size;
+ }
+
+ return node;
+ }
+ parent = node;
+ node = le;
+ }
+
+ return nil;
+}
+
+val tree_del_min(val tree)
+{
+ val node = tree_del_min_node(tree);
+ return if2(node, node->tn.key);
+}
+
static val tree_root(val tree)
{
val self = lit("tree-root");
- struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_s));
+ struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_cls));
return tr->root;
}
static val tree_equal_op(val left, val right)
{
val self = lit("equal");
- struct tree *ltr = coerce(struct tree *, cobj_handle(self, left, tree_s));
- struct tree *rtr = coerce(struct tree *, cobj_handle(self, right, tree_s));
+ struct tree *ltr = coerce(struct tree *, cobj_handle(self, left, tree_cls));
+ struct tree *rtr = coerce(struct tree *, cobj_handle(self, right, tree_cls));
if (ltr->size != rtr->size)
return nil;
@@ -490,7 +751,7 @@ static val tree_equal_op(val left, val right)
return nil;
{
- struct tree_iter liter = tree_iter_init(), riter = tree_iter_init();
+ struct tree_iter liter = tree_iter_init(0), riter = tree_iter_init(0);
val lnode = ltr->root, rnode = rtr->root;
while ((lnode = tn_find_next(lnode, &liter)) &&
@@ -530,7 +791,7 @@ static void tree_print_op(val tree, val out, val pretty, struct strm_ctx *ctx)
put_char(chr(')'), out);
{
- struct tree_iter trit = tree_iter_init();
+ struct tree_iter trit = tree_iter_init(0);
val node = tr->root;
while ((node = tn_find_next(node, &trit))) {
@@ -574,7 +835,7 @@ static ucnum tree_hash_op(val obj, int *count, ucnum seed)
hash += equal_hash(tr->equal_fn, count, seed);
{
- struct tree_iter trit = tree_iter_init();
+ struct tree_iter trit = tree_iter_init(0);
val node = tr->root;
while ((node = tn_find_next(node, &trit)) && (*count)-- <= 0)
@@ -590,11 +851,12 @@ static struct cobj_ops tree_ops = cobj_ops_init(tree_equal_op,
tree_mark,
tree_hash_op);
-val tree(val keys_in, val key_fn, val less_fn, val equal_fn)
+val tree(val keys_in, val key_fn, val less_fn, val equal_fn, val dup_in)
{
struct tree *tr = coerce(struct tree *, chk_calloc(1, sizeof *tr));
val keys = default_null_arg(keys_in), key;
- val tree = cobj(coerce(mem_t *, tr), tree_s, &tree_ops);
+ val tree = cobj(coerce(mem_t *, tr), tree_cls, &tree_ops);
+ val dup = default_null_arg(dup_in);
seq_iter_t ki;
uses_or2;
@@ -612,7 +874,7 @@ val tree(val keys_in, val key_fn, val less_fn, val equal_fn)
seq_iter_init(tree_s, &ki, keys);
while (seq_get(&ki, &key))
- tree_insert(tree, key);
+ tree_insert(tree, key, dup);
return tree;
}
@@ -638,7 +900,7 @@ static val tree_construct(val opts, val keys)
val key_fn = tree_construct_fname(pop(&opts));
val less_fn = tree_construct_fname(pop(&opts));
val equal_fn = tree_construct_fname(pop(&opts));
- return tree(keys, key_fn, less_fn, equal_fn);
+ return tree(keys, key_fn, less_fn, equal_fn, t);
}
static val deep_copy_tnode(val node)
@@ -654,17 +916,38 @@ val copy_search_tree(val tree)
{
val self = lit("copy-search-tree");
struct tree *ntr = coerce(struct tree *, malloc(sizeof *ntr));
- struct tree *otr = coerce(struct tree *, cobj_handle(self, tree, tree_s));
+ struct tree *otr = coerce(struct tree *, cobj_handle(self, tree, tree_cls));
val nroot = deep_copy_tnode(otr->root);
- val ntree = cobj(coerce(mem_t *, ntr), tree_s, &tree_ops);
+ val ntree = cobj(coerce(mem_t *, ntr), tree_cls, &tree_ops);
*ntr = *otr;
ntr->root = nroot;
+ gc_hint(tree);
+ return ntree;
+}
+
+val make_similar_tree(val tree)
+{
+ val self = lit("make-similar-tree");
+ struct tree *ntr = coerce(struct tree *, malloc(sizeof *ntr));
+ struct tree *otr = coerce(struct tree *, cobj_handle(self, tree, tree_cls));
+ val ntree = cobj(coerce(mem_t *, ntr), tree_cls, &tree_ops);
+ *ntr = *otr;
+ ntr->root = nil;
+ ntr->size = ntr->max_size = 0;
+ gc_hint(tree);
return ntree;
}
val treep(val obj)
{
- return tnil(type(obj) == COBJ && obj->co.cls == tree_s);
+ return tnil(type(obj) == COBJ && obj->co.cls == tree_cls);
+}
+
+val tree_count(val tree)
+{
+ val self = lit("tree-count");
+ struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_cls));
+ return unum(tr->size);
}
static void tree_iter_mark(val tree_iter)
@@ -675,7 +958,9 @@ static void tree_iter_mark(val tree_iter)
for (i = 0; i < tdi->ti.depth; i++)
gc_mark(tdi->ti.path[i]);
+ gc_mark(tdi->tree);
gc_mark(tdi->lastnode);
+ gc_mark(tdi->highkey);
}
static struct cobj_ops tree_iter_ops = cobj_ops_init(eq,
@@ -684,27 +969,160 @@ static struct cobj_ops tree_iter_ops = cobj_ops_init(eq,
tree_iter_mark,
cobj_eq_hash_op);
-val tree_begin(val tree)
+val tree_begin(val tree, val lowkey, val highkey)
{
val self = lit("tree-begin");
- struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_s));
+ struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_cls));
struct tree_diter *tdi = coerce(struct tree_diter *,
chk_calloc(1, sizeof *tdi));
- tdi->tr = tr;
- tdi->lastnode = tr->root;
+ val iter = cobj(coerce(mem_t *, tdi), tree_iter_cls, &tree_iter_ops);
+
+ tdi->ti.self = iter;
+ tdi->tree = tree;
- return cobj(coerce(mem_t *, tdi), tree_iter_s, &tree_iter_ops);
+ if (!missingp(lowkey))
+ tn_find_low(tr->root, tdi, tr, lowkey);
+ else
+ tdi->lastnode = tr->root;
+
+ if (!missingp(highkey))
+ tdi->highkey = highkey;
+ else
+ tdi->highkey = iter;
+
+ return iter;
+}
+
+val copy_tree_iter(val iter)
+{
+ val self = lit("copy-tree-iter");
+ struct tree_diter *tdis = coerce(struct tree_diter *,
+ cobj_handle(self, iter, tree_iter_cls));
+ struct tree_diter *tdid = coerce(struct tree_diter *,
+ chk_calloc(1, sizeof *tdid));
+ val iter_copy = cobj(coerce(mem_t *, tdid), tree_iter_cls, &tree_iter_ops);
+ int depth = tdis->ti.depth;
+
+ tdid->ti.self = iter_copy;
+ tdid->ti.depth = depth;
+ tdid->ti.state = tdis->ti.state;
+ tdid->tree = tdis->tree;
+ tdid->lastnode = tdis->lastnode;
+
+ if (tdis->highkey == iter)
+ tdid->highkey = iter_copy;
+ else
+ tdid->highkey = tdis->highkey;
+
+ memcpy(tdid->ti.path, tdis->ti.path, sizeof tdid->ti.path[0] * depth);
+
+ gc_hint(iter);
+
+ return iter_copy;
+}
+
+val replace_tree_iter(val diter, val siter)
+{
+ val self = lit("replace-tree-iter");
+ struct tree_diter *tdid = coerce(struct tree_diter *,
+ cobj_handle(self, diter, tree_iter_cls));
+ struct tree_diter *tdis = coerce(struct tree_diter *,
+ cobj_handle(self, siter, tree_iter_cls));
+ int depth = tdis->ti.depth;
+
+ tdid->ti.depth = depth;
+ tdid->ti.state = tdis->ti.state;
+ tdid->tree = tdis->tree;
+ tdid->lastnode = tdis->lastnode;
+
+ if (tdis->highkey == siter)
+ tdid->highkey = diter;
+ else
+ tdid->highkey = tdis->highkey;
+
+ memcpy(tdid->ti.path, tdis->ti.path, sizeof tdid->ti.path[0] * depth);
+
+ mut(diter);
+
+ return diter;
+}
+
+val tree_reset(val iter, val tree, val lowkey, val highkey)
+{
+ val self = lit("tree-reset");
+ struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_cls));
+ struct tree_diter *tdi = coerce(struct tree_diter *,
+ cobj_handle(self, iter, tree_iter_cls));
+ const struct tree_iter it = tree_iter_init(0);
+
+ tdi->ti = it;
+ set(mkloc(tdi->ti.self, iter), iter);
+ set(mkloc(tdi->tree, iter), tree);
+
+ if (!missingp(lowkey)) {
+ tdi->lastnode = nil;
+ tn_find_low(tr->root, tdi, tr, lowkey);
+ } else {
+ set(mkloc(tdi->lastnode, iter), tr->root);
+ }
+
+ if (!missingp(highkey))
+ set(mkloc(tdi->highkey, iter), highkey);
+ else
+ tdi->highkey = iter;
+
+ return iter;
}
val tree_next(val iter)
{
val self = lit("tree-next");
struct tree_diter *tdi = coerce(struct tree_diter *,
- cobj_handle(self, iter, tree_iter_s));
+ cobj_handle(self, iter, tree_iter_cls));
+ struct tree *tr = coerce(struct tree *, cobj_handle(self, tdi->tree, tree_cls));
if (tdi->lastnode) {
val node = tn_find_next(tdi->lastnode, &tdi->ti);
- set(mkloc(tdi->lastnode, iter), node);
+ if (tdi->highkey == iter) {
+ set(mkloc(tdi->lastnode, iter), node);
+ return node;
+ } else if (node) {
+ val key = node->tn.key;
+ if (if3(tr->less_fn,
+ funcall2(tr->less_fn, key, tdi->highkey),
+ less(key, tdi->highkey)))
+ return set(mkloc(tdi->lastnode, iter), node);
+ else
+ return tdi->lastnode = nil;
+ } else {
+ return tdi->lastnode = nil;
+ }
+ return node;
+ }
+
+ return nil;
+}
+
+val tree_peek(val iter)
+{
+ val self = lit("tree-peek");
+ struct tree_diter *tdi = coerce(struct tree_diter *,
+ cobj_handle(self, iter, tree_iter_cls));
+ struct tree *tr = coerce(struct tree *, cobj_handle(self, tdi->tree, tree_cls));
+
+ if (tdi->lastnode) {
+ val node = tn_peek_next(tdi->lastnode, &tdi->ti);
+ if (tdi->highkey == iter) {
+ return node;
+ } else if (node) {
+ val key = node->tn.key;
+ if (if3(tr->less_fn,
+ funcall2(tr->less_fn, key, tdi->highkey),
+ less(key, tdi->highkey)))
+ return node;
+ else
+ return nil;
+ }
return node;
}
@@ -714,18 +1132,34 @@ val tree_next(val iter)
val tree_clear(val tree)
{
val self = lit("tree-clear");
- struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_s));
+ struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_cls));
cnum oldsize = tr->size;
tr->root = nil;
tr->size = tr->max_size = 0;
return oldsize ? num(oldsize) : nil;
}
+val sub_tree(val tree, val from, val to)
+{
+ val iter = tree_begin(tree, from, to);
+ val node;
+ list_collect_decl (out, ptail);
+
+ while ((node = tree_next(iter)))
+ ptail = list_collect(ptail, node->tn.key);
+
+ return out;
+}
+
void tree_init(void)
{
tree_s = intern(lit("tree"), user_package);
tree_iter_s = intern(lit("tree-iter"), user_package);
tree_fun_whitelist_s = intern(lit("*tree-fun-whitelist*"), user_package);
+
+ tree_cls = cobj_register(tree_s);
+ tree_iter_cls = cobj_register(tree_iter_s);
+
reg_fun(tnode_s, func_n3(tnode));
reg_fun(intern(lit("left"), user_package), func_n1(left));
reg_fun(intern(lit("right"), user_package), func_n1(right));
@@ -734,19 +1168,32 @@ void tree_init(void)
reg_fun(intern(lit("set-right"), user_package), func_n2(set_right));
reg_fun(intern(lit("set-key"), user_package), func_n2(set_key));
reg_fun(intern(lit("copy-tnode"), user_package), func_n1(copy_tnode));
- reg_fun(tree_s, func_n4o(tree, 0));
+ reg_fun(intern(lit("tnodep"), user_package), func_n1(tnodep));
+ reg_fun(tree_s, func_n5o(tree, 0));
reg_fun(tree_construct_s, func_n2(tree_construct));
reg_fun(intern(lit("copy-search-tree"), user_package), func_n1(copy_search_tree));
+ reg_fun(intern(lit("make-similar-tree"), user_package), func_n1(make_similar_tree));
reg_fun(intern(lit("treep"), user_package), func_n1(treep));
- reg_fun(intern(lit("tree-insert-node"), user_package), func_n2(tree_insert_node));
- reg_fun(intern(lit("tree-insert"), user_package), func_n2(tree_insert));
+ reg_fun(intern(lit("tree-count"), user_package), func_n1(tree_count));
+ reg_fun(intern(lit("tree-insert-node"), user_package), func_n3o(tree_insert_node, 2));
+ reg_fun(intern(lit("tree-insert"), user_package), func_n3o(tree_insert, 2));
reg_fun(intern(lit("tree-lookup-node"), user_package), func_n2(tree_lookup_node));
reg_fun(intern(lit("tree-lookup"), user_package), func_n2(tree_lookup));
+ reg_fun(intern(lit("tree-min-node"), user_package), func_n1(tree_min_node));
+ reg_fun(intern(lit("tree-min"), user_package), func_n1(tree_min));
reg_fun(intern(lit("tree-delete-node"), user_package), func_n2(tree_delete_node));
reg_fun(intern(lit("tree-delete"), user_package), func_n2(tree_delete));
+ reg_fun(intern(lit("tree-delete-specific-node"), user_package), func_n2(tree_delete_specific_node));
+ reg_fun(intern(lit("tree-del-min-node"), user_package), func_n1(tree_del_min_node));
+ reg_fun(intern(lit("tree-del-min"), user_package), func_n1(tree_del_min));
reg_fun(intern(lit("tree-root"), user_package), func_n1(tree_root));
- reg_fun(intern(lit("tree-begin"), user_package), func_n1(tree_begin));
+ reg_fun(intern(lit("tree-begin"), user_package), func_n3o(tree_begin, 1));
+ reg_fun(intern(lit("copy-tree-iter"), user_package), func_n1(copy_tree_iter));
+ reg_fun(intern(lit("replace-tree-iter"), user_package), func_n2(replace_tree_iter));
+ reg_fun(intern(lit("tree-reset"), user_package), func_n4o(tree_reset, 2));
reg_fun(intern(lit("tree-next"), user_package), func_n1(tree_next));
+ reg_fun(intern(lit("tree-peek"), user_package), func_n1(tree_peek));
reg_fun(intern(lit("tree-clear"), user_package), func_n1(tree_clear));
+ reg_fun(intern(lit("sub-tree"), user_package), func_n3o(sub_tree, 1));
reg_var(tree_fun_whitelist_s, list(identity_s, equal_s, less_s, nao));
}
diff --git a/tree.h b/tree.h
index da72c010..d4fdf140 100644
--- a/tree.h
+++ b/tree.h
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,26 +6,28 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
-extern val tree_s, tree_fun_whitelist_s;
+extern val tree_s, tree_iter_s, tree_fun_whitelist_s;
+extern struct cobj_class *tree_cls, *tree_iter_cls;
#define tree_fun_whitelist (deref(lookup_var_l(nil, tree_fun_whitelist_s)))
@@ -38,11 +40,28 @@ val set_left(val node, val nleft);
val set_right(val node, val nright);
val set_key(val node, val nkey);
val copy_tnode(val node);
-val tree(val keys, val key_fn, val less_fn, val equal_fn);
+val tree(val keys, val key_fn, val less_fn, val equal_fn, val dup);
val copy_search_tree(val tree);
+val make_similar_tree(val tree);
val treep(val obj);
-val tree_insert_node(val tree, val node);
-val tree_begin(val tree);
+val tree_count(val tree);
+val tree_insert_node(val tree, val node, val dup);
+val tree_insert(val tree, val key, val dup);
+val tree_lookup_node(val tree, val key);
+val tree_lookup(val tree, val key);
+val tree_min_node(val tree);
+val tree_min(val tree);
+val tree_delete_node(val tree, val key);
+val tree_delete(val tree, val key);
+val tree_delete_specific_node(val tree, val node);
+val tree_del_min_node(val tree);
+val tree_del_min(val tree);
+val tree_begin(val tree, val lowkey, val highkey);
+val copy_tree_iter(val iter);
+val replace_tree_iter(val diter, val siter);
+val tree_reset(val iter, val tree, val lowkey, val highkey);
val tree_next(val iter);
+val tree_peek(val iter);
val tree_clear(val tree);
+val sub_tree(val tree, val from, val to);
void tree_init(void);
diff --git a/txr.1 b/txr.1
index 4143c647..278279cb 100644
--- a/txr.1
+++ b/txr.1
@@ -1,5 +1,5 @@
.\" t '\" vim:set syntax=groff:
-.\" Copyright (C) 2009-2020 Kaz Kylheku <kaz@kylheku.com>.
+.\" Copyright (C) 2009-2024 Kaz Kylheku <kaz@kylheku.com>.
.\" All rights reserved.
.\"
.\" Redistribution and use in source and binary forms, with or without
@@ -98,7 +98,7 @@
..
.\" Directive heading
.de dir
-. NP* The \f[4]\\$1\f[] directive
+. NP* The \f[4]\\$1\f[] Directive
..
.\" Multiple directive heading
.de dirs
@@ -114,7 +114,7 @@
. if (\\n[.$]>0) \{\
. as s and \f[4]\\$1\f[]
. \}
-. NP* The \\*s directives
+. NP* The \\*s Directives
..
.\" heading with code in position 1
.de c1NP
@@ -183,8 +183,28 @@
. shift
. \}
. el \{\
-. as s \\$1
-. shift
+. ie "\\$1"><" \{\
+. shift
+. as s \fI<\\$1>\fP\\$2\fI<\\$3>\fP
+. shift
+. shift
+. shift
+. \}
+. el \{\
+. ie "\\$1"<2>" \{\
+. shift
+. as s \\$1\fI<\\$2>\fP\\$3\fI<\\$4>\fP\\$5
+. shift
+. shift
+. shift
+. shift
+. shift
+. \}
+. el \{\
+. as s \\$1
+. shift
+. \}
+. \}
. \}
. \}
. \}
@@ -218,14 +238,34 @@
. el \{\
. ie "\\$1"<>" \{\
. shift
-. as s \\$1\\f5\\$2\f4\\$3
+. as s \\$1\\f5\\$2\\f4\\$3
. shift
. shift
. shift
. \}
. el \{\
-. as s \\$1
-. shift
+. ie "\\$1"<2>" \{\
+. shift
+. as s \\$1\\f5\\$2\\f4\\$3\\f5\\$4\\f4\\$5
+. shift
+. shift
+. shift
+. shift
+. shift
+. \}
+. el \{\
+. ie "\\$1"><" \{\
+. shift
+. as s \\f5\\$1\\f4\\$2\f5\\$3\\f4
+. shift
+. shift
+. shift
+. \}
+. el \{\
+. as s \\$1
+. shift
+. \}
+. \}
. \}
. \}
. \}
@@ -346,17 +386,57 @@
. gets \\$*
. IP "\\*s"
..
+.\" keystrokes
+.ie \n(M2 \{\
+.de key
+.M2HT <kbd>\\$1</kbd>
+..
+.de keyn
+.M2HT <kbd>\\$1</kbd>\\$2
+..
+.\}
+.el \{\
+. ie n \{\
+. de key
+[\\$1]
+. .
+. de keyn
+[\\$1]\\$2
+. .
+. \}
+. el \{\
+. \" Box macro from Groff manual with $2 added
+. de box
+. nr @wd \w'\\$1'
+\h'.2m'\
+\h'-.2m'\v'(.2m - \\n[rsb]u)'\
+\D'l 0 -(\\n[rst]u - \\n[rsb]u + .4m)'\
+\D'l (\\n[@wd]u + .4m) 0'\
+\D'l 0 (\\n[rst]u - \\n[rsb]u + .4m)'\
+\D'l -(\\n[@wd]u + .4m) 0'\
+\h'.2m'\v'-(.2m - \\n[rsb]u)'\
+\\$1\
+\h'.2m'\\$2
+. .
+. de key
+. box "\\$1" ""
+. .
+. de keyn
+. box "\\$1" "\\$2"
+. .
+. \}
+.\}
.\" TXR name
.ds TX \f[B]TXR\f[]
.ds TL \f[B]TXR Lisp\f[]
.\" Start of man page:
-.TH TXR 1 2020-03-08 "Utility Commands" "TXR Programming Language" "Kaz Kylheku"
+.TH TXR 1 2024-03-17 "Utility Commands" "TXR Programming Language" "Kaz Kylheku"
.SH* NAME
-\*(TX \- Programming Language (Version 233)
+\*(TX \- Programming Language (Version 294)
.SH* SYNOPSIS
.mono
-.meti txr [ < options ] [ < script-file [ < data-files ... ]]
+.meti txr [ < options ] [ < script-file [ < arguments ... ]]
.onom
.SH* DESCRIPTION
@@ -367,13 +447,13 @@ scanning and extraction language referred to as the \*(TX Pattern Language
\*(TX can be used for everything from "one liner" data transformation tasks at
the command line, to data scanning and extracting scripts, to full
-application development in a wide-range of areas.
+application development in a wide range of areas.
A script written in the \*(TX Pattern Language, also referred to in this
document as a
.IR query ,
specifies a pattern which matches one or more sources of inputs, such
-as text files. Patterns can consist of large chunks of multi-line free-form
+as text files. Patterns can consist of large chunks of multiline free-form
text, which is matched literally against material in the input sources. Free
variables occurring in the pattern (denoted by the
.code @
@@ -385,27 +465,27 @@ recursive.
In addition to embedded variables which implicitly match text, the
\*(TX pattern language supports a number of directives, for matching text using
regular expressions, for continuing a match in another file, for searching
-through a file for the place where an entire sub-query matches, for collecting
-lists, and for combining sub-queries using logical conjunction, disjunction and
+through a file for the place where an entire subquery matches, for collecting
+lists, and for combining subqueries using logical conjunction, disjunction and
negation, and numerous others.
Patterns can contain actions which transform data and generate output.
-These actions can be embedded anywhere within the pattern matching logic.
+These actions can be embedded anywhere within the pattern-matching logic.
A common structure for small \*(TX scripts is to perform a complete matching
-session in the at the top of the script, and then deal with processing
+session at the top of the script, and then deal with processing
and reporting at the bottom.
The \*(TL language can be used from within \*(TX scripts as an
-embedded language, or completely stand-alone. It supports functional,
+embedded language, or completely standalone. It supports functional,
imperative and object-oriented programming, and provides numerous data types
such as symbols, strings, vectors, hash tables with weak reference support,
-lazy lists, and arbitrary-precision ("bignum") integers. It has expressive
+lazy lists, and arbitrary-precision ("bignum") integers. It has an expressive
foreign function interface (FFI) for calling into libraries and other software
components that support C-language-style calls.
\*(TL source files as well as individual functions can be optionally compiled
for execution on a virtual machine that is built into \*(TX. Compiled files
-execute and load faster, and resist reverse-engineering. Stand-alone
+execute and load faster, and resist reverse-engineering. Standalone
application delivery is possible.
\*(TX is free software offered under the two-clause BSD license which
@@ -418,9 +498,31 @@ charge, and free of any restrictions.
If \*(TX is given no arguments, it will enter into an interactive
mode. See the INTERACTIVE LISTENER section for a
description of this mode. When \*(TX enters interactive mode this
-way, it prints a one-line banner is printed announcing the program
-name and version, and one line of help text instructing the user
-how to exit.
+way, it prints a one-line banner announcing the program name and version,
+and one line of help text instructing the user how to exit.
+
+If \*(TX is invoked under the name
+.codn txrlisp ,
+it behaves as if the
+.code --lisp
+option had been specified before any other option.
+Similarly, if \*(TX is invoked under the name
+.codn txrvm ,
+it behaves as if the
+.code --compiled
+option had been given.
+
+Unless the
+.code -c
+or
+.code -f
+options are present, the first non-option argument is treated as a
+.meta script-file
+which is executed. This is described after the following
+descriptions of all of the options.
+Any additional arguments have no fixed meaning; they are available to the
+\*(TX query or \*(TL application for specifying input files to be processed, or
+other meanings under the control of the application.
Options which don't take an argument may be combined together.
The
@@ -442,18 +544,23 @@ Bind the variable
to the value
.meta value
prior to processing the query. The name is in scope over the entire
-query, so that all occurrence of the variable are substituted and
+query, so that all occurrences of the variable are substituted and
match the equivalent text. If the value contains commas, these
are interpreted as separators, which give rise to a list value.
For instance
-.code -Da,b,c
-creates a list of the strings
+.code -Dvar=a,b,c
+binds
+.code var
+to the list of the strings
.strn "a" ,
.str "b"
and
.strn "c" .
-(See Collect Directive bellow). List variables provide a multiple
-match. That is to say, if a list variable occurs in a query, a successful
+(See the
+.code @(collect)
+directive.)
+List variables provide a multiple match.
+That is to say, if a list variable occurs in a query, a successful
match occurs if any of its values matches the text. If more than one
value matches the text, the first one is taken.
@@ -464,7 +571,7 @@ to an empty string value prior to processing the query.
.coIP -q
Quiet operation during matching. Certain error messages are not reported on the
-standard error device (but the if the situations occur, they still fail the
+standard error device (but if the situations occur, they still fail the
query). This option does not suppress error generation during the parsing
of the query, only during its execution.
@@ -519,7 +626,9 @@ If the
.code -n
option is effect and \*(TX enters into the interactive listener,
the listener operates in
-.IR "plain mode" .
+.I "plain mode"
+instead of the
+.IR "visual mode" .
The listener reads buffered lines
from the operating system without any character-based editing features
or history navigation. In plain mode, no prompts appear and no
@@ -537,7 +646,7 @@ function) to an object described by Lisp syntax. It requires an argument
of the form
.meta sym=value
where
-.code sym
+.meta sym
must be, syntactically, a token denoting a bindable symbol, and
.meta value
is arbitrary \*(TL syntax. The
@@ -567,7 +676,8 @@ status from the shell's
.I eval
command.
-.coIP "-l or --lisp-bindings"
+.coIP -l
+.coIP --lisp-bindings
This option implies
.codn -B .
Print the variable bindings in Lisp syntax instead of
@@ -587,7 +697,9 @@ nested collect:
.mono
((("a" "b") ("c" "d")) (("e" "f") ("g" "h"))).
.onom
-Suppose this is bound to a variable V. With
+Suppose this is bound to a variable
+.metn V .
+With
.codn "-a 1" ,
this will be
reported as:
@@ -623,12 +735,12 @@ the dimension order is:
.codn "NAME_m_m+1_..._n[1][2]...[m-1]" .
.meIP -c < query
-Specifies the query in the form of a command line argument. If this option is
+Specifies the query in the form of a command-line argument. If this option is
used, the
.meta script-file
argument is omitted. The first non-option argument,
if there is one, now specifies the first input source rather than a query.
-Unlike queries read from a file, (non-empty) queries specified as arguments
+Unlike queries read from a file, (nonempty) queries specified as arguments
using -c do not have to properly end in a newline. Internally,
\*(TX adds the missing newline before parsing the query. Thus
.code -c
@@ -682,30 +794,58 @@ comment syntax can be used for better formatting:
.RE
.meIP -f < script-file
-Specifies the file from which the query is to be read, instead of the
+Provides a way to specify the file from which the query is to be read,
+as an alternative to using the main
.meta script-file
argument. This is useful in
.code #!
-("hash bang") scripts. (See Hash Bang Support below).
+("hash bang") scripts. (See Hash-Bang Support below.)
+Use of this option does not affect the order of processing. All of the options
+are processed first, before the
+.meta script-file
+is read, as if it were specified by the main
+.meta script-file
+argument.
+If the argument to
+.code -f
+is
+.code -
+(dash) then the script will be read from standard input instead
+of a file.
+If this option is used, the first non-option argument, if there is one,
+no longer specifies the
+.metn script-file .
+It is an argument to the script, such as the name of an input source.
+
+.meIP -e < expressions
+Evaluates zero or more \*(TL expressions for their side effects, without
+implicitly printing their values. Can be specified more than once.
+The argument may be empty, in which case the argument has no effect,
+since it calls for an empty sequence of forms to be evaluated.
-.meIP -e < expression
-Evaluates a \*(TL expression for its side effects, without printing
-its value. Can be specified more than once. The
+The
.meta script-file
-argument becomes optional if
-.code -e
-is used at least once. If the evaluation of every
+argument becomes optional if at least one
+.codn -e ,
+.codn -p ,
+.code -P
+or
+.code -t
+option is processed.
+
+If the evaluation of every
.meta expression
evaluated this way terminates normally, and there is no
.meta script-file
-argument, then \*(TX terminates with a successful status.
+argument, then \*(TX terminates with a successful status,
+instead of entering the interactive listener. The
+.code -i
+option can be used to request the listener.
.meIP -p < expression
-Just like
-.code -e
-but prints the value of
-.meta expression
-using the
+The argument must specify exactly one valid \*(TL form.
+If this is successfully parsed and evaluated,
+the value of the expression is printed as if using the
.code prinl
function.
@@ -725,7 +865,6 @@ function.
.meIP -C < number
.meIP >> --compat= number
-
Requests \*(TX to behave in a manner that is compatible with the specified
version of \*(TX. This makes a difference in situations when a release of
\*(TX breaks backward compatibility. If some version N+1 deliberately introduces
@@ -750,7 +889,6 @@ option.
For more information, see the COMPATIBILITY section.
.meIP >> --gc-delta= number
-
The
.meta number
argument to this option must be a decimal integer. It represents
@@ -763,9 +901,9 @@ function for a description.
.meIP --debug-autoload
This option turns on debugging, like
.code --debugger
-but also requests stepping into the auto-load processing of
+but also requests stepping into the autoload processing of
\*(TL library code. Normally, debugging through the evaluations
-triggered by auto-loading is suppressed.
+triggered by autoloading is suppressed.
Implies
.codn --backtrace .
@@ -786,17 +924,24 @@ installed such that the LICENSE file is in the data directory.
Use of \*(TX implies agreement with the liability disclaimer in the license.
.coIP --version
-Prints program version standard output, and terminates successfully.
+Prints a message on standard output which includes the program version,
+and then immediately causes \*(TX to terminate with a successful status.
+
+.coIP --build-id
+If \*(TX was built with an embedded build ID string, this
+option prints that string. Otherwise nothing is printed.
+In either case, \*(TX then immediately terminates with a successful
+status.
.coIP --args
The
.code --args
option provides a way to encode multiple arguments as a single
argument, which is useful on some systems which have limitations in
-their implementation of the "hash bang" mechanism. For details about
-its special syntax, See Hash Bang Support below. It is also useful in
-stand-alone application deployment. See the section
-STAND-ALONE APPLICATION SUPPORT, in which example uses of
+their implementation of the hash-bang mechanism. For details about
+its special syntax, see Hash-Bang Support below. It is also useful in
+standalone application deployment. See the section
+STANDALONE APPLICATION SUPPORT, in which example uses of
.code --args
are shown.
@@ -816,41 +961,62 @@ syntax.
.coIP --lisp
.coIP --compiled
-These options influences the treatment of query files which do not have
-a suffix indicating their type. The
+These options influence the treatment of query files which do not have
+a recognized suffix indicating their type. The
.code --lisp
-option causes an unsuffixed file to be treated as Lisp source; and
+option causes a file with an unrecognized suffix, or no suffix, to be treated
+as Lisp source;
.code --compiled
-causes it to be treated as a compile file.
-
-Moreover, if
+causes it to be treated as a compiled \*(TL file.
+Moreover,
.code --lisp
-is specified, and an unsuffixed file does not exist, then \*(TX
-will add the
-.str .tl
-suffix and try the file again; and
+and
.code --compiled
-will similarly add the
+influence the suffix search. By default, when a query file name does not have
+a recognizable suffix, and the file does not exist, \*(TX adds the
+.str .txr
+suffix to the name and tries opening that name, and in a similar way
+tries
+.strn .tlo ,
+.str .tlo.gz
+and finally
+.strn .tl .
+In this situation, if either of these two options is specified, \*(TX
+tries only the
+.strn .tlo ,
+.str .tlo.gz
+and
+.str .tl
+suffixes, in that order, avoiding the
+.str .txr
+suffix. The search order is always
.str .tlo
-suffix and try opening the file again.
-In the same situation, if neither
+first, then
+.str .tl
+regardless of whether
.code --lisp
-nor
+or
.code --compiled
-has been specified, \*(TX will first try adding the
-.str .txr
-suffix. If that fails,
-then the
-.str .tlo
-suffix will be tried and finally
-.strn .tl .
+is specified.
+
Note that
.code --lisp
and
.code --compiled
influence how the argument of the
.code -f
-option is treated, but only they precedes that option.
+option is treated, but only if they precede that option.
+
+If the file has a recognized suffix:
+.strn .tl ,
+.strn .tlo ,
+.strn .tlo.gz ,
+.str .txr
+or
+.strn .txr_profile ,
+then these options have no effect. The suffix determines the
+interpretation of the content. Moreover, no suffix search takes
+place: only the given path name is tried.
.coIP --reexec
On platforms which support the POSIX
@@ -860,10 +1026,10 @@ The re-executed image receives the remaining arguments which follow
the
.code --reexec
argument. Note: this option is useful for supporting setuid operation in
-"hash hang" scripts. On some platforms, the interpreter designated by
-a "hash bang" script runs without altered privilege, even if that
+hash-hang scripts. On some platforms, the interpreter designated by
+a hash-bang script runs without altered privilege, even if that
interpreter is installed setuid. If the interpreter is executed directly,
-then setuid applies to it, but not if it is executed via "hash bang".
+then setuid applies to it, but not if it is executed via hash bang.
If the
.code --reexec
option is used in the interpreter command line of such a script, the
@@ -872,6 +1038,12 @@ The re-executed image will then obtain the script name from the arguments
which are passed to it and determine whether that script will run setuid.
See the section SETUID/SETGID OPERATION.
+.coIP --noprofile
+If entering the interactive listener, suppress the reading of the
+.code .txr_profile
+in the home directory. See the Interactive Profile File subsection in the
+INTERACTIVE LISTENER section of the manual.
+
.coIP --gc-debug
This option enables a behavior which stresses the garbage collector with
frequent garbage collection requests. The purpose is to make it more likely
@@ -886,6 +1058,15 @@ example, objects which have been reclaimed by the garbage collector
are marked as inaccessible, and marked as uninitialized when they are
allocated again.
+.coIP --free-all
+This option specifies that all memory allocated by \*(TX should be freed upon
+normal termination. This behavior is useful for debugging memory leaks.
+An accurate leak detection tool, such as the one built into Valgrind,
+should report zero leaked or still reachable memory if
+.code --free-all
+has been used and \*(TX has terminated normally.
+that indicates either a leak in \*(TX, a leak or global object retention
+in a platform library, or else a a leak introduced due to misuse of FFI.
.coIP --dv-regex
If this option is used, then regular expressions are all treated using the
derivative-based back-end. The NFA-based regex implementation is disabled.
@@ -894,6 +1075,46 @@ complement operators are handled using the derivative back-end.
This option makes it possible to test that back-end on test cases that it
wouldn't normally receive.
+.meIP >> --in-package= name
+This option changes to the specified package, by finding the package of the
+specified
+.meta name
+and assigning that to the
+.code *package*
+special variable. If the package is not found, a diagnostic is issued,
+and \*(TX terminates unsuccessfully.
+The package thus specified is visible to the subsequent occurrences of the
+.code -e
+family of options as well as of the
+.code --compile
+option. It does not affect the value of
+.code *package*
+which is in effect when a
+.meta script-file
+is executed or when the interactive listener is entered.
+
+.meIP <2> --compile= source-file [: target-file ]
+This option invokes the
+.code compile-update-file
+on
+.metn source-file .
+If
+.meta target-file
+is specified, it is passed to
+.code compile-update-file
+as the target argument; otherwise, that argument is defaulted.
+The option can be used multiple times to process multiple
+files. Unsuccessful compilation throws an exception, causing
+\*(TX to terminate abnormally. Similarly to the
+.code -e
+option, if this option is used at least once,
+and all of the invocations are successful, and there is no
+.meta script-file
+argument, then \*(TX terminates with a successful status instead
+of entering the interactive listener. The
+.code -i
+option can be used request the listener.
+
.coIP --
Signifies the end of the option list.
@@ -914,26 +1135,61 @@ It may be possible to indicate EOF from the interactive terminal, and
then specify more input which is interpreted as the second file, and so forth.
.PP
-After the options, the remaining arguments are files. The first file argument
-specifies the script file, and is mandatory if the
+After the options, the remaining arguments are treated as follows.
+
+If neither the
.code -f
-option has not been specified, and \*(TX isn't operating in interactive
-mode or evaluating expressions from the command line via
-.code -e
-or one of the related options. A file argument consisting of a single
+nor the
+.code -c
+options were specified, then the first argument is treated as the
+.metn script-file .
+If no arguments are present, then \*(TX
+enters interactive mode, provided that none of the
+.codn -e ,
+.codn -p ,
+.code -P
+or
+.code -t
+options had been processed, in which case it instead terminates.
+
+The \*(TX Pattern Language has features for implicitly treating
+the subsequent command-line arguments as input files.
+It follows the convention that an argument consisting of a single
.code -
-means to read the standard input instead of opening a file.
+(dash) character specifies that standard input is to be used,
+instead of opening a file. If the query does not use the
+.code @(next)
+directive to select an alternative data source, and a pattern-matching
+construct is processed which demands data, then the first argument
+will be opened as a data source. Arguments not opened as data sources
+can be assigned alternative meanings and uses, or can be ignored
+entirely, under control of the query.
Specifying standard input as a source with an explicit
.code -
-argument is unnecessary. If no data source arguments are present, then
+argument is unnecessary. If no arguments are present, then
\*(TX scans standard input by default. This was not true in versions of \*(TX
prior to 171; see the COMPATIBILITY section.
.PP
-\*(TX begins by reading the script. In the case of the \*(TX pattern language,
-the entire query is scanned, internalized and then begins executing, if it is
-free of syntax errors. (\*(TL is processed differently, form by form). On the
+\*(TX begins by reading the script, which is given as the
+contents of the argument of the
+.code -c
+option, or else as the contents of an input source specified by the
+.code -f
+option or by the
+.meta script-file
+argument. If
+.code -f
+or the
+.meta script-file
+argument specify
+.code -
+(dash) then the script is read from standard input.
+
+In the case of the \*(TX pattern language,
+the entire query is scanned, internalized, and then begins executing, if it is
+free of syntax errors. (\*(TL is processed differently, form by form.) On the
other hand, the pattern language reads data files in a lazy manner. A file
isn't opened until the query demands material from that file, and then the
contents are read on demand, not all at once.
@@ -947,20 +1203,37 @@ the
.str .tl
suffix, then it is assumed to be \*(TL. The
.code --lisp
-option changes the treatment of unsuffixed script file names, causing them
-to be interpreted as \*(TL .
+and
+.code --compiled
+options change the treatment of unsuffixed script file names, causing them
+to be interpreted as \*(TL source or compiled \*(TL, respectively.
-If an unsuffixed script file name is specified, and cannot be opened, then
-\*(TX will add the
+If a file name is specified which does not have a recognized suffix,
+and names a file which doesn't exist, then
+\*(TX adds the
.str .txr
-suffix and try again. If that fails, it will be tried with the
+suffix and tries again. If that doesn't exist, another attempt is made with the
+.str .tlo
+suffix, which will be treated as as a \*(TL compiled file.
+If that doesn't exist, then
+.str .tlo.gz
+is tried, expected to be a file compressed in
+.code gzip
+format. Finally, if that doesn't exist, the
.str .tl
-suffix, and treated as \*(TL .
-If the
+suffix is tried, which will be treated as containing \*(TL source.
+If either the
.code --lisp
-option has been specified, then \*(TX tries only the
-.str .tl
-suffix.
+or
+.code --compiled
+option has been specified, then \*(TX skips trying the
+.str .txr
+suffix, and tries only
+.str .tlo
+followed by
+.str .tlo.gz
+and
+.strn .tl .
A \*(TL file is processed as if by the
.code load
@@ -987,7 +1260,7 @@ bindings with
or
.codn -a .
-If the command line arguments are incorrect, \*(TX issues an error diagnostic
+If the command-line arguments are incorrect, \*(TX issues an error diagnostic
and terminates with a failed status.
If the
@@ -1009,7 +1282,7 @@ are not erroneous.
In bindings-printing mode (options
.code -B
or
-.codn -a) ,
+.codn -a ),
\*(TX prints the word
.code false
if the query fails, and exits with a failed
@@ -1064,9 +1337,9 @@ character, the
.code #
character can be used. This is an obsolescent feature.
-.SS* Hash Bang Support
-\*(TX has several features which support use of the "hash bang" convention
-for creating apparently stand-alone executable programs.
+.SS* Hash-Bang Support
+\*(TX has several features which support use of the hash-bang convention
+for creating apparently standalone executable programs.
.NP* Basic Hash Bang
Special processing is applied to \*(TX query or \*(TL script files that are
@@ -1077,9 +1350,9 @@ a file begins with the characters
.codn #! ,
that entire line is consumed and processed specially.
-This removal
+This removal allows
for \*(TX queries to be turned into standalone executable programs in the POSIX
-environment using the "hash bang" mechanism. Unlike most interpreters,
+environment using the hash-bang mechanism. Unlike most interpreters,
\*(TX applies special processing to the
.code #!
line, which is described below, in the section
@@ -1103,7 +1376,7 @@ run it. This assumes \*(TX is installed in
Hello, world!
.brev
-When this plain hash bang line is used, \*(TX receives the name of the script
+When this plain hash-bang line is used, \*(TX receives the name of the script
as an argument. Therefore, it is not possible to pass additional options
to \*(TX. For instance, if the above script is invoked like this
@@ -1111,17 +1384,19 @@ to \*(TX. For instance, if the above script is invoked like this
$ ./hello.txr -B
.brev
-the -B option isn't processed by \*(TX, but treated as an additional argument,
+the
+.code -B
+option isn't processed by \*(TX, but treated as an additional argument,
just as if
.mono
-.meti txr < scriptname -B
+.meti txr < script-file -B
.onom
had been executed directly.
This behavior is useful if the script author wants not to expose the
\*(TX options to the user of the script.
-However, the hash bang line can use the
+However, the hash-bang line can use the
.code -f
option:
@@ -1146,7 +1421,7 @@ option is honored.
.coNP Argument Generation with @ --args and @ --eargs
On some operating systems, it is not possible to pass more than one
-argument through the hash bang mechanism. That is to say, this will
+argument through the hash-bang mechanism. That is to say, this will
not work.
.verb
@@ -1155,7 +1430,7 @@ not work.
To support systems like this, \*(TX supports the special argument
.codn --args ,
-as well as as an extended version,
+as well as an extended version,
.codn --eargs .
With
.codn --args ,
@@ -1181,7 +1456,7 @@ The above has the same behavior as
#!/usr/bin/txr -B -f
.brev
-on a system which supports multiple arguments in hash bang.
+on a system which supports multiple arguments in the hash-bang line.
The separator character is the colon, and so the remainder
of that argument,
.codn -B:-f ,
@@ -1190,10 +1465,9 @@ is split into the two arguments
The
.code --eargs
-mechanism allows an additional flexibility. An
-.code --eargs
-argument must be followed by one more argument.
-
+option is similar to
+.codn --args ,
+but must be followed by one more argument.
After
.code --eargs
performs the argument splitting in the same manner as
@@ -1212,8 +1486,8 @@ Example:
.brev
This has an effect which cannot be replicated in any known
-implementation of the hash bang mechanism. Suppose
-that this hash bang line is placed in a script called
+implementation of the hash-bang mechanism. Suppose
+that this hash-bang line is placed in a script called
.codn script.txr .
When this script is invoked with arguments, as in:
@@ -1237,7 +1511,8 @@ processing takes place, firstly the argument sequence
is produced by splitting into four fields using the
.code :
-character as the separator. Then, within these four fields, all occurrences of
+(colon) character as the separator.
+Then, within these four fields, all occurrences of
.code {}
are replaced with the following argument
.codn script.txr ,
@@ -1277,7 +1552,7 @@ mechanisms do not solve the following problem: the POSIX
.code env
utility is often exploited for its
.code PATH
-searching capability, and used to express hash bang scripts in the following
+searching capability, and used to express hash-bang scripts in the following
way:
.verb
@@ -1290,28 +1565,27 @@ utility searches for the
.code txr
program in the directories indicated by the
.code PATH
-variable, which liberates the script from having encode the exact location
+variable, which liberates the script from having to encode the exact location
where the program is installed. However, if the operating system allows only
-one argument in the hash bang mechanism, then no arguments can be passed
+one argument in the hash-bang mechanism, then no arguments can be passed
to the program.
To mitigate this problem,
\*(TX
-supports a special feature in its hash bang support. If the hash bang
-.code #!
-line contains a null byte, then text after the null byte, to the end of the
-line, is split into fields using the space character as a separator, and these
+supports a special feature in its hash-bang support. If the hash-bang
+line contains a null byte, then the text from after the null byte
+until the end of the line
+is split into fields using the space character as a separator, and these
fields are inserted into the command line. This manipulation happens during
-command line processing, prior to the execution of the file, which happens
-after command-line processing. If this processing is applied to a file
-that is specified using the
+command-line processing, i.e. prior to the execution of the file.
+If this processing is applied to a file that is specified using the
.code -f
option, then the arguments which arise from the special processing
are inserted after that option and its argument. If this processing is
applied to the file which is the first non-option argument, then the
options are inserted before that argument. However, care is taken not
to process that argument a second time.
-In either situation, processing of the command line options continues, and the
+In either situation, processing of the command-line options continues, and the
arguments which are processed next are the ones which were just inserted. This
is true even if the options had been inserted as a result of processing the
first non-option argument, which would ordinarily signal the termination of
@@ -1328,7 +1602,7 @@ resolves to
.codn /usr/bin/txr .
The
.code <NUL>
-code indicates a literal ASCII NUL character, or zero bytes.
+code indicates a literal ASCII NUL character (the zero byte).
Basic example:
@@ -1349,8 +1623,8 @@ Thus, including the executable name, \*(TX receives this full argument list:
.brev
The first non-option argument is the name of the script. \*(TX opens
-the script, and notices that it begins with a hash bang line.
-It consumes the hash bang line and finds the null byte inside it,
+the script, and notices that it begins with a hash-bang line.
+It consumes the hash-bang line and finds the null byte inside it,
retrieving the character string after it, which is
.strn "-a 3" .
This is split into the two arguments
@@ -1364,7 +1638,7 @@ the script name. The effective command line then becomes:
/usr/bin/txr -a 3 /home/jenny/foo.txr --bar abc
.brev
-Command line option processing continues, beginning with the
+Command-line option processing continues, beginning with the
.code -a
option. After the option is processed,
.code /home/jenny/foo.txr
@@ -1375,8 +1649,8 @@ do if it hadn't triggered the insertion of any arguments.
Advanced example: use
.code env
to invoke
-.code txr
-passing options to interpreter and to the script:
+.codn txr ,
+passing options to the interpreter and to the script:
.verb
#!/usr/bin/env txr<NUL>--eargs:-C:175:{}:--debug
@@ -1393,7 +1667,7 @@ begins executing, it receives the arguments
.brev
The script file is opened, and the arguments delimited by the
-null character in the hash bang line are inserted, resulting
+null character in the hash-bang line are inserted, resulting
in the effective command line:
.verb
@@ -1426,24 +1700,24 @@ argument: it executes with the
list containing one element, the character string
.strn --debug .
-The hash bang null hack feature was introduced in \*(TX 177.
-Previous versions ignore the hash bang line, performing no special
+The hash-bang null-hack feature was introduced in \*(TX 177.
+Previous versions ignore the hash-bang line, performing no special
processing. Where a risk exists that programs which depend on the
feature might be executed by an older version of \*(TX, care must
be taken to detect and handle that situation, either by means of the
.code txr-version
-variable, or else by some logic which infers that the processing of the hash
-bang line hadn't been performed.
+variable, or else by some logic which infers that the processing of the
+hash-bang line hasn't been performed.
-.coNP Passing Options to \*(TX via Hash Bang Null Hack
+.coNP Passing Options to \*(TX via Hash-Bang Null Hack
-It is possible to use the Hash Bang Null Hack, such that the resulting
+It is possible to use the Hash-Bang Null Hack, such that the resulting
executable program recognizes \*(TX options. This is made possible by
a special behavior in the processing of the
.code -f
option.
-For instance, suppose that the effect of the following familiar hash bang line
+For instance, suppose that the effect of the following familiar hash-bang line
is required:
.verb
@@ -1452,8 +1726,8 @@ is required:
However, suppose there is also a requirement to use the
.code env
-utility to find \*(TX. Furthermore, the operation system allows only one hash
-bang argument. Using the Null Hack, this is rewritten as:
+utility to find \*(TX. Furthermore, the operating system allows only one
+hash-bang argument. Using the Null Hack, this is rewritten as:
.verb
#!/usr/bin/env txr<NUL>-f
@@ -1480,7 +1754,7 @@ However, note that there is a subtle issue with the
.code -f
option that has been inserted via the Null Hack: namely, this
insertion happens after
-\*(TX has opened the script file and read the hash bang line from it.
+\*(TX has opened the script file and read the hash-bang line from it.
This means that when the inserted
.code -f
option is being processed, the script file is already open.
@@ -1488,14 +1762,14 @@ A special behavior occurs. The
.code -f
option processing notices that the argument to
.code -f
-is identical to the path name of name of the script file that \*(TX has
+is identical to the pathname of name of the script file that \*(TX has
already opened for processing. The
.code -f
option and its argument are then skipped.
.NP* Hash Bang and Setuid
-\*(TX supports setuid hash bang scripting, even on platforms that do not
-support setuid and setgid attributes on hash bang scripts. On such
+\*(TX supports setuid hash-bang scripting, even on platforms that do not
+support setuid and setgid attributes on hash-bang scripts. On such
platforms, \*(TX has to be installed setuid/setgid. See the section
SETUID/SETGID OPERATION. On some platforms, it may also be necessary to
to use the
@@ -1528,9 +1802,9 @@ For matching a single space, the syntax
.code "@\e "
can be used (backslash-escaped space).
-It is more often necessary to match multiple spaces than to exactly
-match one space, so this rule simplifies many queries and adds inconvenience
-to only few.
+It is more often necessary to match multiple spaces than to
+match exactly one space, so this rule simplifies many queries
+and inconveniences only a few.
In output clauses, string and character literals and quasiliterals, a space
token denotes a space.
@@ -1559,7 +1833,7 @@ section Variables below.
A query may not leave a line of input partially matched. If any portion of a
line of input is matched, it must be entirely matched, otherwise a matching
failure results. However, a query may leave unmatched lines. Matching only
-four lines of a ten line file is not a matching failure. The
+four lines of a ten-line file is not a matching failure. The
.code eof
directive can be used to explicitly match the end of a file.
@@ -1616,7 +1890,7 @@ can be used. Example:
.PP
In this example, the query matches, since the regular expression
-matches the string "of data". (See Regular Expressions section below).
+matches the string "of data". (See the Regular Expressions section below.)
Another way to do this is:
.IP code:
@@ -1629,13 +1903,13 @@ Control characters may be embedded directly in a query (with the exception of
newline characters). An alternative to embedding is to use escape syntax.
The following escapes are supported:
-.meIP >> @\e newline
+.meIP >> @\e newline
A backslash immediately followed by a newline introduces a physical line
break without breaking up the logical line. Material following this sequence
continues to be interpreted as a continuation of the previous line, so
that indentation can be introduced to show the continuation without appearing
in the data.
-.meIP >> @\e space
+.meIP >> @\e space
A backslash followed by a space encodes a space. This is useful in line
continuations when it is necessary for some or all of the leading spaces to be
preserved. For instance the two line sequence
@@ -1672,7 +1946,7 @@ kinds of terminals, or ejects a page of text from a line printer.
Carriage return (ASCII 13, CR).
.coIP @\ee
Escape (ASCII 27, ESC)
-.meIP @\ex < hex-digits
+.meIP >> @\ex hex-digits
A
.code @\ex
immediately followed by a sequence of hex digits is interpreted as a hexadecimal
@@ -1681,8 +1955,7 @@ numeric character code. For instance
is the ASCII character A. If a semicolon character immediately follows the
hex digits, it is consumed, and characters which follow are not considered
part of the hex escape even if they are hex digits.
-.meIP @\e < octal-digits
-
+.meIP >> @\e octal-digits
A
.code @\e
immediately followed by a sequence of octal digits (0 through 7) is interpreted
@@ -1726,26 +1999,21 @@ and
.codn L_CTYPE .
The program reads and writes only the UTF-8 encoding.
-If
-\*(TX encounters an invalid bytes in the UTF-8 input, what happens depends on
-the context in which this occurs. In a query, comments are read without regard
-for encoding, so invalid encoding bytes in comments are not detected. A comment
-is simply a sequence of bytes terminated by a newline. In lexical elements
-which represent text, such as string literals, invalid or unexpected encoding
-bytes are treated as syntax errors. The scanner issues an error message,
-then discards a byte and resumes scanning. Certain sequences pass through the
-scanner without triggering an error, namely some UTF-8 overlong sequences.
-These are caught when when the lexeme is subject to UTF-8 decoding, and treated
-in the same manner as other UTF-8 data, described in the following paragraph.
-
-Invalid bytes in data are treated as follows. When an invalid byte is
-encountered in the middle of a multibyte character, or if the input
-ends in the middle of a multibyte character, or if a character is extracted
-which is encoded as an overlong form, the UTF-8 decoder returns to the starting
-byte of the ill-formed multibyte character, and extracts just that byte,
-mapping it to the Unicode character range U+DC00 through U+DCFF. The decoding
-resumes afresh at the following byte, expecting that byte to be the start
-of a UTF-8 code.
+\*(TX deals with UTF-8 separately in its parser and in its I/O streams
+implementation.
+
+\*(TX's text streams perform UTF-8 conversion internally,
+such that \*(TX applications use Unicode code points.
+
+In text streams, invalid UTF-8 bytes are treated as follows. When an invalid
+byte is encountered in the middle of a multibyte character, or if the input
+ends in the middle of a multibyte character, or if an invalid character is decoded,
+such as an overlong from, or code in the range U+DC00 through U+DCFF, the UTF-8
+decoder returns to the starting byte of the ill-formed multibyte character, and
+extracts just one byte, mapping that byte to the Unicode character range U+DC00
+through U+DCFF, producing that code point as the decoded result. The decoder
+is then reset to its initial state and begins decoding at the following byte,
+where the same algorithm is repeated.
Furthermore, because \*(TX internally uses a null-terminated character
representation of strings which easily interoperates with C language
@@ -1754,16 +2022,33 @@ the code U+DC00. On output, this code converts back to a null byte,
as explained in the previous paragraph. By means of this representational
trick, \*(TX can handle textual data containing null bytes.
+In contrast to the above, the \*(TX parser scans raw UTF-8 bytes from a binary
+stream, rather than using a text stream. The parser performing its own
+recognition of UTF-8 sequences in certain language constructs, using a UTF-8
+decoder only when processing certain kinds of tokens.
+
+Comments are read without regard for encoding, so invalid encoding bytes in
+comments are not detected. A comment is simply a sequence of bytes terminated
+by a newline.
+
+Invalid UTF-8 encountered while scanning identifiers and character names in
+character literal (hash-backslash) syntax is diagnosed as a syntax error.
+
+UTF-8 in string literals is treated in the same way as UTF-8 in text streams.
+Invalid UTF-8 bytes are mapped into code points in the U+DC000 through U+DCFF
+range, and incorporated as such into the resulting string object which the
+literal denotes. The same remarks apply to regular-expression literals.
+
.SS* Regular Expression Directives
-In place of a piece of text (see section Text above), a regular expression
+In place of a piece of text (see section Text above), a regular-expression
directive may be used, which has the following syntax:
.verb
@/RE/
.brev
-where the RE part enclosed in slashes represents regular expression
+where the RE part enclosed in slashes represents regular-expression
syntax (described in the section Regular Expressions below).
Long regular expressions can be broken into multiple lines using a
@@ -1780,11 +2065,11 @@ sequence is not significant, so the following two are equivalent:
There may not be whitespace between the backslash and newline.
Whereas literal text simply represents itself, regular expression denotes a
-(potentially infinite) set of texts. The regular expression directive
+(potentially infinite) set of texts. The regular-expression directive
matches the longest piece of text (possibly empty) which belongs to the set
denoted by the regular expression. The match is anchored to the current
position; thus if the directive is the first element of a line, the match is
-anchored to the start of a line. If the regular expression directive is the
+anchored to the start of a line. If the regular-expression directive is the
last element of a line, it is anchored to the end of the line also: the regular
expression must match the text from the current position to the end of the
line.
@@ -1798,7 +2083,7 @@ only two lines. This will fail: the data has no line for the regular expression
match. A line containing no characters is not the same thing as the absence of
a line, even though both abstractions imply an absence of characters.
-Like text which follows a variable, a regular expression directive which
+Like text which follows a variable, a regular-expression directive which
follows a variable has special semantics, described in the section Variables
below.
@@ -1813,7 +2098,7 @@ character. Two consecutive
characters encode a literal
.codn @ .
-A variable matching or substitution directive is written in one of several
+A variable-matching or substitution directive is written in one of several
ways:
.mono
@@ -1822,20 +2107,20 @@ ways:
.mets >> @* sident
.mets <> @*{ bident }
.mets >> @{ bident <> / regex /}
-.mets >> @{ bident >> ( fun >> [ arg ... ])}
+.mets >> @{ bident >> ( fun >> [ arg ...])}
.mets >> @{ bident << number }
+.mets >> @{ bident << bident }
.onom
The forms with an
.code *
indicate a long match, see Longest Match below.
-The last two three forms with the embedded regexp
+The forms with the embedded regexp
.mono
.meti <> / regex /
.onom
-or
+or function or
.meta number
-or function
have special semantics; see Positive Match below.
The identifier
@@ -1876,7 +2161,7 @@ otherwise be interpreted as being part of the identifier. When a name is
enclosed in braces it is a
.metn bident .
-The following additional characters may be used as part of
+The following additional characters may be used as part of a
.meta bident
which are not allowed in a
.metn sident :
@@ -1889,8 +2174,9 @@ Moreover, most Unicode characters beyond U+007F may appear in a
.metn bident ,
with certain exceptions. A character may not be used if it is any of the
Unicode space characters, a member of the high or low surrogate region,
-a member of any Unicode private use area, or is one of the two characters
-U+FFFE or U+FFFF.
+a member of any Unicode private-use area, or is either of the two characters
+U+FFFE and U+FFFF. These situations produce a syntax error. Invalid UTF-8
+in an identifier is also a syntax error.
The rule still holds that a name cannot look like a number so
.code +123
@@ -1943,7 +2229,7 @@ material finds a match. This is why this is called a "negative match": the
spanned text which ends up bound to the variable is that in which the match for
the trailing material did not occur.
-A variable may be followed by a piece of text, a regular expression directive,
+A variable may be followed by a piece of text, a regular-expression directive,
a function call, a directive, another variable, or nothing (i.e. occurs at the
end of a line). These cases are described in detail below.
@@ -1973,7 +2259,9 @@ So for instance in this example:
.brev
.PP
-the variable @a is considered to be followed by
+the variable
+.code a
+is considered to be followed by
.strn ":@/foo/bcd e" .
If a variable is followed by text, then the extent of the negative match is
@@ -2014,7 +2302,7 @@ is
.strn " e f" .
This is found within the data
.str "c d e f"
-at position 3 (counting from 0). So positions 0-2
+at position 3 (counting from 0). So positions 0\(en2
.mono
("c d")
.onom
@@ -2034,13 +2322,15 @@ For example:
.brev
Here,
-.code foo
+.code @foo
will match the text from the current position to where
.str "xyz"
occurs, even though there is a
.code @(bind)
directive. Furthermore, if
-more material is added after the xyz, it is part of the search.
+more material is added after the
+.strn "xyz" ,
+it is part of the search.
Note the difference between the following two:
.verb
@@ -2048,13 +2338,17 @@ Note the difference between the following two:
@foo@(func)@/abc/
.brev
-In the first example, the variable foo matches the text from the current
-position until the match for the regular expression abc.
+In the first example,
+.code @foo
+matches the text from the current
+position until the match for the regular expression
+.strn "abc" .
.code @(func)
is not
considered when processing
.codn @foo .
-In the second example, the variable foo
+In the second example,
+.code @foo
matches the text from the current position until the position which matches
the function call, followed by a match for the regular expression.
The entire sequence
@@ -2080,7 +2374,7 @@ variables. (In theory, a repetition of the same variable, like
.codn @FOO@FOO ,
could find a solution by dividing the match extent in half, which would work
only in the case when it contains an even number of characters. This behavior
-seems to have dubious value).
+seems to have dubious value.)
An unbound variable may be followed by one which is bound. The bound
variable is effectively replaced by the text which it denotes, and the logic
@@ -2150,11 +2444,11 @@ a match. The first match is taken.
An unbound variable may be followed by another unbound variable which specifies
a regular expression or function call match. This is a special case called a
"double variable match". What happens is that the text is searched using the
-regular expression or function. If the search fails, than neither variable is
-bound: it is a matching failure. If the search succeeds, than the first
+regular expression or function. If the search fails, then neither variable is
+bound: it is a matching failure. If the search succeeds, then the first
variable is bound to the text which is skipped by the search. The second
variable is bound to the text matched by the regular expression or function.
-Examples:
+Example:
.IP code:
.mono
\ @foo@{bar /abc/}
@@ -2169,10 +2463,8 @@ Examples:
.onom
.PP
-.NP* Consecutive Variables Via Directive
-Two variables can be
-.I de facto
-consecutive in a manner shown in the
+.NP* Consecutive Variables via Directive
+Two variables can be de facto consecutive in a manner shown in the
following example:
.verb
@@ -2229,7 +2521,7 @@ everything:
The closest-match behavior for the negative match can be overridden to longest
match behavior. A special syntax is provided for this: an asterisk between the
.code @
-and the variable, e.g:
+and the variable, e.g.:
.IP code:
.mono
\ a @*{FOO}cd
@@ -2254,7 +2546,6 @@ and the variable, e.g:
.IP result:
.mono
\ FOO="b "
- b=""
.onom
.PP
@@ -2280,7 +2571,7 @@ enclosed with the variable in braces:
.mono
.mets >> @{ bident <> / regex /}
-.mets >> @{ bident >> ( fun >> [args ...])}
+.mets >> @{ bident >> ( fun >> [ args ...])}
.mets >> @{ bident << number }
.mets >> @{ bident << bident }
.onom
@@ -2290,20 +2581,28 @@ from a regular expression, function or character count, rather than from
trailing material (which is regarded as a "negative" match, since the
variable is bound to material which is
.B skipped
-in order to match the trailing material). In the
+in order to match the trailing material).
+
+The positive match syntax is processed without considering any following
+syntax, and therefore may be followed by an unbound variable.
+
+In the
.mono
-.meti <> / regex /
+.meti >> @{ bident <> / regex /}
.onom
form, the match
extends over all characters from the current position which match
the regular expression
.metn regex .
-(see Regular Expressions section below).
+(See the Regular Expressions section below.)
+If the variable already has a value, the text extracted by the regular
+expression must exactly match the variable.
+
In the
.mono
-.meti >> ( fun >> [ args ...])
+.meti >> @{ bident >> ( fun >> [ args ...])}
.onom
-form, the match extends over characters which
+form, the match extends over lines or characters which
are matched by the call to the function, if the call
succeeds. Thus
.code "@{x (y z w)}"
@@ -2314,33 +2613,51 @@ text skipped over by
.code "@(y z w)"
is also bound to the variable
.codn x .
-See Functions below.
+Except in one special case, the matching takes place horizontally within the
+current line, and the spanned range of text is treated as a string.
+The exception is that if the
+.mono
+.meti >> @{ bident >> ( fun >> [ args ...])}
+.onom
+appears as the only element of a line, and
+.meta fun
+has a binding as a vertical function, then the function is invoked in
+the same manner as it would be by the
+.mono
+.meti >> @( fun >> [ args ...])
+.onom
+syntax. Then the variable indicated by
+.meta bident
+is bound to the list of lines matched by the function call.
+Pattern functions are described in the Functions section below.
+The function is invoked even if the variable already has a value.
+The text matched by the function must match the variable.
In the
-.meta number
+.mono
+.meti >> @{ bident << number }
+.onom
form, the match processes a field of text which
-consists of the specified number of characters, which must be non-negative
+consists of the specified number of characters, which must be a nonnegative
number. If the data line doesn't have that many characters starting at the
current position, the match fails. A match for zero characters produces an
empty string. The text which is actually bound to the variable
is all text within the specified field, but excluding leading and
trailing whitespace. If the field contains only spaces, then an empty
-string is extracted.
-
-This syntax is processed without consideration of what other
-syntax follows. A positive match may be directly followed by an unbound
-variable.
+string is extracted. This fixed-field extraction takes place whether or not the
+variable already has a binding. If it already has a binding, then it must match
+the extracted, trimmed text.
The
.mono
-.mets >> @{ bident << bident }
+.meti >> @{ bident << bident }
.onom
syntax allows the
.meta number
or
.meta regex
modifier to come from a variable. The variable must be bound and contain
-a non-negative integer or regular expression.
+a nonnegative integer or regular expression.
For example,
.code "@{x y}"
behaves like
@@ -2377,7 +2694,7 @@ cannot be used as variables. When evaluated, they evaluate to themselves.
In the \*(TX pattern language,
.code nil
can be used in the variable binding syntax, but does not create a binding;
-it has a special meaning. It allows the variable matching syntax to be used to
+it has a special meaning. It allows the variable-matching syntax to be used to
skip material, in ways similar to the
.code skip
directive.
@@ -2393,15 +2710,15 @@ is considered to be anonymous.
.SS* Keyword Symbols
-Names whose names begin with the
+Names beginning with the
.code :
-character are keyword symbols. These also
-may not be used as variables either and stand for themselves. Keywords are
+(colon) character are keyword symbols. These also
+stand for themselves and may not be used as variables. Keywords are
useful for labeling information and situations.
.SS* Regular Expressions
Regular expressions are a language for specifying sets of character strings.
-Through the use of pattern matching elements, regular expression is
+Through the use of pattern-matching elements, a regular expression is
able to denote an infinite set of texts.
\*(TX contains an original implementation of regular expressions, which
supports the following syntax:
@@ -2561,7 +2878,7 @@ you to leave it in place, then enable it later by removing the "block".
If
.code R
is a regular expression, then so is
-.code (R).
+.codn (R) .
The contents of parentheses denote one regular expression unit, so that for
instance in
.codn (RE)* ,
@@ -2582,7 +2899,7 @@ operator is sometimes called the "Kleene star", or "Kleene closure".
The Kleene closure favors the longest match. Roughly speaking, if there are two
or more ways in which
.code R1*R2
-can match, than that match occurs in which
+can match, then that match occurs in which
.code R1*
matches the longest possible text.
.coIP R+
@@ -2608,7 +2925,7 @@ number of times, which is opposite from the behavior of
Repetitions of
.code R1
terminate at the earliest
-point in the text where a non-empty match for
+point in the text where a nonempty match for
.code R2
occurs. Because
it favors shorter matches,
@@ -2681,7 +2998,7 @@ or logical not.
Two consecutive regular expressions denote catenation:
the left expression must match, and then the right.
.coIP R1|R2
-match either the expression
+Match either the expression
.code R1
or
.codn R2 .
@@ -2701,16 +3018,16 @@ and the set matched by
This operator is called intersection, logical and, or conjunction.
.PP
-Any character which is not a regular expression operator, a backslash escape,
-or the slash delimiter, denotes one-position match of that character itself.
+Any character which is not a regular-expression operator, a backslash escape,
+or the slash delimiter, denotes a one-position match of that character itself.
Any of the special characters, including the delimiting
.codn / ,
and the backslash, can be escaped with a backslash to suppress its
meaning and denote the character itself.
-Furthermore, all of the same escapes as are described in the section Special
-Characters in Text above are supported - the difference is that in regular
+Furthermore, all of the same escapes that are described in the section Special
+Characters in Text above are supported \(em the difference is that in regular
expressions, the
.code @
character is not required, so for example a tab is coded as
@@ -2721,7 +3038,7 @@ Octal and hex character escapes can be optionally
terminated by a semicolon, which is useful if the following characters are
octal or hex digits not intended to be part of the escape.
-Only the above escapes are supported. Unlike in some other regular expression
+Only the above escapes are supported. Unlike in some other regular-expression
implementations, if a backlash appears before a character which isn't a regex
special character or one of the supported escape sequences, it is an error.
This wasn't true of historic versions of \*(TX. See the COMPATIBILITY section.
@@ -2747,10 +3064,8 @@ operand, but like a unary operator with respect to its right operand.
Thus
.code a~b%c~d
is
-.mono
-a(~(b%(c(~d))))
-.onom
-, demonstrating right-to-left associativity,
+.codn a(~(b%(c(~d)))) ,
+demonstrating right-to-left associativity,
where all of
.code b%
may be regarded as a unary operator being applied to
@@ -2765,7 +3080,7 @@ behaves like a postfix operator.
In
\*(TX, regular expression matches do not span multiple lines. The regex
-language has no feature for multi-line matching. However, the
+language has no feature for multiline matching. However, the
.code @(freeform)
directive
allows the remaining portion of the input to be treated as one string
@@ -2775,8 +3090,7 @@ may freely match through this sequence.
It's possible for a regular expression to match an empty string.
For instance, if the next input character is
.codn z ,
-facing a
-the regular expression
+facing the regular expression
.codn /a?/ ,
there is a zero-character match:
the regular expression's state machine can reach an acceptance
@@ -2853,8 +3167,8 @@ the rightmost place. Thus variable
.code A
fetches the entire line.
-For additional information about the advanced regular expression
-operators, NOTES ON EXOTIC REGULAR EXPRESSIONS below.
+For additional information about the advanced regular-expression
+operators, see NOTES ON EXOTIC REGULAR EXPRESSIONS below.
.SS* Compound Expressions
If the
@@ -2866,8 +3180,7 @@ The \*(TX language has the unusual property that its syntactic elements,
so-called
.IR directives ,
are Lisp compound expressions. These expressions not only enclose syntax, but
-expressions which begin with certain symbols
-.I de facto
+expressions which begin with certain symbols de facto
behave as tokens in a phrase structure grammar. For instance, the expression
.code @(collect)
begins a block which must be terminated by the expression
@@ -2877,7 +3190,7 @@ otherwise there is a syntax error. The
expression can contain arguments which modify the behavior of the construct,
for instance
.codn "@(collect :gap 0 :vars (a b))" .
-In some ways, this situation might be compared to the HTML language, in which
+In some ways, this situation might be compared to HTML, in which
an element such as
.code <a>
must be terminated by
@@ -2885,8 +3198,9 @@ must be terminated by
and can have attributes such as
.codn "<a href=\(dq...\(dq>" .
-Compound contain subexpressions: other compound expressions, or literal objects
-of various kinds. Among these are: symbols, numbers, string literals, character
+Compound expressions contain subexpressions which are
+other compound expressions or literal objects of various kinds.
+Among these are: symbols, numbers, string literals, character
literals, quasiliterals and regular expressions. These are described in the
following sections. Additional kinds of literal objects exist, which are
discussed in the TXR LISP section of the manual.
@@ -2907,7 +3221,7 @@ Some examples of compound expressions are:
(_ `@file.txt`)
.brev
-Symbols occurring in a compound expression follow a slight more permissive
+Symbols occurring in a compound expression follow a slightly more permissive
lexical syntax than the
.meta bident
in the syntax
@@ -2928,7 +3242,7 @@ numbers and not symbols.
Character literals are introduced by the
.code #\e
-syntax, which is either
+(hash-backslash) syntax, which is either
followed by a character name, the letter
.code x
followed by hex digits,
@@ -2978,12 +3292,11 @@ and
are recognized, as are hexadecimal escapes like
.code \exFF
or
-.code \exxabc
-and octal
-escapes like
+.code \exabc
+and octal escapes like
.codn \e123 .
Ambiguity between an escape and subsequent
-text can be resolved by using trailing semicolon delimiter:
+text can be resolved by adding a semicolon delimiter after the escape:
.str "\exabc;d"
is a string consisting of the character
.code "U+0ABC"
@@ -2997,6 +3310,22 @@ as a delimiter. Thus,
represents
.strn "!;" .
+Note that the source code syntax of \*(TX string literals is specified
+in UTF-8, which is decoded into an internal string representation consisting
+of code points. The numeric escape sequences are an abstract syntax for
+specifying code points, not for specifying bytes to be inserted into the
+UTF-8 representation, even if they lie in the 8-bit range. Bytes cannot be
+directly specified, other than literally. However, when a \*(TX string object
+is encoded to UTF-8, every code point lying in the range U+DC00 through U+DCFF
+is converted to a single byte by taking the low-order eight bits of its
+value. By manipulating code points in this special range, \*(TX programs can
+reproduce arbitrary byte sequences in text streams. Also note that the
+.code \eu
+escape sequence for specifying code points found in some languages is
+unnecessary and absent, since the existing hexadecimal and octal escapes
+satisfy this requirement. More detailed information is given in the earlier
+section Character Handling and International Characters.
+
If the line ends in the middle of a literal, it is an error, unless the
last character is a backslash. This backslash is a special escape which does
not denote a character; rather, it indicates that the string literal continues
@@ -3033,11 +3362,11 @@ There are two flavors of the WLL: the regular WLL which begins with
.mono
#"
.onom
-(hash, double-quote) and the splicing list literal which begins with
+(hash, double quote) and the splicing list literal which begins with
.mono
#*"
.onom
-(hash, star, double-quote).
+(hash, star, double quote).
Both types are terminated by a double quote, which may be escaped
as
@@ -3048,8 +3377,9 @@ in order to include it as a character. All the escaping conventions
used in string literals can be used in word literals.
Unlike in string literals, whitespace (tabs and spaces) is not
-significant in word literals: it separates words. Whitespace may be
-escaped with a backslash in order to include it as a literal character.
+significant in word literals: it separates words.
+A whitespace character may be escaped with a backslash
+in order to include it as a literal character.
Just like in string literals, an unescaped newline character is not allowed.
A newline preceded by a backslash is permitted. Such an escaped backslash,
@@ -3124,34 +3454,37 @@ string literals.
.SS* Quasiword List Literals
-The quasiword list literals (QLL-s) are to quasiliterals what WLL-s are to
+The quasiword list literals (QLLs) are to quasiliterals what WLLs are to
ordinary literals. (See the above section Word List Literals.)
A QLL combines the convenience of the WLL
with the power of quasistrings.
-Just as in the case of WLL-s, there are two flavors of the
+Just as in the case of WLLs, there are two flavors of the
QLL: the regular QLL which begins with
.code #`
-\ (hash, backquote) and the splicing QLL which begins with
+(hash, backquote) and the splicing QLL which begins with
.code #*`
-\ (hash, star, backquote).
+(hash, star, backquote).
Both types are terminated by a backquote, which may be escaped
as
.code \e`
-\ in order to include it as a character. All the escaping conventions
-used in quasiliterals can be used in QLL.
+in order to include it as a character. All the escaping conventions
+used in quasiliterals can be used in QLLs.
Unlike in quasiliterals, whitespace (tabs and spaces) is not
-significant in QLL: it separates words. Whitespace may be
-escaped with a backslash in order to include it as a literal character.
+significant in QLLs: it separates words.
+A whitespace character may be escaped with a backslash
+in order to include it as a literal character.
A newline is not permitted unless escaped. An escaped newline works exactly the
-same way as it does in word list literals (WLL-s).
+same way as it does in WLLs.
Note that the delimiting into words is done before the variable
-substitution. If the variable a contains spaces, then
+substitution. If the variable
+.code a
+contains spaces, then
.code #`@a`
nevertheless
expands into a list of one item: the string derived from
@@ -3176,7 +3509,7 @@ merged into the surrounding syntax.
\*(TX supports integers and floating-point numbers.
-An integer constant is made up of digits
+An integer literal is made up of digits
.code 0
through
.codn 9 ,
@@ -3185,6 +3518,16 @@ optionally preceded by a
or
.code -
sign.
+The character
+.code ,
+(comma) may appear between digits, as a visual separator of no semantic significance.
+The digit sequence must start and end with a digit.
+Runs of consecutive commas are permitted. Commas outside of the digit sequence
+are interpreted as the Lisp unquote syntax.
+
+Compatibility node: support for separator commas appeared in \*(TX 283.
+Older \*(TX versions will interpret commas in the middle of numeric
+constants as instances of the unquote syntax.
Examples:
@@ -3194,6 +3537,16 @@ Examples:
+0
-0
+234483527304983792384729384723234
+ -1,000,000,001
+ 1,2,3,,4 ;; equivalent to 1234
+.brev
+
+Examples that are not integer tokens:
+
+.verb
+ ,123 ;; equivalent to (sys:unquote 123)
+ 123,a ;; equivalent to 123, followed by (sys:unquote a)
+ -,1 ;; symbol - followed by (sys:unquote 1)
.brev
An integer constant can also be specified in hexadecimal using the prefix
@@ -3202,7 +3555,7 @@ followed by an optional sign, followed by hexadecimal digits:
.code 0
through
.code 9
-and the upper or lower case letters
+and the uppercase or lowercase letters
.code A
through
.codn F :
@@ -3212,12 +3565,20 @@ through
#x-ABC ;; -2748
.brev
+These digits may contain separator commas, just as in the case
+of the decimal integer:
+
+.verb
+ #xFFFF,FFFF,FFFF
+.brev
+
Similarly, octal numbers are supported with the prefix
.code #o
followed by octal digits:
.verb
- #o777 ;; 511
+ #o777 ;; 511
+ #o123,456 ;; 42797
.brev
and binary numbers can be written with a
@@ -3225,17 +3586,26 @@ and binary numbers can be written with a
prefix:
.verb
- #b1110 ;; 14
+ #b1110 ;; 14
+ #b1111,1111 ;; 255
+.brev
+
+A comma between the radix prefix and digits is
+a syntax error:
+
+.verb
+ #x,DEF5,549C ;; Syntax error
+ #b,1001,1101 ;; Likewise
.brev
Note that the
.code #b
prefix is also used for buffer literals.
-A floating-point constant is marked by the inclusion of a decimal point, the
-exponential "e notation", or both. It is an optional sign, followed
+A floating-point literal is marked by the inclusion of a decimal point, the
+scientific E notation, or both. It is an optional sign, followed
by a mantissa consisting of digits, a decimal point, more digits, and then an
-optional exponential notation consisting of the letter
+optional E notation consisting of the letter
.code "e"
or
.codn "E" ,
@@ -3245,8 +3615,12 @@ or
.code -
sign, and then digits indicating the exponent value.
In the mantissa, the digits are not optional. At least one digit must either
-precede the decimal point or follow. That is to say, a decimal point by itself
-is not a floating-point constant.
+precede the decimal point or follow it.
+That is to say, a decimal point by itself is not a floating-point constant.
+
+The digits of the mantissa may include separator commas, in the same manner as decimal
+integer literals, in both the integer and fractional part. The digits of the
+exponent may not include separator commas.
Examples:
@@ -3260,6 +3634,7 @@ Examples:
-.5
+3E+3
1.E5
+ 1,123,456.935,342E+013
.brev
Examples which are not floating-point constant tokens:
@@ -3271,6 +3646,7 @@ Examples which are not floating-point constant tokens:
1.0E ;; syntax error: invalid floating point constant
1.E ;; syntax error: invalid floating point literal
.e ;; syntax error: dot token followed by symbol
+ ,1.0 ;; equivalent to (sys:unquote 1.0)
.brev
In \*(TX there is a special "dotdot" token consisting of two consecutive periods.
@@ -3289,11 +3665,48 @@ followed by
.code ..
token).
-Dialect note: unlike in Common Lisp,
+Dialect Note: unlike in Common Lisp,
.code 123.
is not an integer, but the floating-point number
.codn 123.0 .
+Integers within a certain small range centered on zero have
+.code fixnum
+type. Values in the
+.code fixnum
+range fit into a Lisp value directly, not requiring heap allocation.
+A value which is implemented as a reference to a heap-allocated
+object is called
+.IR boxed ,
+whereas a self-contained value not referencing any storage
+elsewhere is called
+.IR unboxed .
+Thus values in the
+.code fixnum
+are unboxed; those outside of the range have
+.code bignum
+type instead, and are boxed. The variables
+.code fixnum-min
+and
+.code fixnum-max
+indicate the range.
+
+Floating-point values are all unboxed if \*(TX is built with "NaN boxing"
+enabled, otherwise they are all boxed. The Lisp expression
+.code "(eq (read \(dq0.0\(dq) (read \(dq0.0\(dq))"
+returns
+.code t
+under NaN boxing, indicating that the two instances of 0.0 are the
+same object. In the absence of NaN boxing, the two
+.code read
+calls produce distinct, boxed representations of 0.0, which
+compare unequal under
+.codn eq .
+(The expression
+.code "(eq 0.0 0.0)"
+may not be relied upon if it is compiled, since compilation may deduplicate
+identical boxed literals, leading to a false positive.)
+
.SS* Comments
Comments of the form
@@ -3318,7 +3731,7 @@ This is equivalent to
.SS* Overview
-When a \*(TL compound expressions occurs in \*(TX preceded by a
+When a \*(TL compound expression occurs in \*(TX preceded by a
.codn @ ,
it is a
.IR directive .
@@ -3341,18 +3754,18 @@ requires a matching
directive. In other words,
.code @(collect)
is not only
-an expression, but serves as a kind of token in a higher level phrase structure
+an expression, but serves as a kind of token in a higher-level, phrase-structure
grammar.
Effectively,
.code collect
is a reserved symbol in the \*(TX language. A \*(TX program cannot use
-this symbol as the name of a pattern function, due to its role in the syntax.
+this symbol as the name of a pattern function due to its role in the syntax.
The symbol has no reserved role in \*(TL.
Usually if this type of directive occurs alone in a line, not
-preceded or followed by other material, it is involved in a "vertical" (or line
-oriented) syntax.
+preceded or followed by other material, it is involved in a "vertical"
+(or line-oriented) syntax.
If such a directive is embedded in a line (has preceding or trailing material)
then it is in a horizontal syntactic and semantic context (character-oriented).
@@ -3368,25 +3781,25 @@ a line of data. (This is necessary because all horizontal syntax matches
something within a line of data, which is undesirable for definitions.)
Many directives exhibit both horizontal and vertical syntax, with different but
-closely related semantics. A few are vertical only, and some are
+closely related semantics. Some are vertical only, some are
horizontal only.
A summary of the available directives follows:
.coIP @(eof)
Explicitly match the end of file. Fails if unmatched data remains in
-the input stream.
+the input stream. Can capture or match the termination status of a pipe.
.coIP @(eol)
Explicitly match the end of line. Fails if the current position is not the
end of a line. Also fails if no data remains (there is no current line).
.coIP @(next)
-Continue matching in another file or other data source.
+Continue matching in another file or data source.
.coIP @(block)
Groups together a sequence of directives into a logical name block,
-which can be explicitly terminated from within using
+which can be explicitly terminated from within by using
the
.code @(accept)
and
@@ -3396,8 +3809,10 @@ Blocks are described in the section Blocks below.
.coIP @(skip)
Treat the remaining query as a subquery unit, and search the lines (or
-characters) of the input file until that subquery matches somewhere. A skip is
-also an anonymous block.
+characters) of the input file until that subquery matches somewhere.
+A
+.code skip
+is also an anonymous block.
.coIP @(trailer)
Treat the remaining query or subquery as a match for a trailing context. That
@@ -3422,7 +3837,7 @@ number or character position.
Match a variable against the name of the current data source.
.coIP @(data)
-Match a variable against the remaining data (lazy list of strings).
+Match a variable against the remaining data (a lazy list of strings).
.coIP @(some)
Multiple clauses are each applied to the same input. Succeeds if at least one
@@ -3455,8 +3870,11 @@ The
directive is similar to the
.code do
directive in that it evaluates one or more
-\*(TL expressions. If the result of the rightmost expression is nil,
-then require triggers a match failure. See the TXR LISP section far below.
+\*(TL expressions. If the result of the rightmost expression is
+.codn nil ,
+then
+.code require
+triggers a match failure. See the TXR LISP section far below.
.ccIP @, @(if) @, @(elif) and @ @(else)
The
@@ -3465,8 +3883,11 @@ directive with optional
.code elif
and
.code else
-clauses allows one of multiple bodies of pattern matching directives to be
-conditionally selected by testing the values of Lisp expressions.
+clauses allows one of multiple bodies of pattern-matching directives to be
+conditionally selected by testing the values of Lisp expressions. It is
+also available inside
+.code @(output)
+for conditionally selecting output clauses.
.coIP @(choose)
Multiple clauses are applied to the same input. The one whose effect persists
@@ -3487,7 +3908,7 @@ clauses, in conjunction with
.meIP @(define < name >> ( args ...))
Introduces a function. Functions are described in the Functions section below.
-.meIP @(call < expr << args *)
+.meIP @(call < expr << arg *)
Performs function indirection. Evaluates
.metn expr ,
which must produce a symbol that names a pattern function. Then that
@@ -3503,7 +3924,7 @@ Search the data for multiple matches of a clause. Collect the
bindings in the clause into lists, which are output as array variables.
The
.code @(collect)
-directive is line oriented. It works with a multi-line
+directive is line-oriented. It works with a multiline
pattern and scans line by line. A similar directive called
.code @(coll)
works within one line.
@@ -3558,7 +3979,8 @@ Blocks are described in the section Blocks below.
.coIP @(accept)
Terminate the processing of a block, as if it were a successful match.
-What bindings emerge may depend on the kind of block: collect
+What bindings emerge may depend on the kind of block:
+.code collect
has special semantics. Blocks are described in the section Blocks below.
.coIP @(try)
@@ -3578,11 +4000,11 @@ The
.code assert
directive requires the following material to match, otherwise
it throws an exception. It is useful for catching mistakes or omissions
-in parts of a query that are sure-fire matches.
+in parts of a query that are surefire matches.
.coIP @(flatten)
Normalizes a set of specified variables to one-dimensional lists. Those
-variables which have scalar value are reduced to lists of that value.
+variables which have a scalar value are reduced to lists of that value.
Those which are lists of lists (to an arbitrary level of nesting) are converted
to flat lists of their leaf values.
@@ -3617,15 +4039,21 @@ Removes variable bindings.
Synonym of
.codn @(forget) .
-.coIP @(output)
+.ccIP @ @(output) and @(push)
A directive which encloses an output clause in the query. An output section
-does not match text, but produces text. The directives above are not
-understood in an output clause.
+does not match text, but produces text which can be directed to various
+destinations, the default being standard output. Most directives cannot
+be used inside an output clause. The
+.code @(push)
+clause is a variant of
+.code @(output)
+which produces text that implicitly pushed back into the input stream to be
+matched.
.coIP @(repeat)
A directive understood within an
.code @(output)
-section, for repeating multi-line
+section, for repeating multiline
text, with successive substitutions pulled from lists. The directive
.code @(rep)
produces iteration over lists horizontally within one line. These directives
@@ -3781,8 +4209,7 @@ and takes various arguments, according to these possibilities:
.mono
.mets @(next)
-.mets @(next << source )
-.mets @(next < source :nothrow)
+.mets @(next < source <> [ :nothrow ] <> [ :noclose ])
.mets @(next :args)
.mets @(next :env)
.mets @(next :list << lisp-expr )
@@ -3829,11 +4256,41 @@ is invoked with the
.code :nothrow
keyword, then if the input
source cannot be opened, the situation is treated as a simple
-match failure.
+match failure. The
+.code :nothrow
+keyword also ensures that when the stream is later closed,
+which occurs when the lazy list reads all of the available data,
+the implicit call to the
+.code close-stream
+function specifies
+.code nil
+as the argument value to that function's
+.meta throw-on-error-p
+parameter. This
+.code :nothrow
+mechanism does not suppress all exceptions related to the processing
+of that stream; unusual conditions encountered during the reading of
+data from the stream may throw exceptions.
+
+When the subsequent directives which follow
+.code @(next)
+are processed, the directive terminates, and any stream which had been opened
+for
+.meta source
+is closed. If the
+.code :noclose
+keyword is present, then this is prevented; the stream
+remains open. Note: keeping the stream open may be necessary if the
+.code @(data)
+directive is used to capture the input list into a variable whose value is used
+after the
+.code @(next)
+directive terminates, because the input list is lazy, and may depend on
+the stream continuing to be open.
The variant
.code "@(next :args)"
-means that the remaining command line arguments are to
+means that the remaining command-line arguments are to
be treated as a data source. For this purpose, each argument is considered to
be a line of text. The argument list does include that argument which specifies
the file that is currently being processed or was most recently processed.
@@ -3977,11 +4434,11 @@ The
variant indicates that the following subquery is applied to empty data,
and the list of data sources from the command line is considered empty.
This directive is useful in front of \*(TX code which doesn't process data
-sources from the command line, but takes command line arguments.
+sources from the command line, but takes command-line arguments.
The
.code "@(next nil)"
incantation absolutely prevents \*(TX from trying to open the
-first command line argument as a data source.
+first command-line argument as a data source.
Note that the
.code @(next)
@@ -4075,8 +4532,10 @@ the next 15 lines:
size: @SIZE
.brev
-Without the range limitation skip will keep searching until it consumes
-the entire input source. In a horizontal
+Without the range limitation,
+.code skip
+will keep searching until it consumes the entire input source.
+In a horizontal
.codn skip ,
the range-limiting numeric argument is expressed in characters, so that
@@ -4152,7 +4611,7 @@ Without
.codn :greedy ,
the variable
.code @c
-will can match multiple tokens,
+may match multiple tokens,
and end up with spaces in it, because nothing follows
.code @c
and so it matches from any position which follows a space to the
@@ -4163,9 +4622,9 @@ space,
.code @a
will get an empty string.
-A line oriented example of greedy skip: match the last line without
+A line-oriented example of greedy skip: match the last line without
using
-.codn @eof :
+.codn @(eof) :
.verb
@(skip :greedy)
@@ -4183,7 +4642,7 @@ skip 15 lines and then search indefinitely for
.brev
The two arguments may be used together. For instance, the following
-matches if, and only if, the 15th line of input starts with
+matches if and only if the 15th line of input starts with
.codn "begin " :
.verb
@@ -4224,9 +4683,9 @@ Or using greedy skip:
@(skip 1 3)
.brev
-Nongreedy skip with the
+Non-greedy skip with the
.code @(eof)
-has a slight advantage because the greedy skip
+directive has a slight advantage because the greedy skip
will keep scanning even though it has found the correct match, then backtrack
to the last good match once it runs out of data. The regular skip with explicit
.code @(eof)
@@ -4236,8 +4695,10 @@ matches.
.NP* Reducing Backtracking with Blocks
+The
.code skip
-can consume considerable CPU time when multiple skips are nested. Consider:
+directive can consume considerable CPU time when multiple skips are nested.
+Consider:
.verb
@(skip)
@@ -4248,32 +4709,33 @@ can consume considerable CPU time when multiple skips are nested. Consider:
C
.brev
-This is actually nesting: the second a third skips occur within the body of the
+This is actually nesting: the second and third skips occur within the body of the
first one, and thus this creates nested iteration. \*(TX is searching for the
-combination of skips which find match the pattern of lines
+combination of skips which match the pattern of lines
.codn A ,
.code B
and
-.codn C ,
+.code C
with
backtracking behavior. The outermost skip marches through the data until it
finds
-.codn A ,
+.code A
followed by a pattern match for the second skip. The second skip
-iterates within to find
-.codn B ,
+iterates to find
+.code B
followed by the third skip, and the third skip
iterates to find
.codn C .
-If there is only one line
-.codn A ,
-and one
-.codn B ,
+If
+.code A
+and
+.code B
+are only one line each,
then this is reasonably fast. But suppose there are many lines matching
.code A
and
.codn B ,
-giving rise to a large number combinations of skips which match
+giving rise to a large number of combinations of skips which match
.code A
and
.codn B ,
@@ -4362,7 +4824,7 @@ whereas a horizontal
prevents the horizontal position from advancing. In other words,
.code trailer
performs matching without consuming the input, providing a
-look-ahead mechanism.
+lookahead mechanism.
Example:
@@ -4449,9 +4911,11 @@ argument is given, its value limits the range of lines which are combined
together. For instance
.code "@(freeform 5)"
means to only consider the next five lines
-to to be one big line. Without this argument, freeform is "bottomless". It
-can match the entire file, which creates the risk of allocating a large amount
-of memory.
+to be one big line. Without this argument,
+.code freeform
+is "bottomless".
+It can match the entire file,
+which creates the risk of allocating a large amount of memory.
If the
.meta string
@@ -4589,14 +5053,23 @@ evaluate to integers:
This expresses that over the next
.meta n
query lines, the matching strictness
-is relaxed a little bit. Only m out of those n lines have to match.
+is relaxed a little bit. Only
+.meta m
+out of those
+.meta n
+lines have to match.
Afterward, the rest of the query follows normal, strict processing.
-In the degenerate situation that there are fewer than n query lines following
-the
+In the degenerate situation where there are fewer than
+.meta n
+query lines following the
.code fuzz
-directive, then m of them must succeed nevertheless. (If there
-are fewer than m, then this is impossible.)
+directive, then
+.meta m
+of them must succeed anyway. (If there
+are fewer than
+.metn m ,
+then this is impossible.)
.dirs line chr
@@ -4664,7 +5137,7 @@ The argument of
.code line
or
.code chr
-may be a
+may be an
.codn @ -delimited
Lisp expression. This is useful for matching computed lines or
character positions:
@@ -4778,6 +5251,64 @@ lines:
@(do (tprint remainder))
.brev
+.dir eof
+
+The
+.code eof
+directive, if not given any argument, matches successfully when no more input
+is available from the current input source.
+
+In the following example, the
+.meta line
+variable captures the text
+.str "One-line file"
+and then since that is the last line of input, the
+.code eof
+directive matches:
+
+.IP code:
+.mono
+\ @line
+ @(eof)
+.onom
+
+.IP data:
+.mono
+\ One-line file
+.onom
+.PP
+
+If the data consisted of two or more lines,
+.code eof
+would fail.
+
+The
+.code eof
+directive may be given a single argument, which is a pattern that matches the
+termination status of the input source. This is useful when the input source
+is a process pipe. For the purposes of
+.codn eof ,
+sources which are not process pipes have the symbol
+.code t
+as their termination status.
+
+In the following example, which assumes the availability of a POSIX shell
+command interpreter in the host system, the variable
+.meta a
+captures the string
+.str a
+and the
+.meta status
+variable captures the integer value
+.codn 5 ,
+which is the termination status of the command:
+
+.verb
+ @(next (open-command "echo a; exit 5"))
+ @a
+ @(eof status)
+.brev
+
.dirs some all none maybe cases choose
These directives, called the parallel directives, combine multiple subqueries,
@@ -5048,8 +5579,15 @@ Example:
The
.code if
-directive allows for conditional selection of pattern matching clauses,
-based on the Boolean results Lisp expressions.
+directive allows for conditional selection of pattern-matching clauses,
+based on the Boolean results of Lisp expressions.
+
+A variant of the
+.code if
+directive is also available for use inside an
+.code output
+clauses, where it similarly allows for the conditional selection of output
+clauses.
The syntax of the
.code if
@@ -5106,7 +5644,7 @@ then matching continues with
.strn "foo: @a b" ,
otherwise it proceeds with
.codn {@c} .
-
+.PP
More precisely, how the
.code if
directive works is as follows. The Lisp expressions are evaluated in order,
@@ -5119,7 +5657,7 @@ expressions if any are present. If any Lisp expression yields a true result
.codn nil )
then evaluation of Lisp expressions stops. The corresponding clause of that
Lisp expression is selected and pattern matching continues
-with that clauses. The result of that clause (its success or failure,
+with that clause. The result of that clause (its success or failure,
and any newly bound variables) is then taken as the result of the
.code if
directive. If none of the Lisp expressions yield true, and an
@@ -5135,6 +5673,41 @@ clause, then the
directive is deemed to have trivially succeeded, allowing matching to continue
with whatever directive follows it.
+.coNP The Lisp @ if versus TXR @ if
+
+The
+.code @(output)
+directive supports the embedding of Lisp expressions, whose values are
+interpolated into the output. In particular, Lisp
+.code if
+expressions are useful. For instance
+.code "@(if expr \(dqA\(dq \(dqB\(dq)"
+reproduces
+.code A
+if
+.code expr
+yields a true value, otherwise
+.codn B .
+Yet the
+.code @(if)
+directive is also supported in
+.codn @(output) .
+How the apparent conflict between the two is resolved is that the two take
+different numbers of arguments. An
+.code @(if)
+which has no arguments at all is a syntax error. One that has one argument
+is the head of the
+.code if
+directive syntax which must be terminated by
+.code @(end)
+and which takes the optional
+.code @(elif)
+and
+.code @(else)
+clauses. An
+.code @(if)
+which has two or more arguments is parsed as a self-contained Lisp expression.
+
.dir gather
Sometimes text is structured as items that can appear in an arbitrary order.
@@ -5152,7 +5725,7 @@ For further convenience, the lines of the first clause of the
directive
are implicitly treated as separate clauses.
-The syntax follows this pattern
+The syntax follows this pattern:
.verb
@(gather)
@@ -5179,7 +5752,7 @@ The syntax follows this pattern
@(end)
.brev
-The multi-line clauses are optional. The
+The multiline clauses are optional. The
.code gather
directive takes
keyword parameters, see below.
@@ -5201,8 +5774,10 @@ clause:
@(end)
.brev
-How gather works is that the text is searched for matches for the single line
-and multi-line queries. The clauses are applied in the order in which they appear.
+How
+.code gather
+works is that the text is searched for matches for the single-line
+and multiline queries. The clauses are applied in the order in which they appear.
Whenever one of the clauses matches, any bindings it produces are retained and
it is removed from further consideration. Multiple clauses can match at the
same text position. The position advances by the longest match from among the
@@ -5223,12 +5798,19 @@ order:
@(end)
.brev
-If the until or last clause is present and a match occurs, then the matches
-from the other clauses are discarded and the gather terminates. The difference
-between
+If the
+.code until
+or
+.code last
+clause is present and a match occurs, then the matches
+from the other clauses are discarded and the
+.code gather
+terminates. The difference between
.cod3 until / last
-is that any bindings bindings established in last are
-retained, and the input position is advanced past the matched material.
+is that any bindings bindings established in
+.code last
+are retained,
+and the input position is advanced past the matching material.
The
.cod3 until / last
clause has visibility to bindings established in the
@@ -5257,13 +5839,16 @@ also occurs, whether or not the clause is
Meaningful use of
.code :mandatory
requires that the gather be open-ended; it must allow some (or all) variables
-not to be required. The presence of the option means that for the gather
+not to be required. The presence of the option means that for
+.code gather
to succeed, all required variables must be gathered first, but then termination
must be achieved via the
.cod3 until / last
-clause before all gather clauses are satisfied.
+clause before all
+.code gather
+clauses are satisfied.
-.coNP Keyword parameters in @ gather
+.coNP Keyword Parameters in @ gather
The
.code gather
directive accepts the keyword parameter
@@ -5297,12 +5882,17 @@ The presence of
.code :vars
changes the behavior in three ways.
-Firstly, even if all the clauses in the gather match successfully and are
+Firstly, even if all the clauses in the
+.code gather
+match successfully and are
eliminated, the directive will fail if the required variables do not have
bindings. It doesn't matter whether the bindings are existing, or whether they
-are established by the gather.
+are established by
+.codn gather .
-Secondly, if some of the clauses of the gather did not match, but all
+Secondly, if some of the clauses of
+.code gather
+did not match, but all
of the required variables have bindings, then the directive succeeds.
Without the presence of
.codn :vars ,
@@ -5331,7 +5921,11 @@ directive is:
@(end)
.brev
-or with an until or last clause:
+or with an
+.code until
+or
+.code last
+clause:
.verb
@(collect)
@@ -5351,7 +5945,7 @@ The
.code repeat
symbol may be specified instead of
.codn collect ,
-which changes the meaning, see below:
+which changes the meaning:
.verb
@(repeat)
@@ -5359,13 +5953,23 @@ which changes the meaning, see below:
@(end)
.brev
+The
+.code @(repeat)
+syntax is equivalent to
+.code "@(collect :vars nil)"
+and doesn't take the
+.code :vars
+clause. It accepts other
+.code collect
+parameters.
+
The subquery is matched repeatedly, starting at the current line.
If it fails to match, it is tried starting at the subsequent line.
If it matches successfully, it is tried at the line following the
entire extent of matched data, if there is one. Thus, the collected regions do
not overlap. (Overlapping behavior can be obtained: see the
.code @(trailer)
-directive).
+directive.)
Unless certain keywords are specified, or unless the collection is explicitly
failed with
@@ -5377,7 +5981,9 @@ clause never finds a match.
If no
.cod3 until / last
-last clause is specified, and the collect is not limited
+clause is specified, and the
+.code collect
+is not limited
using parameters, the collection is unbounded: it consumes the entire data
file.
@@ -5385,19 +5991,29 @@ file.
If an
.cod3 until / last
-last clause is specified, the collection stops when that clause
+clause is specified, the collection stops when that clause
matches at the current position.
If an
.code until
-clause terminates collect, no bindings are collected at that
-position, even if the main clause matches at that position also. Moreover, the
-position is not advanced. The remainder of the query begins matching at that
-position.
+clause terminates
+.codn collect ,
+no bindings are collected at that position,
+even if the main clause matches at that position also.
+Moreover, the position is not advanced.
+The remainder of the query begins matching at that position.
-If a last clause terminates collect, the behavior is different. Any bindings
-captured by the main clause are thrown away, just like with the until clause.
-However, the bindings in the last clause itself survive, and the position is
+If a
+.code last
+clause terminates
+.codn collect ,
+the behavior is different. Any bindings
+captured by the main clause are thrown away, just like with the
+.code until
+clause.
+However, the bindings in the
+.code last
+clause itself survive, and the position is
advanced to skip over that material.
Example:
@@ -5458,14 +6074,16 @@ the output will be different:
The
.code 42
-is not collected into the a list, just like before. But now
+is not collected into a list, just like before. But now
the binding captured by
.code @b
emerges. Furthermore, the position advances
so variable now takes
.codn 6 .
-The binding variables within the clause of a collect are treated specially.
+The binding variables within the clause of a
+.code collect
+are treated specially.
The multiple matches for each variable are collected into lists,
which then appear as array variables in the final output.
@@ -5502,24 +6120,31 @@ a list of three elements, reported as an array.
Variables with list bindings may be referenced in a query. They denote a
multiple match. The
.code -D
-command line option can establish a one-dimensional
+command-line option can establish a one-dimensional
list binding.
The clauses of
.code collect
-may be nested. Variable matches collated into lists in an
-inner collect, are again collated into nested lists in the outer collect.
+may be nested.
+Variable matches collated into lists in an inner
+.code collect
+are again collated into nested lists in the outer
+.codn collect .
Thus an unbound variable wrapped in N nestings of
.code @(collect)
will
-be an N-dimensional list. A one dimensional list is a list of strings;
-a two dimensional list is a list of lists of strings, etc.
+be an N-dimensional list. A one-dimensional list is a list of strings;
+a two-dimensional list is a list of lists of strings, etc.
It is important to note that the variables which are bound within the main
-clause of a collect. That is, the variables which are subject to
-collection appear, within the collect, as normal one-value bindings. The
-collation into lists happens outside of the collect. So for instance in the
-query:
+clause of a
+.codn collect ,
+that is, the variables which are subject to collection, appear, within the
+.codn collect ,
+as normal one-value bindings.
+The collation into lists happens outside of the
+.codn collect .
+So for instance in the query:
.mono
@(collect)
@@ -5536,17 +6161,23 @@ refers to that binding. The value of
.code @x
is different in each
iteration, and these values are collected. What finally comes out of the
-collect clause is a single variable called
+.code collect
+clause is a single variable called
.code x
which holds a list containing each value that
-was ever instantiated under that name within the collect clause.
+was ever instantiated under that name within the
+.code collect
+clause.
-Also note that the until clause has visibility over the bindings
+Also note that the
+.code until
+clause has visibility over the bindings
established in the main clause. This is true even in the terminating
-case when the until clause matches, and the bindings of the main clause
-are discarded.
+case when the
+.code until
+clause matches, and the bindings of the main clause are discarded.
-.coNP Keyword parameters in @ collect
+.coNP Keyword Parameters in @ collect
By default,
.code collect
searches the rest of the input indefinitely,
@@ -5570,8 +6201,9 @@ The
keyword takes a numeric argument
.metn n ,
which is a Lisp expression.
-It causes the collect to terminate
-if it fails to find a match after skipping
+It causes
+.code collect
+to terminate if it fails to find a match after skipping
.meta n
lines from the starting position,
or more than
@@ -5583,8 +6215,9 @@ lines since any successful match. For example,
.brev
specifies that the gap between the current position and the first
-match for the body of the collect, or between consecutive matches
-can be no longer than five lines. A
+match for the body of the
+.codn collect ,
+or between consecutive matches can be no longer than five lines. A
.code :maxgap
value of
.code 0
@@ -5637,8 +6270,12 @@ This shorthand means the same thing as if
.meIP :mintimes < n :maxtimes < n
were specified. This means that exactly
.meta n
-matches must occur. If fewer occur, then the collect fails.
-Collect stops once it achieves
+matches must occur. If fewer occur, then
+.code collect
+fails.
+The
+.code collect
+stops once it achieves
.code n
matches.
@@ -5649,7 +6286,9 @@ of the
.code :mintimes
keyword is a Lisp expression which specifies that at least
.meta n
-matches must occur, or else the collect fails.
+matches must occur, or else
+.code collect
+fails.
.meIP :mintimes < n
The Lisp argument expression
@@ -5667,8 +6306,12 @@ of the
.code :lines
keyword parameter
is a Lisp expression which specifies the upper bound on how many lines
-should be scanned by collect, measuring from the starting position.
-The extent of the collect body is not counted. Example:
+should be scanned by
+.codn collect ,
+measuring from the starting position.
+The extent of the
+.code collect
+body is not counted. Example:
.verb
@(collect :lines 2)
@@ -5687,8 +6330,10 @@ and one line down.
The
.code :vars
keyword specifies a restriction on what variables will emanate
-from the collect. Its argument is a list of variable
-names. An empty list may be specified using empty parentheses
+from the
+.codn collect .
+Its argument is a list of variable names.
+An empty list may be specified using empty parentheses
or, equivalently, the symbol
.codn nil .
The
@@ -5714,8 +6359,11 @@ Unlike
the
.code :lists
mechanism doesn't assert that only the listed variables may emanate
-from the collect. It also doesn't assert that each iteration of the
-collect must bind each of those variables.
+from the
+.codn collect .
+It also doesn't assert that each iteration of the
+.code collect
+must bind each of those variables.
.meIP :counter >> { variable | >> ( variable << starting-value )}
The
@@ -5766,13 +6414,17 @@ with a value of
.codn nil .
.PP
-.coNP Specifying variables in @ collect
+.coNP Specifying Variables in @ collect
Normally, any variable for which a new binding occurs in a
.code collect
-block is collected. A collect clause may be "sloppy": it can neglect to collect
+block is collected. A
+.code collect
+clause may be "sloppy": it can neglect to collect
some variables on some iterations, or bind some variables which are intended to
behave like local temporaries, but end up collated into lists. Another issue is
-that the collect clause might not match anything at all, and then none of the
+that the
+.code collect
+clause might not match anything at all, and then none of the
variables are bound.
The
@@ -5796,30 +6448,41 @@ for the variable, which is optional.
When a
.code :vars
list is specified, it means that only the given variables can
-emerge from the successful collect. Any newly introduced bindings for other
-variables do not propagate. More precisely, whenever the collect body matches
-successfully, the following three rules apply:
-.IP 1
+emerge from the successful
+.codn collect .
+Any newly introduced bindings for other variables do not propagate.
+More precisely, whenever the
+.code collect
+body matches successfully, the following three rules apply:
+.IP 1.
If
.code :vars
-specifies required variables, the collect body must bind all of them,
+specifies required variables, the
+.code collect
+body must bind all of them,
or else must not bind any variable at all, whether listed in
.code :vars
or not, otherwise an exception of type
.code query-error
is thrown.
-.IP 2
+.IP 2.
If
.code :vars
specifies required variables, and also specifies default variables,
-and the collect body binds no variable at all, then the default variables
+and the
+.code collect
+body binds no variable at all, then the default variables
are not bound to their default values.
-.IP 3
+.IP 3.
If
.code :vars
specifies optional variables, and all required variables are bound by
-the collect body, then all those optional variables that are not bound
-by the collect body are bound to their default values. Under this rule, if
+the
+.code collect
+body, then all those optional variables that are not bound
+by the
+.code collect
+body are bound to their default values. Under this rule, if
.code :vars
specifies no required variables, that is deemed to be
logically equivalent to all required variables being bound.
@@ -5833,7 +6496,7 @@ specified in
whether required or optional, are all bound to
empty lists. These bindings are established after the processing of the
.cod3 until / last
-last clause, if present.
+clause, if present.
Example:
@@ -5906,7 +6569,9 @@ is bound to an empty list.
.brev
The following means: do not allow any variables to propagate out of any
-iteration of the collect and therefore collect nothing:
+iteration of the
+.code collect
+and therefore collect nothing:
.verb
@(collect :vars nil)
@@ -5919,7 +6584,9 @@ Instead of writing
it is possible to write
.codn @(repeat) .
.code @(repeat)
-takes all collect keywords, except for
+takes all
+.code collect
+keywords, except for
.codn :vars .
There is a
.code @(repeat)
@@ -5943,14 +6610,17 @@ exemplified by the following:
@(end)
.brev
-This means that the collect
+This means that the
+.code collect
.B must
be terminated by a match for the
.cod3 until / last
clause, or else by an explicit
.codn @(accept) .
-Specifically, the collect cannot terminate due to simply running out of data,
+Specifically, the
+.code collect
+cannot terminate due to simply running out of data,
or exceeding a limit on the number of matches that may be collected. In
those situations, if an
.code until
@@ -5958,7 +6628,9 @@ or
.code last
clause is present with
.codn :mandatory ,
-the collect is deemed to have failed.
+the
+.code collect
+is deemed to have failed.
.dir coll
@@ -5968,7 +6640,7 @@ directive is the horizontal version of
.codn collect .
Whereas
.code collect
-works with multi-line clauses on line-oriented
+works with multiline clauses on line-oriented
material,
.code coll
works within a single line. With
@@ -5976,7 +6648,8 @@ works within a single line. With
it is possible to
recognize repeating regularities within a line and collect lists.
-Regular-expression based Positive Match variables work well with coll.
+Regular-expression-based Positive Match variables work well with
+.codn coll .
Example: collect a comma-separated list, terminated by a space.
.IP code:
@@ -6001,7 +6674,7 @@ Here, the variable
is bound to tokens which match the regular
expression
.codn "/[^, ]+/" :
-non-empty sequence of characters other than commas or
+nonempty sequence of characters other than commas or
spaces.
Like
@@ -6185,7 +6858,7 @@ can also be solved with
.onom
.PP
-.coNP Keyword parameters in @ coll
+.coNP Keyword Parameters in @ coll
The
.code @(coll)
directive takes most of the same parameters as
@@ -6224,13 +6897,13 @@ takes all keywords, except
The
.code flatten
-directive can be used to convert variables to one dimensional
+directive can be used to convert variables to one-dimensional
lists. Variables which have a scalar value are converted to lists containing
that value. Variables which are multidimensional lists are flattened to
one-dimensional lists.
Example (without
-.codn @(flatten) )
+.codn @(flatten) ):
.IP code:
.mono
\ @b
@@ -6441,13 +7114,13 @@ against a value produced by the
.meta bind-expression
on the right.
-Variables names occurring in the
+Variable names occurring in the
.meta pattern
-expression may refer to bound variables, or may be unbound.
+expression may refer to bound or unbound variables.
-All variables references occurring in
+All variable references occurring in
.meta bind-expression
-must have value.
+must have a value.
Binding occurs as follows. The tree structure of
.meta pattern
@@ -6470,9 +7143,11 @@ or else
the
.code bind
directive fails. Variables which are already bound are not altered,
-retaining their current values, even if the matching is inexact.
+retaining their current values even if the matching is inexact.
-The simplest bind is of one variable against itself, for instance bind
+The simplest
+.code bind
+is of one variable against itself, for instance binding
.code A
against
.codn A :
@@ -6490,7 +7165,9 @@ succeeds, since
.code A
matches itself.
-The next simplest bind binds one variable to another:
+The next simplest
+.code bind
+binds one variable to another:
.verb
@(bind A B)
@@ -6505,7 +7182,9 @@ If
is bound, it has
to match
.codn B ,
-or the bind fails. Matching means that either
+or the
+.code bind
+fails. Matching means that either
.IP -
.code A
and
@@ -6520,7 +7199,7 @@ is a list, and
occurs within
.codn B .
.IP -
-.IR "vice versa" :
+vice versa:
.code B
is text,
.code A
@@ -6533,12 +7212,11 @@ occurs within
and
.code B
are lists and are either identical, or one is
-found as substructure within the other.
+found as a substructure within the other.
.PP
-The right hand side does not have to be a variable. It may be some other
-object, like a string, quasiliteral, regexp, or list of strings,
-.IR "et cetera" .
-For instance
+The right-hand side does not have to be a variable. It may be some other
+object, like a string, quasiliteral, regexp, or list of strings, etc.
+For instance,
.verb
@(bind A "ab\etc")
@@ -6554,11 +7232,12 @@ is unbound. If
.code A
is bound, this will fail unless
.code A
-already contains an identical string. However, the right hand side of a bind
+already contains an identical string. However, the right-hand side of a
+.code bind
cannot be an unbound variable, nor a complex expression that contains unbound
variables.
-The left hand side of
+The left-hand side of
.code bind
can be a nested list pattern containing variables.
The last item of a list at any nesting level can be preceded by a
@@ -6681,7 +7360,7 @@ which is then structurally matched against the pattern
.codn "(X (Y Z))" ,
and the variables receive the corresponding pieces.
-.coNP Keywords in the @ bind directive
+.coNP Keywords in The @ bind Directive
The
.code bind
directive accepts these keywords:
@@ -6707,10 +7386,10 @@ filtering through the :upcase filter.
The argument to
.code :rfilt
is a filter specification. The specified filter is
-applied to the right hand side material prior to matching it against
+applied to the right-hand-side material prior to matching it against
the left side. The filter is not applied if the left side is a variable
with no binding. It is only applied to determine a match. Binding takes
-place the unmodified right hand side object.
+place the unmodified right-hand-side object.
For example, the following produces a match:
@@ -6752,14 +7431,14 @@ succeeds, because the value of a matches the second element of the list
if it is upcased, and likewise
.code b
matches
-.str "b"
+.str b
and
.code c
matches
.str c
if these are upcased.
-.coNP Lisp forms in the @ bind directive
+.coNP Lisp Forms in The @ bind Directive
\*(TL forms, introduced by
.code @
@@ -6794,12 +7473,20 @@ produce equal values.
.dir set
+The syntax of the
+.code set
+directive is:
+
+.mono
+.mets @(set < pattern << bind-expression )
+.onom
+
The
.code set
directive syntactically resembles
.codn bind ,
but is not a pattern match. It overwrites
-the previous values of variables with new values from the right hand side.
+the previous values of variables with new values from the right-hand side.
Each variable that is assigned must have an existing binding:
.code set
will not induce binding.
@@ -6876,21 +7563,45 @@ Because it is preceded by the
.code @
escape, it is a Lisp variable, and not a pattern variable.
+The
+.code set
+directive also doesn't support Lisp expressions in the
+.metn pattern ,
+which must consist only of variables.
+
.dir rebind
+The syntax of the
+.code rebind
+directive is:
+
+.mono
+.mets @(rebind < pattern << bind-expression )
+.onom
+
The
.code rebind
directive resembles
-.code set
-but it is not an assignment.
+.codn bind .
It combines the semantics of
-.codn local ,
-.code bind
+.code local
and
-.codn set .
-The expression on the right hand side is evaluated in the current
-environment. Then the variables in the pattern on the left are introduced
-as new bindings, whose values come from the pattern.
+.code bind
+into a single directive.
+The
+.meta bind-expression
+is evaluated in the current
+environment, and its value remembered. Then a new
+environment is produced in which all the variables specified in
+.meta pattern
+are absent. Then, the pattern is newly bound in
+that environment against the previously produced value, as if using
+.codn bind .
+
+The old environment with the previous variables is not modified;
+it continues to exist. This is in contrast with the
+.code set
+directive, which mutates existing bindings.
.code rebind
makes it easy to create temporary bindings based on existing bindings.
@@ -6904,8 +7615,8 @@ makes it easy to create temporary bindings based on existing bindings.
.brev
When the function terminates, the previous value of recursion-level
-is restored. The effect is like the following, but much easier
-to write and faster to execute:
+is restored. The effect is less verbose and more efficient than
+the following equivalent
.verb
@(define pattern-function (arg))
@@ -6918,6 +7629,30 @@ to write and faster to execute:
@(end)
.brev
+Like
+.codn bind ,
+.code rebind
+supports nested patterns, such as
+
+.verb
+ @(rebind (a (b c)) (1 (2 3))
+.brev
+
+but it does not support any keyword arguments. The filtering
+features of
+.code bind
+do not make sense in
+.code rebind
+because the variables are always reintroduced into an environment
+in which they don't exist, whereas filtering applies in
+situations when bound variables are matched against values.
+
+The
+.code rebind
+directive also doesn't support Lisp expressions in the
+.metn pattern ,
+which must consist only of variables.
+
.dir forget
The
@@ -6990,7 +7725,7 @@ Example:
.verb
@; match text into variables a and b, then insert into hash table h
- @(bind h (hash))
+ @(bind h @(hash))
@a:@b
@(do (set [h a] b))
.brev
@@ -7066,7 +7801,7 @@ Blocks are sections of a query which are either denoted by a name,
or are anonymous. They may nest: blocks can occur within blocks
and other constructs.
-Blocks are useful for terminating parts of a pattern matching search
+Blocks are useful for terminating parts of a pattern-matching search
prematurely, and escaping to a higher level. This makes blocks not only
useful for simplifying the semantics of certain pattern matches,
but also an optimization tool.
@@ -7203,7 +7938,7 @@ Immediately terminate the enclosing query block called
.metn name ,
as if that block
failed to match anything. If more than one block by that name encloses
-the directive, the inner-most block is terminated. No bindings emerge from
+the directive, the innermost block is terminated. No bindings emerge from
a failed block.
.coIP @(fail)
@@ -7219,8 +7954,10 @@ If the implicit block introduced by
is terminated in this manner,
this has the effect of causing
.code skip
-itself to fail. I.e. the behavior
-is as if skip search did not find a match for the trailing material,
+itself to fail. In other words, the behavior
+is as if
+.codn @(skip) 's
+search did not find a match for the trailing material,
except that it takes place prematurely (before the end of the available
data source is reached).
@@ -7230,10 +7967,12 @@ is terminated this way,
then the entire
.code collect
fails. This is a special behavior, because a
-collect normally does not fail, even if it matches nothing and collects nothing!
+.code collect
+normally does not fail, even if it matches nothing and collects nothing!
-To prematurely terminate a collect by means of its anonymous block, without
-failing it, use
+To prematurely terminate a
+.code collect
+by means of its anonymous block, without failing it, use
.codn @(accept) .
.meIP @(accept << name )
@@ -7241,7 +7980,7 @@ Immediately terminate the enclosing query block called
.metn name ,
as if that block
successfully matched. If more than one block by that name encloses the
-directive, the inner-most block is terminated.
+directive, the innermost block is terminated.
.coIP @(accept)
Immediately terminate the innermost enclosing anonymous block, as if
@@ -7507,7 +8246,7 @@ to the
.code @second
variable.
-.coNP Interaction Between the @ trailer and @ accept Directives
+.coNP Interaction Between The @ trailer and @ accept Directives
If one of the clauses which follow a
.code @(trailer)
@@ -7557,7 +8296,7 @@ and adjusted back to the first line. Neglecting to do this adjustment
would violate the semantics of
.codn trailer .
-.coNP Interaction Between the @ next and @ accept Directives
+.coNP Interaction Between The @ next and @ accept Directives
When the clauses under a
.code next
@@ -7633,7 +8372,7 @@ is nested within that block, \*(TX would backtrack to the
previous input position within
.strn file-x .
-.coNP Interaction Between Functions and the @ accept directive
+.coNP Interaction Between Functions and the @ accept Directive
If a pattern function is terminated due to
.codn accept ,
the function return mechanism intercepts the
@@ -7754,12 +8493,11 @@ and
.code fail
directives comes in horizontal and vertical forms.
-This creates the possibility than an
+This creates the possibility that an
.code accept
in horizontal context targets a vertical
.code block
-or
-.IR "vice versa" ,
+or vice versa,
raising the question of how the input position
is treated. The semantics of this is defined.
@@ -8026,7 +8764,7 @@ Functions may be nested within function bodies. Such local functions have
dynamic scope. They are visible in the function body in which they are defined,
and in any functions invoked from that body.
-The body of a function is an anonymous block. (See Blocks above).
+The body of a function is an anonymous block. (See Blocks above.)
.NP* Two Forms of The Horizontal Function
@@ -8049,7 +8787,7 @@ This would, in turn, would mean that the
is
actually in horizontal mode, and so it matches a span of zero characters within
a line (which means that is would require a line of input to match: a
-surprising behavior for a non-matching directive!)
+surprising behavior for a nonmatching directive!)
A horizontal function can be defined in an actual horizontal context. This
occurs if its is in a line where it is preceded by other material.
@@ -8120,7 +8858,7 @@ These are rebound to the arguments
and
.codn second .
The second call to the function binds the a parameter to the word
-.strn "ice" ,
+.strn ice ,
and the
.code b
is unbound, because the
@@ -8246,7 +8984,7 @@ Example:
A call made in a clearly horizontal context will prefer the
horizontal function, and only fall back on the vertical one
-if the horizontal one doesn't exist. (In this fall-back case,
+if the horizontal one doesn't exist. (In this fallback case,
the vertical function is called with empty data; it is useful
for calling vertical functions which process arguments and
produce values.)
@@ -8409,7 +9147,7 @@ Function indirection may be performed using the
.code call
directive. If
.meta fun-expr
-is an expression which evaluates to a symbol, and
+is an Lisp expression which evaluates to a symbol, and
that symbol names a function which takes no arguments, then
.verb
@(call fun-expr)
@@ -8423,7 +9161,7 @@ Example 1:
\ @(define foo (arg))
@(bind arg "abc")
@(end)
- @(call @'foo b)
+ @(call 'foo b)
.onom
In this example, the effect is that
@@ -8436,14 +9174,9 @@ ends up bound to
The
.code call
directive here uses the
-.code @'foo
-expression to calculate the name of the function to be invoked.
-The
-.code @
-symbol indicates that the expression which follows is \*(TL ,
-and
.code 'foo
-is the \*(TL syntax for quoting a symbol. (See the
+expression to calculate the name of the function to be invoked.
+(See the
.code quote
operator).
@@ -8515,7 +9248,9 @@ If the value of the
.code *load-path*
variable has a current value which is not
.code nil
-and the path is pure relative according to the
+and the path given in
+.meta expr
+is pure relative according to the
.code pure-rel-path-p
function, then the effective path is interpreted taken relative
to the directory portion of the path which is stored in
@@ -8523,7 +9258,9 @@ to the directory portion of the path which is stored in
If
.code *load-path*
-is nil, or the load path is not pure relative, then the
+is
+.codn nil ,
+or the load path is not pure relative, then the
path is taken as-is as the effective path.
Next, an attempt is made to open the file for processing, in
@@ -8541,6 +9278,19 @@ is tried, and so forth, as described for the
.code load
function.
+If these initial attempts to find the file fail, and the failure
+is due to the file not being found rather than some other problem such as a
+permission error, and
+.meta expr
+isn't an absolute path according to
+.codn abs-path-p ,
+then additional attempts are made by searching for the file in the
+list of directories given in the
+.code *load-search-dirs*
+variable. Details are given in the description of the \*(TL
+.code load
+function.
+
Both the
.code load
and
@@ -8554,6 +9304,11 @@ variable is also given a new dynamic binding, whose value is the
same as the existing binding. These bindings are removed when the
load operation completes, restoring the prior values of these
variables.
+The
+.code *load-hooks*
+variable is given a new dynamic binding, with a
+.code nil
+value.
If the file opened for processing is \*(TL source, or
a compiled \*(TL file, then it is processed in the manner
@@ -8610,7 +9365,18 @@ takes place prior to evaluation time, whereas
.code load
doesn't execute until evaluation time.
+Note:
+the
+.code load
+directive doesn't provide access to the value propagated by a
+.code return
+via the
+.code load
+block.
+
See also: the
+.code load
+function, and the
.codn self-path ,
.code stdlib
and
@@ -8665,7 +9431,7 @@ argument,
if present,
is treated as a \*(TL expression and evaluated.
The resulting value is taken as the output destination. The value may be a
-string which gives the path name of a file to open for output. Otherwise,
+string which gives the pathname of a file to open for output. Otherwise,
the destination must be a stream object.
The keyword list consists of a mixture of Boolean keywords which
@@ -8692,6 +9458,7 @@ trying to open a destination file, but not having permissions, etc.
.coIP :append
This keyword is meaningful for files, specifying append mode: the output is to
be added to the end of the file rather than overwriting the file.
+.PP
The following value keywords are supported:
@@ -8701,7 +9468,7 @@ the variable substitutions occurring within the
.code output
clause.
The argument can also be a list of filter symbols, which specifies
-that multiple filters are to be applied, in left to right order.
+that multiple filters are to be applied, in left-to-right order.
See the later sections Output Filtering below, and The Deffilter Directive.
@@ -8759,6 +9526,97 @@ At the end of the output block, the stream is closed.
An example is given in the documentation for the Close Directive
below.
+.dir push
+
+The
+.code @(push)
+directive is a variant of
+.code @(output)
+which produces lines of text that are pushed back into the input stream.
+
+This directive supports only the
+.code :filter
+keyword argument.
+
+This directive doesn't take any of the keyword arguments supported by
+.code @(output)
+except for the
+.code :filter
+keyword.
+
+After the execution of a
+.codn @(push) ,
+the next pattern matching syntax that is evaluated now faces the material
+produced by that
+.code @(push)
+followed by the original input. In order to preserve the line numbering of the
+original input,
+.code @(push)
+adjusts the line number for the synthetic input by subtracting the number of
+synthetic lines from the original input's line number. For instance if the
+original input is line 5, and 7 lines are prepended by
+.codn @(push) ,
+then those lines are numbered -2 to 4.
+
+The input-synthesizing effect of
+.code @(push)
+is visible to a subsequent form in exactly those situations in which
+an input-consuming effect of a pattern matching directive would also
+be visible. For instance, a
+.code @(push)
+occurring in the body of a
+.code @(collect)
+can produce input that is visible to the next iteration.
+
+The
+.code @(push)
+directive interacts with the parallel matching directives such as
+.codn @(some) .
+When multiple parallel clauses match, the input position is advanced
+by the longest match. Lines pushed into the input by
+.code @(push)
+look like negative advancement. If one clause advances in the input,
+while another one pushes into it, the push will lose to the
+advancement and its effect will disappear. If two clauses push varying amounts
+of material, the shorter push will win.
+
+.TP* Example:
+
+Swap the first two lines if they start with a colon, changing
+the colon to a period:
+
+.IP Code:
+.verb
+ @(maybe)
+ :@a
+ :@b
+ @ (push)
+ .@b
+ .@a
+ @ (end)
+ @(end)
+ @(data capture)
+ @(do (tprint capture))
+.brev
+
+.IP Data:
+.verb
+ :hello
+ :there
+ rest
+ of
+ data
+.brev
+
+.IP Output:
+.verb
+ .there
+ .hello
+ rest
+ of
+ data
+.brev
+
.NP* Output Text
Text in an output clause is not matched against anything, but is output
@@ -8815,7 +9673,7 @@ See Output Filtering below.
.NP* Output Variables: Indexing
Additional syntax is supported in output variables that does not appear
-in pattern matching variables.
+in pattern-matching variables.
A square bracket index notation may be used to extract elements or
ranges from a variable, which works with strings, vectors and lists. Elements
@@ -8836,7 +9694,7 @@ one position less than the position given by
If the variable is a list, it is treated as a list substitution,
exactly as if it were the value of an unsubscripted list variable.
The elements of the list are converted to strings and catenated
-together wit ha separator string between them, the default one being
+together with a separator string between them, the default one being
a single space.
An alternate character may be given as a string argument in the brace
@@ -8861,7 +9719,7 @@ spaces wide. The
argument extracts a range of
.codn a ;
the
-.str ","
+.str ,
argument specifies an alternate
separator string, and
.code 10
@@ -8926,7 +9784,7 @@ hold lists which contain at least one item, then no output is performed,
(unless the repeat specifies an
.code @(empty)
clause, see below).
-Otherwise, among those variables which contain non-empty lists, repeat finds
+Otherwise, among those variables which contain nonempty lists, repeat finds
the length of the longest list. This length of this list determines the number
of repetitions, R.
@@ -9042,30 +9900,45 @@ and if it is the last repetition.
.PP
The precedence among the clauses which take an iteration is:
-.codn "single > first > mod > modlast > last > main" .
-That is if two or more of these
+.codn "single > first > modlast > last > mod > main" .
+That is, whenever two or more of these
clauses can apply to a repetition, then the leftmost one in this precedence
-list applies. For instance, if there is just a single repetition, then any of
-these special clause types can apply to that repetition, since it is the only
-repetition, as well as the first and last one. In this situation, if there is a
+list will be selected. It is possible for all these clauses to be viable
+for processing the same repetition. If a
+.code repeat
+occurs which has only one repetition, then that repetition is simultaneously
+the first, only and last repetition. Moreover, it also matches
+.code "(mod 0 m)"
+and, because it is the last repetition, it matches
+.codn "(modlast 0 m)" .
+In this situation, if there is a
.code @(single)
-clause present, then the repetition is processed using that clause.
-Otherwise, if there is a
+clause present, then the repetition shall be processed using that
+clause. Otherwise, if there is a
.code @(first)
-clause present, that clause is used. Failing
+clause present, that clause is activated. Failing
that,
-.code @(mod)
-is used if there is such a clause and its numeric conditions
-are satisfied. If there isn't, then
.code @(modlast)
-clauses are considered, and if there
-are none, or none of them activate, then
+is used if there is such a clause, featuring an
+.code n
+argument of zero. If there isn't, then the
.code @(last)
-is considered. Finally if none
-of all these clauses are present or apply, then the repetition is processed
-using the main clause.
+clause is considered, if present. Otherwise, the
+.code @(mod)
+clause is considered if present with an
+.code n
+argument of zero. Otherwise, none of these clauses are present or applicable,
+and the repetition is processed using the main clause.
-Repeat supports arguments.
+The
+.code @(empty)
+clause does not appear in the above precedence list because it is mutually
+exclusive with respect to the others: it is processed only when there are no
+iterations, in which case even the main clause isn't active.
+
+The
+.code @(repeat)
+clause supports arguments.
.mono
.mets @(repeat
@@ -9078,7 +9951,7 @@ The
argument designates a symbol which will behave as an integer
variable over the scope of the clauses inside the repeat. The variable provides
access to the repetition count, starting at zero, incrementing with each
-repetition. If the the argument is given as
+repetition. If the argument is given as
.mono
.meti >> ( symbol << expr )
.onom
@@ -9093,102 +9966,152 @@ which counts from 1.
The
.code :vars
-argument specifies a list of variable names, or pairs consisting of a variable
-name and Lisp expression. For every variable paired with a Lisp expression,
-the expression is evaluated, and a binding is introduced, associating
-that variable with the expression's value.
+argument specifies a list of variable name symbols
+.meta symbol
+or else pairs of the form
+.mono
+.meti >> ( symbol << init-form )
+.onom
+consisting of a variable name and Lisp expression. Historically, the former
+syntax informed
+.code repeat
+about references to variables contained in Lisp code. This usage is no
+longer necessary as of \*(TX 243, since the
+.code repeat
+construct walks Lisp code, identifying all free variables.
+The latter syntax introduces a new pattern variable binding for
+.meta symbol
+over the scope of the
+.code repeat
+construct. The
+.meta init-form
+specifies a Lisp expression which is evaluated to produce the
+binding's value.
The
.code repeat
directive then processes the list of variables, selecting from it
-those which have a binding, either a previously existing binding or one just
-introduced from a Lisp expression. For each selected variable, repeat
-will assume that the variable occur in the repeat block and contains
+those which have a binding, either a previously existing binding or the
+one just introduced. For each selected variable, repeat
+will assume that the variable occurs in the repeat block and contains
a list to be iterated.
-Thus
+The variable binding syntax supported by
.code :vars
-Firstly, it is needed for situations in which \*(TL expressions which
-reference variables are embedded in
-.code @(repeat)
-blocks. Variables references embedded in Lisp code are not found
-.codn @(repeat) .
-For instance, the following produces no output:
+of the form
+.mono
+.meti >> ( symbol << init-form )
+.onom
+provides a solution for situations when it is necessary to iterate
+over some list, but that list is the result of an expression, and not stored in
+any variable. A repeat block iterates only over lists emanating from variables;
+it does not iterate over lists pulled from arbitrary expressions.
+
+Example: output all file names matching the
+.code *.txr
+pattern in the current directory:
.verb
- @(bind list ("a" "b" "c"))
@(output)
- @(repeat)
- @(format nil "<~a>" list)
+ @(repeat :vars ((name (glob "*.txr"))))
+ @name
@(end)
@(end)
.brev
-Although the list variable appears in the repeat block, it is embedded
-in a \*(TL construct. That construct will never be evaluated because
-no repetitions take place: the repeat construct doesn't find any variables
-and so doesn't iterate. The remedy is to provide a little help via
-the :vars parameter:
+Prior to \*(TX 243, the simple variable-binding syntax supported by
+.code :vars
+of the form
+.meta symbol
+was needed for situations in which \*(TL expressions which
+referenced variables were embedded in
+.code @(repeat)
+blocks. Variable references embedded in Lisp code were not identified in
+.codn @(repeat) .
+For instance, the following produced no output, because no variables
+were found in the
+.code repeat
+body:
.verb
- @(bind list ("a" "b" "c"))
+ @(bind trigraph ("abc" "def" "ghi"))
@(output)
- @(repeat :vars (list))
- @(format nil "<~a>" list)
+ @(repeat)
+ @(reverse trigraph)
@(end)
@(end)
.brev
-Now the repeat block iterates over list and the output is:
-
-.verb
- <a>
- <b>
- <c>
-.brev
-
-Secondly, The variable binding syntax supported by
+There is a reference to
+.meta trigraph
+but it's inside the
+.code "(reverse trigraph)"
+Lisp expression that was not processed by
+.codn repeat .
+The solution was to mention
+.meta trigraph
+in the
.code :vars
-additionally provides a solution for situations when it is necessary to iterate
-over some list, but that list is the result of an expression, and not stored in
-any variable. A repeat block iterates only over lists emanating from variables;
-it does not iterate over lists pulled from arbitrary expressions.
-
-Example: output all file names matching the
-.code *.txr
-pattern in the current directory:
+construct:
.verb
+ @(bind trigraph ("abc" "def" "ghi"))
@(output)
- @(repeat :vars ((name (glob "*.txr"))))
- @name
+ @(repeat :vars (trigraph))
+ @(reverse trigraph)
@(end)
@(end)
.brev
+Then the
+.code repeat
+block would iterate over
+.metn trigraph ,
+producing the output
+
+.verb
+ cba
+ fed
+ igh
+.brev
+
+This workaround is no longer required as of \*(TX 243; the output
+is produced by the first example, without
+.codn :vars .
+
.coNP Nested @ repeat directives
If a
.code repeat
clause encloses variables which hold multidimensional lists,
-those lists require additional nesting levels of repeat (or rep).
+those lists require additional nesting levels of
+.code repeat
+(or
+.codn rep ).
It is an error to attempt to output a list variable which has not been
-decimated into primary elements via a repeat construct.
+decimated into primary elements via a
+.code repeat
+construct.
Suppose that a variable
.code X
is two-dimensional (contains a list of lists).
.code X
-must be twice nested in a
+must be nested twice in a
.codn repeat .
-The outer repeat will traverse the lists
-contained in
+The outer
+.code repeat
+will traverse the lists contained in
.codn X .
-The inner repeat will traverse the elements of each of these
-lists.
+The inner
+.code repeat
+will traverse the elements of each of these lists.
-A nested repeat may be embedded in any of the clauses of a repeat,
-not only the main clause.
+A nested
+.code repeat
+may be embedded in any of the clauses of a
+.codn repeat ,
+not only in the main clause.
.dir rep
@@ -9198,7 +10121,7 @@ directive is similar to
.codn repeat .
Whereas
.code repeat
-is line oriented,
+is line-oriented,
.code rep
generates material within a line. It has all the same clauses,
but everything is specified within one line:
@@ -9399,10 +10322,10 @@ is replaced by
.codn > .
.coIP :upcase
-Convert the 26 lower case letters of the English alphabet to upper case.
+Convert the 26 lowercase letters of the English alphabet to uppercase.
.coIP :downcase
-Convert the 26 upper case letters of the English alphabet to lower case.
+Convert the 26 uppercase letters of the English alphabet to lowercase.
.coIP :frompercent
Decode percent-encoded text. Character triplets consisting
@@ -9542,7 +10465,7 @@ Multiple filters can be applied at the same time. For instance:
This will fold the contents of
.code x
-to upper case, and then encode any special
+to uppercase, and then encode any special
characters into HTML. Beware of combinations that do not make sense.
For instance, suppose the original text is HTML, containing codes
like
@@ -9767,7 +10690,7 @@ symbol must be followed by the name of the filter to be defined,
followed by bind expressions which evaluate to lists of strings. Each list must
be at least two elements long and specifies one or more texts which are mapped
to a replacement text. For instance, the following specifies a telephone keypad
-mapping from upper case letters to digits.
+mapping from uppercase letters to digits.
.verb
@(deffilter alpha_to_phone ("E" "0")
@@ -9788,7 +10711,9 @@ mapping from upper case letters to digits.
@(deffilter sub x y)
.brev
-The last deffilter has the same effect as the
+The last
+.code deffilter
+has the same effect as the
.mono
@(deffilter sub ("from" "to") ("---" "+++"))
.onom
@@ -9796,7 +10721,7 @@ directive.
Filtering works using a longest match algorithm. The input is scanned from left
to right, and the longest piece of text is identified at every character
-position which matches a string on the left hand side, and that text is
+position which matches a string on the left-hand side, and that text is
replaced with its associated replacement text. The scanning then continues
at the first character after the matched text.
@@ -9808,7 +10733,7 @@ Filtering is not in-place but rather instantiates a new text, and so
replacement text is not re-scanned for more replacements.
If a filter definition accidentally contains two or more repetitions of the
-same left hand string with different right hand translations, the later ones
+same left-hand string with different right-hand translations, the later ones
take precedence. No warning is issued.
@@ -9830,7 +10755,7 @@ Example: convert
.codn b ,
and
.code c
-to upper case and HTML encode:
+to uppercase and HTML encode:
.verb
@(filter (:upcase :tohtml) a b c)
@@ -9841,7 +10766,7 @@ to upper case and HTML encode:
.NP* Introduction
The exceptions mechanism in \*(TX is another
-disciplined form of non-local transfer, in addition to the blocks
+disciplined form of nonlocal transfer, in addition to the blocks
mechanism (see Blocks above). Like blocks, exceptions provide a construct
which serves as the target for a dynamic exit. Both blocks and exceptions
can be used to bail out of deep nesting when some condition occurs.
@@ -9893,8 +10818,9 @@ directive
also provides unwind protection by means of a
.code @(finally)
clause,
-which specifies query material to be executed unconditionally when
-the try clause terminates, no matter how it terminates.
+which specifies query material to be executed unconditionally when the
+.code try
+clause terminates, no matter how it terminates.
.dir try
@@ -10022,7 +10948,7 @@ A
directive can terminate in one of three ways. The main clause
may match successfully, and possibly yield some new variable bindings.
The main clause may fail to match. Or the main clause may be terminated
-by a non-local control transfer, like an exception being thrown or a block
+by a nonlocal control transfer, like an exception being thrown or a block
return (like the block foo example in the previous section).
No matter how the
@@ -10149,7 +11075,7 @@ which captures
When
.code finally
-clauses are processed during a non-local return,
+clauses are processed during a nonlocal return,
they have no externally visible effect if they do not bind variables.
However, their execution makes itself known if they perform side effects,
such as output.
@@ -10213,7 +11139,7 @@ directive throws an exception of type
.codn file-error ,
because the given file does not exist. The exit point for this exception is the
.code "@(catch file-error)"
-clause in the outer-most
+clause in the outermost
.code try
block. The inner block is
not eligible because it contains no catch clauses at all. However, the inner
@@ -10442,7 +11368,7 @@ unbound, and if it is bound, it stays as is.
.IP code:
.mono
\ @(try)
- @(trow e "honda" unbound)
+ @(throw e "honda" unbound)
@(catch e (car1 car2))
@car1 @car2
@(end)
@@ -10482,7 +11408,7 @@ parameters are left alone. They may be bound or unbound variables.
.IP code:
.mono
\ @(try)
- @(trow e "honda")
+ @(throw e "honda")
@(catch e (car1 car2))
@car1 @car2
@(end)
@@ -10593,6 +11519,25 @@ if
.code abc
matches.
+If
+.code throw
+is used to generate an exception derived from type
+.code error
+and that exception is not handled, \*(TX will issue diagnostics on the
+.code *stderr*
+stream and terminate. If an exception derived from
+.code warning
+is not handled, \*(TX will generate diagnostics on the
+.code *stderr*
+stream, after which control returns to the
+.code throw
+directive, and proceeds with the next directive.
+If an exception not derived from
+.code error
+is thrown, control returns to the
+.code throw
+directive and proceeds with the next directive.
+
.dir defex
The
@@ -10624,7 +11569,7 @@ also. Furthermore, every type is a subtype of the type
which has no
supertype other than itself. Type
.code nil
-is is a subtype of every type, including
+is a subtype of every type, including
itself. The subtyping relationship is transitive also. If
.code A
is a subtype
@@ -10697,7 +11642,7 @@ Thus
.code a
is now a subtype of
.codn e .
-The the above can be condensed to:
+The above can be condensed to:
.verb
@(defex a b c d e)
@@ -10786,7 +11731,7 @@ definitions are in error:
The
.code assert
-directive requires the remaining query or sub-query which follows it
+directive requires the remaining query or subquery which follows it
to match. If the remainder fails to match, the
.code assert
directive throws an exception. If the directive is simply
@@ -10856,6 +11801,25 @@ followed by a successful match for
.strn "d@x" ,
or else an exception is thrown.
+If the exception is not handled, and is derived from
+.code error
+then \*(TX issues diagnostics on the
+.code *stderr*
+stream and terminates. If the exception is derived from
+.code warning
+and not handled, \*(TX issues a diagnostic on
+.code *stderr*
+after which control returns to the
+.code assert
+directive. Control silently returns to the
+.code assert
+directive if an exception of any other kind is not handled.
+
+When control returns to
+.code assert
+due to an unhandled exception, it behaves like a failed match,
+similarly to the require directive.
+
.SH* TXR LISP
The \*(TX language contains an embedded Lisp dialect called \*(TL.
@@ -10886,8 +11850,11 @@ and
\*(TL code can be placed into files. On the command
line, \*(TX treats files with a
-.str ".tl"
-suffix as \*(TL code, and the
+.strn .tl ,
+.str .tlo
+or
+.str .tlo.gz
+suffix as \*(TL source or compiled code, and the
.code @(load)
directive does also.
@@ -10956,7 +11923,7 @@ with the symbols
and
.code nil
(note the case sensitivity of
-identifiers denoting symbols!) Furthermore, the symbol
+identifiers denoting symbols!). Furthermore, the symbol
.code nil
is also the empty list, which terminates nonempty lists.
@@ -10968,7 +11935,7 @@ are supported. \*(TL also supports global lexical variables via
.codn defvarl .
Functions are lexically scoped in \*(TL; they can be
-defined in pervasive global environment using
+defined in the pervasive global environment using
.code defun
or in local scopes using
.code flet
@@ -11090,7 +12057,7 @@ denotes an uninterned symbol named
.codn bar ,
described in the next section.
-.TP* "Dialect note:"
+.TP* "Dialect Note:"
In ANSI Common Lisp, the
.code foo:bar
syntax does not intern the symbol
@@ -11128,6 +12095,91 @@ to the same object: the first occurrence creates the symbol and associates it
with its name in a package. Subsequent occurrences do not create a new symbol,
but retrieve the existing one.
+.NP* Meta-Atoms and Meta-Expressions
+
+An expression may be preceded by the
+.code @
+(at sign) character. If the expression is an
+.codn atom ,
+then this is a meta-atom, otherwise it is a meta-expression.
+
+When the atom is a symbol, this is also called a meta-symbol and in situations
+when such a symbol behaves like a variable, it is also referred to as a
+meta-variable.
+
+When the atom is an integer, the meta-atom expression is called a meta-number.
+
+Meta-atom and meta-expression expressions have no evaluation semantics;
+evaluating them throws an exception. They play a syntactic role in the
+.code op
+operator, which makes use of meta-variables and meta-numbers, and in structural
+pattern matching, which uses meta-variables as pattern variables and whose
+operator vocabulary is based on meta-expressions.
+
+Meta-expressions also appear in the quasiliteral notation.
+
+In other situations, application code may assign meaning to meta syntax as the
+programmer sees fit.
+
+Meta syntax is defined as a shorthand notation, as follows:
+
+If
+.code X
+is the syntax of an atom, such as a symbol, string or vector, then
+.code @X
+is a shorthand for the expression
+.codn "(sys:var X)" .
+Here,
+.code sys:var
+refers to the
+.code var
+symbol in the
+.codn system-package .
+
+If
+.code X
+is a compound expression, either
+.code "(...)"
+or
+.codn "[...]" ,
+then
+.code @X
+is a shorthand for the expression
+.codn "(sys:expr X)" .
+
+The behavior of
+.code @
+followed by the syntax of a floating-point constant introduced by a leading
+decimal point, not preceded by digits, is unspecified. Examples of this
+are
+.code "@.123"
+and
+.codn "@.123E+5" .
+
+The behavior of
+.code @
+followed by the syntax of a floating-point expression in E notation,
+which lacks a decimal point, is also unspecified. An example of this is
+.codn @12E5 .
+
+It is a syntax error for
+.code @
+to be followed by what appears to be a floating-point constant consisting
+of a decimal point flanked by digits on both sides. For instance
+.code @1.2
+is rejected.
+
+A meta-expression followed by a period, and the syntax of another object is
+otherwise interpreted as a referencing dot expression. For instance
+.code @1.E3
+denotes
+.code "(qref @1 E3)"
+which, in turn, denotes
+.codn "(qref (sys:var 1) E3)" ,
+even though the unprefixed character sequence
+.code 1.E3
+is otherwise a floating-point constant.
+
.NP* Consing Dot
Unlike other major Lisp dialects, \*(TL allows a consing dot with no forms
@@ -11166,10 +12218,38 @@ In no other circumstances is
printed as
.codn () ,
or an atom
-.code sym
+.meta sym
as
.codn "(. sym)" .
+This notation is implemented for the square brackets, according to this
+transformation:
+
+.verb
+ [. expr] -> (dwim . expr)
+.brev
+
+This is useful in Structural Pattern Matching, allowing a pattern like
+
+.verb
+ [. @args]
+.brev
+
+to match a
+.code dwim
+expression and capture all of its arguments in a variable, without having
+to resort to the internal notation:
+
+Compatibility Note: support for
+.code "[. expr]"
+was introduced in \*(TX 282. Older versions do not read the syntax,
+but do print
+.code "(dwim . @var)"
+as
+.code "[. @var]"
+which is then unreadable in those versions, breaking read-print
+consistency.
+
.NP* Referencing Dot
A dot token which is flanked by expressions on both sides, without any
@@ -11205,16 +12285,21 @@ to produce
.codn "(qref a b c)" .
If the referencing dot is immediately followed by a question mark, it forms
-a single token, which produces the following syntactic variation:
+a single token, which produces the following syntactic variation,
+in which the following item is annotated as a list headed by
+the symbol
+.codn t :
.verb
a.?b <--> (t a).b <--> (qref (t a) b)
a.?b.?c <--> (t a).(t b).c <--> (qref (t a) (t b) c)
+ a.?(b) <--> (t a).(b) <--> (qref (t a) (b))
+ (a).?b <--> (t (a)).b <--> (qref (t (a)) b)
.brev
This syntax denotes
.I null-safe
-access to structure slots.
+access to structure slots and methods.
.code a.?b
means that
.code a
@@ -11227,7 +12312,24 @@ otherwise,
must evaluate to a
.code struct
which has a slot
-.codn b .
+.codn b ,
+and the expression denotes access to that slot.
+Similarly,
+.code "a.?(b 1)"
+means that if
+.code a
+evaluates to
+.codn nil ,
+the expression yields
+.codn nil ;
+otherwise,
+.code a
+is treated as a struct object whose method
+.code b
+is invoked with argument
+.codn 1 ,
+and the value returned by that method becomes the value of
+the expression.
Integer tokens cannot be involved in this syntax, because they
form floating-point constants when juxtaposed with a dot.
@@ -11269,7 +12371,7 @@ is as follows:
.verb
.?a <--> (uref t a)
.?a.b <--> (uref t a b)
- .?a.?b <--> (uref t a (t b))
+ .?a.?b <--> (uref t a (t b))
.brev
When the unbound referencing dot is applied to a dotted expression,
@@ -11316,8 +12418,8 @@ The function detects this case and returns
.NP* Quote and Quasiquote
+.RS
.meIP >> ' expr
-
The quote character in front of an expression is used for suppressing evaluation,
which is useful for forms that evaluate to something other than themselves.
For instance if
@@ -11338,7 +12440,6 @@ is the contents of the variable
.codn a .
.meIP >> ^ qq-template
-
The caret in front of an expression is a quasiquote. A quasiquote is like
a quote, but with the possibility of substitution of material.
@@ -11382,7 +12483,7 @@ belongs to the inner quasiquote
and the outer quasiquote does not have
any unquotes of its own, making it equivalent to a quote.
-Dialect note: in Common Lisp and Scheme,
+Dialect Note: in Common Lisp and Scheme,
.code ^form
is written
.codn `form ,
@@ -11390,10 +12491,9 @@ and
quasiquotes are also informally known as backquotes. In \*(TX, the backquote
character
.code `
-used for quasi string literals.
+used for quasistring literals.
.meIP >> , expr
-
The comma character is used within a
.meta qq-template
to denote an unquote. Whereas the quasiquote suppresses evaluation,
@@ -11421,7 +12521,6 @@ variable name must be used:
.codn ", *x*" .
.meIP >> ,* expr
-
The comma-star operator is used within quasiquote list to denote a splicing
unquote. The form which follows
.code ,*
@@ -11436,6 +12535,37 @@ is evaluated to produce the list
.codn "(6 8)" ,
and this list is spliced into the quoted template.
+.meIP >> @,* expr
+This syntax is not a distinct quasiquoting operator, but rather the combination of
+an unquote occurring as a meta-expression, denoting the structure
+.codn "(sys:expr ,expr)" .
+This structure is treated specially by the quasiquote expander. Code is generated
+for it such that if
+.meta expr
+evaluates to a value
+.meta val
+which is an
+.codn atom ,
+then the result will be the
+.mono
+.meti (sys:var << val )
+.onom
+structure. If
+.meta val
+is a
+.code cons
+rather than an
+.codn atom ,
+then the result is the
+.mono
+.meti (sys:expr << val )
+.onom
+structure. In other words, when quasiquoting is used to insert a value under the
+.code @
+meta prefix, the expander generates code to analyze the type of the value, and
+produce to the form which is most likely intended.
+.RE
+
.TP* "Dialect Notes:"
In other Lisp dialects, like Scheme and ANSI Common Lisp, the equivalent syntax
@@ -11474,6 +12604,50 @@ throw an exception:
In other Lisp dialects, a comma not enclosed by backquote syntax is
treated as a syntax error by the reader.
+\*(TX's quasiquote supports splicing multiple items into a
+.codn quote ,
+if that quote is itself evaluated via an unquote. Concretely,
+these two examples produce the same result:
+
+.verb
+ (eval
+ (eval
+ (let ((args '(a b c)))
+ ^^(let ((a 1) (b 2) (c 3))
+ (list ,',*args)))))
+ -> (1 2 3)
+
+ (eval
+ (eval
+ (let ((args '(a b c)))
+ ^^(let ((a 1) (b 2) (c 3))
+ (list ,*',args)))))
+ -> (1 2 3)
+.brev
+
+The only difference is that the former example uses
+.code ",',*args"
+whereas the latter
+.codn ",*',args" .
+Thus the former example splices
+.code args
+into the quote as if by
+.code "(quote ,*args)"
+which is invalid
+.code quote
+syntax if
+.code args
+doesn't expand to exactly one element. This invalid quote syntax
+is accepted by the quasiquote expander when it occurs in the above unquoting
+and splicing situation. Effectively, it behaves as if the splice distributes
+across the quoted unquote, such that all the arguments of the
+.code quote
+end up individually quoted, and spliced into the surrounding list.
+
+The Common Lisp equivalent this combination,
+.codn ",',@args" ,
+works in some Common Lisp implementations, such as CLISP.
+
.NP* Quasiquoting non-List Objects
Quasiquoting is supported over hash table and vector literals (see Vectors
and Hashes below). A hash table or vector literal can be quoted, like any
@@ -11526,7 +12700,7 @@ it is embedded in a quasiquote:
^(a b c #(d ,a))) ; value is (a b c #(d 42))
.brev
-Hash table literals have two parts: the list of hash construction
+Hash-table literals have two parts: the list of hash construction
arguments and the key-value pairs. For instance:
.verb
@@ -11576,7 +12750,6 @@ Example:
.NP* Vector Literals
.coIP "#(...)"
-
A hash token followed by a list denotes a vector. For example
.code "#(1 2 a)"
is a three-element vector containing the numbers
@@ -11589,7 +12762,6 @@ and the symbol
.NP* Struct Literals
.meIP >> #S( name >> { slot << value }*)
-
The notation
.code #S
followed by a nested list syntax denotes a struct literal.
@@ -11616,10 +12788,9 @@ expression.
.NP* Hash Literals
.meIP <> #H(( hash-argument *) >> ( key << value )*)
-
The notation
.code #H
-followed by list syntax denotes a hash table literal.
+followed by list syntax denotes a hash-table literal.
The first item in the syntax is a list of keywords. These are the same
keywords as are used when calling the function hash to construct
a hash table. Allowed keywords are:
@@ -11627,7 +12798,7 @@ a hash table. Allowed keywords are:
.codn :eql-based ,
.codn :eq-based ,
.codn :weak-keys ,
-.codn :weak-values ,
+.codn :weak-vals ,
and
.codn :userdata .
If the
@@ -11661,7 +12832,7 @@ be specified as
.codn nil ;
the empty parentheses notation is required.
-The hash table key-value contents are specified as zero or more
+The hash table's key-value contents are specified as zero or more
two-element lists, whose first element specifies the
.meta key
and whose second specifies the
@@ -11671,7 +12842,6 @@ Both expressions are literal objects, not subject to evaluation.
.NP* Range Literals
.meIP >> #R( from << to )
-
The notation
.code #R
followed by a two-element list syntax denotes a range literal.
@@ -11689,7 +12859,6 @@ fields are the objects denoted by these expressions.
.NP* Buffer Literals
.meIP <> #b' hex-data '
-
The notation
.code #b'
introduces a buffer object: a data representation for a
@@ -11723,7 +12892,6 @@ or
.NP* Tree Node Literals
.meIP >> #N([ key >> [ left <> [ right ]]])
-
The notation
.code #N
followed by list syntax denotes a tree node literal. The list syntax must be a
@@ -11748,7 +12916,6 @@ If the tree node literal syntax omits any of these, they default to
.NP* Tree Literals
.meIP >> #T([([ keyfun >> [ lessfun <> [ equalfun ]]]) << item *])
-
The notation
.code #T
followed by list syntax denotes a tree literal, which specifies an
@@ -11799,6 +12966,177 @@ syntax, either explicitly or as defaults. Then, every
object is constructed from its respective literal syntax and inserted into
the tree.
+Duplicate objects are preserved. For instance the tree literal
+.code "#T(() 1 1 1)"
+specifies a tree with three nodes which have the same key.
+Duplicates appear in the tree in the order that they appear in the
+literal.
+
+.NP* JSON Literals
+.meIP >> #J json-syntax
+Introduces a JSON literal.
+.meIP >> #J^ json-syntax
+Introduces a JSON quasiliteral, allowing unquoting and splicing of Lisp expressions.
+
+The implementation of JSON syntax is based on, and intended to conform with
+the IETF RFC 8259 document. Only \*(TX's extensions to JSON syntax are described
+in this manual, as well as the correspondence between JSON syntax and Lisp.
+
+The
+.meta json-syntax
+is translated into a \*(TL object as follows.
+
+A JSON string corresponds to a Lisp string. A JSON number corresponds to a
+Lisp floating-point number. A JSON array corresponds to a Lisp vector.
+A JSON object corresponds to an
+.codn equal -based
+hash table.
+
+The JSON Boolean symbols
+.code true
+and
+.code false
+translate to the Lisp symbols
+.code t
+and
+.codn nil ,
+respectively, those being the standard ones in the
+.code usr
+package.
+
+The JSON symbol
+.code null
+maps to the
+.code null
+symbol in the
+.code usr
+package.
+
+The
+.mono
+.meti >> #J json-syntax
+.onom
+expression produces the object:
+
+.mono
+.mets (json quote << lisp-object )
+.onom
+
+where
+.meta lisp-object
+is the Lisp value which corresponds to the
+.metn json-syntax .
+
+Similarly, but with a key difference, the
+.mono
+.meti >> #J^ json-syntax
+.onom
+expression produces the object:
+
+.mono
+.mets (json sys:qquote << lisp-object )
+.onom
+
+in which
+.code quote
+has been replaced with
+.codn sys:qquote .
+
+The
+.code json
+symbol is bound as a macro, which is expanded when a
+.code #J
+expression is evaluated.
+
+The following remarks indicate special treatment and extensions in the
+processing of JSON. Similar remarks regarding the production of JSON are
+given under the
+.code put-json
+function.
+
+When an invalid UTF-8 byte is encountered inside a JSON string, its value is
+mapped into the code point range U+DC01 to U+DCFF. That byte is consumed, and
+decoding continues with the next byte. This treatment is consistent with the
+treatment of invalid UTF-8 bytes in \*(TL literals and I/O streams. If the
+valid UTF-8 byte U+0000 (ASCII NUL) occurs in a JSON string, it is also mapped
+to U+DC00, \*(TX's pseudo-null character. This treatment is consistent with
+\*(TX string literals and I/O streams.
+
+The JSON escape sequence
+.code "\eu0000"
+denoting the U+0000 NUL character is also converted to U+DC00.
+
+\*(TL does not impose the restriction that the keys in a JSON object
+must be strings:
+.code "#J{1:2,true:false}"
+is accepted.
+
+\*(TL allows the circle notation to occur within JSON syntax. See the section
+Notation for Circular and Shared Structure.
+
+\*(TL supports the extension of Lisp comments in JSON. When the
+.code ;
+character (semicolon) occurs in the middle of JSON syntax, outside
+of a token, that character and all characters until the end of the line
+constitute a comment that is discarded. \*(TL never produces comments
+when printing JSON.
+
+\*(TL allows for JSON syntax to be quasiquoted, and provides two extensions
+for writing unquotes and splicing unquotes. Within a JSON quasiquote, the
+.code ~
+(tilde) character introduces a Lisp expression whose value is to be substituted
+at that point. Thus, the tilde serves the role of the unquoting comma used
+in Lisp quasiquotes. Splicing is indicated by the character sequence
+.codn ~* ,
+which introduces a Lisp expression that is expected to produce a list, whose
+elements are interpolated into the JSON value.
+
+Note: quasiquoting allows Lisp values to be introduced into the resulting
+object which are outside of the JSON type system, such as integers, characters,
+symbols or structures. These objects have no representation in JSON syntax.
+
+.TP* Examples:
+
+.verb
+ ;; Basic JSON:
+
+ #Jtrue -> t
+ #Jfalse -> nil
+ (list #J true #Jtrue #Jfalse) -> (t t nil)
+ #J[1, 2, 3.14] -> #(1.0 2.0 3.14)
+ #J{"foo":"bar"} -> #H(() ("foo" "bar"))
+
+ ;; Quoting JSON shows the json expression
+
+ '#Jfalse -> (json quote ())
+ '#Jtrue -> (json quote t)
+ '#J["a", true, 3.0] -> (json quote #("a" t 3.0))
+ '#J^[~(+ 2 2), 3] -> (json sys:qquote #(,(+ 2 2) 3.0))
+
+ :; Circle notation:
+
+ #J[#1="abc", #1#, #1#] -> #("abc" "abc" "abc")
+
+ ;; JSON Quasiquote:
+
+ #J^[~*(list 1.0 2.0 3.0), ~(* 2.0 2), 5.0]
+ --> #(1.0 2.0 3.0 4.0 5.0)
+
+ ;; Lisp quasiquote around JSON quote: requires evaluation round.
+
+ ^#J[~*(list 1.0 2.0 3.0), ~(* 2.0 2), 5.0]
+ --> (json quote #(1.0 2.0 3.0 4.0 5.0))
+
+ (eval ^#J[~*(list 1.0 2.0 3.0), ~(* 2.0 2), 5.0])
+ --> #(1.0 2.0 3.0 4.0 5.0)
+
+ ;; Comment extension
+ #J[1, ; Comment inside JSON.
+ 2, ; Another one.
+ 3] ; Lisp comment outside of JSON.
+ --> #(1.0 2.0 3.0)
+.brev
+
.coNP The @ .. notation
In \*(TL, there is a special "dotdot" notation consisting of a pair of dots.
This can be written between successive atoms or compound expressions, and is a
@@ -11848,7 +13186,7 @@ denotes
Note that range objects are not printed using the dotdot notation.
A range literal has the syntax of a two-element list, prefixed by
.codn #R .
-(See Range Literals above).
+(See Range Literals above.)
In any context where the dotdot notation may be used, and where
it is evaluated to its value, a range literal may also be specified.
@@ -11933,10 +13271,10 @@ may be understood according to the following transformations:
[f a b c ... . x] --> [apply f a b c ... x]
.brev
-In addition to atoms, meta-expressions and meta-variables can appear in the dot
-position, even though their underlying syntax is comprised of a compound
-expression. This appears to work according to a transformation pattern
-which superficially appears to be the same as that for atoms:
+In addition to atoms, meta-expressions and meta-symbols can appear in the dot
+position, even though their underlying syntax is actually a compound
+expression. This is made to work according to a transformation pattern
+which superficially resembles the above one for atoms:
.verb
(f a b c ... . @x) --> (apply (fun f) a b c ... @x)
@@ -11944,10 +13282,10 @@ which superficially appears to be the same as that for atoms:
However, in this situation, the
.code @x
-is actually the form
+is a notation denoting the expression
.code "(sys:var x)"
-and the dotted form is actually a proper list. The transformation is
-in fact taking place over a proper list, like this:
+and thus the entire form is a proper list, not a dotted list.
+With the underlying syntax revealed, the transformation looks like this:
.verb
(f a b c ... sys:var x) --> (apply (fun f) a b c ... (sys:var @x))
@@ -12062,7 +13400,7 @@ then
receives the improper list form
.codn "3 . 4" .
-.NP* Regular Expression Literals
+.NP* Regular-Expression Literals
In \*(TL, the
.code /
character can occur in symbol names, and the
@@ -12101,7 +13439,7 @@ can be represented as
The
.code #5=
part introduces a reference label, associating the arbitrarily
-chosen non-negative integer 5 with the object which follows.
+chosen nonnegative integer 5 with the object which follows.
The subsequent notation
.code #5#
simply refers to the object labeled by 5, reproducing that object
@@ -12127,7 +13465,6 @@ circular reference in the object.
A detailed description of the notational elements follows:
.meIP <> # digits = < object
-
The
.code #=
syntax introduces an object label which denotes the
@@ -12150,7 +13487,6 @@ top-level expression in which they appear. Consequently, references
in one \*(TL top-level expression cannot reach definitions in another.
.meIP <> # digits #
-
The
.code ##
syntax denotes a label reference: the repetition of an object that was
@@ -12167,9 +13503,11 @@ and is applied to an object which either encloses the reference,
or lexically precedes the reference. Forward references such as
.code "(#1# #1=(1 2))"
are not supported.
+.PP
+
+Note:
-.TP* "Note:"
-Circular notation can span hash table literals. The syntax
+Circular notation can span hash-table literals. The syntax
.code "#1=#H((:eql-based) (#1# #1#))"
denotes an
.codn eql -based
@@ -12181,7 +13519,8 @@ hash tables. The analogous syntax
.code "#1=#H(() (#1# #1#))"
produces a hash table in an inconsistent state.
-.TP* "Dialect note:"
+Dialect Note:
+
Circle notation is taken from Common Lisp,
intended to be unsurprising to users familiar with that
language.
@@ -12193,7 +13532,6 @@ PRINT-CIRCLE-SHARED:RESPECT-PRINT-CIRCLE.
.NP* Notation for Erasing Objects
.meIP #; < expr
-
The \*(TL notation
.code #;
in TXR Lisp indicates that the expression
@@ -12201,8 +13539,9 @@ in TXR Lisp indicates that the expression
is to be read and then discarded, as if it were replaced by whitespace.
This is useful for temporarily "commenting out" an expression.
+.PP
+Notes:
-.TP* Notes:
Whereas it is valid for a \*(TL source file to be empty, it is
a syntax error if a \*(TL source file contains nothing but one or more
objects which are each suppressed by a preceding
@@ -12389,13 +13728,133 @@ The lazy versions of these functions such as
do not have this behavior;
they produce lazy lists.
+.SS* Generalization of Iteration
+
+\*(TL implements a unified paradigm for iterating over sequence-like
+container structures and abstract spaces such as bounded and unbounded ranges
+of integers. This concept is based around an iterator abstraction which is
+directly compatible with Lisp cons-cell traversal in the sense that when
+iteration takes place over lists, the iterator instance is nothing but a cons
+cell.
+
+An iterator is created using the constructor function
+.code iter-begin
+which takes a single argument. The argument denotes a space to be traversed;
+the iterator provides the means for that traversal.
+
+When the
+.code iter-begin
+function is applied to a list (a
+.code cons
+cell or the
+.code nil
+object), the return value is that object itself. The remaining functions
+in the iterator API then behave like aliases for list processing functions.
+The
+.code iter-more
+function behaves like
+.codn identity ,
+.code iter-item
+behaves like
+.code car
+and
+.code iter-step
+behaves like
+.codn cdr .
+
+For example, the following loops not only produce identical behavior,
+but the
+.code iter
+variable steps through the
+.code cons
+cells in the same manner in both:
+
+.verb
+ ;; print all symbols in the list (a b c d):
+
+ (let ((iter '(a b c d)))
+ (while iter
+ (prinl (car iter))
+ (set iter (cdr iter))))
+
+ ;; likewise:
+
+ (let ((iter (iter-begin '(a b c d))))
+ (while (iter-more iter)
+ (prinl (iter-item iter))
+ (set iter (iter-step iter))))
+.brev
+
+There are three important differences.
+
+Firstly, both examples will still work
+if the list
+.code "(a b c d)"
+is replaced by a different kind of sequence, such as the string
+.str abcd
+or the vector
+.codn "#(a b c d)" .
+However, the former example will not execute efficiently on these objects.
+The reason is that the
+.code cdr
+function will construct successive suffixes of the string and list object.
+That requires not only the allocation of memory, but changes the running time
+complexity of the loop from linear to quadratic.
+
+Secondly, the former example with
+.cod3 car / cdr
+will not work correctly if the sequence is an empty non-list sequence, like
+the null string or empty vector. Rectifying this problem requires the
+.code nullify
+function to be used:
+
+.verb
+ ;; print all symbols in the list (a b c d):
+
+ (let ((iter (nullify "abcd")))
+ (while iter
+ (prinl (car iter))
+ (set iter (cdr iter))))
+.brev
+
+The
+.code nullify
+function converts empty sequences of all kinds into the empty list
+.codn nil .
+
+Thirdly, the second
+example will work even if the input list is replaced with certain objects
+which are not sequences at all:
+
+.verb
+ ;; Print the integers from 0 to 3
+
+ (let ((iter (iter-begin 0..4)))
+ (while (iter-more iter)
+ (prinl (iter-item iter))
+ (set iter (iter-step iter))))
+
+ ;; Print incrementing integers starting at 1,
+ ;; breaking out of the loop after 100.
+
+ (let ((iter (iter-begin 1)))
+ (while (iter-more iter)
+ (if (eql 100 (prinl (iter-item iter)))
+ (return))
+ (set iter (iter-step iter))))
+.brev
+
+In \*(TL, numerous functions that appear as list processing functions in other
+contemporary Lisp dialects, and historically, are actually sequence processing
+functions based on the above iterator paradigm.
+
.SS* Callable Objects
In \*(TL, sequences (strings, vectors and lists) as well as hashes and
regular expressions can be used as functions everywhere, not just with the DWIM
brackets.
-Sequences work as one or two-argument functions. With a single argument, an
+Sequences work as one- or two-argument functions. With a single argument, an
element is selected by position and returned. With two arguments, a range is
extracted and returned.
@@ -12414,6 +13873,15 @@ operates on a string argument.
It returns the leftmost matching substring, or else
.codn nil .
+Structure objects are callable if they implement the
+.code lambda
+method.
+
+Integers and ranges are callable like functions. They take one argument,
+which must be a sequence or hash. An integer selects the corresponding
+element position from the sequence, and a range extracts a slice of
+its argument.
+
.B Example 1:
.verb
@@ -12459,7 +13927,7 @@ index 1, up to and not including index 3, as if by the call
(call '(1 2 3 4) '(0 2)) -> (1 2)
.brev
-A list of indices applied to a sequence is equivalent to using the
+A sequence applied to a list of index arguments is equivalent to using the
select function, as if
.code "(select '(1 2 3 4) '(0 2))"
were called.
@@ -12476,6 +13944,26 @@ substring
within the argument
.strn abcd .
+.B Example 5:
+
+.verb
+ [1 "abcd"] -> #\eb
+
+ ["abcd" 1] -> #\eb
+.brev
+An integer used as function indexes into sequence.
+This produces the same result as when the sequence is used
+as a function with an integer argument.
+
+.B Example 6:
+
+.verb
+ [1..3 '(a b c d)] -> (b c)
+ ['(a b c d) 1..3] -> (b c)
+.brev
+
+A range used as a function extracts a slice of its argument.
+
.SS* Special Variables
Similarly to Common Lisp, \*(TL is lexically scoped by default, but
also has dynamically scoped (a.k.a "special") variables.
@@ -12719,7 +14207,7 @@ overwritten with a value. What exactly it means for a place to be deleted,
or whether that is even permitted, depends on the kind of place.
For instance a place which denotes a lexical variable may not be deleted,
whereas a global variable may be.
-A place which denotes a hash table entry may be deleted, and results in the
+A place which denotes a hash-table entry may be deleted, and results in the
entry being removed from the hash table. Deleting a place in a list
causes the trailing items, if any, or else the terminating atom, to
move in to close the gap. Users may define new kinds of places
@@ -12736,7 +14224,7 @@ treated as (and consequently required to be) a syntactic place, or whether it is
an ordinary form.
All built-in place operators perform the evaluation of place and non-place
-argument forms in strict left to right order.
+argument forms in strict left-to-right order.
Place forms are evaluated not in order to compute a value, but in order to
determine the storage location. In addition to determining a storage location,
@@ -12745,7 +14233,7 @@ Once a place is fully evaluated, the storage location can then be accessed.
Access to the storage location is not considered part of the evaluation of a
place. To determine a storage location means to compute some hidden referential
object which provides subsequent access to that location without the need for a
-re-evaluation of the original place form. (The subsequent access to the
+reevaluation of the original place form. (The subsequent access to the
place through this referential object may still require a multi-step traversal
of a data structure; minimizing such steps is a matter of optimization.)
@@ -12820,7 +14308,7 @@ but
may also be overwritten with a new value.
This behavior is necessary because the DWIM brackets notation maintains
-the illusion of an encapsulated array-like container over several dis-similar
+the illusion of an encapsulated array-like container over several dissimilar
types, including Lisp lists. But Lisp lists do not behave as fully
encapsulated containers. Some mutations on Lisp lists return new objects,
which then have to stored (or otherwise accepted) in place of the original
@@ -12852,7 +14340,6 @@ defined by \*(TX programs.
.mets (nthcdr < index << obj )
.mets (nthlast < index << obj )
.mets (butlastn < num << obj )
-.mets (last < num << obj )
.mets (nth < index << obj )
.mets (ref < seq << idx )
.mets (sub < sequence >> [ from <> [ to ]])
@@ -12861,10 +14348,14 @@ defined by \*(TX programs.
.mets (gethash < hash < key <> [ alt ])
.mets (hash-userdata << hash )
.mets (dwim < obj-place < index <> [ alt ])
+.mets (dwim < integer < obj-place ) ;; integers are callable
+.mets (dwim < range < obj-place ) ;; ranges are callable
.mets (sub-list < obj >> [ from <> [ to ]])
.mets (sub-vec < obj >> [ from <> [ to ]])
.mets (sub-str < str >> [ from <> [ to ]])
.mets >> [ obj-place < index <> [ alt ]] ;; equivalent to dwim
+.mets >> [ integer < obj-place ]
+.mets >> [ range < obj-place ]
.mets (symbol-value << symbol-valued-form )
.mets (symbol-function << function-name-valued-form )
.mets (symbol-macro << symbol-valued-form )
@@ -12873,13 +14364,15 @@ defined by \*(TX programs.
.mets (errno)
.mets (slot < struct-obj << slot-name-valued-form )
.mets (qref < struct-obj << slot-name ) ;; by macro-expansion to (slot ...)
-.mets < struct-obj . < slot-name ;; equivalent to qref
+.mets >< struct-obj . slot-name ;; equivalent to qref
.mets (sock-peer << socket )
+.mets (sock-opt < socket < level < option <> [ ffi-type ])
.mets (carray-sub < carray >> [ from <> [ to ]])
.mets (sub-buf < buf >> [ from <> [ to ]])
.mets (left << node )
.mets (right << node )
.mets (key << node )
+.mets (read-once << node )
.onom
.NP* Built-In Place-Mutating Operators
@@ -12888,7 +14381,7 @@ The following is a summary of the built-in place mutating macros.
They are described in detail in their own sections.
.meIP (set >> { place << new-value }*)
-Assigns the values of expressions to places, performing assignments in left to right order,
+Assigns the values of expressions to places, performing assignments in left-to-right order,
returning the value assigned to the rightmost place.
.meIP (pset >> { place << new-value }*)
@@ -12948,6 +14441,19 @@ value into
and returns
.codn t .
+.meIP (ensure < place << init-expr )
+If the place is
+.codn nil ,
+evaluates
+.codn init-expr ,
+stores that value into
+.meta place
+and returns it.
+Otherwise, returns the value of
+.meta place
+without changing its value or evaluating
+.codn init-expr .
+
.meIP (inc < place <> [ delta ])
Increments
.meta place
@@ -13019,12 +14525,13 @@ and
.metn right-place .
.meIP (push < item << place )
-Pushes
+Adds
.meta item
-into the list stored in
+to the front of the list which is currently stored in
+.codn place ,
+then stores the extended list back into
.code place
-and returns
-.codn item .
+and returns it.
.meIP (pop << place )
Pop the list stored in
@@ -13048,7 +14555,7 @@ goes to the rightmost place, and that value is returned.
Deletes a place which supports deletion, and returns
the value which existed in that place prior to deletion.
-.meIP (lset <> { place }+ << list-expr )
+.meIP (lset <> { place }+ << sequence )
Sets multiple places to values obtained from successive
elements of
.metn sequence .
@@ -13061,6 +14568,20 @@ operational pipeline to the value of
and stores the result back into
.metn place .
+.meIP (set-mask < place << integer *)
+Sets to 1 the bits in
+.meta place
+corresponding to bits that are equal to 1 in the mask made up of the
+.meta integer
+arguments (by combining them together with the inclusive or operation).
+
+.meIP (clear-mask < place << integer *)
+Clears (sets to 0) the bits in
+.meta place
+corresponding to bits that are equal to 1 in the mask made up of the
+.meta integer
+arguments (by combining them together with the inclusive or operation).
+
.PP
.SS* Namespaces and Environments
@@ -13070,7 +14591,7 @@ functions and variables.
.NP* Global Functions and Operator Macros
-In \*(TL, global functions and operator macros co-exist, meaning that the same
+In \*(TL, global functions and operator macros coexist, meaning that the same
symbol can be defined as both a macro and a function.
There is a global namespace for functions,
@@ -13159,7 +14680,7 @@ is provided by
and
.codn lexical-lisp1-binding .
-Lexical operator macros and lexical functions can also co-exist in the
+Lexical operator macros and lexical functions can also coexist in the
following way. A lexical function shadows a global or lexical macro
completely. However, the reverse is not the case. A lexical macro shadows
only those uses of a function which look like macro calls. This is
@@ -13229,7 +14750,7 @@ The pattern language doesn't see Lisp lexical variables.
When Lisp code is evaluated from the pattern language, the pattern variable
bindings are not only installed as dynamic variables for the sake of their
visibility from Lisp, but they are also specially stored in a dynamic
-environment frame. When \*(TX pattern code is re-entered from Lisp, these
+environment frame. When \*(TX pattern code is reentered from Lisp, these
bindings are picked up from the closest such environment frame, allowing the
nested invocation of pattern code to continue with the bindings captured by
outer pattern code.
@@ -13245,6 +14766,7 @@ Lisp variables using the
prefix, which is a consequence of that prefix introducing an expression that is
evaluated as Lisp, the name of a variable being such an expression.
+
.SH* LISP OPERATOR, FUNCTION AND MACRO REFERENCE
.SS* Conventions
@@ -13281,7 +14803,8 @@ The curly braces may be omitted if the scope of the
is clear.
.coIP {syntax | syntax | ...}
-This indicates a choice among alternatives.
+This indicates a single, mandatory element, which is selected
+from among the indicated alternatives.
May be combined with
.code +
or
@@ -13291,6 +14814,11 @@ repetition.
.meIP [syntax] <> [ word ]
Square brackets indicate optional syntax.
+.meIP [syntax | syntax | ...]
+Square brackets containing piped elements indicate an optional
+element, which, if present, must be chosen from among the indicated
+alternatives.
+
.coIP '[' ']'
The quoted square brackets indicate literal brackets which appear
in the syntax, which they do without quotes. For instance
@@ -13314,7 +14842,7 @@ When the form is an operator invocation, the interpretation of the meaning of
that form is under the complete control of that operator.
If the compound form is a function call, the remaining forms, if any, denote
-argument expressions to the function. They are evaluated in left to right
+argument expressions to the function. They are evaluated in left-to-right
order to produce the argument values, which are passed to the function. An
exception is thrown if there are not enough arguments, or too many. Programs
can define named functions with the defun operator
@@ -13336,7 +14864,7 @@ and string literals.
Special operators can also perform code transformations during the expansion
phase, but that is not considered macroexpansion, but rather an adjustment
-of the representation of the operator into an required executable form.
+of the representation of the operator into a required executable form.
In effect, it is post-macro compilation phase.
Note that Lisp forms occurring in \*(TX pattern language are not individual
@@ -13356,19 +14884,39 @@ and instead returns
.meta form
itself as an object. For example, if
.meta form
-is a symbol, then
-.meta form
-is not evaluated to the symbol's value; rather
-the symbol itself is returned.
+is a symbol
+.metn sym ,
+then the value of
+.mono
+.meti (quote << sym )
+.onom
+is
+.meta sym
+itself. Without
+.codn quote ,
+.meta sym
+would evaluate to the value held by the variable which is named
+.metn sym ,
+or else throw an error if there is no such variable.
+The
+.code quote
+operator never raises an error, if it is given exactly one argument,
+as required.
-Note: the quote syntax
+The notation
+.mono
+.meti >> ' obj
+.onom
+is translated to the object
.mono
-.meti >> ' <form>
+.meti (quote << obj )
.onom
-is translated to
+providing a shorthand for quoting. Likewise, when an object of the form
.mono
-.meti (quote << form ).
+.meti (quote << obj )
.onom
+is printed, it appears as
+.codn 'obj .
.TP* Example:
@@ -13397,10 +14945,10 @@ some form known as a
and the corresponding environment is instantiated during the evaluation
of that construct. There also exist bindings outside of any binding
construct, in the so-called
-.I global environment .
+.IR "global environment" .
Bindings in the global environment can be temporarily shadowed by
lexically-established binding in the
-.I dynamic environment .
+.IR "dynamic environment" .
See the Special Variables section above.
Certain special symbols cannot be used as variable names, namely the
@@ -13429,7 +14977,7 @@ a form are fully expanded prior to the evaluation of a form, therefore
evaluation does not consider the possibility of a symbol being
a symbol macro.
-.coNP Operator @ defvar and macro @ defparm
+.coNP Operator @ defvar and Macro @ defparm
.synb
.mets (defvar < sym <> [ value ])
.mets (defparm < sym << value )
@@ -13471,8 +15019,8 @@ The symbols
.code t
and
.code nil
-may not be used as variables, and neither
-can be keyword symbols: symbols denoted by a leading colon.
+may not be used as variables,
+nor can they be keyword symbols (symbols denoted by a leading colon).
In addition to creating a binding, the
.code defvar
@@ -13594,7 +15142,7 @@ The plain
variant specifies a variable which is initialized to
.codn nil .
The
-.metn init-form -s
+.metn init-form s
are evaluated in order, by both
.code let
and
@@ -13614,23 +15162,23 @@ and
is that in
.codn let* ,
later
-.codn init-form -s
+.codn init-form s
are in scope of the variables established by earlier variables in the same
.code let*
construct. In plain
.codn let ,
the
-.metn init-form -s
+.metn init-form s
are evaluated in a scope which does not include any of the variables.
When the variables are established, the
-.metn body-form -s
+.metn body-form s
are evaluated in order. The value of the last
.meta body-form
becomes the return value of the
.codn let .
If there are no
-.metn body-form -s,
+.metn body-form s,
then the return value
.code nil
is produced.
@@ -13638,7 +15186,7 @@ is produced.
The list of variables may be empty.
The list of variables may contain duplicate
-.metn sym -s
+.metn sym s
if the operator is
.codn let* .
In that situation, a given
@@ -13647,7 +15195,7 @@ has in scope the rightmost duplicate of any given
.meta sym
that has been previously established.
The
-.metn body-form -s
+.metn body-form s
have in scope the rightmost duplicate of any
.meta sym
in the construct.
@@ -13706,7 +15254,7 @@ than the lexical environment.
In
.codn let* ,
later
-.metn init-form -s
+.metn init-form s
are evaluated in a dynamic scope in which previous dynamic variables
are established, and later dynamic variables are not yet established.
A special variable may appear multiple times in a
@@ -13728,6 +15276,90 @@ closures, but are captured in delimited continuations.
(let (:a nil)) -> error, :a and nil can't be used as variables
.brev
+.TP* "Rationale:"
+
+\*(TL follows ANSI Common Lisp in making
+.code let
+the parallel binding construct, and
+.code let*
+the sequential one. In that language, the situation exists for historic
+reasons: mainly that
+.code let
+was initially understood as being a macro for an immediately-called
+.code lambda
+where the parameters come into existence simultaneously, receiving the
+evaluated values of all the argument expressions. The need for sequential
+binding was recognized later, by which time
+.code let
+was cemented as a parallel binding construct.
+There are very good arguments for, in a new design, using the
+.code let
+name for the construct which has sequential semantics.
+Nevertheless, in this matter, \*(TL remains compatible with dialects like
+ANSI CL and Emacs Lisp.
+
+.coNP Operator @ progv
+.synb
+.mets (progv < symbols-expr < values-expr << body-form *)
+.syne
+.desc
+The
+.code progv
+operator binds dynamic variables, and evaluates the
+.metn body-form s
+in the dynamic scope of those bindings. The bindings are removed
+when the form terminates. The result value is that of the
+last
+.meta body-form
+or else
+.code nil
+if there are no forms.
+
+The
+.meta symbols-expr
+and
+.meta values-expr
+are expressions which are evaluated. Their values are expected
+to be lists, of bindable symbols and arbitrary values, respectively.
+The symbols coming from one list are bound to the values coming
+from the other list.
+
+If there are more symbols than values, then the extra symbols
+will appear unbound, as if they were first bound and then hidden
+using the
+.code makunbound
+function.
+
+If there are more values than symbols, the extra values are ignored.
+
+Note that dynamic binding takes place for the symbols even if they
+have not been introduced as special variables via
+.code defvar
+or
+.codn defparm .
+However, if those symbols appear as expressions denoting variables inside the
+.metn body-form s,
+they will not necessarily be treated as dynamic variables.
+If they have lexical definitions in scope, those will be referenced.
+Furthermore, the compiler treats undefined variables as global
+references, and not dynamic.
+
+.TP* Examples:
+
+.verb
+
+ (progv '(a b) '(1 2) (cons a b)) -> (1 . 2)
+
+ (progv '(x) '(1) (let ((x 4)) (symbol-value 'x))) -> 1
+
+ (let ((x 'lexical)
+ (vars (list 'x))
+ (vals (list 'dynamic)))
+ (progv vars vals (list x (symbol-value 'x))))
+
+ --> (lexical dynamic)
+.brev
+
.SS* Functions
.coNP Operator @ defun
.synb
@@ -13750,7 +15382,7 @@ expanded. See the section Parameter List Macros.
Unlike in
.codn lambda ,
the
-.metn body-form -s
+.metn body-form s
of a
.code defun
are surrounded by a block.
@@ -13822,7 +15454,7 @@ In TXR Lisp, they may not.
.TP* "Dialect Note:"
A function defined by
.code defun
-may co-exist with a macro defined by
+may coexist with a macro defined by
.codn defmacro .
This is not permitted in ANSI Common Lisp.
@@ -13839,7 +15471,7 @@ The
operator produces a value which is a function. Like in most other
Lisps, functions are objects in \*(TL. They can be passed to functions as
arguments, returned from functions, aggregated into lists, stored in variables,
-.IR "et cetera" .
+etc.
Note that the above syntax synopsis describes only the canonical
parameter syntax which remains after parameter list macros are
@@ -13872,7 +15504,7 @@ accepts only a variable argument list and no required arguments:
(These notations are syntactically equivalent because the list notation
.code "(. X)"
actually denotes the object
-.code X
+.meta X
which isn't wrapped in any list).
The keyword symbol
@@ -13891,10 +15523,10 @@ An optional parameter can also be written in the form
.mono
.meti >> ( name < expr <> [ sym ]).
.onom
-In this situation, if the call does not specify a value for the parameter
-(or specifies a value as the keyword
+In this situation, if the call does not specify a value for the parameter,
+or specifies a value as the
.code :
-(colon)) then the parameter takes on the
+(colon) keyword symbol, then the parameter takes on the
value of the expression
.metn expr .
This expression is only evaluated when its value is required.
@@ -13908,10 +15540,12 @@ introduced as an additional binding with a Boolean value which indicates
whether or not the optional parameter had been specified by the caller.
Each
-.code expr
-that is evaluated is evaluated an environment in which
+.meta expr
+that is evaluated is evaluated in an environment in which
all of the previous parameters are visible, in addition to the surrounding
-environment of the lambda. For instance:
+environment of the
+.codn lambda .
+For instance:
.verb
(let ((default 0))
@@ -13925,7 +15559,7 @@ the initializing expression for the optional parameter
end is
.codn "(length str)" ,
and the
-.code str
+.meta str
variable it refers to is the previous
argument. The initializer for the optional variable counter is
the expression default, and it refers to the binding established
@@ -13941,7 +15575,7 @@ may not be used as parameter names.
The behavior is unspecified if the same symbol is specified
more than once anywhere in the parameter list, whether as a parameter name or as
the indicator
-.code sym
+.meta sym
in an optional parameter or any combination.
Implementation note: the \*(TX compiler diagnoses and rejects duplicate
@@ -13949,49 +15583,158 @@ symbols in
.code lambda
whereas the interpreter ignores the situation.
+Note: it is not always necessary to use the
+.code lambda
+operator directly in order to produce an anonymous function.
+
+In situations when
+.code lambda
+is being written in order to simulate partial evaluation, it may be possible
+to instead make use of the
+.code op
+macro. For instance the function
+.code "(lambda (. args) [apply + a args])"
+which adds the values of all of its arguments together, and to the lexically
+captured variable
+.code a
+can be written more succinctly as
+.codn "(op + a)" .
+The
+.code op
+operator is the main representative of a family of operators:
+.codn lop ,
+.codn ap ,
+.codn ip ,
+.codn do ,
+.codn ado ,
+.code opip
+and
+.codn oand .
+
+In situations when functions are simply combined together, the effect
+may be achieved using some of the available functional combinators,
+instead of a
+.codn lambda .
+For instance chaining together functions as in
+.code "(lambda (x) (square (cos x)))"
+is achievable using the
+.code chain
+function:
+.codn "[chain cos square]" .
+The
+.code opip
+operator can also be used:
+.codn "(opip cos square)" .
+Numerous combinators are available; see the section Partial Evaluation and
+Combinators.
+
+When a function is needed which accesses an object, there are also
+alternatives. Instead of
+.code "(lambda (obj) obj.slot)"
+and
+.codn "(lambda (obj arg) obj.(slot arg))" ,
+it is simpler to use the
+.code ".slot"
+and
+.code ".(slot arg)"
+notations. See the section Unbound Referencing Dot.
+Also see the functions
+.code umethod
+and
+.code uslot
+as well as the related convenience macros
+.code umeth
+and
+.codn usl .
+
+If a function is needed which partially applies,
+to some arguments, a method invoked on a specific object, the
+.code method
+function or
+.code meth
+macro may be used. For instance, instead of
+.codn "(lambda (arg) obj.(method 3 arg))" ,
+it is possible to write
+.code "(meth obj 3)"
+except that the latter produces a variadic function.
+
.TP* Examples:
-.IP "Counting function:"
-This function, which takes no arguments, captures the
-variable
+
+The following expression returns a function which captures
+the variable
.codn counter .
-Whenever this object is called, it increments
+Whenever the returned function is called, it increments
.code counter
-by
-.code 1
-and returns the incremented value.
+by one, and returns the incremented value.
.verb
(let ((counter 0))
(lambda () (inc counter)))
.brev
-.IP "Function that takes two or more arguments:"
-The third and subsequent arguments are aggregated into a list passed as the
-single parameter
+The following produces a variadic function which requires at least two
+arguments. The third and subsequent arguments are aggregated into a list
+passed as the single parameter
.codn z :
.verb
(lambda (x y . z) (list 'my-arguments-are x y z))
.brev
-.IP "Variadic function:"
+A variadic function with no required arguments. The parameter name for the
+received arguments appears alone in place of the parameter list.
.verb
(lambda args (list 'my-list-of-arguments args))
.brev
-.IP "Optional arguments:"
+Same as the previous example, using a dotted notation specific to \*(TL.
+
+.verb
+ (lambda (. args) (list 'my-list-of-arguments args))
+.brev
+
+Note that
+.code "(. args)"
+is just a written notation equivalent to
+.code args
+and not a different object structure.
+
+Optional arguments:
.verb
[(lambda (x : y) (list x y)) 1] -> (1 nil)
[(lambda (x : y) (list x y)) 1 2] -> (1 2)
.brev
+Passing
+.code :
+(colon symbol) to request default value of optional parameter:
+
+.verb
+ [(lambda (x : (y 42) z) (list x y z)) 1 2 3] -> (1 2 3)
+ [(lambda (x : (y 42) z) (list x y z)) 1 : 3] -> (1 42 3)
+ [(lambda (x : (y 42) z) (list x y z)) 1] -> (1 42 nil)
+.brev
+
+Presence-indicating variable accompanying optional parameter:
+
+.verb
+ [(lambda (x : (y 42 have-y)) (list x y have-y)) 1 2]
+ -> (1 2 t)
+
+ [(lambda (x : (y 42 have-y)) (list x y have-y)) 1]
+ -> (1 42 nil)
+
+ ;; defaulting via : is indistinguishable from missing
+ [(lambda (x : (y 42 have-y)) (list x y have-y)) 1 :]
+ -> (1 42 nil)
+.brev
+
.coNP Macros @ flet and @ labels
.synb
.mets (flet >> ({( name < param-list << function-body-form *)}*)
.mets \ \ << body-form *)
-
.mets (labels >> ({( name < param-list << function-body-form *)}*)
.mets \ \ << body-form *)
.syne
@@ -14023,7 +15766,7 @@ Multiple functions in the same
do not have each other's names in their scopes.
More formally, the
-.metn function-body-form -s
+.metn function-body-form s
and
.meta param-list
of the functions defined by
@@ -14039,7 +15782,7 @@ and
.codn flet ,
the local functions that are defined are
lexically visible to the main
-.metn body-form -s.
+.metn body-form s.
Note that
.code labels
@@ -14107,12 +15850,19 @@ function invokes
.metn function ,
passing it the given arguments, if any.
+.meta function
+need not be a function; other kinds of objects
+can be used in place of functions with various semantics.
+The details are given in the description of the
+.code dwim
+operator.
+
.TP* Examples:
-Apply arguments
-.code "1 2"
-to a
+Apply
.code lambda
-which adds them to produce
+to
+.code "1 2"
+arguments, adding them to produce
.codn 3 :
.verb
@@ -14128,6 +15878,155 @@ on a named function; equivalent to
(call (fun list) 1 2)
.brev
+.coNP Functions @ apply and @ iapply
+.synb
+.mets (apply < function <> [ arg * << trailing-args ])
+.mets (iapply < function <> [ arg * << trailing-args ])
+.syne
+.desc
+The
+.code apply
+function invokes
+.metn function ,
+optionally passing to it an argument
+list. The return value of the
+.code apply
+call is that of
+.metn function .
+
+If no arguments are present after
+.metn function ,
+then
+.meta function
+is invoked without arguments.
+
+If one argument is present after
+.metn function ,
+then it is interpreted as
+.metn trailing-args .
+If this is a sequence (a list, vector or string),
+then the elements of the sequence are passed as individual arguments to
+.metn function .
+If
+.meta trailing-args
+is not a sequence, then
+.meta function
+is invoked
+with an improper argument list, terminated by the
+.meta trailing-args
+atom.
+
+If two or more arguments are present after
+.metn function ,
+then the last of these arguments is interpreted as
+.metn trailing-args .
+The previous arguments represent leading arguments.
+When the argument list is formed to which
+.meta function
+is applied, the leading arguments become individual arguments
+presented in the same order, followed by arguments taken from the
+.meta trailing_args
+list.
+
+Note that if
+.meta trailing-args
+value is an atom or an improper list, the function is then
+invoked with an improper argument list. Only a variadic
+function may be invoked with an improper argument list.
+Moreover, all of the function's required and optional
+parameters must be satisfied by elements of the
+improper list, such that the terminating atom either
+matches the
+.meta rest-param
+directly (see the
+.code lambda
+operator) or else the
+.meta rest-param
+receives an improper list terminated by that atom.
+To treat the terminating atom of an improper list as an
+ordinary element which can satisfy a required or optional
+function parameter, the
+.code iapply
+function may be used, described next.
+
+The
+.code iapply
+function ("improper apply") is similar to
+.codn apply ,
+except with regard to the treatment of
+.metn trailing-args .
+Firstly, under
+.codn iapply ,
+if
+.meta trailing-args
+is an atom other than
+.code nil
+(possibly a sequence, such as a vector or string),
+then it is treated as an ordinary argument:
+.meta function
+is invoked with a proper argument list, whose last element is
+.metn trailing-args .
+Secondly, if
+.meta trailing-args
+is a list, but an improper list, then the terminating atom of
+.meta trailing-args
+becomes an individual argument.
+This terminating atom is not split into multiple arguments,
+even if it is a sequence.
+Thus, in all possible cases,
+.code iapply
+treats an extra
+.cod2 non- nil
+atom as an argument, and never calls
+.meta function
+with an improper argument list.
+
+.TP* Examples:
+.verb
+ ;; '(1 2 3) becomes arguments to list, thus (list 1 2 3).
+ (apply (fun list) '(1 2 3)) -> (1 2 3)
+
+ ;; this effectively invokes (list 1 2 3 4)
+ (apply (fun list) 1 2 '(3 4)) -> (1 2 3 4)
+
+ ;; this effectively invokes (list 1 2 . 3)
+ (apply (fun list) 1 2 3)) -> (1 2 . 3)
+
+ ;; "abc" is separated into characters
+ ;; which become arguments of list
+ (apply (fun list) "abc") -> (#\ea #\eb #\ec)
+.brev
+
+.TP* "Dialect Note:"
+Note that some uses of this function that are necessary in other Lisp dialects
+are not necessary in \*(TL. The reason is that in \*(TL, improper list
+syntax is accepted as a compound form, and performs application:
+
+.verb
+ (foo a b . x)
+.brev
+
+Here, the variables
+.code a
+and
+.code b
+supply the first two arguments for
+.codn foo .
+In
+the dotted position,
+.code x
+must evaluate to a list or vector. The list or
+vector's elements are pulled out and treated as additional arguments for
+.codn foo .
+This syntax can only be used if
+.code x
+is a symbolic form or an atom. It
+cannot be a compound form, because
+.code "(foo a b . (x))"
+and
+.code "(foo a b x)"
+are equivalent structures.
+
.coNP Operator @ fun
.synb
.mets (fun << function-name )
@@ -14173,9 +16072,11 @@ retrieve a global macro expander using the function
.coNP Operator @ dwim
.synb
.mets (dwim << argument *)
-.mets <> '[' argument *']'
.mets (set (dwim < obj-place < index <> [ alt ]) << new-value )
+.mets (set (dwim >> { integer | << range } << obj-place ) << new-value )
+.mets <> '[' argument *']'
.mets (set >> '[' obj-place < index <> [ alt ]']' << new-value )
+.mets (set >> '[{' integer | << range } << obj-place ']' << new-value )
.syne
.desc
The
@@ -14230,7 +16131,7 @@ and is referenced by a dwim argument, this constitutes a conflict which is
resolved according to two rules. When nested scopes are concerned, then an
inner binding shadows an outer binding, regardless of their kind. An inner
variable binding for a symbol shadows an outer or global function binding, and
-.IR "vice versa" .
+vice versa.
If a symbol is bound to both a function and variable in the global namespace,
then the variable binding is favored.
@@ -14318,6 +16219,15 @@ is a list, then the
.meta sequence
form itself must be a place.
+This form is implemented using the
+.code ref
+accessor such that, except for the argument evaluation semantics of the DWIM
+brackets, it is equivalent to using the
+.mono
+.meti (ref < sequence << index )
+.onom
+syntax.
+
.meIP >> [ sequence << from-index..to-below-index ]
Retrieve the specified range of elements.
The range of elements is specified in the
@@ -14326,7 +16236,8 @@ and
.code to
fields of a range object. The
.code ..
-(dotdot) syntactic sugar denotes it construction via the
+(dotdot)
+syntactic sugar denotes the construction of the range object via the
.code rcons
function. See the section on Range Indexing below.
@@ -14348,14 +16259,25 @@ regardless of whether the target is a string, vector or list.
If the target is a string, the replacement sequence must be
a string, or a list or vector of characters.
-.meIP >> [ sequence << index-list ]
-Elements specified
-by
-.metn index-list ,
-which may be a list or vector,
-are extracted from
+The semantics is implemented using the
+.code sub
+accessor, such that the following equivalence holds:
+
+.verb
+ [seq from..to] <--> (sub seq from..to)
+.brev
+
+For this reason,
.meta sequence
-and returned as a sequence
+may be any object that is iterable by
+.codn iter-begin .
+
+.meIP >> [ sequence << index-seq ]
+Elements of
+.meta sequence
+specified by elements of
+.metn index-seq ,
+are extracted and returned as a sequence
of the same kind as
.metn sequence .
@@ -14371,7 +16293,7 @@ is one. If a sequence is assigned to this place,
then elements of the sequence are distributed to the
specified locations.
-The following equivalences hold between index-list-based indexing
+The following equivalences hold between index-sequence-based indexing
and the
.code select
and
@@ -14383,18 +16305,18 @@ always returns the value assigned, whereas
returns its first argument:
.verb
- [seq idx-list] <--> (select seq idx-list)
+ [seq idx-seq] <--> (select seq idx-seq)
- (set [seq idx-list] new) <--> (replace seq new idx-list)
+ (set [seq idx-seq] new) <--> (replace seq new idx-seq)
.brev
Note that unlike the select function, this does not support
.mono
-.meti >> [ hash << index-list ]
+.meti >> [ hash << index-seq ]
.onom
because since hash keys may be lists, that syntax is
indistinguishable from a simple hash lookup where
-.meta index-list
+.meta index-seq
is the key.
.meIP >> [ hash < key <> [ alt ]]
@@ -14406,7 +16328,20 @@ if there is no such entry. The expression
.meta alt
is always evaluated, whether or not its value is used.
-.meIP >> [ regex >> [ start <> [ from-end ]] < string ]
+.meIP >> [ search-tree << key ]
+Retrieves an element from the search tree as if by applying the
+.code tree-lookup
+function to
+.metn key .
+
+.meIP >> [ search-tree << from-key..to-below-key ]
+Retrieves a list of elements from the search tree as if by evaluating the
+.mono
+.meti (sub-tree < search-tree < from-key << to-below-key )
+.onom
+expression.
+
+.meIP >> [ regex >> [ start <> [ from-end ]] << string ]
Determine whether regular expression
.meta regex
matches
@@ -14467,14 +16402,48 @@ These, in turn, rely on the specialized functions.
.code carray-sub
and
.codn carray-replace .
+
.meIP >> [ buf << index ]
Indexing is supported for objects of type
.codn buf .
This provides a way to access and store the individual bytes
of a buffer.
+
+.meIP >> [ integer << sequence ]
+If the left argument is an integer, it denotes selection of an
+element from
+.metn sequence .
+The
+.meta integer
+value acts as the index into a vector-like or list-like sequence,
+or a key into a hash table.
+
+.meIP >> [ range >> { seq | << ind }]
+If the left argument is a range, and there is one argument, the
+semantics is that of the
+.code rangeref
+function: either the selection of a point from the range by
+an integer index
+.metn ind ,
+or the selection of a subrange of sequence
+.meta seq
+according to the endpoints of
+.metn range .
.RE
.PP
+Note that the various above forms are not actually cases of the
+.code dwim
+operator but the due to the semantics of the left argument objects being used
+as functions. All of the semantics described above is available in any
+situation in which an object is used as a function: for instance, as an
+argument of the
+.code call
+or
+.code apply
+operators, or the functional argument in
+.codn mapcar .
+
.TP* "Range Indexing:"
Vector and list range indexing is based from zero, meaning
that the first element is numbered zero, the second one
@@ -14493,17 +16462,17 @@ The symbol
.code t
represents the position one past the end of the vector, string or
list, so
-.code "0 .. t"
+.code 0..t
denotes the entire list or vector, and the range
-.code "t .. t"
+.code t..t
represents the empty range just beyond the last element.
It is possible to assign to
-.codn "t .. t" .
+.codn t..t .
For instance:
.verb
(defvar list '(1 2 3))
- (set [list t .. t] '(4)) ;; list is now (1 2 3 4)
+ (set [list t..t] '(4)) ;; list is now (1 2 3 4)
.brev
The value zero has a "floating" behavior when used as the end of a range.
@@ -14541,9 +16510,9 @@ means that there
is a variable called
.codn car ,
which holds a function, which is retrieved from that
-variable and the argument
+variable and applied to the
.code 1
-is applied to it. In the expression
+argument. In the expression
.codn "(car car)" ,
both occurrences of
.code car
@@ -14560,7 +16529,7 @@ the two occurrences refer to different bindings:
one is a function and the other a variable.
Thus there can exist a variable
.code car
-which holds a cons cell object, rather than the
+which holds a cons-cell object, rather than the
.code car
function, and the form makes sense.
@@ -14665,14 +16634,13 @@ made by
.code copy-fun
has its own copy of that environment. If the copied function changes the
values of captured lexical variables, the original function is not affected by
-these changes and
-.IR "vice versa" .
+these changes and vice versa.
The entire lexical environment is copied; the copy and original function do not
share any portion of the environment at any level of nesting.
.SS* Sequencing, Selection and Iteration
-.coNP Operators @ progn and @ prog1
+.coNP Operators/Functions @ progn and @ prog1
.synb
.mets (progn << form *)
.mets (prog1 << form *)
@@ -14680,16 +16648,20 @@ share any portion of the environment at any level of nesting.
.desc
The
.code progn
-operator evaluates forms in order, and returns the value
-of the last form. The return value of the form
+operator evaluates each
+.meta form
+in left-to-right order, and returns the value
+of the last form. The value of the form
.code (progn)
is
.codn nil .
The
.code prog1
-operator evaluates forms in order, and returns the value
-of the first form. The return value of the form
+operator evaluates each
+.meta form
+in left-to-right order, and returns the value
+of the first form. The value of the form
.code (prog1)
is
.codn nil .
@@ -14701,6 +16673,66 @@ of a body of forms, the value of the last of which is returned.
These operators are said to feature an implicit
.codn progn .
+These special operators are also functions. The
+.code progn
+function accepts zero or more arguments. It returns its last argument, or
+.code nil
+if called with no arguments. The
+.code prog1
+function likewise accepts zero or more arguments. It returns its first argument, or
+.code nil
+if called with no arguments.
+
+.TP* "Dialect Notes:"
+In ANSI Common Lisp,
+.code prog1
+requires at least one argument. Neither
+.code prog
+nor
+.code prog1
+exist as functions.
+
+.coNP Macro/Function @ prog2
+.synb
+.mets (prog2 << form *)
+.syne
+.desc
+The
+.code prog2
+evaluates each
+.meta form
+in left-to-right order. The value is that of the second form, if present,
+otherwise it is
+.codn nil .
+
+The form
+.code "(prog2 1 2 3)"
+yields
+.codn 2 .
+The value of
+.code "(prog2 1 2)"
+is also
+.codn 2 ;
+.code "(prog2 1)"
+and
+.code "(prog2)"
+yield
+.codn nil .
+
+The
+.code prog2
+symbol also has a function binding. The
+.code prog2
+function accepts any number of arguments. If invoked with at least two arguments,
+it returns the second one. Otherwise it returns
+.codn nil .
+
+.TP* "Dialect Notes:"
+In ANSI Common Lisp,
+.code prog2
+requires at least two arguments.
+It does not exist as a function.
+
.coNP Operator @ cond
.synb
.mets (cond >> {( test << form *)}*)
@@ -14747,18 +16779,15 @@ yields
These three macros arrange for the evaluation of
.metn test-form ,
whose value is then compared against the key or keys in each
-.meta normal-clause
-in turn.
+.metn normal-clause .
When the value matches a key, then the remaining forms of
.meta normal-clause
are evaluated, and the value of the last form is returned; subsequent
-clauses are not evaluated. When the value doesn't match any of the keys
-of a
-.meta normal-clause
-then the next
+clauses are not evaluated.
+
+If no
.meta normal-clause
-is tested.
-If all these clauses are exhausted, and there is no
+matches, and there is no
.metn else-clause ,
then the value nil is returned. Otherwise, the forms in the
.meta else-clause
@@ -14767,6 +16796,12 @@ If there are no forms, then
.code nil
is returned.
+If duplicates keys are present in such a way that the value of the
+.meta test-form
+matches multiple
+.metn normal-clause s,
+it is unspecified which of those clauses is evaluated.
+
The syntax of a
.meta normal-clause
takes on these two forms:
@@ -14862,7 +16897,7 @@ The
.meta else-clause
works the same way under these macros as under
.code caseq
-.IR "et al" .
+et al.
Note that although in a
.metn normal-clause ,
@@ -14871,7 +16906,7 @@ must not be the atom
.codn t ,
there is no restriction against it being
an atom which evaluates to
-.code t.
+.codn t .
In this situation, the value
.code t
has no special meaning.
@@ -14903,7 +16938,75 @@ macros as case keys.
--> "cool"
.brev
-.coNP Operator/function @ if
+.coNP Macros @, ecaseq @, ecaseql @, ecasequal @, ecaseq* @ ecaseql* and @ ecasequal*
+.synb
+.mets (ecaseq < test-form << normal-clause * <> [ else-clause ])
+.mets (ecaseql < test-form << normal-clause * <> [ else-clause ])
+.mets (ecasequal < test-form << normal-clause * <> [ else-clause ])
+.mets (ecaseq* < test-form << normal-clause * <> [ else-clause ])
+.mets (ecaseql* < test-form << normal-clause * <> [ else-clause ])
+.mets (ecasequal* < test-form << normal-clause * <> [ else-clause ])
+.syne
+.desc
+These macros are error-catching variants of, respectively,
+.codn caseq ,
+.codn caseql ,
+.codn casequal ,
+.codn caseq* ,
+.code caseql*
+and
+.codn casequal* .
+
+If the
+.meta else-clause
+is present in the invocation of an error-catching case macro, then the the
+invocation is precisely equivalent to the corresponding non-error-trapping
+variant.
+
+If the
+.meta else-clause
+is missing in the invocation of an error-catching variant, then a default
+.meta else-clause
+is inserted which throws an exception of type
+.codn case-error ,
+derived from
+.codn error .
+After this insertion, the semantics follows that of the non-error-trapping
+variant.
+
+For instance,
+.codn "(ecaseql 3)" ,
+which has no
+.metn else-clause ,
+is equivalent to
+.mono
+.meti (caseql 3 (t << expr ))
+.onom
+where
+.meta expr
+indicates the inserted expression which throws
+.codn case-error .
+However,
+.code "(ecaseql 3 (t 42))"
+is simply equivalent to
+.codn "(caseql 3 (t 42))" ,
+since it has an
+.metn else-clause .
+
+Note: the error-catching case macros are intended for situations in which it is
+a matter of program correctness that every possible value of
+.meta test-form
+matches a
+.metn normal-clause ,
+such that if a failure to match occurs, it indicates a software defect.
+The error-throwing
+.meta else-clause
+helps to ensure that the error situation is noticed.
+Without this clause, the case macro terminates with a value of
+.codn nil ,
+which may conceal the defect and delay its identification.
+
+.coNP Operator/Function @ if
.synb
.mets (if < cond < t-form <> [ e-form ])
.mets '['if < cond < then <> [ else ]']'
@@ -14915,7 +17018,7 @@ operator and an
.code if
function. A list form with the symbol
.code if
-in the fist position is interpreted as an invocation of the
+in the first position is interpreted as an invocation of the
.code if
operator.
The function can be accessed using the DWIM bracket notation and in other
@@ -14945,7 +17048,7 @@ were specified as
The
.code if
-function provides no evaluation control. All of arguments
+function provides no evaluation control. All of its arguments
are evaluated from left to right. If the
.meta cond
argument is true, then it
@@ -14956,7 +17059,7 @@ argument, otherwise it returns the value of the
argument if present, otherwise it returns
.codn nil .
-.coNP Operator/function @ and
+.coNP Operator/Function @ and
.synb
.mets (and << form *)
.mets '['and << arg *']'
@@ -14969,7 +17072,7 @@ operator and an
function. A list form with the
symbol
.code and
-in the fist position is interpreted as an invocation of the
+in the first position is interpreted as an invocation of the
operator. The function can be accessed using the DWIM bracket notation and in
other ways.
@@ -14988,25 +17091,28 @@ operator evaluates as follows. First, a return value is
established and initialized to the value
.codn t .
The
-.metn form -s,
+.metn form s,
if any, are
evaluated from left to right. The return value is overwritten with
-the result of each form. Evaluation stops when all forms are exhausted,
-or when
+the result of each
+.metn form .
+Evaluation stops when all
+.metn form s
+are exhausted, or when
.code nil
is stored in the return value.
When evaluation stops, the operator yields the return value.
The
.code and
-function provides no evaluation control; it receives all of its
+function provides no evaluation control: it receives all of its
arguments fully evaluated. If it is given no arguments, it returns
.codn t .
If it is given one or more arguments, and any of them are
.codn nil ,
it returns
.codn nil .
-Otherwise it returns the value of the last argument.
+Otherwise, it returns the value of the last argument.
.TP* Examples:
.verb
@@ -15015,7 +17121,36 @@ Otherwise it returns the value of the last argument.
(and 1 2 3) -> 3 ;; shorthand for (if (and 1 2) 3).
.brev
-.coNP Operator/function @ or
+.coNP Macro/Function @ nand
+.synb
+.mets (nand << form *)
+.mets '['nand << arg *']'
+.syne
+.desc
+There exist both a
+.code nand
+macro and a
+.code nand
+function.
+A list form with the symbol
+.code nand
+in the first position is interpreted as an invocation of the macro.
+The function can be accessed using the DWIM bracket notation and in
+other ways.
+
+The
+.code nand
+macro and function are the logical negation of the
+.code and
+operator and function.
+They are related according to the following equivalences:
+
+.verb
+ (nand f0 f1 f2 ...) <--> (not (and f0 f1 f2 ...))
+ [nand f0 f1 f2 ...] <--> (not [and f0 f1 f2 ...])
+.brev
+
+.coNP Operator/Function @ or
.synb
.mets (or << form *)
.mets '['or << arg *']'
@@ -15028,16 +17163,19 @@ operator and an
function. A list form with the
symbol
.code or
-in the fist position is interpreted as an invocation of the
+in the first position is interpreted as an invocation of the
operator. The function can be accessed using the DWIM bracket notation and in
other ways.
-The or operator provides three functionalities in one. It computes the
+The
+.code or
+operator provides three functionalities in one. It computes the
logical "or" function over several forms. It controls evaluation (a.k.a.
"short-circuiting"). The behavior of
.code or
-also provides an idiom for the selection of the first non-nil value from a
-sequence of forms.
+also provides an idiom for the selection of the first
+.cod2 non- nil
+value from a sequence of forms.
The
.code or
@@ -15045,18 +17183,19 @@ operator evaluates as follows. First, a return value is
established and initialized to the value
.codn nil .
The
-.metn form -s,
+.metn form s,
if any,
are evaluated from left to right. The return value is overwritten
with the result of each
.metn form .
-Evaluation stops when all forms are
-exhausted, or when a true value is stored into the return value.
+Evaluation stops when all
+.metn form s
+are exhausted, or when a true value is stored into the return value.
When evaluation stops, the operator yields the return value.
The
.code or
-function provides no evaluation control; it receives all of its
+function provides no evaluation control: it receives all of its
arguments fully evaluated. If it is given no arguments, it returns
.codn nil .
If all of its arguments are
@@ -15075,13 +17214,44 @@ returns the value of the first argument which isn't
(or (> 10 20) (stringp "foo")) -> t
.brev
+.coNP Macro/Function @ nor
+.synb
+.mets (nor << form *)
+.mets '['nor << arg *']'
+.syne
+.desc
+There exist both a
+.code nor
+macro and a
+.code nor
+function.
+A list form with the symbol
+.code nor
+in the first position is interpreted as an invocation of the macro.
+The function can be accessed using the DWIM bracket notation and in
+other ways.
+
+The
+.code nor
+macro and function are the logical negation of the
+.code or
+operator and function.
+They are related according to the following equivalences:
+
+.verb
+ (nor f0 f1 f2 ...) <--> (not (or f0 f1 f2 ...))
+ [nor f0 f1 f2 ...] <--> (not [or f0 f1 f2 ...])
+.brev
+
.coNP Macros @ when and @ unless
.synb
.mets (when < expression << form *)
.mets (unless < expression << form *)
.syne
.desc
-The when macro operator evaluates
+The
+.code when
+macro operator evaluates
.metn expression .
If
.meta expression
@@ -15089,14 +17259,18 @@ yields
true, and there are additional forms, then each
.meta form
is evaluated.
-The value of the last form is becomes the result value of the when form.
+The value of the last form becomes the result value of the
+.code when
+form.
If there are no forms, then the result is
.codn nil .
The
.code unless
-operator is similar to when, except that it reverses the
-logic of the test. The forms, if any, are evaluated if, and only if
+operator is similar to
+.codn when ,
+except that it reverses the
+logic of the test. The forms, if any, are evaluated if and only if
.meta expression
is false.
@@ -15128,14 +17302,17 @@ repeating all of the previous steps.
The
.code until
-macro operator is similar to while, except that the until form
-terminates when
+macro operator is similar to
+.codn while ,
+except that the
+.code until
+form terminates when
.meta expression
evaluates true, rather than false.
These operators arrange for the evaluation of all their enclosed forms
in an anonymous block. Any of the
-.metn form -s,
+.metn form s,
or
.metn expression ,
may use
@@ -15167,7 +17344,7 @@ and
.codn until .
They differ in one respect: they begin by evaluating the
-.metn form -s
+.metn form s
one time unconditionally, without first evaluating
.metn expression .
After this evaluation, the subsequent behavior is
@@ -15179,7 +17356,7 @@ or
Another way to regard the behavior is that that these forms execute
one iteration unconditionally, without evaluating the termination test prior to
the first iteration. Yet another view is that these constructs relocate the
-test from the "top of the loop" to the "bottom of the loop".
+test from the top of the loop to the bottom of the loop.
.coNP Macro @ whilet
.synb
@@ -15194,24 +17371,24 @@ binding.
The evaluation of the form takes place as follows. First, fresh bindings are
established for
-.metn sym -s
+.metn sym s
as if by the
.code let*
operator.
It is an error for the list of variable bindings to be empty.
-After the establishment of the bindings, the the value of the
+After the establishment of the bindings, the value of the last
.meta sym
is tested. If the value is
.codn nil ,
then
.code whilet
terminates. Otherwise,
-.metn body-form -s
+.metn body-form s
are evaluated in the scope of the variable bindings, and then
.code whilet
iterates from the beginning, again establishing fresh bindings for the
-.metn sym -s,
+.metn sym s,
and testing the value of the last
.metn sym .
@@ -15294,13 +17471,13 @@ counterpart.
If the list of variable bindings is empty, it is interpreted as the atom
.code nil
and treated as an
-.codn atom-form .
+.metn atom-form .
If one or more bindings are specified rather than
.metn atom-form ,
then the evaluation of these forms takes
place as follows. First, fresh bindings are established for
-.metn sym -s
+.metn sym s
as if by the
.code let*
operator.
@@ -15346,13 +17523,13 @@ is returned.
In the case of the
.code whenlet
operator, if the test is true, then the
-.metn body-form -s,
+.metn body-form s,
if any, are evaluated. The value of the last one is
returned, otherwise
.code nil
if the forms are missing.
If the test is false, then evaluation of
-.metn body-form -s
+.metn body-form s
is skipped, and
.code nil
is returned.
@@ -15391,8 +17568,8 @@ is returned.
.coNP Macro @ condlet
.synb
.mets (condlet
-.mets \ \ ([({ sym | >> ( sym << init-form )}+) | << atom-form ]
-.mets \ \ \ << body-form *)*)
+.mets \ ([({ sym | >> ( sym << init-form )}+) | << atom-form ]
+.mets \ \ << body-form *)*)
.syne
.desc
The
@@ -15404,10 +17581,10 @@ Each argument is a compound consisting of at least one item: a list of
bindings or
.metn atom-form .
This item is followed by zero or more
-.metn body-form -s.
+.metn body-form s.
-If the are are no
-.metn body-form -s
+If there are no
+.metn body-form s
then the situation is treated as if there were a single
.meta body-form
specified as
@@ -15421,7 +17598,7 @@ leftmost.
If the argument's left item is an
.meta atom-form
then the form is evaluated. If it yields true, then the
-.metn body-form -s
+.metn body-form s
next to it are evaluated in order, and the
.code condlet
form terminates, yielding the value obtained from the last
@@ -15435,7 +17612,7 @@ with exactly the same logic as under the
.code iflet
macro. If the last binding contains a true value, then the
adjoining
-.metn body-form -s
+.metn body-form s
are evaluated in a scope in which all of the bindings are visible, and
.code condlet
terminates, yielding the value of the last
@@ -15454,17 +17631,17 @@ runs out of arguments, it terminates and returns
.verb
(let ((l '(1 2 3)))
(condlet
- ;; first arg
- (((a (first l) ;; a binding gets 1
- (b (second l)) ;; b binding gets 2
- (g (> a b)))) ;; last variable g is nil
- 'foo) ;; not evaluated
- ;; second arg
- (((b (second l) ;; b gets 2
- (c (third l)) ;; c gets 3
- (g (> b c)))) ;; last variable g is true
- 'bar))) ;; condlet terminates
- --> bar ;; result is bar
+ ;; first arg
+ (((a (first l) ;; a binding gets 1
+ (b (second l)) ;; b binding gets 2
+ (g (> a b)))) ;; last variable g is nil
+ 'foo) ;; not evaluated
+ ;; second arg
+ (((b (second l) ;; b gets 2
+ (c (third l)) ;; c gets 3
+ (g (> b c)))) ;; last variable g is true
+ 'bar))) ;; condlet terminates
+ --> bar ;; result is bar
.brev
.coNP Macro @ ifa
@@ -15474,7 +17651,7 @@ runs out of arguments, it terminates and returns
.desc
The
.code ifa
-macro provides a anaphoric conditional operator resembling the
+macro provides an anaphoric conditional operator resembling the
.code if
operator. Around the evaluation of the
.meta then
@@ -15503,7 +17680,13 @@ alias is used multiple times in the
.meta then
or
.meta else
-expressions. Otherwise, if the form is not a syntactic place
+expressions. Furthermore, the place form is implicitly surrounded with
+.code read-once
+so that the place's value is accessed only once, and multiple references to
+.code it
+refer to a copy of the value cached in a hidden variable, rather than
+generating multiple accesses to the place.
+Otherwise, if the form is not a syntactic place
.code it
is bound as an ordinary lexical variable to
the form's value.
@@ -15761,7 +17944,7 @@ is evaluated one time to produce a limiting value, which should be a number.
Then, if the value of
.meta var
is less than the limiting value, the
-.metn body-form -s
+.metn body-form s
are evaluated,
.meta var
is incremented by one, and the process repeats with a new comparison
@@ -15780,7 +17963,7 @@ unless a
.meta result-form
is present, in which case the value of that form specifies the return value.
-.metn body-form -s
+.metn body-form s
as well as
.meta result-form
are evaluated in the scope in which the binding of
@@ -15798,22 +17981,25 @@ is visible.
.syne
.desc
These operators establish a loop for iterating over the elements of one or more
-lists. Each
+sequences. Each
.meta init-form
-must evaluate to a list. The lists are then iterated in
+must evaluate to an iterable object that is suitable as an argument for the
+.code iter-begin
+function.
+The sequences are then iterated in
parallel over repeated evaluations of the
-.metn body-form -s,
+.metn body-form s,
with each
.meta sym
-variable being assigned to successive elements of its list. The shortest list
-determines the number of iterations, so if any of the
-.metn init-form -s
+variable being assigned to successive elements of its sequence. The shortest
+list determines the number of iterations, so if any of the
+.metn init-form s
evaluate to
-an empty list, the body is not executed.
+an empty sequence, the body is not executed.
If the list of
.mono
-.meti >> ( syn << init-form )
+.meti >> ( sym << init-form )
.onom
pairs itself is empty, then an infinite loop is specified.
@@ -15866,9 +18052,9 @@ differ from
and
.code append-each
in the following way. The plain forms evaluate the
-.metn init-form -s
+.metn init-form s
in an environment in which none of the
-.code sym
+.meta sym
variables are yet visible. By contrast, the alternate
forms evaluate each
.meta init-form
@@ -15886,12 +18072,62 @@ iteration, however, the
variables are assigned the first item from each
of their lists.
+.TP* Note:
+The semantics of
+.code collect-each
+may be understood in terms of an equivalence to a code pattern involving
+.codn mapcar :
+
+.mono
+ (collect-each ((x xinit) (mapcar (lambda (x y)
+ (y yinit)) <--> body)
+ body) xinit yinit)
+.onom
+
+The
+.code collect-each*
+variant may be understood in terms of the following equivalence involving
+.code let*
+for sequential binding and
+.codn mapcar :
+
+.mono
+ (collect-each* ((x xinit) (let* ((x xinit)
+ (y yinit)) <--> (y yinit))
+ body) (mapcar (lambda (x y)
+ body)
+ x y))
+.onom
+
+However, note that the
+.code let*
+as well as each invocation of the
+.code lambda
+binds fresh instances of the variables, whereas these operators are permitted
+to bind a single instance of the variables, which are first initialized with
+the initializing expressions, and then reused as iteration variables which are
+stepped by assignment.
+
+The other operators may be understood likewise, with the substitution
+of the
+.code mapdo
+function in the case of
+.code each
+and
+.code each*
+and of the
+.code mappend
+function in the case of
+.code append-each
+and
+.codn append-each* .
+
.TP* Example:
.mono
;; print numbers from 1 to 10 and whether they are even or odd
- (each* ((n (range 1 10)) ;; n list a list here!
+ (each* ((n 1..11) ;; n is just a range object in this scope
(even (collect-each ((m n)) (evenp m))))
- ;; n is an item here!
+ ;; n is an integer in this scope
(format t "~s is ~s\en" n (if even "even" "odd")))
.onom
.TP* Output:
@@ -15908,19 +18144,24 @@ of their lists.
10 is "even"
.onom
-.coNP Operators @ for and @ for*
+.coNP Macros @ for and @ for*
.synb
.mets ({for | for*} >> ({ sym | >> ( sym << init-form )}*)
.mets \ \ \ \ \ \ \ \ \ \ \ \ \ >> ([ test-form << result-form *])
-.mets \ \ \ \ \ \ \ \ \ \ \ \ \ <> ( inc-form *)
+.mets \ \ \ \ \ \ \ \ \ \ \ \ \ <> [( inc-form *)]
.mets \ \ << body-form *)
+.mets ""
+.mets ({for | for*} >> ({ sym | >> ( sym << init-form )}*)
+.mets \ \ \ \ \ \ \ \ \ \ \ \ \ >> ([ test-form << result-form *]))
+.mets ""
+.mets ({for | for*} >> ({ sym | >> ( sym << init-form )}*))
.syne
.desc
-The
+The macros
.code for
and
.code for*
-operators combine variable binding with loop iteration.
+combine variable binding with loop iteration.
The first argument is a list of variables with optional initializers,
exactly the same as in the
.code let
@@ -15937,11 +18178,17 @@ and
.code let*
with regard to this list of variables.
+The second variant in the above syntax synopsis shows that when
+.metn body-form s
+are absent, then a list of
+.metn inc-form s
+which is empty may be omitted from the syntax.
+
The
.code for
and
.code for*
-operators execute these steps:
+macros execute these steps:
.RS
.IP 1.
Establish an anonymous block over the entire form, allowing
@@ -15971,9 +18218,9 @@ yields
then the loop terminates. Each
.meta result-form
is evaluated, and the value of the last of these
-forms is is the result value of the loop.
+forms is the result value of the loop.
If there are no
-.metn result-form -s
+.metn result-form s
then the result value is
.codn nil .
If the
@@ -15990,16 +18237,6 @@ is evaluated in turn. Then, each
is evaluated in turn and processing resumes at step 2.
.RE
-.IP
-Furthermore, the
-.code for
-and
-.code for*
-operators establish an anonymous block,
-allowing the
-.code return
-operator to be used to terminate at any point.
-
.coNP Macros @ doloop and @ doloop*
.synb
.mets ({doloop | doloop*}
@@ -16023,7 +18260,7 @@ Each
element in the form must be a symbol suitable for use as a variable name.
The
-.metn tagbody-form -s
+.metn tagbody-form s
are placed into an implicit
.codn tagbody ,
meaning that a
@@ -16046,11 +18283,11 @@ Then, in the environment in which these variables now exist,
is evaluated. If that form yields
.codn nil ,
then the loop terminates. The
-.metn result-form -s
+.metn result-form s
are evaluated, and the value of the last one is returned.
If
-.metn result-form -s
+.metn result-form s
are absent, then
.code nil
is returned.
@@ -16063,11 +18300,11 @@ is also absent, then the loop terminates and returns
If
.meta test-form
produces a true value, then
-.metn result-form -s
+.metn result-form s
are not evaluated. Instead, the implicit
.code tagbody
-comprised of the
-.metn tagbody-form -s
+consisting of the
+.metn tagbody-form s
is evaluated.
If that evaluation terminates normally, the loop variables are
then updated by assigning to each
@@ -16175,6 +18412,417 @@ into the
.meta step-form
position.
+.coNP Macros @, sum-each @, sum-each* @ mul-each and @ mul-each*
+.synb
+.mets (sum-each >> ({( sym << init-form )}*) << body-form *)
+.mets (sum-each* >> ({( sym << init-form )}*) << body-form *)
+.mets (mul-each >> ({( sym << init-form )}*) << body-form *)
+.mets (mul-each* >> ({( sym << init-form )}*) << body-form *)
+.syne
+.desc
+The macros
+.codn sum-each ,
+and
+.code mul-each
+behave very similarly to the
+.code each
+operator. Whereas the
+.code each
+operator form returns
+.code nil
+as its result, the
+.code sum-each
+and
+.code mul-each
+forms, if they execute to completion and return normally, return
+an accumulated value.
+
+The
+.code sum-each
+macro initializes newly instantiated, hidden accumulator variable
+to the value
+.codn 0 .
+For each iteration of the loop, the
+.metn body-form s
+are evaluated, and are expected to produce a value. This value
+is added to the current value of the hidden accumulator using the
+.code +
+function, and the result is stored into the accumulator. If
+.code sum-each
+returns normally, then the value of this accumulator becomes its
+resulting value.
+
+The
+.code mul-each
+macro similarly initializes a hidden accumulator to the value
+.codn 1 .
+The value from each iteration of the body is multiplied with
+the accumulator using the
+.code *
+function, and the result is stored into the accumulator. If
+.code mul-each
+returns normally, then the value of this accumulator becomes
+its resulting value.
+
+The
+.code sum-each*
+and
+.code mul-each*
+variants of the macros implement the sequential scoping rule for
+the variable bindings, exactly the way
+.code each*
+alters the semantics of
+.codn each .
+
+The
+.metn body-form s
+are enclosed in an implicit anonymous block. If the forms terminate
+by returning from the anonymous block then these macros terminate
+with the specified value.
+
+When
+.code sum-each*
+and
+.code sum-each
+are specified with variables whose values specify zero iterations,
+or with no variables at all, the form terminates with a value of
+.codn 0 .
+In this situation,
+.code mul-each
+and
+.code mul-each*
+terminate with
+.codn 1 .
+Note that this behavior differs from
+.codn each ,
+and its closely-related operators, which loop infinitely when no variables are
+specified.
+
+It is unspecified whether
+.code mul-each
+and
+.code mul-each*
+continue iterating when the accumulator takes on a value satisfying the
+.code zerop
+predicate.
+
+.coNP Macros @, each-true @, some-true @ each-false and @ some-false
+.synb
+.mets (each-true >> ({( sym << init-form )}*) << body-form *)
+.mets (some-true >> ({( sym << init-form )}*) << body-form *)
+.mets (each-false >> ({( sym << init-form )}*) << body-form *)
+.mets (some-false >> ({( sym << init-form )}*) << body-form *)
+.syne
+.desc
+These macros iterate zero or more variables over sequences, similarly to the
+.code each
+operator, and calculate logical results, with short-circuiting semantics.
+
+The
+.code each-true
+macro initializes an internal result variable to the
+.code t
+value. It then evaluates the
+.metn body-form s
+for each tuple of variable values, replacing the result variable with
+the value produced by these forms. If that value is
+.codn nil ,
+the iteration stops. When the iteration terminates normally, the
+value of the result variable is returned.
+
+If no variables are specified, termination occurs immediately.
+Note that this is different from the
+.code each
+operator, which iterates indefinitely if no variables are specified.
+
+The
+.metn body-form s
+are surrounded by an implicit anonymous block, making it possible
+to terminate via
+.code return
+or
+.codn return-from .
+In these cases, the form terminates with
+.code nil
+or the specified return value. The internal result is ignored.
+
+The
+.code some-true
+macro is similar to
+.codn each-true ,
+with the following differences.
+The internal result variable is initialized to
+.code nil
+rather than
+.codn t .
+The iteration stops whenever the
+.metn body-form s
+produce a true value, and that value is returned.
+
+The
+.code each-false
+and
+.code some-false
+macros are, respectively, similar to
+.code each-true
+and
+.codn some-true ,
+with one difference. After each iteration, the value produced by the
+.metn body-form s
+is logically inverted using the
+.code not
+function prior to being assigned to the result variable.
+
+.TP* Examples:
+
+.verb
+ (each-true ()) -> t
+ (each-true ((a ()))) -> t
+ (each-true ((a '(1 2 3))) a) -> 3
+
+ (each-true ((a '(1 2 3))
+ (b '(4 5 6)))
+ (< a b))
+ -> t
+
+ (each-true ((a '(1 2 3))
+ (b '(4 0 6)))
+ (< a b))
+ -> nil
+
+ (some-true ((a '(1 2 3))) a) -> 1
+ (some-true ((a '(nil 2 3))) a) -> 2
+ (some-true ((a '(nil nil nil))) a) -> nil
+
+ (some-true ((a '(1 2 3))
+ (b '(4 0 6)))
+ (< a b))
+ -> t
+
+ (some-true ((a '(1 2 3))
+ (b '(0 1 2)))
+ (< a b))
+ -> nil
+
+ (each-false ((a '(1 2 3))
+ (b '(4 5 6)))
+ (> a b))
+ -> t
+
+ (each-false ((a '(1 2 3))
+ (b '(4 0 6)))
+ (> a b))
+ -> nil
+
+ (some-false ((a '(1 2 3))
+ (b '(4 0 6)))
+ (> a b))
+ -> t
+
+ (some-false ((a '(1 2 3))
+ (b '(0 1 2)))
+ (> a b))
+ -> nil
+.brev
+
+.coNP Macros @, each-prod @ collect-each-prod and @ append-each-prod
+.synb
+.mets (each-prod >> ({( sym << init-form )}*) << body-form *)
+.mets (collect-each-prod >> ({( sym << init-form )}*) << body-form *)
+.mets (append-each-prod >> ({( sym << init-form )}*) << body-form *)
+.syne
+.desc
+The macros
+.codn each-prod ,
+.code collect-each-prod
+and
+.code append-each-prod
+have a similar syntax to
+.codn each ,
+.code collect-each
+and
+.codn collect-each-prod .
+However, instead of iterating over sequences in parallel, they iterate over
+the Cartesian product of the elements from the sequences.
+The difference between
+.code collect-each
+and
+.code collect-each-prod
+is analogous to that between the functions
+.code mapcar
+and
+.codn maprod .
+
+Like in the
+.code each
+operator family, the
+.metn body-form s
+are surrounded by an anonymous block. If these forms execute a return from
+this block, then these macros terminate with the specified return value.
+
+When no iterations are performed, including in the case when an empty
+list of variables is specified, all these macro forms terminate and return
+.codn nil .
+Note that this behavior differs from
+.codn each ,
+and its closely-related operators, which loop infinitely when no variables are
+specified.
+
+With one caveat noted below, these macros can be understood as providing
+syntactic sugar according to the pattern established by the following
+equivalences:
+
+.mono
+ (each-prod (block nil
+ ((x xinit) (let ((#:gx xinit) (#:gy yinit))
+ (y yinit)) <--> (maprodo (lambda (x y)
+ body) body)
+ #:gx #:gy))
+
+ (collect-each-prod (block nil
+ ((x xinit) (let ((#:gx xinit) (#:gy yinit))
+ (y yinit)) <--> (maprod (lambda (x y)
+ body) body)
+ #:gx #:gy))
+
+ (append-each-prod (block nil
+ ((x xinit) (let ((#:gx xinit) (#:gy yinit))
+ (y yinit)) <--> (maprend (lambda (x y)
+ body) body)
+ #:gx #:gy))
+.onom
+
+However, note that each invocation of the
+.code lambda
+binds fresh instances of the variables, whereas these operators are
+permitted to bind a single instance of the variables, which are then stepped by
+assignment.
+
+.TP* Example:
+
+.mono
+ (collect-each-prod ((a '(a b c))
+ (n #(1 2)))
+ (cons a n))
+
+ --> ((a . 1) (a . 2) (b . 1) (b . 2) (c . 1) (c . 2))
+.onom
+
+.coNP Macros @, each-prod* @ collect-each-prod* and @ append-each-prod*
+.synb
+.mets (each-prod* >> ({( sym << init-form )}*) << body-form *)
+.mets (collect-each-prod* >> ({( sym << init-form )}*) << body-form *)
+.mets (append-each-prod* >> ({( sym << init-form )}*) << body-form *)
+.syne
+.desc
+The macros
+.codn each-prod* ,
+.code collect-each-prod*
+and
+.code append-each-prod*
+are variants of
+.codn each-prod ,
+.code collect-each-prod
+and
+.code append-each-prod
+with sequential binding.
+
+These macros can be understood as providing syntactic sugar according to the
+pattern established by the following equivalences:
+
+.mono
+ (each-prod* (let* ((x xinit)
+ ((x xinit) (y yinit))
+ (y yinit)) <--> (maprodo (lambda (x y) body)
+ body) x y)
+
+ (collect-each-prod* (let* ((x xinit)
+ ((x xinit) (y yinit))
+ (y yinit)) <--> (maprod (lambda (x y) body)
+ body) x y)
+
+ (append-each-prod* (let* ((x xinit)
+ ((x xinit) (y yinit))
+ (y yinit)) <--> (maprend (lambda (x y) body)
+ body) x y)
+.onom
+
+However, note that the
+.code let*
+as well as each invocation of the
+.code lambda
+binds fresh instances of the variables, whereas these operators are permitted
+to bind a single instance of the variables, which are first initialized with
+the initializing expressions, and then reused as iteration variables which are
+stepped by assignment.
+
+.TP* Example:
+
+.mono
+ (collect-each-prod* ((a "abc")
+ (b (upcase-str a)))
+ `@a@b`)
+
+ --> ("aA" "aB" "aC" "bA" "bB" "bC" "cA" "cB" "cC")
+.onom
+
+.coNP Macros @, sum-each-prod @, sum-each-prod* @ mul-each-prod and @ mul-each-prod*
+.synb
+.mets (sum-each-prod >> ({( sym << init-form )}*) << body-form *)
+.mets (sum-each-prod* >> ({( sym << init-form )}*) << body-form *)
+.mets (mul-each-prod >> ({( sym << init-form )}*) << body-form *)
+.mets (mul-each-prod* >> ({( sym << init-form )}*) << body-form *)
+.syne
+.desc
+The macros
+.code sum-each-prod
+and
+.code mul-each-prod
+have a similar syntax to
+.code sum-each
+and
+.codn mul-each .
+However, instead of iterating over sequences in parallel, they iterate over
+the Cartesian product of the elements from the sequences.
+
+The macros
+.code sum-each-prod*
+and
+.code mul-each-prod*
+variants perform sequential variable binding when establishing the initial
+values of the variables, similarly to the
+.code each*
+operator.
+
+The
+.metn body-form s
+are surrounded by an implicit anonymous block. If these forms execute a return
+from this block, then these macros terminate with the specified return value.
+
+When no iterations are specified, including in the case when an empty
+list of variables is specified, the summing macros terminate, yielding
+.codn 0 ,
+and the multiplicative macros terminate with
+.codn 1 .
+Note that this behavior differs from
+.codn each ,
+and its closely-related operators, which loop infinitely when no variables are
+specified.
+
+.TP* Examples:
+
+.verb
+ ;; Inefficiently calculate (+ (* 1 2 3) (* 4 3 2)).
+ ;; Every value from (1 2 3) is paired with every value
+ ;; from (4 3 2) to form a partial products, and
+ ;; sum-each-prod adds these together implicitly:
+
+ (sum-each-prod ((x '(1 2 3))
+ (y '(4 3 2)))
+ (* x y))
+ -> 54
+.brev
+
.coNP Operators @ block and @ block*
.synb
.mets (block < name << body-form *)
@@ -16186,7 +18834,13 @@ The
operator introduces a named block around the execution of
some forms. The
.meta name
-argument must be a symbol. Since a block name is not
+argument may be any object, though block names are usually symbols.
+Two block
+.meta name
+objects are considered to be the same name according to
+.code eq
+equality.
+Since a block name is not
a variable binding, keyword symbols are permitted, and so are the symbols
.code t
and
@@ -16241,7 +18895,7 @@ It is because blocks are dynamic that the
variant exists; for lexically scoped blocks, it would make little
sense to have support a dynamically computed name.
-Thus blocks in \*(TL provide dynamic non-local returns, as well
+Thus blocks in \*(TL provide dynamic nonlocal returns, as well
as returns out of lexical nesting.
It is permitted for blocks to be aggressively
@@ -16251,7 +18905,7 @@ by compilation. This means that a
form which meets certain criteria is converted to a
.code progn
form which surrounds the
-.metn body-form -s
+.metn body-form s
and thus no longer establishes an exit point.
A
@@ -16260,7 +18914,7 @@ form will be spared from
.codn progn -conversion
by the compiler if it meets the following rules.
.RS
-.IP 1
+.IP 1.
Any
.meta body-form
references the block's
@@ -16272,10 +18926,10 @@ in a
or
.code sys:capture-cont
expression.
-.IP 2
+.IP 2.
The form contains at least one direct call to a function
not in the standard \*(TL library.
-.IP 3
+.IP 3.
The form contains at least one direct call to the functions
.codn sys:capture-cont ,
.codn return* ,
@@ -16287,20 +18941,19 @@ The form contains at least one direct call to the functions
.code compile-file
or
.codn compile-toplevel .
-.IP 4
+.IP 4.
The form references any of the functions in rules 2 and 3
as a function binding via the
.code dwim
operator (or the DWIM brackets notation) or via the
.code fun
operator.
-.IP 5
+.IP 5.
The form is a
.code block*
form; these are spared from the optimization.
.RE
.IP
-
Removal of blocks under the above rules means that some use of blocks which
works in interpreted code will not work in compiled programs. Programs which
adhere to the rules are not affected by such a difference.
@@ -16342,7 +18995,7 @@ is also not considered to be making a direct call.
.TP* "Dialect Note:"
In Common Lisp, blocks are lexical. A separate mechanism consisting of
-catch and throw operators performs non-local transfer based on symbols.
+catch and throw operators performs nonlocal transfer based on symbols.
The \*(TL example:
.verb
@@ -16433,7 +19086,7 @@ and so the second pprint form is not evaluated.
.desc
The
.code return*
-function is similar to the the
+function is similar to the
.code return-from
operator, except that
.code name
@@ -16494,7 +19147,9 @@ or other control transfers, the
.code tagbody
macro evaluates each
.meta form
-in left to right order. The go labels are ignored.
+in left-to-right order. The
+.code go
+labels are ignored.
After the last
.meta form
is evaluated, the
@@ -16504,13 +19159,15 @@ form terminates, and yields
Any
.meta form
-itself, or else any of its sub-forms, may be the form
+itself, or else any of its subforms, may be the form
.mono
.meti (go << label )
.onom
where
.meta label
-matches one of the go labels of a surrounding
+matches one of the
+.code go
+labels of a surrounding
.codn tagbody .
When this
.code go
@@ -16537,7 +19194,9 @@ is a dynamic transfer. All necessary unwinding inside
.meta form
takes place.
-The go labels are lexically scoped, but dynamically bound. Their scope
+The
+.code go
+labels are lexically scoped, but dynamically bound. Their scope
being lexical means that the labels are not visible to forms which are not
enclosed within the
.codn tagbody ,
@@ -16675,9 +19334,9 @@ macro: labels are permitted, along with use of
Finally, an anonymous block is established around all of the enclosed
forms (both the
-.metn init-form -s
+.metn init-form s
and
-.metn body-forms -s)
+.metn body-forms s)
allowing the use of
.code return
to terminate evaluation with a value.
@@ -16703,7 +19362,7 @@ replaced by
.coNP Function @ eval
.synb
-.mets (eval < form <> [ env ])
+.mets (eval < form >> [ env <> [ menv ]])
.syne
.desc
The
@@ -16712,24 +19371,51 @@ function treats the
.meta form
object as a Lisp expression, which is expanded and
evaluated. The side effects implied by the form are performed, and the value
-which it produces is returned. The optional
+which it produces is returned.
+
+The optional
.meta env
-object specifies an environment for
-resolving the function and variable references encountered in the expression.
-If this argument is omitted
-.code nil
-then evaluation takes place in the global environment.
+argument specifies an environment for
+resolving the function and variable references encountered in
+.metn form .
+If this argument is omitted, then evaluation takes place in the global
+environment.
+
+The optional
+.meta menv
+object specifies a macro environment for expanding macros encountered in
+.metn form .
+If this argument is omitted, then
+.meta form
+may refer to only global macros.
+
+If both
+.meta menv
+and
+.meta env
+are specified, then
+.meta env
+takes precedence over
+.metn menv ,
+behaving like a more nested scope. Definitions contained in
+.meta env
+shadow same-named definitions in
+.metn menv .
The
.meta form
is not expanded all at once. Rather, it is treated by the following algorithm:
.RS
-.IP 1
+.IP 1.
First, if
.meta form
is a macro, it is macro-expanded as if by an application of the function
-.codn macroexpand .
-.IP 2
+.code macroexpand
+(with a suitable environment argument, calculated by a combination of
+.meta env
+and
+.metn menv ).
+.IP 2.
If the resulting expanded form is a
.codn progn ,
.codn compile-only ,
@@ -16742,7 +19428,7 @@ recursive call to
.code eval
using the same
.metn env .
-.IP 3
+.IP 3.
Otherwise, if the expanded form isn't one of the above three kinds of
expressions, it is subject to a full expansion and evaluation.
.RE
@@ -16765,7 +19451,29 @@ This expansion and evaluation order is important because the semantics of
.code eval
forms the reference model for how the
.code load
-function processes top-level forms.
+function processes top-level forms. Moreover, file compilation perform
+a similar treatment of top-level forms and incremental macro compilation.
+The result is that the behavior is consistent between source files and
+compiled files. See the sections Top-Level Forms and File Compilation Model.
+
+Note that, according to these rules, the constituent body forms of a
+.code macrolet
+or
+.code symacrolet
+top-level form are not individual top-level forms, even if the
+expansion of the construct combines the expanded versions of those
+forms with
+.codn progn .
+
+The form
+.code "(macrolet () (defmacro foo ()) (foo))"
+will therefore not work correctly. However, the specific problem in
+this situation can be be resolved by rewriting
+.code foo
+as a
+.code macrolet
+macro:
+.codn "(macrolet ((foo ())) (foo))" .
See also: the
.code make-env
@@ -16773,7 +19481,7 @@ function.
.coNP Function @ constantp
.synb
-.mets (constantp < form >> [ env ])
+.mets (constantp < form <> [ env ])
.syne
.desc
The
@@ -16788,8 +19496,9 @@ If
is absent, the global environment is used.
The
.meta env
-argument is used for macro-expanding
-.metn form .
+argument is used for fully expanding
+.meta form
+prior to analyzing.
Currently,
.code constantp
@@ -16803,10 +19512,48 @@ These symbols are the keyword symbols, and the symbols
and
.codn nil .
-In the future,
+Additionally,
+.code constantp
+returns true for a compound form, or a DWIM form, whose symbol is
+the member of a set a large number of constant-foldable library functions,
+and whose arguments are, recursively,
.code constantp
-will be able to recognize more constant forms, such as calls to certain
-functions whose arguments are constant forms.
+expressions for the same environment. The arithmetic functions
+are members of this set.
+
+For all other inputs,
+.code constantp
+returns
+.codn nil .
+
+Note: some uses of
+.code constantp
+require manual expansion.
+
+.TP* Examples:
+
+.verb
+ (constantp nil) -> t
+ (constantp t) -> t
+ (constantp :key) -> t
+ (constantp :) -> t
+ (constantp 'a) -> nil
+ (constantp 42) -> t
+
+ (constantp '(+ 2 2 [* 3 (/ 4 4)])) -> t
+
+ ;; symacrolet form expands to 42, which is constant
+ (constantp '(symacrolet ((a 42)) a))
+
+ (defmacro cp (:env e arg)
+ (constantp arg e))
+
+ ;; macro call (cp 'a) is replaced by t because
+ ;; the symbol a expands to (+ 2 2) in the given environment,
+ ;; and so (* a a) expands to (* (+ 2 2) (+ 2 2)) which is constantp.
+ (symacrolet ((a (+ 2 2)))
+ (cp '(* a a))) -> t
+.brev
.coNP Function @ make-env
.synb
@@ -16874,7 +19621,7 @@ These function retrieve the components of
.metn env ,
which must be an environment. The
.code env-vbindings
-function retrieves the the association list representing variable
+function retrieves the association list representing variable
bindings. Similarly, the
.code env-fbindings
retrieves the association list of function bindings.
@@ -16958,7 +19705,8 @@ If a
.code lambda
expression is passed to
.codn symbol-function ,
-then the function implied by that expression is returned.
+then the expression is macro-expanded and if that is successful, the function
+implied by that expression is returned.
It is unspecified whether this function is interpreted or compiled.
The
@@ -17059,16 +19807,18 @@ operator yields
as the prior value, consistent with the behavior when accessors are used to
retrieve a nonexistent value.
-.TP* "Dialect note:"
+.TP* "Dialect Note:"
In ANSI Common Lisp, the
.code symbol-function
function retrieves a function, macro or special operator binding
of a symbol.
-These are all in one space and may not co-exist. In \*(TL, it
-retrieves a symbol's function binding only. The
-.code symbol-macro
-function doesn't exist in Common Lisp.
+These are all in one space and may not coexist. In \*(TL, it
+retrieves a symbol's function binding only. Common Lisp has an accessor
+named
+.code macro-function
+similar to
+.codn symbol-macro .
.coNP Functions @, boundp @ fboundp and @ mboundp
.synb
@@ -17095,7 +19845,7 @@ has a function binding in the global
environment, the method specified by
.meta method-name
exists, or a lambda expression argument is given.
-Otherwise it returns nil
+Otherwise it returns
.codn nil .
.code mboundp
@@ -17116,7 +19866,13 @@ bindings. In \*(TL, they are considered bindings.
The ANSI Common Lisp
.code fboundp
yields true if its argument has a function, macro or operator
-binding. The behavior of the Common Lisp expression
+binding, whereas the \*(TL
+.code fboundp
+does not consider operators or macros.
+The ANSI CL
+.code fboundp
+does not yield true for lambda expressions.
+Behavior similar to the Common Lisp expression
.code "(fboundp x)"
in Common Lisp can be obtained in \*(TL using the
@@ -17124,22 +19880,22 @@ in Common Lisp can be obtained in \*(TL using the
(or (fboundp x) (mboundp x) (special-operator-p x))
.brev
-expression.
+expression, except that this will also yield true when
+.code x
+is a lambda expression.
The
.code mboundp
function doesn't exist in ANSI Common Lisp.
-.coNP Functions @, makunbound @ fmakunbound and @ mmakunbound
+.coNP Function @ makunbound
.synb
.mets (makunbound << symbol )
-.mets (fmakunbound << symbol )
-.mets (mmakunbound << symbol )
.syne
.desc
The function
.code makunbound
-the binding of
+removes the binding of
.meta symbol
from either the dynamic environment or the global symbol
macro environment. After the call to
@@ -17510,6 +20266,85 @@ if
is a symbol which names a special operator, otherwise it returns
.codn nil .
+.coNP Symbol Macro @ %fun%
+.desc
+The symbol macro
+.code %fun%
+indicates the current function name, There is a global
+.code %fun%
+symbol macro which expands to
+.codn nil .
+Around certain kinds of named functions, a local binding for
+.code %fun%
+is established which provides the function name. The purpose of this name
+is for use in diagnostic messages; therefore it is an abbreviated name.
+
+The
+.code %fun%
+macro is established for
+.codn defun ,
+.code defmacro
+and
+.code defmeth
+forms. It is also established for methods defined inside a
+.code defstruct
+form including the methods
+.codn :init ,
+.codn :postinit ,
+.code :fini
+and
+.codn :postfini .
+
+The
+.code %fun%
+macro is visible not only to the its function's body, but also to the
+expressions inside the parameter list which compute the default values
+for optional parameters.
+
+The name provided by
+.code %fun%
+is intended for use in diagnostic messages and is therefore an informal
+name, and not the formal name which can be passed to
+.code symbol-function
+to retrieve the function.
+
+In the case of a
+.code defun
+function named
+.codn x ,
+the
+.code %fun%
+name is that symbol,
+.codn x .
+Thus, in this case, the name is the same
+as the formal name.
+In the case of a
+.code defmacro
+named
+.codn x ,
+.code %fun%
+also expands to the symbol x
+.codn x ,
+but that is the formal name of the macro, which is
+.codn "(macro x)" .
+In the case of a method
+.code x
+of a structure type
+.codn s ,
+.code %fun%
+is the two-element list
+.codn "(s x)" ,
+rather than the formal name
+.codn "(meth s x)" .
+
+.TP* Example:
+
+.verb
+ ;; log a message naming the function
+ (defun connect-to-host (addr)
+ (format t "~s: connecting to host ~s" %fun% addr))
+.brev
+
.SS* Object Type
In \*(TL, objects obey the following type hierarchy. In this type hierarchy,
@@ -17535,8 +20370,12 @@ brackets indicate a plurality of types which are not listed by name:
| |
| +--- tree-iter
| |
+ | +--- seq-iter
+ | |
| +--- cptr
| |
+ | +--- dir
+ | |
| +--- struct-type
| |
| +--- <all structures>
@@ -17566,6 +20405,8 @@ brackets indicate a plurality of types which are not listed by name:
| |
| +--- bignum
|
+ +--- chr
+ |
+--- sym
|
+--- env
@@ -17577,6 +20418,8 @@ brackets indicate a plurality of types which are not listed by name:
+--- pkg
|
+--- fun
+ |
+ +--- args
.brev
In addition to the above hierarchy, the following relationships also exist:
@@ -17704,7 +20547,7 @@ Hash table.
I/O stream of any kind.
.coIP regex
-Regular expression object.
+Regular-expression object.
.coIP struct-type
A structure type: the type of any one of the values which represents
@@ -17724,18 +20567,26 @@ There are more kinds of objects, such as user-defined structures.
.coNP Function @ subtypep
.synb
-.mets (subtypep < left-type-symbol << right-type-symbol )
+.mets (subtypep < left-type << right-type )
.syne
.desc
The
.code subtypep
function tests whether
-.meta left-type-symbol
+.meta left-type
and
-.meta right-type-symbol
+.meta right-type
name a pair of types, such that the left type is a subtype of the right
type.
+The arguments are either type symbols, or structure type objects, as returned by the
+.code find-struct-type
+function. Thus, the symbol
+.codn time ,
+which is the name of a predefined struct type, and the object returned by
+.code "(find-struct-type 'time)"
+are considered equivalent argument values.
+
If either argument doesn't name a type, the behavior is
unspecified.
@@ -17743,10 +20594,10 @@ Each type is a subtype of itself. Most other type relationships can be inferred
from the type hierarchy diagrams given in the introduction to this section.
In addition, there are inheritance relationships among structures. If
-.meta left-type-symbol
+.meta left-type
and
-.meta right-type-symbol
-both name structure types, then
+.meta right-type
+are both structure types, then
.code subtypep
yields true if the types are the same struct type, or if the right
type is a direct or indirect supertype of the left.
@@ -17787,7 +20638,7 @@ and then successively tests its type against each clause.
Each clause consists of a type symbol
.meta type-sym
and zero or more
-.metn clause-form -s.
+.metn clause-form s.
The first clause whose
.meta type-sym
@@ -17795,12 +20646,12 @@ is a supertype of the type of
.metn test-form 's
value is considered to be the matching clause.
That clause's
-.metn clause-form -s
+.metn clause-form s
are evaluated, and the value of the last form is returned.
If there is no matching clause, or there are no clauses present,
or the matching clause has no
-.metn clause-form -s,
+.metn clause-form s,
then
.code nil
is returned.
@@ -17816,9 +20667,60 @@ always matches. If such a clause is placed as the last clause of a
it provides a fallback case, whose forms are evaluated if none of the
previous clauses match.
+.coNP Macro @ etypecase
+.synb
+.mets (etypecase < test-form >> {( type-sym << clause-form *)}*)
+.syne
+.desc
+The
+.code etypecase
+macro is the error-catching variant of
+.codn typecase ,
+similar to the relationship between the
+.code ecaseq
+and
+.code caseq
+families of macros.
+
+If one of the clauses has a
+.meta type-sym
+which is the symbol
+.codn t ,
+then
+.code etypecase
+is precisely equivalent to
+.codn typecase .
+Otherwise,
+a clause with a
+.meta type-sym
+of
+.code t
+and which throws an exception of type
+.codn case-error ,
+derived from
+.codn error ,
+is appended to the existing clauses,
+after which the semantics follows that of
+.codn typecase .
+
+.coNP Function @ built-in-type-p
+.synb
+.mets (built-in-type-p << object )
+.syne
+.desc
+The
+.code built-in-type-p
+function returns
+.code t
+if
+.meta object
+is a symbol which is the name of a built-in type.
+For all other objects it returns
+.codn nil .
+
.SS* Object Equivalence
-.coNP Functions @, identity @ identity and @ use
+.coNP Functions @, identity @ identity* and @ use
.synb
.mets (identity << value )
.mets (identity* << value *)
@@ -17832,7 +20734,8 @@ function returns its argument.
If the
.code identity*
function is given at least one argument, then it returns its
-leftmost argument, otherwise it returns nil.
+leftmost argument, otherwise it returns
+.codn nil .
The
.code use
@@ -17982,13 +20885,13 @@ The
function uses the strictest equivalence test, called implementation
equality. The eq function returns
.code t
-if, and only if,
+if and only if,
.meta left-obj
and
.meta right-obj
are actually the same object. The
.code eq
-test is is implemented
+test is implemented
by comparing the raw bit pattern of the value, whether or not it is
an immediate value or a pointer to a heaped object.
Two character values are
@@ -17999,7 +20902,7 @@ are
if they have the same value. All other object representations are actually
pointers, and are
.code eq
-if, and only, if they point to the same object in memory.
+if and only if they point to the same object in memory.
So, for instance, two bignum integers might not be
.code eq
even if they have the same numeric
@@ -18024,7 +20927,7 @@ and
are numbers which are of the same kind and have the same numeric value,
.code eql
returns
-.metn t ,
+.codn t ,
even if they are different objects.
Note that an integers and a floating-point number are not
.code eql
@@ -18083,7 +20986,9 @@ if they have the same length, and
their corresponding elements are
.codn equal .
-If two objects are strings, they are equal if they are textually identical.
+If two objects are strings, they are
+.code equal
+if they are textually identical.
If two objects are functions, they are
.code equal
@@ -18160,8 +21065,7 @@ then
.code neq
returns
.codn nil .
-.IR "Vice versa" ,
-if
+Vice versa, if
.code eq
returns
.codn nil ,
@@ -18477,7 +21381,7 @@ with the arguments reversed. That is to say, the following
equivalences hold:
.verb
- (greater a <--> (less a) <--> t
+ (greater a) <--> (less a) <--> t
(greater a b) <--> (less b a)
(greater a b c ...) <--> (less ... c b a)
.brev
@@ -18524,6 +21428,116 @@ in the same way as do
and
.codn greater .
+.coNP Function @ copy
+.synb
+.mets (copy << object )
+.syne
+.desc
+The
+.code copy
+function duplicates objects of various supported types: sequences, hashes,
+structures and random states. If
+.meta object
+is
+.codn nil ,
+it
+returns
+.codn nil .
+Otherwise,
+.code copy
+is equivalent to invoking a more specific copying function according to
+the type of the argument, as follows:
+.RS
+.coIP cons
+.mono
+.meti (copy-list << object )
+.onom
+.coIP str
+.mono
+.meti (copy-str << object )
+.onom
+.coIP vec
+.mono
+.meti (copy-vec << object )
+.onom
+.coIP hash
+.mono
+.meti (copy-hash << object )
+.onom
+.IP "struct type"
+.mono
+.meti (copy-struct << object )
+.onom
+.coIP fun
+.mono
+.meti (copy-fun << object )
+.onom
+.coIP buf
+.mono
+.meti (copy-buf << object )
+.onom
+.coIP carray
+.mono
+.meti (copy-carray << object )
+.onom
+.coIP random-state
+.mono
+.meti (make-random-state << object )
+.onom
+.coIP tnode
+.mono
+.meti (copy-tnode << object )
+.onom
+.coIP tree
+.mono
+.meti (copy-search-tree << object )
+.onom
+.coIP tree-iter
+.mono
+.meti (copy-tree-iter << object )
+.onom
+.coIP cptr
+.mono
+.meti (copy-cptr << object )
+.onom
+.RE
+
+.IP
+For all other types of
+.metn object ,
+the invocation is erroneous.
+
+Except in the case when
+.meta sequence
+is
+.codn nil ,
+.code copy
+returns a value that
+is distinct from (not
+.code eq
+to)
+.metn sequence .
+This is different from
+the behavior of
+.mono
+.meti >> [ sequence 0..t]
+.onom
+or
+.mono
+.meti (sub < sequence 0 t)
+.onom
+which recognize
+that they need not make a copy of
+.metn sequence ,
+and just return it.
+
+Note however, that the elements of the returned sequence may be
+eq to elements of the original sequence. In other words, copy is
+a deeper copy than just duplicating the
+.code sequence
+value itself,
+but it is not a deep copy.
+
.SS* List Manipulation
.coNP Function @ cons
.synb
@@ -18598,7 +21612,7 @@ In other words
is exactly the same as
.codn "(a b ... l m n o ... w x y z)" .
-Every list, and more generally cons cell tree structure, can be written
+Every list, and more generally cons-cell tree structure, can be written
in a "fully dotted" notation, such that there are as many dots as there
are cells. For instance the cons structure of the nested list
.code "(1 (2) (3 4 (5)))"
@@ -18679,7 +21693,7 @@ otherwise.
is equivalent to
.codn "(not (atom x))" .
-Non-empty lists test positive under
+Nonempty lists test positive under
.code consp
because a list is represented as a reference to the first cons in a chain of
one or more conses.
@@ -18837,7 +21851,7 @@ is allowed, and returns
.codn nil .
.meta object
-may also be a vector or a string. If it is a non-empty string or vector
+may also be a vector or a string. If it is a nonempty string or vector
containing at least two items, then the remaining part of the object is
returned, with the first element removed. For example
.mono
@@ -18847,7 +21861,7 @@ yields
.strn "bc" .
If
.meta object
-is is a one-element vector or string, or an empty vector or string,
+is a one-element vector or string, or an empty vector or string,
then
.code nil
is returned. Thus
@@ -19004,7 +22018,7 @@ and
.code rplacd
functions return
.metn cons .
-Note: \*(TX versions 89 and earlier, these functions returned the new value.
+Note: In \*(TX versions 89 and earlier, these functions returned the new value.
The behavior was undocumented.
The
@@ -19033,7 +22047,7 @@ It is permissible to use
on an empty string or vector. In this case,
.meta new-cdr-value
specifies the contents of the entire string or vector, as if the operation
-were done on a non-empty vector or string, followed by the deletion of the
+were done on a nonempty vector or string, followed by the deletion of the
first element.
The
@@ -19120,7 +22134,7 @@ The
function creates a new object which is a catenation of the
.meta list
arguments. All arguments are optional;
-.code (append)
+.code append
produces the empty list, and if
a single argument is specified, that argument
is returned.
@@ -19327,7 +22341,7 @@ which is unmodified.
The
.code nreconc
function behaves similarly, except
-that the the returned object may share
+that the returned object may share
structure with not only
.meta list2
but also
@@ -19413,7 +22427,7 @@ function, except that it operates on its
.meta list
argument using list operations, and assumes that
.meta list
-it is terminated by
+is terminated by
.codn nil .
If a
@@ -19459,7 +22473,7 @@ function, except that it operates on its
.meta list
argument using list operations. It assumes that
.meta list
-it is terminated by
+is terminated by
.codn nil ,
and that it is made of cells which can be mutated using
.codn rplaca .
@@ -19576,7 +22590,7 @@ The
function which returns a list similar to
.metn list ,
but with
-a newly allocated cons cell structure.
+a newly allocated cons-cell structure.
If
.meta list
@@ -19607,6 +22621,62 @@ Common Lisp does not allow the argument to be an atom, except
for the empty list
.codn nil .
+.coNP Function @ length-list-<
+.synb
+.mets (length-list-< < list << len )
+.syne
+.desc
+The
+.code length-list-<
+function determines whether the length of
+.metn list ,
+is less than the integer
+.metn len .
+
+The expression
+
+.verb
+ (length-list-< x y)
+.brev
+
+is similar to, but usefully different from
+
+.verb
+ (< (length-list x) y)
+.brev
+
+because
+.code length-list-<
+is required to only traverses
+.meta list
+far enough to be able to determine the return value.
+If the end of the list is reached before
+.meta len
+conses are encountered, the function returns
+.codn t ,
+otherwise if
+.code len
+conses are encountered, the function terminates immediately and returns
+.codn nil .
+
+The
+.code length-list-<
+function is therefore safe to use with infinite lazy lists and circular
+lists, for which
+.code length
+would not terminate.
+
+Note: there is more generic function
+.code length-<
+which works with efficiently with different kinds of sequences.
+
+Note: the
+.code length-list-<
+is useful in situations when a decision must be made between two
+algorithms based on the length of one or more input lists.
+The decision can be made without wastefully performing a full pass over the
+input lists to measure their length.
+
.coNP Function @ copy-cons
.synb
.mets (copy-cons << cons )
@@ -19817,7 +22887,7 @@ isn't permitted.
If
.meta list
-is is of length zero, or an atom (in which case its
+is of length zero, or an atom (in which case its
length is considered to be zero) then the above
remarks about position
.I n
@@ -19921,7 +22991,7 @@ element indicated by the zero-based index value given by
.metn index .
The
.meta index
-argument must be a non-negative integer.
+argument must be a nonnegative integer.
If
.meta index
@@ -19950,7 +23020,7 @@ The
function retrieves the n-th cons cell of a list, indexed from zero.
The
.meta index
-parameter must be a non-negative integer. If
+parameter must be a nonnegative integer. If
.meta index
specifies a nonexistent cons beyond the end of the list,
then
@@ -19982,7 +23052,7 @@ resulting place denotes
.metn list .
Storing a value to
.mono
-.meti (nthcdr < 0 << list)
+.meti (nthcdr < 0 << list )
.onom
overwrites
.metn list .
@@ -20004,7 +23074,7 @@ forms do not denote places.
.coNP Function @ tailp
.synb
-.mets (tailp < object << list)
+.mets (tailp < object << list )
.syne
.desc
The
@@ -20055,7 +23125,7 @@ yields the same value as the
.onom
expression.
-.coNP Accessors @, caar @, cadr @, cdar @, cddr @ ... and @ cdddddr
+.coNP Accessors @, caar @, cadr @, cdar @, cddr ..., @ cdddddr
.synb
.mets (caar << object )
.mets (cadr << object )
@@ -20069,7 +23139,7 @@ expression.
.syne
.desc
The
-.I a-d accessors
+.I "a-d accessors"
provide a shorthand notation for accessing two to five
levels deep into a cons-cell-based tree structure. For instance, the
the equivalent of the nested function call expression
@@ -20085,7 +23155,7 @@ The symbol names of the a-d accessors are a generalization of the words
.code car
and
.code cdr
-traversal of the structure using a sequence of the the letters
+traversal of the structure using a sequence of the letters
.code a
and
.code d
@@ -20136,29 +23206,94 @@ places. For example,
means the same as
.codn "(del (car (cddr x)))" .
+.coNP Functions @ cyr and @ cxr
+.synb
+.mets (cyr < address << object )
+.mets (cxr < address << object )
+.syne
+.desc
+The
+.code cyr
+and
+.code cxr
+functions provide
+.cod3 car / cdr
+navigation of tree structure driven by numeric address given by the
+.meta address
+argument.
+
+The
+.meta address
+argument can express any combination of the application of
+.code car
+and
+.code cdr
+functions, including none at all.
+
+The difference between
+.code cyr
+and
+.code cxr
+is the bit order of the encoding. Under
+.codn cyr ,
+the most significant bit of the encoding given in
+.meta address
+indicates the initial
+.cod3 car / cdr
+navigation, and the least significant bit gives the final one.
+Under
+.codn cxr ,
+it is opposite.
+
+Both functions require
+.meta address
+to be a positive integer. Any other argument raises an error.
+
+Under both functions, the
+.meta address
+value
+.code 1
+encodes the
+.code identity
+operation: no
+.cod3 car / cdr
+
.coNP Functions @ flatten and @ flatten*
.synb
-.mets (flatten << list )
-.mets (flatten* << list )
+.mets (flatten >> { list | << atom })
+.mets (flatten* >> { list | << atom })
.syne
.desc
The
.code flatten
-function produces a list whose elements are all of the
+function recursively traverses a nested
+.metn list ,
+returning a list whose elements are all of the
.cod2 non- nil
-atoms contained in the structure of
-.metn list .
+atoms contained in
+.metn list ,
+at any level of nesting.
+If the argument is an
+.meta atom
+rather than a
+.metn list ,
+then it is returned.
+Otherwise, the
+.meta list
+argument must be a proper list, as must all lists
+nested within it.
The
.code flatten*
-function
-works like
-.code flatten
+function calculates the same result as
+.codn flatten ,
except that it produces a lazy list. It can be used to lazily flatten an
-infinite lazy structure.
+infinite lazy list.
.TP* Examples:
.verb
+ (flatten 42) -> 42
+
(flatten '(1 2 () (3 4))) -> (1 2 3 4)
;; equivalent to previous, since
@@ -20168,6 +23303,8 @@ infinite lazy structure.
(flatten nil) -> nil
(flatten '(((()) ()))) -> nil
+
+ (flatten '(a (b . c))) -> ;; error
.brev
.coNP Functions @ flatcar and @ flatcar*
@@ -20196,6 +23333,10 @@ atoms which appear in
.code cdr
fields.
+If the
+.meta tree
+argument is an atom, it is returned.
+
The
.code flatcar*
function
@@ -20213,14 +23354,17 @@ infinite lazy structure.
--> (a b c d e f g nil z nil h)
.brev
-.coNP Function @ tree-find
+.coNP Functions @ tree-find and @ cons-find
.synb
-.mets (tree-find < obj < tree << test-function )
+.mets (tree-find < obj < tree <> [ test-function ])
+.mets (cons-find < obj < tree <> [ test-function ])
.syne
.desc
The
.code tree-find
-function searches
+and
+.code cons-find
+function search
.meta tree
for an occurrence of
.metn obj .
@@ -20238,9 +23382,14 @@ arguments, and has conventions similar to
.code eql
or
.codn equal .
+If an argument is omitted, the default function is
+.codn equal .
+Under both
.code tree-find
-works as follows. If
+and
+.codn cons-find ,
+if
.meta tree
is equivalent to
.meta obj
@@ -20248,16 +23397,22 @@ under
.metn test-function ,
then
.code t
-is returned to announce a successful finding.
-If this test fails, and
-.meta tree
-is an atom,
+is returned to announce a successful finding. Next, if the mismatched
+.meta obj
+is an atom, both functions return
.code nil
-is returned immediately to
-indicate that the find failed. Otherwise,
+to indicate that the search failed.
+
+If none of the above cases occur, the semantics of the functions diverge, as
+follows.
+
+In the case of
+.codn tree-find ,
.meta tree
is taken to be a proper list,
-and tree-find is recursively applied to each element of the list in turn, using
+and
+.code tree-find
+is recursively applied to each element of the list in turn, using
the same
.meta obj
and
@@ -20267,6 +23422,22 @@ which returns a
.cod2 non- nil
value.
+In the case of
+.codn cons-find ,
+.meta tree
+is taken to be
+.codn cons -cell-based
+tree structure. The
+.code cons-find
+function is recursively applied to the
+.code car
+and
+.code cdr
+fields of
+.metn tree .
+Thus a match may be found in any position in the structure, including the
+dotted position of a list.
+
.coNP Functions @, memq @ memql and @ memqual
.synb
.mets (memq < object << list )
@@ -20373,10 +23544,10 @@ These functions are counterparts to
.code member
and
.code member-if
-which look for the right-most
+which look for the rightmost
element which matches
.metn object ,
-rather than for the left-most element.
+rather than for the leftmost element.
.coNP Functions @ conses and @ conses*
.synb
@@ -20449,10 +23620,81 @@ can be expressed as:
(conses list1) ... (conses listn))
.brev
+.coNP Function @ delcons
+.synb
+.mets (delcons < cons << list )
+.syne
+.desc
+The
+.code delcons
+function destructively removes a cons cell from a list. The
+.meta list
+is searched to see whether one of its cons cells is the same object as
+.metn cons .
+If so, that cell is removed from the list.
+
+The
+.meta list
+argument may be a proper or improper list, possibly empty. It may also be an
+atom other than
+.codn nil ,
+which is regarded as being, effectively, an empty improper list terminated by
+that atom.
+
+The operation of
+.code delcons
+is divided into the following three cases. If
+.meta cons
+is the first cons cell of
+.metn list ,
+then the
+.code cdr
+of
+.meta list
+is returned. If
+.meta cons
+is the second or subsequent cons of
+.metn list ,
+then
+.meta list
+is destructively altered to remove
+.meta cons
+and then returned. This means that the
+.code cdr
+field of the predecessor of
+.meta cons
+is altered from referencing
+.meta cons
+to referencing
+.mono
+.meti (cdr << cons )
+.onom
+instead.
+The returned value is the same cons cell as
+.metn list .
+The third case occurs when
+.meta cons
+is not found in
+.metn list .
+In this situation,
+.meta list
+is returned unchanged.
+
+.TP* Examples:
+.verb
+ (let ((x (list 1 2 3)))
+ (delcons x x))
+ -> (2 3)
+
+ (let ((x (list 1 2 . 3)))
+ (delcons (cdr x) x))
+ -> (1 . 3)
+.brev
+
.SS* Association Lists
Association lists are ordinary lists formed according to a special convention.
-Firstly, any empty list is a valid association list. A non-empty association
+Firstly, any empty list is a valid association list. A nonempty association
list contains only cons cells as the key elements. These cons cells are
understood to represent key/value associations, hence the name "association
list".
@@ -20608,7 +23850,7 @@ function rather than
.coNP Function @ alist-remove
.synb
-.mets (alist-remove < alist << keys )
+.mets (alist-remove < alist << key *)
.syne
.desc
The
@@ -20616,13 +23858,13 @@ The
function takes association list
.meta alist
and produces a
-duplicate from which cells matching the specified keys have been removed. The
-.meta keys
-argument is a list of the keys not to appear in the output list.
+duplicate from which cells matching any of the specified
+.metn key s
+have been removed.
.coNP Function @ alist-nremove
.synb
-.mets (alist-nremove < alist << keys )
+.mets (alist-nremove < alist << key *)
.syne
.desc
The
@@ -20632,7 +23874,7 @@ function is like
but potentially destructive.
The input list
.meta alist
-may be destroyed and its structural material re-used to
+may be destroyed and its structural material reused to
form the output list. The application should not retain references to the input
list.
@@ -20656,6 +23898,63 @@ is produced as if by the
function applied to the corresponding
element of the input list.
+.coNP Function @ pairlis
+.synb
+.mets (pairlis < keys < values <> [ alist ])
+.syne
+.desc
+The
+.code pairlis
+function returns an association list consisting of pairs formed from
+the elements of
+.meta keys
+and
+.meta values
+prepended to the existing
+.metn alist .
+
+If an
+.meta alist
+argument is omitted, it defaults to
+.codn nil .
+
+Pairs of elements are formed by taking successive elements from the
+.meta keys
+and
+.meta values
+sequences in parallel.
+
+If the sequences are not of equal length, the excess elements from
+the longer sequence are ignored.
+
+The pairs appear in the resulting list in the original order in
+which their constituents appeared in
+.meta keys
+and
+.metn values .
+
+.TP* "Dialect Note:"
+The ANSI CL
+.code pairlis
+requires
+.meta key
+and
+.meta data
+to be lists, not sequences. The behavior of the ANSI CL
+.code pairlis
+is undefined of those lists are of different lengths. Finally, the elements are
+permitted to appear in either the original order or reverse order.
+
+.TP* Examples:
+
+.verb
+ (pairlis nil nil) -> nil
+ (pairlis "abc" #(1 2 3 4)) -> ((#\ea . 1) (#\eb . 2) (#\ec . 3))
+
+ (pairlis '(1 2 3) '(a b c) '((x . y) (z . w)))
+ -> ((1 . a) (2 . b) (3 . c) (x . y) (z . w))
+.brev
+
.SS* Property Lists
A
.IR "property list",
@@ -20860,7 +24159,7 @@ is an empty list, then the sorted database will
emerge in the original order. If
.meta less-funcs
contains exactly one function,
-then the rows of the database is sorted according to the first column. The
+then the rows of the database are sorted according to the first column. The
remaining columns simply follow their row. If
.meta less-funcs
contains more than
@@ -20872,6 +24171,10 @@ one compare
.codn equal ,
then the corresponding second column elements are compared
using the second column comparison function.
+The
+.meta less-funcs
+argument may be a function object, in which case it is treated as if
+it were a one-element list containing that function object.
The optional
.meta key-funcs
@@ -20908,7 +24211,7 @@ and
arguments of
.code make-lazy-cons
when the lazy cons is created. These arguments default to
-.meta nil
+.code nil
if omitted. A lazy cons also
has an update function, which is specified by the
.meta function
@@ -21131,8 +24434,8 @@ function:
.coNP Functions @ lazy-stream-cons and @ get-lines
.synb
-.mets (lazy-stream-cons << stream )
-.mets (get-lines <> [ stream ])
+.mets (lazy-stream-cons < stream <> [ no-throw-close-p ])
+.mets (get-lines >> [ stream <> [ no-throw-close-p ]])
.syne
.desc
The
@@ -21179,7 +24482,8 @@ by making another call to
.codn lazy-stream-cons ,
installing the result into the
.code cdr
-field.
+field. When this lazy list obtains an end-of-file indication from the stream,
+it closes the stream.
.code lazy-stream-cons
inspects the real-time property of a stream
@@ -21204,6 +24508,92 @@ a one-line stream translates to
.onom
and so forth.
+If and when
+.meta stream
+is closed by the function directly, or else by the returned lazy list, the
+.meta no-throw-close-p
+Boolean argument, defaulting to
+.codn nil ,
+controls the
+.meta throw-on-error-p
+argument of the call to the
+.code close-stream
+function. These arguments have opposite polarity: if
+.meta no-throw-close-p
+is true, then
+.meta throw-on-error-p
+shall be false, and vice versa.
+
+.coNP Macro @ close-lazy-streams
+.synb
+.mets (close-lazy-streams << body-form *)
+.syne
+.desc
+The
+.code close-lazy-streams
+macro establishes a dynamic environment in which zero or more
+.metn body-form s
+are evaluated, yielding the value of the last
+.metn body-form ,
+or else
+.code nil
+if there are no
+.meta body-form
+arguments. In this regard, the macro operator resembles
+.codn progn .
+
+The environment established by
+.code close-lazy-streams
+sets up special monitoring of the the functions
+.code lazy-stream-cons
+and
+.codn get-lines .
+Whenever these functions register an I/O stream with a lazy list, that stream is
+recorded in a hidden. When the
+.code close-lazy-streams
+form terminates, it invokes the
+.code close-stream
+on each stream in the hidden list.
+
+Note: the
+.code close-lazy-streams
+macro provides a possible solution for situations in which a body of code,
+possibly consisting of nested functions, manipulates lazy lists of lines coming
+from from I/O streams, such that these lists are not completely forced.
+Incompletely processed lazy lists will not close their associated streams until
+they are reclaimed by garbage collection, which could cause the application to
+run out of file descriptors.
+The
+.code close-lazy-streams
+macro allows the application to delineate a dynamic contour of code
+upon whose termination all such stream associations generated within
+that contour will be duly cleaned up.
+
+.TP* Example:
+
+Collect list of names of
+.code .tl
+files which contain the string
+.strn "(cons " :
+
+.verb
+ ;; Incorrect version: could run out of open files if there are many
+ ;; files which contain a match processed, because find-if will stop
+ ;; traversing the list of lines when it finds a match:
+ (build
+ (each ((file (glob "*.tl")))
+ (if (find-if #/\e(cons / (file-get-lines file))
+ (add file))))
+
+ ;; Addressed with close-lazy-streams: after each iteration, the
+ ;; stream created by file-get-lines is closed.
+ (build
+ (each ((file (glob "*.tl")))
+ (close-lazy-streams
+ (if (find-if #/\e(cons / (file-get-lines file))
+ (add file)))))
+.brev
+
.coNP Macro @ delay
.synb
.mets (delay << expression )
@@ -21353,9 +24743,9 @@ Under
the scope of the bindings of the
.meta sym
variables extends over the
-.metn init-form -s,
+.metn init-form s,
as well as the
-.metn body-form -s.
+.metn body-form s.
Unlike the
.code let*
@@ -21580,7 +24970,7 @@ receives
The return value is interpreted as follows. If
.meta gen-fun
-returns a cons cell pair
+returns a cons-cell pair
.mono
.meti >> ( elem . << next )
.onom
@@ -21725,7 +25115,7 @@ catenated together.
.coNP Function @ pad
.synb
-.mets (pad < sequence < object <> [ count ])
+.mets (pad < sequence >> [ object <> [ count ]])
.syne
.desc
The
@@ -21737,6 +25127,11 @@ followed by repetitions of
.metn object .
If
+.meta object
+is omitted, it defaults to
+.codn nil .
+
+If
.meta count
is omitted, then the repetition of
.meta object
@@ -21917,11 +25312,19 @@ The
.code range
and
.code range*
-functions generate a lazy sequence of integers, with a
-fixed step between successive values.
+functions generate a lazy, potentially infinite list, according to
+several disciplines.
+
+There is a major division in behavior
+depending on whether or not the
+.code from
+argument, which specifies the initial item, is an arithmetic type
+according to the
+.code arithp
+function. The following remarks describe the arithmetic case. A
+description of the non-arithmetic behavior follows.
The difference between
-.code range
and
.code range*
is that
@@ -21939,17 +25342,38 @@ generates
All arguments are optional. If the
.meta step
argument is omitted, then it defaults
-to
-.codn 1 :
-each value in the sequence is greater than the previous one by
-.codn 1 .
-Positive or negative step sizes are allowed. There is no check for a step size
-of zero, or for a step direction which cannot meet the endpoint.
+to 1 if the
+.meta to
+argument is omitted, or else if it is greater than or equal to
+.meta from
+according to the
+.code >
+function.
+If
+.meta to
+is given, and is less than
+.metn from ,
+then a missing
+.code step
+argument defaults to -1.
+
+Each value in the list is obtained from the previous by adding the
+.meta step
+value. Positive or negative
+.meta step
+values are allowed. There is no check for a step size of zero, or for a step
+direction which cannot meet the endpoint.
+
+The
+.meta step
+argument may be a function. The function must accept one argument.
+That argument is an element of the list, from which the function
+calculates the next element.
The
.meta to
argument specifies the endpoint value, which, if it occurs in the
-sequence, is excluded from it by the
+list, is excluded from it by the
.code range*
function, but included by the range
function. If
@@ -21957,27 +25381,115 @@ function. If
is missing, or specified as
.codn nil ,
then there is no endpoint,
-and the sequence which is generated is infinite, regardless of
+and the list which is generated is infinite, regardless of
.metn step .
If
.meta from
-is omitted, then the sequence begins at zero, otherwise
+is omitted, then the list begins at zero, otherwise
.meta from
-must be an integer which specifies the initial value.
+must be an arithmetic object which specifies the initial value.
-The sequence stops if it reaches the endpoint value (which is included in the
+The list stops if it reaches the endpoint value (which is included in the
case of
.codn range ,
and excluded in the case of
.codn range *).
-However, a sequence with a stepsize greater than
-.code 1
-or less than
-.code -1
-might step over the endpoint value, and
-therefore never attain it. In this situation, the sequence also stops, and the
-excess value which surpasses the endpoint is excluded from the sequence.
+However, depending on the arguments, it is possible that the generated list
+doesn't contain the endpoint value, yet steps over it. This occurs when
+the previous value of the list is less than the endpoint value, but
+the next value is greater, or vice versa. In this situation, the list also
+stops, and the excess value which surpasses the endpoint is excluded from the
+list.
+
+The rest of the description applies to the case when the
+.code from
+argument is a non-arithmetic type.
+
+In the non-arithmetic case, the
+.meta step
+argument unconditionally defaults to 1. If it is given, it must either be a
+function, or else a positive integer.
+
+If
+.meta step
+is a function, that function is used to determine each successive
+value from the previous similarly to the arithmetic case.
+If the
+.meta to
+value is omitted, an infinite list is generated this way.
+If the
+.meta to
+argument is present, the list stops if it attains the endpoint value. No
+provision is made for the endpoint value being skipped, like in the arithmetic
+case. When the endpoint value is reached,
+.code range*
+function omits that value from the list.
+
+If
+.meta step
+is a positive integer, then range iteration is used. A range value is
+constructed from the
+.meta from
+and
+.meta to
+arguments as if by the
+.mono
+.meti (rcons* < from << to )
+.onom
+expression. Here, the
+.code to
+argument defaults to
+.code nil
+if it is missing. An iterator is created for the resulting range
+object as if by
+.code iter-begin
+and this iterator is then used to obtain values for the
+lazy list returned by
+.code range
+or
+.codn range* .
+The list ends when the iterator indicates that no more items
+are available. In the case of the
+.code range*
+function, the last value produced by the iterator is omitted
+from the list. The
+.meta step
+size is used to skip items from the iterator. For instance, if
+the value is 3, then the sequence begins with the
+.meta from
+value. The next two values from the sequence are omitted,
+The fourth item from the sequence is included in the list,
+(unless there either is no such item, or the function is
+.codn range* ,
+and that item is the last one).
+
+.TP* Examples:
+
+.verb
+ (range 1 1) -> (1)
+ (range 0 4) -> (0 1 2 3 4)
+ (range 4 0) -> (4 3 2 1 0)
+ (range 0.0 2.0 0.5) (0.0 0.5 1.0 1.5 2.0)
+ (range #R(0 1) #R(3 4)) (#R(0 1) #R(1 2) #R(3 4))
+ (range 0 4 2) -> (0 2 4)
+ (range #\ea #\ee 2) (#\ea #\ec #\ee)
+ (range 1 32 (op * 2)) -> (1 2 4 8 16 32))
+
+ (range* 1 1) -> nil
+ (range* 0 4) -> (0 1 2 3)
+
+ (range* 4 0 -2) -> (4 2)
+
+ (range 0 1.25 0.5) -> (0 0.5 1.0)
+ (range* 0 1.25 0.5) -> (0 0.5 1.0))
+
+ (range "A" "A") -> nil
+ (range "AA" "BC") -> ("AA" "AB" "AC" "BA" "BB" "BC")
+ (range "AA" "BC" 2) -> ("AA" "AC" "BB")
+
+ [range* "ABCD" nil rest] -> ("ABCD" "BCD" "CD" "D")
+.brev
.coNP Functions @ rlist and @ rlist*
.synb
@@ -22064,8 +25576,9 @@ function rather than
Note: it is permissible for
.meta item
objects to specify infinite ranges.
-It is also permissible to apply an infinite argument list to
-.codn rlist .
+It is also permissible to apply
+.code rlist
+to an infinite argument list.
.TP* Examples:
.verb
@@ -22305,10 +25818,74 @@ The following equivalences hold:
(in-range* r x) <--> (and (lequal (from r) x)
(less x (to r)))
.brev
+
+.coNP Function @ rangeref
+.synb
+.mets (rangeref < range >> [ idx | << seq ])
+.syne
+.desc
+The
+.code rangeref
+function requires its
+.meta range
+argument to be a range object.
+
+It supports two semantics, based on the type of the second argument.
+
+If the second argument is an integer, then it is interpreted as
+.metn idx .
+The function then treats the
+.meta range
+as if it were a sequence. The
+.meta range
+must be a numeric or character range.
+The
+.code from
+field of
+.meta range
+is added to
+.meta idx
+to form the tentative return value.
+
+If the
+.code to
+field is a value other than
+.code t
+or the
+.code :
+(colon) symbol, then the tentative value must be less than
+the value of this field, or an exception is thrown.
+In other words,
+.meta ind
+must indicate a point within the range.
+
+After the above range check is performed, if applicable,
+the tentative value is returned.
+
+If the second argument isn't an integer, it is interpreted
+as a sequence
+.metn seq .
+The
+.meta range
+object's values are used to extract a subrange of
+.metn seq ,
+according to the following equivalence:
+
+.verb
+ (rangeref r s) <--> (sub s (from r) (to r))
+.brev
+
+except that
+.code r
+and
+.code s
+are evaluated only once, in that order.
+
.SS* Characters and Strings
-.coNP Function @ mkstring
+.coNP Functions @ mkstring and @ str
.synb
.mets (mkstring < length <> [ char ])
+.mets (str < length >> [ char | << string ])
.syne
.desc
The
@@ -22316,7 +25893,10 @@ The
function constructs a string object of a length specified
by the
.meta length
-parameter. Every position in the string is initialized
+parameter. The
+.meta length
+parameter must be non-negative.
+Every position in the string is initialized
with
.metn char ,
which must be a character value.
@@ -22325,6 +25905,35 @@ If the optional argument
.meta char
is not specified, it defaults to the space character.
+The
+.code str
+function resembles
+.codn mkstring ,
+and behaves the same way when the second argument
+is omitted, and when it is a character value.
+The second argument of
+.code str
+may be a
+.metn string ,
+in which case the newly created string is filled by
+taking successive characters from
+.metn string .
+If
+.meta string
+is longer than
+.metn length ,
+its excess characters are ignored. If
+.meta string
+is shorter, then characters are taken from the beginning again;
+.meta string
+is effectively taken as a fill pattern to be repeated as many times as
+necessary to provide the required number of characters.
+If
+.meta string
+is empty,
+.code str
+fills the new string with spaces.
+
.coNP Function @ copy-str
.synb
.mets (copy-str << string )
@@ -22357,8 +25966,8 @@ The
.code upcase-str
function produces a copy of
.meta string
-such that all lower-case
-characters of the English alphabet are mapped to their upper case counterparts.
+such that all lowercase
+characters of the English alphabet are mapped to their uppercase counterparts.
.coNP Function @ downcase-str
.synb
@@ -22370,12 +25979,12 @@ The
function produces a copy of
.meta string
such that
-all upper case characters of the English alphabet are mapped to their
-lower case counterparts.
+all uppercase characters of the English alphabet are mapped to their
+lowercase counterparts.
.coNP Function @ string-extend
.synb
-.mets (string-extend < string << tail )
+.mets (string-extend < string < tail <> [ final ])
.syne
.desc
The
@@ -22399,6 +26008,45 @@ The string appears to be the original one because of an internal terminating
null character remains in place, but the characters beyond the terminating zero
are indeterminate.
+The optional Boolean argument
+.metn final ,
+defaulting to
+.codn nil ,
+is a hint which indicates whether this
+.code string-extend
+call is expected to be the last time that the function
+is invoked on the given
+.metn string .
+If
+.meta final
+is true, then the
+.meta string
+object's underlying memory allocation is trimmed to fit the actual
+string data. If the argument is false, the object may be given a larger
+allocation intended to improves the performance of subsequent
+.code string-extend
+calls.
+
+.coNP Function @ string-finish
+.synb
+.mets (string-finish << string )
+.syne
+.desc
+The
+.code string-finish
+function removes excess allocation from
+.meta string
+that may have been produced by previous calls to
+.codn string-extend .
+
+Note: if the most recent call to string
+.code string-extend
+specified a true value for the
+.meta final
+parameter, then calling
+.code string-finish
+is unnecessary and does nothing.
+
.coNP Function @ stringp
.synb
.mets (stringp << obj )
@@ -22406,7 +26054,9 @@ are indeterminate.
.desc
The
.code stringp
-function returns t if
+function returns
+.code t
+if
.meta obj
is one of the several
kinds of strings. Otherwise it returns
@@ -22460,7 +26110,7 @@ it returns
If a
.meta start
argument is not specified, it defaults to zero. If it is
-a non-negative integer, it specifies the starting character position for
+a nonnegative integer, it specifies the starting character position for
the search. Negative values of
.meta start
indicate positions from the end of the
@@ -22515,16 +26165,11 @@ argument, the
function determines whether
.meta littlestring
is a prefix of
-.metn bigstring ,
-returning a
-.code t
-or
-.code nil
-indication.
+.metn bigstring .
If the
.meta start
-argument is specified, and is a non-negative integer, then the
+argument is specified, and is a nonnegative integer, then the
function tests whether
.meta littlestring
matches a prefix of that portion of
@@ -22557,6 +26202,25 @@ then this corresponds to testing whether
is a suffix of
.metn bigstring .
+The
+.code match-str
+function returns
+.code nil
+if there is no match.
+
+If a prefix match is successful,
+then an integer value is returned indicating the position, inside
+.metn bigstring ,
+one character past the matching prefix. If the entire string is matched, then
+this value corresponds to the length of
+.metn bigstring .
+
+If a suffix match is successful, the return value is the position within
+.meta bigstring
+where the leftmost character of
+.meta littlestring
+matched.
+
.coNP Function @ match-str-tree
.synb
.mets (match-str-tree < bigstring < tree <> [ start ])
@@ -22564,8 +26228,9 @@ is a suffix of
.desc
The
.code match-str-tree
-function is a generalization of match-str which matches
-multiple test strings against
+function is a generalization of
+.code match-str
+which matches multiple test strings against
.meta bigstring
at the same time. The value
reported is the longest match from among any of the strings.
@@ -22575,8 +26240,8 @@ strings at the leaves.
If
.meta tree
-is a single string atom, then the function behaves
-exactly like match-str.
+is a single string atom, then the function behaves exactly like
+.codn match-str .
.coNP Accessor @ sub-str
.synb
@@ -22631,25 +26296,81 @@ function has the same parameters and semantics as the
function, except that the first argument is operated upon
using string operations.
-.coNP Function @ cat-str
+.coNP Functions @, cat-str @ join-with and @ join
.synb
-.mets (cat-str < string-list <> [ sep ])
+.mets (cat-str < item-seq <> [ sep ])
+.mets (join-with < sep << item *)
+.mets (join << item *)
.syne
.desc
The
+.codn cat-str ,
+.code join-with
+and
+.code join
+functions combine items into a single string, which is returned.
+
+Every
+.meta item
+argument must be a character, string or else a possibly empty
+sequence of items. This rule applies recursively.
+
+If a
+.meta sep
+argument is present, it must be a character or string.
+
+The
+.meta item-seq
+argument must be a sequence of any mixture of items which are
+characters, strings or sequences of items.
+Note that this means that if
+.meta item-seq
+is a character string, it is a valid argument, since it is a sequence
+of characters.
+
+If
+.meta item-seq
+is empty, or no
+.meta item
+arguments are present, then all three functions return an
+empty string.
+
+All three functions operate on an abstract sequence of character and string
+items, produced by a left-to-right recursive traversal of their
+.meta item-seq
+or
+.meta item
+arguments.
+
+Under the
+.code join-with
+function, as well as the
.code cat-str
-function catenates a list of strings given by
-.meta string-list
-into a
-single string. The optional
+function a
.meta sep
-argument specifies a separator
-which is interposed between the catenated strings.
-It must be either a character or a string.
+argument is given to it,
+the items are catenated together such that
+.meta sep
+is interposed between them. If there are
+.I n
+character or string items, then
+.I "n - 1"
+copies of
+.meta sep
+occur in the resulting string, which is returned.
+
+Under the
+.code join
+function, or
+.code cat-str
+function invoked without a
+.meta sep
+argument, the items are catenated together directly, without any separator.
+The resulting string is returned.
.coNP Function @ split-str
.synb
-.mets (split-str < string < sep <> [ keep-between ])
+.mets (split-str < string < sep >> [ keep-between <> [ count ]])
.syne
.desc
The
@@ -22664,12 +26385,19 @@ or a regular expression. It determines the separator character
sequences within
.metn string .
+The following describes the behavior of
+.code split-str
+in the case when the integer parameter
+.meta count
+is omitted. The semantics of
+.meta count
+are then given.
+
All non-overlapping matches for
.meta sep
within
.meta string
-are identified in left
-to right order, and are removed from
+are identified in left-to-right order, and are removed from
.metn string .
The string is broken into pieces
according to the gaps left behind by the removed separators, and a list
@@ -22758,9 +26486,29 @@ last character, whereas
does not recognize empty separators at these outer limits
of the string.
-.coNP Function @ spl
+If the
+.meta count
+parameter is present, it must be a non-negative integer. This value
+specifies the maximum number of pieces of the input
+.meta string
+which are extracted by the splitting process. The returned list
+consists of these pieces, followed by the remainder of the string, if
+the remainder is nonempty. If
+.meta keep-sep
+is true, then separators appear between the pieces, and if the remainder
+piece is present, the separator between the last piece and the remainder
+is included.
+If
+.meta count
+is zero, then
+.code split-str
+returns a list of one element, which is
+.metn string .
+
+.coNP Functions @ spl and @ spln
.synb
.mets (spl < sep <> [ keep-between ] << string )
+.mets (spln < count < sep <> [ keep-between ] << string )
.syne
.desc
The
@@ -22792,9 +26540,19 @@ family, in the common situation when
.meta string
is the unbound argument.
-.coNP Function @ split-str-set
+The
+.code spln
+function is similar to
+.codn spl ,
+taking a required argument
+.metn count ,
+which behaves exactly like the same-named argument of
+.codn spl-str .
+
+.coNP Functions @ split-str-set and @ sspl
.synb
.mets (split-str-set < string << set )
+.mets (sspl < set << string )
.syne
.desc
The
@@ -22824,9 +26582,17 @@ This operation is nondestructive:
.meta string
is not modified in any way.
+The
+.code sspl
+function performs the same operation; the only difference between
+.code sspl
+and
+.code split-str-set
+is argument order.
+
.coNP Functions @ tok-str and @ tok-where
.synb
-.mets (tok-str < string < regex <> [ keep-between ])
+.mets (tok-str < string < regex >> [ keep-between <> [ count ]])
.mets (tok-where < string << regex )
.syne
.desc
@@ -22850,7 +26616,7 @@ the search for another token within
.meta string
resumes after advancing by one
character position. However, if an empty match occurs immediately
-after a non-empty token, that empty match is not turned into
+after a nonempty token, that empty match is not turned into
a token.
So for instance,
@@ -22863,12 +26629,12 @@ returns
.onom
After the token
.str "a"
-is extracted from a non-empty match
+is extracted from a nonempty match
for the regex, an empty match for the regex occurs just
before the character
.codn b .
This match is discarded because it is an empty match which
-immediately follows the non-empty match. The character
+immediately follows the nonempty match. The character
.code b
is skipped. The next match is an empty match between the
.code b
@@ -22882,9 +26648,7 @@ character and is extracted.
If the
.meta keep-between
-argument is specified, and is not
-.codn nil ,
-then the behavior
+argument is true, then the behavior
of
.code tok-str
changes in the following way. The pieces of
@@ -22903,6 +26667,15 @@ substring of
.meta string
between the last token and the end.
+If
+.meta count
+is specified, it must be a nonnegative integer. The value limits the
+number of tokens which are extracted. The returned list then includes
+one more item: the remainder of the string after the last extracted token.
+This item is omitted if the rest of the string is empty, unless
+.meta keep-between
+is true.
+
The
.code tok-where
function works similarly to
@@ -22919,13 +26692,16 @@ of the pair gives the starting character position, and the second number
is one position past the end of the match. If a match is empty, then the
two numbers are equal.
-The tok-where function does not support the
+The
+.code tok-where
+function does not support the
.meta keep-between
parameter.
.coNP Function @ tok
.synb
.mets (tok < regex <> [ keep-between ] << string )
+.mets (tokn < count < regex <> [ keep-between ] << string )
.syne
.desc
The
@@ -22957,6 +26733,15 @@ family, in the common situation when
.meta string
is the unbound argument.
+The
+.code tokn
+function is similar to
+.codn tok ,
+taking a required argument
+.metn count ,
+which behaves exactly like the same-named argument of
+.codn tok-str .
+
.coNP Function @ list-str
.synb
.mets (list-str << string )
@@ -22978,6 +26763,120 @@ function produces a copy of
from which leading and
trailing tabs, spaces and newlines are removed.
+.coNP Function @ str-esc
+.synb
+.mets (str-esc < esc-set < esc-tok << str )
+.syne
+.desc
+The
+.code str-esc
+function performs a
+.I "character escaping"
+transformation on the input string
+.metn str .
+
+The argument
+.meta esc-set
+is a string containing zero or more characters.
+
+The
+.meta esc-tok
+argument is a character or string.
+
+The function returns a transformed version of
+.meta str
+in which every character of
+.meta str
+which occurs in
+.meta esc-set
+is preceded by
+.metn esc-tok .
+
+.TP* Examples;
+
+.verb
+ (str-esc "$@#" "$" "$foo @abc #1") -> "$$foo $@abc $#1"
+
+ (str-esc "'" "'\e\e'" "foo 'bar' baz") -> "foo '\e\e''bar'\e\e'' baz"
+.brev
+
+.coNP Functions @ string-set-code and @ string-get-code
+.synb
+.mets (string-set-code < string << value )
+.mets (string-get-code << string )
+.syne
+.desc
+The
+.code string-set-code
+and
+.code string-get-code
+functions provide a mechanism for associating an integer code
+with a string.
+
+Note: this mechanism is the basis for associating system error messages passed
+in exceptions with the
+.code errno
+values of the failed system library calls which precipitated these error
+exceptions.
+
+Not all string types can have an integer code: lazy strings and literal
+strings do not have this capability. The
+.meta string
+argument must be of type
+.codn str .
+
+The
+.meta value
+argument must be an integer or character. It is recommended that its
+value be confined to the non-negative range of the platform's
+.code int
+C type. Otherwise it is unspecified whether the same value shall be
+observed by
+.code string-get-code
+as what was stored with
+.codn string-set-code .
+
+The
+.code string-set-code
+function associates the integer
+.meta value
+with the given
+.codn string ,
+and returns
+.codn string .
+Any previously associated value is overwritten.
+
+The
+.code string-get-code
+function retrieves the value most recently associated with
+.metn string .
+If
+.meta string
+has no associated value, then
+.code nil
+is returned.
+
+If the
+.code string-extend
+is invoked on a
+.meta string
+then it is unspecified whether or not
+.meta string
+has an associated value and, if so, what value that is, except in the
+following case: if
+.code string-extend
+is invoked with a
+.meta final
+argument which is true, then
+.meta string
+is caused not to have an associated value.
+
+If the
+.code string-finish
+function is invoked on a
+.metn string ,
+that string is caused not to have an associated value.
+
.coNP Function @ chrp
.synb
.mets (chrp << obj )
@@ -22998,8 +26897,8 @@ Returns
.code t
if
.meta char
-is an alpha-numeric character, otherwise nil. Alpha-numeric
-means one of the upper or lower case letters of the English alphabet found in
+is an alphanumeric character, otherwise nil. Alphanumeric
+means one of the uppercase or lowercase letters of the English alphabet found in
ASCII, or an ASCII digit. This function is not affected by locale.
.coNP Function @ chr-isalpha
@@ -23014,7 +26913,7 @@ if
is an alphabetic character, otherwise
.codn nil .
Alphabetic
-means one of the upper or lower case letters of the English alphabet found in
+means one of the uppercase or lowercase letters of the English alphabet found in
ASCII. This function is not affected by locale.
.coNP Function @ chr-isascii
@@ -23043,11 +26942,14 @@ function returns
.code t
if the character
.meta char
-is a character whose code
-ranges from 0 to 31, or is 127. In other words, any non-printable ASCII
-character. For other characters, it returns
+is a control character. For all other character, it returns
.codn nil .
+A control character is one which belongs to the Unicode C0 or C1 block.
+C0 consists of the characters U+0000 through U+001F, plus the
+character U+007F. These are the original ASCII control characters.
+Block C1 consists of U+0080 through U+009F.
+
.coNP Functions @ chr-isdigit and @ chr-digit
.synb
.mets (chr-isdigit << char )
@@ -23056,7 +26958,7 @@ character. For other characters, it returns
.desc
If
.meta char
-is is an ASCII decimal digit character,
+is an ASCII decimal digit character,
.code chr-isdigit
returns the value
.code t
@@ -23078,10 +26980,13 @@ function returns
if
.meta char
is a non-space printable ASCII character.
-It returns nil if it is a space or control character.
+It returns
+.code nil
+if it is a space or control character.
-It also returns nil for non-ASCII characters: Unicode characters with a code
-above 127.
+It also returns
+.code nil
+for non-ASCII characters: Unicode characters with a code above 127.
.coNP Function @ chr-islower
.synb
@@ -23094,7 +26999,7 @@ function returns
.code t
if
.meta char
-is an ASCII lower case letter. Otherwise it returns
+is an ASCII lowercase letter. Otherwise it returns
.codn nil .
.coNP Function @ chr-isprint
@@ -23126,8 +27031,9 @@ function returns
if
.meta char
is an ASCII character which is not a
-control character. It also returns nil for all non-ASCII characters: Unicode
-characters with a code above 127.
+control character. It also returns
+.code nil
+for all non-ASCII characters: Unicode characters with a code above 127.
.coNP Function @ chr-isspace
.synb
@@ -23214,7 +27120,7 @@ For all other characters, it returns
.coNP Function @ chr-isupper
.synb
-.mets (chr-isupper < char )
+.mets (chr-isupper << char )
.syne
.desc
The
@@ -23223,7 +27129,7 @@ function returns
.code t
if
.meta char
-is an ASCII upper case letter. Otherwise it returns
+is an ASCII uppercase letter. Otherwise it returns
.codn nil .
.coNP Functions @ chr-isxdigit and @ chr-xdigit
@@ -23253,7 +27159,7 @@ or else one of the letters
.code A
through
.code F
-or their lower-case equivalents
+or their lowercase equivalents
.code a
through
.code f
@@ -23266,8 +27172,8 @@ denoting the values 10 to 15.
.desc
If character
.meta char
-is a lower case ASCII letter character, this function
-returns the upper case equivalent character. If it is some other
+is a lowercase ASCII letter character, this function
+returns the uppercase equivalent character. If it is some other
character, then it just returns
.metn char .
@@ -23278,8 +27184,8 @@ character, then it just returns
.desc
If character
.meta char
-is an upper case ASCII letter character, this function
-returns the lower case equivalent character. If it is some other
+is an uppercase ASCII letter character, this function
+returns the lowercase equivalent character. If it is some other
character, then it just returns
.metn char .
@@ -23289,21 +27195,25 @@ character, then it just returns
.mets (chr-int << num )
.syne
.desc
-The argument
+The
.meta char
-must be a character. The
-.code num-chr
+argument must be a character. The
+.code int-chr
function returns that
character's Unicode code point value as an integer.
-The argument
+The
.meta num
-must be a fixnum integer in the range
+argument must be a fixnum integer in the range
.code 0
to
.codn #\ex10FFFF .
-The argument is taken to be a Unicode code point value and the
-corresponding character object is returned.
+The
+.code chr-int
+function interprets
+.meta num
+as a Unicode code point value and returns the
+corresponding character object.
Note: these functions are also known by the obsolescent names
.code num-chr
@@ -23327,7 +27237,7 @@ which must
be within range of the string.
The index value 0 corresponds to the first (leftmost) character of the string
-and so non-negative values up to one less than the length are possible.
+and so nonnegative values up to one less than the length are possible.
Negative index values are also allowed, such that -1 corresponds to the
last (rightmost) character of the string, and so negative values down to
@@ -23453,6 +27363,18 @@ consists only of the characters in string
.metn set ,
in any combination.
+If both arguments are strings, the function returns
+an integer between 0 and the length of
+.metn str .
+
+.TP* Examples:
+.verb
+ (span-str "abcde" "ab") -> 2
+ (span-str "abcde" "z") -> 0
+ (span-str "abcde" "") -> 0
+ (span-str "abcde" "edcba") -> 5
+.brev
+
.coNP Function @ compl-span-str
.synb
.mets (compl-span-str < str << set )
@@ -23467,6 +27389,19 @@ consists only of the characters which do not appear in
.metn set ,
in any combination.
+If both arguments are strings, the function returns
+an integer between 0 and the length of
+.metn str .
+
+.TP* Examples:
+.verb
+ (compl-span-str "abc,def" ",") -> 3
+ (compl-span-str "abc," ",") -> 3
+ (compl-span-str "abc" ",") -> 3
+ (compl-span-str "abc3" "0123456789") -> 3
+ (compl-span-str "3" "0123456789") -> 0
+.brev
+
.coNP Function @ break-str
.synb
.mets (break-str < str << set )
@@ -23484,8 +27419,15 @@ If there is no such character, then
.code nil
is returned.
+.TP* Examples:
+.verb
+ (break-str "abc,def.ghi" ",.:") -> 3
+ (break-str "abc,def.ghi" ".:") -> 6
+ (break-str "abc,def.ghi" ":") -> nil
+.brev
+
.SS* Lazy Strings
-Lazy strings are objects that were developed for the \*(TX pattern matching
+Lazy strings are objects that were developed for the \*(TX pattern-matching
language, and are exposed via \*(TL. Lazy strings behave much like strings,
and can be substituted for strings. However, unlike regular strings, which
exist in their entirety, first to last character, from the moment they are
@@ -23574,6 +27516,9 @@ expresses a maximum limit on how many elements will be consumed from
.meta string-list
in order to feed the lazy string. Once that many elements are
drawn, the string ends, even if the list has not been exhausted.
+However, that remaining list, though not contributing to the string, is still
+incorporated into the value returned by
+.codn lazy-str-get-trailing-list .
.coNP Function @ lazy-stringp
.synb
@@ -23607,9 +27552,15 @@ position, exactly as used in the
.code chr-str
function.
+It is an error if the
+.meta lazy-str
+argument isn't a lazy string.
+
Some positions beyond
.meta index
-may also materialize, as a side effect.
+may also materialize, as a side effect, because the operation
+takes only whole strings from the internal list, according
+to the algorithm described below.
If the string is already materialized through to at least
.metn index ,
@@ -23618,13 +27569,46 @@ possible to materialize the string that far, then the value
.code t
is returned to indicate success.
-If there is insufficient material to force the lazy string through to the
+If there is sufficient material to force the lazy string through to the
.meta index
-position, then nil is returned.
+position, then
+.code t
+is returned, otherwise
+.codn nil .
-It is an error if the
+The
.meta lazy-str
-argument isn't a lazy string.
+object's
+.meta limit-count
+is observed: a total of no more than
+.meta limit-count
+elements are taken from the object's list.
+
+The algorithm is as follows:
+.RS
+.IP 1.
+While the length of the materialized prefix of the string is less than or equal to
+.meta index
+and while elements are available in the list, subject to observance of the
+.metn limit-count ,
+perform the following steps 2 and 3:
+.IP 2.
+Remove the next available string from the list, and add it as a suffix to the materialized prefix.
+.IP 3.
+Add the
+.meta terminator
+string to the materialized prefix.
+.IP 4.
+Return
+.code t
+if the length of the materialized prefix exceeds
+.metn index ,
+otherwise
+.codn nil .
+.RE
+.IP
+The algorithm does not take portions of strings from the list, and always adds the terminator
+after incorporating each piece into the materialized prefix.
.coNP Function @ lazy-str-force
.synb
@@ -23639,6 +27623,24 @@ to fully materialize.
The return value is an ordinary, non-lazy string equivalent to the fully
materialized lazy string.
+The
+.meta lazy-str
+object's
+.meta limit-count
+is observed: a total of no more than
+.meta limit-count
+elements are taken from the object's list.
+
+The algorithm that is followed by
+.code lazy-str-force
+is similar to the one followed by
+.codn lazy-str-force-upto ,
+with only the following modification. The test in step 1 isn't concerned with
+the length of the materialized prefix, since the goal is to materialize all available
+characters. Steps 2 and 3 are performed while elements are available in
+the list, subject to observance of the
+.metn limit-count .
+
.coNP Function @ lazy-str-get-trailing-list
.synb
.mets (lazy-str-get-trailing-list < string << index )
@@ -23649,33 +27651,58 @@ The
function can be considered, in some way, an inverse operation to
the production of the lazy string from its associated list.
-First,
+Note: the behavior of this function changed in \*(TX 274. This is subject
+to a note in the COMPATIBILITY section.
+
+First, the lazy string
.meta string
is forced up through the position
-.metn index .
-That is the only extent to which
-.meta string
-is modified by this function.
-
-Next, the suffix of the materialized part of the lazy string starting at
-position
.metn index ,
-is split into pieces on occurrences of the
-terminator character (which had been given as the
-.meta terminator
-argument in the
-.code lazy-str
-constructor, and defaults to newline). If the
+as if by a call to
+.metn lazy-str-force-upto .
+
+
+If
+.meta string
+consists of
.meta index
-position is beyond the part of the string which can be materialized
-(in adherence with the lazy string's
-.meta limit-count
-constructor parameter), then the list of pieces is considered
-to be empty.
+or more characters, then after the forcing operation, it is guaranteed that
+at least
+.meta index
+characters of the string have been materialized into a single string, called the
+.IR "materialized prefix"
+of the lazy string. If fewer than
+.meta index
+characters are available, taking into account the contribution of the
+terminator string, then the number of characters in the materialized prefix fall short of
+.metn index .
+The materialized prefix never takes fractional strings from the lazy string's
+list, and is always terminated by the terminator string.
+
+Next, the materialized prefix is split into pieces on occurrences of
+.metn string 's
+terminator string, as if by using
+.code spl
+function. If the terminator string is empty, it is split into individual characters,
+in accordance with the semantics of that function.
+
+Then, if the last piece of the split prefix is an empty string, it is removed.
+This situation occurs in two cases: the materialized prefix is empty, or else
+it ends in the terminating string. For example, if the terminating
+string is a single newline, and the prefix is
+.strn "foo\en" .
+In this case,
+.code "(spl \(dq\en\(dq \(dqfoo\en\(dq)"
+produces
+.code "(\(dqfoo\(dq \(dq\(dq)"
+from which the trailing empty string is removed, leaving
+.codn "(\(dqfoo\(dq)" .
-Finally, a list is returned consisting of the pieces produced by the split,
-to which is appended the remaining list of the string which has not yet been
-forced to materialize.
+Finally, a list is formed by appending the split piece of the materialized prefix,
+calculated as described above, with
+.metn string 's
+remaining list of strings which have not been pulled into the materialized
+prefix. This list is returned.
.coNP Functions @, length-str-> @, length-str->= @ length-str-< and @ length-str-<=
.synb
@@ -23854,7 +27881,9 @@ function creates a vector out of its arguments.
.desc
The
.code vectorp
-function returns t if
+function returns
+.code t
+if
.meta obj
is a vector, otherwise it returns
.codn nil .
@@ -24067,6 +28096,94 @@ function except that the
.meta vec
argument must be a vector.
+.coNP Function @ fill-vec
+.synb
+.mets (fill-vec < vec < elem >> [ from <> [ to ]])
+.syne
+.desc
+The
+.code fill-vec
+function overwrites a range of the vector with copies of the
+.meta elem
+value.
+
+The
+.meta from
+and
+.meta to
+index arguments follow the same range indexing conventions as the
+.meta replace
+and
+.meta sub
+functions.
+If
+.meta from
+is omitted, it defaults to zero.
+If
+.meta to
+is omitted, it defaults to the length of
+.metn vec .
+Negative values of
+.meta from
+and
+.meta to
+are adjusted by adding the length of the vector to them, once.
+
+If the adjusted value of either
+.meta from
+or
+.meta to
+is negative, or exceeds the length of
+.metn vec ,
+an error exception is thrown.
+
+The adjusted values of
+.meta to
+and
+.meta from
+specify a range of vec starting at the
+.meta from
+index, and ending at the
+.meta to
+index, which is excluded from the range.
+
+If the adjusted
+.meta to
+is less than or equal to the adjusted
+.metn from ,
+then
+.meta vec
+is unaltered.
+
+Otherwise, copies of element are stored into
+.meta vec
+starting at the
+.meta from
+index, ending just before the
+.meta to
+index is reached.
+
+The
+.code fill-vec
+function returns
+.metn vec .
+
+.TP* Examples:
+
+.verb
+ (defvarl v (vec 1 2 3))
+
+ v --> #(1 2 3)
+
+ (fill-vec v 0) --> #(0 0 0)
+
+ (fill-vec v 3 1) --> #(0 3 3)
+
+ (fill-vec v 4 -1) --> #(0 3 4)
+
+ (fill-vec v 5 -3 -1) --> #(5 5 4)
+.brev
+
.coNP Function @ cat-vec
.synb
.mets (cat-vec << vec-list )
@@ -24083,16 +28200,97 @@ It returns
a single large vector formed by catenating those vectors together in
order.
+.coNP Functions @ nested-vec and @ nested-vec-of
+.synb
+.mets (nested-vec << dimension *)
+.mets (nested-vec-of < object << dimension *)
+.syne
+.desc
+The
+.code nested-vec-of
+function constructs a nested vector according to the
+.meta dimension
+arguments, described in detail below.
+
+The
+.code nested-vec
+function is equivalent to
+.code nested-vec-of
+with an
+.meta object
+argument of
+.codn nil .
+
+When there are no
+.meta dimension
+arguments,
+.code nested-vec-of
+returns
+.codn nil .
+
+If there is exactly one
+.meta dimension
+argument, it must be a nonnegative integer. A newly created
+having that many elements is returned, with each element of the
+vector being
+.metn object .
+
+If there are two or more
+.meta dimension
+arguments, nested vector is returned. The first
+.meta dimension
+argument specifies the outermost dimension: a vector of that many elements are
+returned. Each element of that vector is a vector whose length is given by the
+second dimension. This nesting pattern continues through the remaining
+dimensions. The last dimension specifies the length of vectors which
+are filled with
+.metn object .
+
+From the above it follows that if a zero-valued
+.meta dimension
+is encountered, every vector corresponding to that level of nesting shall be empty,
+and that shall be the last dimension regardless of the presence of additional
+.meta dimension
+arguments.
+
+.TP* Examples:
+
+.verb
+ (nested-vec) -> nil
+
+ (nested-vec-of 0 4) -> #(0 0 0 0)
+
+ (nested-vec-of 0 4 3) -> #(#(0 0 0)
+ #(0 0 0)
+ #(0 0 0)
+ #(0 0 0))
+
+ (nested-vec-of 'a 4 3 2) -> #(#(#(a a) #(a a) #(a a))
+ #(#(a a) #(a a) #(a a))
+ #(#(a a) #(a a) #(a a))
+ #(#(a a) #(a a) #(a a)))
+
+ (nested-vec-of 'a 1 1 1) -> #(#(#(a)))
+ (nested-vec-of 'a 1 1 0) -> #(#(#()))
+ (nested-vec-of 'a 1 0 1) -> #(#())
+ (nested-vec-of 'a 1 0) -> #(#())
+ (nested-vec-of 'a 0 1) -> #()
+ (nested-vec-of 'a 0) -> #()
+
+ (nested-vec-of 'a 4 0 1) #(#() #() #() #())
+ (nested-vec-of 'a 4 0) #(#() #() #() #()))
+.brev
+
.SS* Buffers
-.coSS The @ buf type
+.coNP The @ buf type
Object of the type
.code buf
are
.IR buffers :
vector-like objects specialized for holding binary data represented as
-a sequence of 8 bit bytes. Buffers support operations specialized toward the
+a sequence of 8-bit bytes. Buffers support operations specialized toward the
encoding of Lisp values into machine-oriented data types, and decoding such
data types into Lisp values.
@@ -24203,9 +28401,9 @@ If
.meta init-val
is present, it specifies the value with which the first
.meta len
-byte of the buffer are initialized. If omitted, it
+bytes of the buffer are initialized. If omitted, it
defaults to zero.
-bytes. The value of
+The value of
.meta init-val
must lie in the range 0 to 255.
@@ -24326,7 +28524,7 @@ is used as a syntactic place, the argument expressions
and
.meta new-val
are evaluated just once. The prior value, if required, is accessed by calling
-.code buf-sub
+.code sub-buf
and
.meta new-val
is then stored via
@@ -24416,7 +28614,7 @@ The
.code buf-put-i8
converts
.meta val
-into an eight bit signed integer, and stores it into the buffer at
+into an 8-bit signed integer, and stores it into the buffer at
the offset indicated by
.metn pos .
@@ -24432,7 +28630,7 @@ The
.code buf-put-u8
converts
.meta val
-into an eight bit unsigned integer, and stores it into the buffer at
+into an 8-bit unsigned integer, and stores it into the buffer at
the offset indicated by
.metn pos .
@@ -24480,7 +28678,7 @@ The
.code buf-put-i32
converts
.meta val
-into a 32 bit signed integer, and stores it into the buffer at
+into a 32-bit signed integer, and stores it into the buffer at
the offset indicated by
.metn pos .
@@ -24496,7 +28694,7 @@ The
.code buf-put-u32
converts
.meta val
-into a 32 bit unsigned integer, and stores it into the buffer at
+into a 32-bit unsigned integer, and stores it into the buffer at
the offset indicated by
.metn pos .
@@ -24512,7 +28710,7 @@ The
.code buf-put-i64
converts
.meta val
-into a 64 bit signed integer, and stores it into the buffer at
+into a 64-bit signed integer, and stores it into the buffer at
the offset indicated by
.metn pos .
@@ -24528,7 +28726,7 @@ The
.code buf-put-u64
converts the value
.meta val
-into a 64 bit unsigned integer, and stores it into the buffer at
+into a 64-bit unsigned integer, and stores it into the buffer at
the offset indicated by
.metn pos .
@@ -24718,7 +28916,7 @@ the offset indicated by
.desc
The
.code buf-get-i8
-function extracts and returns signed eight bit integer from
+function extracts and returns signed 8-bit integer from
.meta buf
at the offset given by
.metn pos .
@@ -24730,7 +28928,7 @@ at the offset given by
.desc
The
.code buf-get-u8
-function extracts and returns an unsigned eight bit integer from
+function extracts and returns an unsigned 8-bit integer from
.meta buf
at the offset given by
.metn pos .
@@ -24742,7 +28940,7 @@ at the offset given by
.desc
The
.code buf-get-i16
-function extracts and returns a signed 16 bit integer from
+function extracts and returns a signed 16-bit integer from
.meta buf
at the offset given by
.metn pos .
@@ -24754,7 +28952,7 @@ at the offset given by
.desc
The
.code buf-get-u16
-function extracts and returns an unsigned 16 bit integer from
+function extracts and returns an unsigned 16-bit integer from
.meta buf
at the offset given by
.metn pos .
@@ -24766,7 +28964,7 @@ at the offset given by
.desc
The
.code buf-get-i32
-function extracts and returns a signed 32 bit integer from
+function extracts and returns a signed 32-bit integer from
.meta buf
at the offset given by
.metn pos .
@@ -24778,7 +28976,7 @@ at the offset given by
.desc
The
.code buf-get-u32
-function extracts and returns an unsigned 32 bit integer from
+function extracts and returns an unsigned 32-bit integer from
.meta buf
at the offset given by
.metn pos .
@@ -24790,7 +28988,7 @@ at the offset given by
.desc
The
.code buf-get-i64
-function extracts and returns a signed 64 bit integer from
+function extracts and returns a signed 64-bit integer from
.meta buf
at the offset given by
.metn pos .
@@ -24802,7 +29000,7 @@ at the offset given by
.desc
The
.code buf-get-u64
-function extracts and returns an unsigned 64 bit integer from
+function extracts and returns an unsigned 64-bit integer from
.meta buf
at the offset given by
.metn pos .
@@ -25082,10 +29280,34 @@ Finally, if the operation succeeds, then
.code fill-buf-adjust
adjusts the length of the buffer to match the position that is returned.
+.coNP Function @ get-line-as-buf
+.synb
+.mets (get-line-as-buf <> [ stream ])
+.syne
+.desc
+The
+.code get-line-as-buf
+reads bytes from
+.meta stream
+as if using the
+.code get-byte
+function, until either a the newline character is encountered, or else the end
+of input is encountered. The bytes which are read, exclusive of the newline
+character, are returned in a new buffer object. The newline character, if it
+occurs, is consumed.
+
+If
+.meta stream
+is omitted, it defaults to
+.codn *stdin* .
+
+The stream is required to support byte input.
+
.coNP Functions @ file-get-buf and @ command-get-buf
.synb
-.mets (file-get-buf < name >> [ max-bytes <> [ skip-bytes ]])
-.mets (command-get-buf < cmd >> [ max-bytes <> [ skip-bytes ]])
+.mets (file-get-buf < name >> [ max-bytes
+.mets \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ >> [ skip-bytes <> [ mode-opts ]]])
+.mets (command-get-buf < cmd >> [ max-byte> <> [ skip-bytes ]])
.syne
.desc
The
@@ -25097,7 +29319,7 @@ buffer object. The buffer's length corresponds to the number of bytes
read from the file.
The
-.code command-get
+.code command-get-buf
function opens a binary stream over an input command pipe created for
the command string
.metn cmd ,
@@ -25108,7 +29330,7 @@ input is available. The bytes are returned aggregated into a buffer object.
If the
.meta max-bytes
-parameter is given an argument, it must be a non-negative integer.
+parameter is given an argument, it must be a nonnegative integer.
That value specifies a limit on the number of bytes to read. A buffer
no longer than
.meta max-bytes
@@ -25116,7 +29338,7 @@ shall be returned.
If the
.meta skip-bytes
-parameter is given an argument, it must be a non-negative integer.
+parameter is given an argument, it must be a nonnegative integer.
That value specifies how many initial bytes of the input should be
discarded before accumulation of the buffer begins.
If possible, the semantics of this parameter is achieved by performing a
@@ -25124,11 +29346,33 @@ If possible, the semantics of this parameter is achieved by performing a
operation, falling back on reading and discarding bytes if the
stream doesn't support seeking.
+If
+.meta max-bytes
+is specified, then the stream is opened in unbuffered mode, so that bytes
+beyond the specified range shall not be requested from the underlying file,
+device or process.
+
+The
+.code file-get-buf
+function opens the file as if using the
+.code open-file
+function, using a
+.meta mode-string
+of
+.strn r .
+If the
+.meta mode-opts
+is present, it specifies
+.meta options
+to be added to the string. These must be compatible with the implicit
+.str r
+mode.
+
.coNP Functions @, file-put-buf @ file-append-buf and @ command-put-buf
.synb
-.mets (file-put-buf < name < buf << skip-bytes )
-.mets (file-place-buf < name < buf << skip-bytes )
-.mets (file-append-buf < name << buf )
+.mets (file-put-buf < name < buf < skip-bytes <> [ mode-opts ])
+.mets (file-place-buf < name < buf < skip-bytes <> [ mode-opts ])
+.mets (file-append-buf < name < buf <> [ mode-opts ])
.mets (command-put-buf < cmd << buf )
.syne
.desc
@@ -25142,7 +29386,7 @@ into the file, and then closes the file. If the file doesn't exist, it is
created. If it exists, it is truncated to zero length and overwritten.
The default value of the optional
.meta skip-bytes
-parameter is zero. If an argument is given, it must be a non-negative integer.
+parameter is zero. If an argument is given, it must be a nonnegative integer.
If it is nonzero, then after opening the file, before writing the buffer,
the function will seek to an offset of that many bytes from the start of the
file. The contents of
@@ -25174,25 +29418,58 @@ It then writes the contents of buffer
.meta buf
into the stream and closes the stream.
+The
+.codn file-put-buf ,
+.code file-place-buf
+and
+.code file-append-buf
+functions open a file as if using the
+.code open-file
+function using, respectively,
+.meta mode-string
+values of
+.strn wb ,
+.strn mb ,
+and
+.strn ab .
+
+The
+.meta mode-opts
+argument, if present, specifies additional
+.meta options
+to be added to these modes.
+
The return value of all three functions is that of the
.code put-buf
operation which is implicitly performed.
.coNP Functions @ buf-str and @ str-buf
.synb
-.mets (buf-str < buf <> [ null-term-p ])
-.mets (str-buf < str <> [ null-term-p ])
+.mets (buf-str < str <> [ null-term-p ])
+.mets (str-buf < buf <> [ null-term-p ])
.syne
.desc
The
.code buf-str
and
.code str-buf
-functions perform UTF-8 conversion between the buffer and character string
+functions perform UTF-8 conversion between the character string and buffer
data types.
The
.code buf-str
+function UTF-8-encodes
+.meta str
+and returns a buffer containing the converted representation.
+If a true argument is given to the
+.meta null-term-p
+parameter, then a null terminating byte is added to the buffer.
+This byte is added even if the previous byte is already a null byte
+from the conversion of a pseudo-null character occurring in
+.metn str .
+
+The
+.code str-buf
function takes the contents of buffer
.meta buf
to be UTF-8 data, which is converted to a character string and returned.
@@ -25204,22 +29481,10 @@ parameter, then if the contents of
.meta buf
end in a null byte, that byte is not included in the conversion.
-The
-.code str-buf
-function UTF-8-encodes
-.meta str
-and returns a buffer containing the converted representation.
-If a true argument is given to the
-.meta null-term-p
-parameter, then a null terminating byte is added to the buffer.
-This byte is added even if the previous byte is already a null byte
-from the conversion of a pseudo-null character occurring in
-.metn str .
-
.coNP Functions @ buf-int and @ buf-uint
.synb
-.mets (buf-int < integer )
-.mets (buf-uint < integer )
+.mets (buf-int << integer )
+.mets (buf-uint << integer )
.syne
.desc
The
@@ -25234,7 +29499,7 @@ significant byte first.
The
.code buf-uint
-function requires a non-negative
+function requires a nonnegative
.meta integer
argument, which may be a character. The representation stored in the
buffer is a pure binary representation of the value using the smallest
@@ -25250,7 +29515,7 @@ stored in the buffer is a two's complement representation of
using the smallest number of bytes which can represent that value.
If
.meta integer
-is non-negative, then the first byte of the buffer lies in the range
+is nonnegative, then the first byte of the buffer lies in the range
0 to 127.
If
.meta integer
@@ -25272,8 +29537,8 @@ function.
.coNP Functions @ int-buf and @ uint-buf
.synb
-.mets (int-buf < buf )
-.mets (uint-buf < buf )
+.mets (int-buf << buf )
+.mets (uint-buf << buf )
.syne
.desc
The
@@ -25323,9 +29588,56 @@ is of integer type and, in the case of
.codn buf-uint ,
nonnegative.
+.coNP Functions @ buf-compress and @ buf-decompress
+.synb
+.mets (buf-compress < buf <> [ level ])
+.mets (buf-decompress << buf )
+.syne
+.desc
+The
+.code buf-compress
+and
+.code buf-decompress
+functions perform compression using the Deflate algorithm, via Zlib.
+These functions are only available if \*(TX is built with Zlib support.
+More specifically,
+.code buf-compress
+uses Zlib's
+.code compress2
+function; therefore it can be expected to interoperate with other software
+which uses the same function.
+
+The
+.code buf-compress
+function compresses the entire contents of
+.meta buf
+and returns new buffer with the compressed contents. The optional
+.meta level
+argument specifies the compression level as an integer.
+Valid values range from 0 (no compression) to 9 (maximum compression).
+The value -1 selects a default compression determined internally by Zlib.
+
+The
+.code buf-decompress
+function reverses the
+.code buf-compress
+operation: it takes a compressed
+.meta buf
+and returns a buffer containing the original uncompressed data.
+
+The
+.code buf-compress
+function throws an error exception if the
+.meta level
+value is unacceptable to Zlib. The
+.code buf-decompress
+function throws an error exception if
+.meta buf
+doesn't contain a compressed image.
+
.SS* Structures
-\*(TX supports application-defined types in the form of structures. Structures
+\*(TX supports user-defined types in the form of structures. Structures
are objects which hold multiple storage locations called slots, which are named
by symbols. Structures can be related to each other by inheritance. Multiple
inheritance is permitted.
@@ -25371,7 +29683,7 @@ When
is applied to a struct instance, it returns the name of
the struct type. Effectively, struct names are types.
-The consequences are unspecified if an existing struct name is re-used for a
+The consequences are unspecified if an existing struct name is reused for a
different struct type, or an existing type name is used for a struct type.
.NP* Static Slots
@@ -25445,7 +29757,7 @@ will not inherit the
.meta B
instance of slot
.metn s .
-Moreover, if the the definition of
+Moreover, if the definition of
.code D
omits the
.meta init-form
@@ -25461,14 +29773,13 @@ static slot, yet have that in their own instance.
The slot type can be overridden. A structure type deriving from another
type can introduce slots which have the same names as the supertype,
but are of a different kind: an instance slot in the supertype
-can be replaced by a static slot in the derived type or
-.IR "vice versa" .
+can be replaced by a static slot in the derived type or vice versa.
Note that, in light of the above type overriding possibility, the static slot
value propagation happens only from the immediate supertype.
If
.code D
-is is derived from
+is derived from
.code G
which has a static slot
.codn s ,
@@ -25510,15 +29821,9 @@ This situation with two or more supertypes is called
The contrasting term is
.IR "single inheritance" ,
denoting the situation when a structure has exactly one supertype.
-The term
-.IR "strict single inheritance"
-refers to the situation when a structure has exactly one supertype;
-its supertype has at most one supertype; and, recursively, any additional
-indirect supertypes all have at most one supertype.
-Note: \*(TX 228 and older versions permitted only single inheritance,
-thus programs were restricted to strict single inheritance.
-\*(TL's multiple-inheritance is a straightforward extension of its
-single inheritance semantics.
+\*(TL's struct types initially permitted only single inheritance.
+Multiple inheritance support was introduced in version 229, as a
+straightforward extension of single inheritance semantics.
In the
.code make-struct-type
@@ -25553,8 +29858,101 @@ methods are similarly invoked in right-to-left order, before the
.code :postinit
methods of the new type itself.
Thus the order is: supertype inits, own inits, supertype post-inits,
-own post-inits. If a supertype is referenced, directly or indirectly, two or
-more times, then its initializing expressions are evaluated that many times.
+own post-inits.
+
+.NP* Duplicate Supertypes
+Multiple inheritance makes it possible for a type to inherit the
+same supertype more than once, either directly (by naming it more than
+once as a direct supertype) or indirectly (by inheriting two or
+more different types, which have a common ancestor).
+The latter situation is sometimes referred to as the
+.IR "diamond problem" .
+
+Until \*(TX 242, the situation of duplicate supertypes was
+ignored for the purposes of object initialization. It was documented that if a
+supertype is referenced by inheritance, directly or indirectly, two or more
+times, then its initializing expressions are evaluated that many times.
+
+Starting in \*(TX 243, duplicate supertypes no longer give rise to duplicate
+initialization. When an object is instantiated, only one initialization of a
+duplicated supertype occurs. The subsequent initializations that would take
+place in the absence of duplicate detection are suppressed.
+
+Note also that the
+.code :fini
+mechanism is tied to initialization. Initialization of an object
+registers the finalizers, and so in \*(TX 242,
+.code :fini
+finalizers are also executed multiple times, if
+.code :init
+initializers are.
+
+.TP* Examples:
+
+Consider following program:
+
+.verb
+ (defstruct base ()
+ (:init (me) (put-line "base init"))
+ (:fini (me) (put-line "base fini")))
+
+ (defstruct d1 (base)
+ (:init (me) (put-line "d1 init"))
+ (:fini (me) (put-line "d1 fini")))
+
+ (defstruct d2 (base)
+ (:init (me) (put-line "d2 init"))
+ (:fini (me) (put-line "d2 fini")))
+
+ (defstruct s (d1 d2))
+
+ (call-finalizers (new s))
+.brev
+
+Under \*(TX 242, and earlier versions that support multiple inheritance, it
+produces the output:
+
+.verb
+ base init
+ d2 init
+ base init
+ d1 init
+ d1 fini
+ base fini
+ d2 fini
+ base fini
+.brev
+
+The supertypes are initialized in a right-to-left traversal of the
+type lattice, without regard for
+.code base
+being duplicated.
+
+Starting with \*(TX 243, the output is:
+
+.verb
+ base init
+ d2 init
+ d1 init
+ d1 fini
+ d2 fini
+ base fini
+.brev
+
+The rightmost duplicate of the base is initialized, so that the initialization
+is complete prior to the initializations of any dependent types.
+Likewise, the same rightmost duplicate of the base is finalized, so that
+finalization takes place after that of any dependent struct types.
+
+Note, however, that the
+.code derived
+function function mechanism is not required to detect duplicated direct
+supertypes.
+If a supertype implements the
+.code derived
+function to detect situations when it is the target of inheritance,
+and some subtype inherits that type more than once, that function
+may be called more than once. The behavior is unspecified.
.NP* Dirty Flags
All structure instances contain a Boolean flag called the
@@ -25578,7 +29976,7 @@ slot of an object.
Note: the dirty flag can be used to support support the caching of values
derived from an object's slots. The derived values don't have to be
-re-computed while an object remains clean.
+recomputed while an object remains clean.
.NP* Equality Substitution
@@ -25643,6 +30041,39 @@ compares the replacement object in place of the original, and an
hash table uses the replacement object as the key for the purposes of
hashing and comparison.
+.NP* Custom Slot Expansion
+
+The
+.code defstruct
+macro has a provision for for application-defined clauses, which may
+be defined using the
+.code define-struct-clause
+macro. This macro associates new clause keywords with custom expansion.
+The
+.code :delegate
+clause of
+.code defstruct
+is in fact implemented externally to
+.code defstruct
+using
+.codn define-struct-clause .
+
+.NP* Custom Preludes
+
+The
+.code defstruct
+macro has a provision for implicit inclusion of application-defined
+clauses called preludes, which are previously defined via the
+.code define-struct-prelude
+macro.
+During macro-expansion,
+.code defstruct
+checks whether the structure being defined is the target of one
+or more preludes. If so, it includes the clauses from those preludes
+as if they were written directly in the
+.code defstruct
+syntax.
+
.coNP Macro @ defstruct
.synb
.mets (defstruct >> { name | >> ( name << arg *)} < super
@@ -25681,8 +30112,18 @@ used to call the function. Some remarks in the description of
only apply to structure types defined using that macro.
Slots are specified using zero or more
-.IR "slot specifiers" .
-Slot specifiers come in the following variety:
+.meta slot-specifier
+clauses.
+
+Application-defined clauses are possible via
+.codn define-struct-clause .
+The
+.code defstruct
+macro may bring in prelude clauses which are not specified in its syntax,
+but that have been specified using
+.codn define-struct-prelude .
+
+The following built-in clauses are supported:
.RS
.meIP < name
The simplest slot specifier is just a name, which must be a bindable
@@ -25748,7 +30189,7 @@ form. The function takes the arguments specified
by the
.meta param
symbols, and its body consists of the
-.metn body-form -s.
+.metn body-form s.
There must be at least one
.metn param .
When the function is invoked as a method, as intended,
@@ -25756,7 +30197,7 @@ the leftmost
.meta param
receives the structure instance.
The
-.metn body-form -s
+.metn body-form s
are evaluated in a context in which a block named
.meta name
is visible. Consequently,
@@ -25783,7 +30224,7 @@ form. The function takes the arguments specified
by the
.meta param
symbols, and its body consists of the
-.metn body-form -s.
+.metn body-form s.
This specifier differs from
.code :method
only in one respect: there may be zero
@@ -25791,7 +30232,7 @@ parameters. A structure function defined this way is
intended to be used as a utility function which doesn't
receive the structure instance as an argument.
The
-.metn body-form -s
+.metn body-form s
are evaluated in a context in which a block named
.meta name
is visible. Consequently,
@@ -25799,9 +30240,9 @@ is visible. Consequently,
may be used to terminate the execution of the function
and return a value.
Such functions are called using the
-.code "instance.[name arg ...]"
-syntax which doesn't insert the instance into
-the argument list.
+.code "(call instance.name arg ...)"
+or else the DWIM brackets syntax
+.codn "[instance.name arg ...]" .
The remarks about inheritance and overriding
in the description of
@@ -25815,17 +30256,18 @@ specifier doesn't describe a slot. Rather, it specifies code
which is executed when a structure is instantiated, before
the slot initializations specific to the structure type
are performed. The code consists of
-.metn body-form -s
+.metn body-form s
which are evaluated in order in a lexical scope in
which the variable
.meta param
is bound to the structure object.
-The
+Multiple
.code :init
-specifier may not appear more than once in a given
+specifiers may appear in the same
.code defstruct
-form.
+form. They are executed in their order of appearance,
+left to right.
When an object with one or more levels of inheritance
is instantiated, the
@@ -25854,7 +30296,7 @@ these values to be stable can be defined with
Initializers in base structures must be careful about assumptions about slot
kinds, because derived structures can alter static slots to instance slots or
-.IR "vice versa" .
+vice versa.
To avoid an unwanted initialization being applied to the
wrong kind of slot, initialization code can be made conditional on the
outcome of
@@ -25865,11 +30307,12 @@ applied to the slot.
for initializing instance slots performs this kind of check).
The
-.metn body-form -s
+.metn body-form s
of an
.code :init
specifier are not surrounded by an implicit
.codn block .
+
.meIP (:postinit <> ( param ) << body-form *)
The
.code :postinit
@@ -25877,7 +30320,7 @@ specifier is similar to
.codn :init .
Both specify forms which are evaluated during object instantiation.
The difference is that the
-.codn body-form -s
+.codn body-form s
of a
.code :postinit
are evaluated after other initializations have taken
@@ -25898,8 +30341,13 @@ actions,
.code :postinit
actions registered at different levels of the type's
inheritance hierarchy are invoked in the base-to-derived
-order, and in right-to-left order among multiple bases
-at the same level.
+order, in right-to-left order among multiple bases
+at the same level. Multiple
+.code :postinit
+form in the same
+.code defstruct
+are invoked in left-to-right order.
+
.meIP (:fini <> ( param ) << body-form *)
The
.code :fini
@@ -25927,21 +30375,99 @@ hierarchy, the finalizers specified for a derived structure type are called
before inherited finalizers.
The
-.metn body-form -s
+.metn body-form s
of a
.code :fini
specifier are not surrounded by an implicit
.codn block .
+Multiple
+.code :fini
+clauses may be specified in the same
+.codn defstruct ,
+in which case they are invoked in reverse, right-to-left order.
+
Note that an object's finalizers can be called explicitly with
.codn call-finalizers .
-.RE
-.IP
-The
+Note: the
.code with-objects
macro arranges for finalizers to be called on objects when the execution
of a scope terminates by any means.
+.meIP (:postfini <> ( param ) << body-form *)
+Like
+.codn :fini ,
+.code :postfini
+specifier doesn't describe a slot. The syntax is identical to
+.codn :fini .
+Independently of whether
+.code :fini
+is specified, at most one
+.code :postfini
+may be specified. The only difference between
+.code :fini
+and
+.code :postfini
+is that
+.code :postfini
+arranges for a finalizer to be registered as if by the evaluation of the form
+.mono
+.meti (finalize < obj (lambda <> ( param ) << body-form ...))
+.onom
+where
+.meta obj
+denotes the structure instance. Note the that unlike
+.codn :fini ,
+this omits the
+.code t
+parameter, which means that
+.code :postfini
+finalizers of derived structures execute after the execution of inherited
+finalizers. It also means that multiple
+.code :postfini
+finalizers appearing in the same
+.code defstruct
+execute in left-to-right order unlike the reverse right-to-left order of
+.code :fini
+finalizers.
+
+When both
+.code :fini
+and
+.code :postfini
+clauses are specified in the same
+.code defstruct
+form, all the
+.code :postfini
+finalizers execute after all the
+.code :fini
+finalizers regardless of the order in which they appear.
+
+.meIP (:inherit << super *)
+The
+.code :inherit
+clause specifies zero or more types to be inherited. Each
+.meta super
+argument must be a symbol which is the name of an existing struct type.
+These symbols are appended to the list of supertypes coming from the
+.meta super
+argument
+.codn defstruct .
+Note: the motivation behind
+.code :inherit
+is to make it possible for struct clauses defined by
+.code define-struct-clause
+to inject supertypes. Developers are encouraged to use the regular
+.meta super
+argument of
+.code defstruct
+to declare inheritance of supertypes, rather than writing visible
+.code :inherit
+clauses that can be moved into the
+.meta super
+argument.
+.RE
+.IP
The slot names given in a
.code defstruct
must all be unique among themselves, but they
@@ -25988,7 +30514,7 @@ The initialization for slots which are specified using the
.code :method
or
.code :function
-specifiers is re-ordered with regard to
+specifiers is reordered with regard to
.code :static
slots. Regardless of their placement in the
.code defstruct
@@ -26024,7 +30550,7 @@ or the syntax
If the second form is used, then the structure type will support
"boa construction", where "boa" stands for "by order of arguments".
The
-.metn arg -s
+.metn arg s
specify the list of slot names which are to be initialized in the
by-order-of-arguments style. For instance, if three slot names
are given, then those slots can be optionally initialized by giving three
@@ -26035,8 +30561,8 @@ macro or the
function.
Slots are first initialized according to their
-.metn init-form -s,
-regardless of whether they are involved in boa construction
+.metn init-form s,
+regardless of whether they are involved in boa construction.
A slot initialized in this style still has a
.meta init-form
@@ -26056,7 +30582,7 @@ optional parameter syntax isn't supported.
When boa construction is invoked with optional arguments missing,
the default values for those arguments come from the
-.metn init-form -s
+.metn init-form s
in the remaining
.code defstruct
syntax.
@@ -26140,10 +30666,10 @@ The function takes the arguments specified
by the
.meta param-list
symbols, and its body consists of the
-.metn body-form -s.
+.metn body-form s.
The
-.metn body-form -s
+.metn body-form s
are placed into a
.code block
named
@@ -26151,8 +30677,8 @@ named
A method named
.code lambda
-allows a structure to be used as if it were a function. When arguments
-are applied to the structure as if it were a function, the
+allows a structure to be used as if it were a function. When a structure
+is applied to arguments, as if it were a function, the
.code lambda
method is invoked with those arguments, with the object itself inserted
into the leftmost argument position.
@@ -26202,7 +30728,7 @@ The
.code defmeth
macro returns a method name: a unit of syntax of the form
.mono
-.meti (meth < type-name << name)
+.meti (meth < type-name << name )
.onom
which can be used as an argument to the accessor
.code symbol-function
@@ -26236,9 +30762,9 @@ arguments.
Note: the evaluation order in
.code new
is surprising: namely,
-.metn init-form -s
+.metn init-form s
are evaluated before
-.metn arg -s
+.metn arg s
if both are present.
When the object is constructed, all default initializations take place
@@ -26253,7 +30779,7 @@ macro, and lastly the "boa constructor" overrides.
If any of the initializations abandon the evaluation of
.code new
-by a non-local exit such as an exception throw, the object's
+by a nonlocal exit such as an exception throw, the object's
finalizers, if any, are invoked.
The macro
@@ -26265,7 +30791,7 @@ function.
When
.code lnew
is used to construct an instance, a lazy struct is returned
-immediately, without evaluating any of the the
+immediately, without evaluating any of the
.meta arg
and
.meta init-form
@@ -26279,7 +30805,7 @@ and initialization proceeds in the same way.
If any of the initializations abandon the delayed initializations steps
arranged by
.code lnew
-by a non-local exit such as an exception throw, the object's
+by a nonlocal exit such as an exception throw, the object's
finalizers, if any, are invoked.
Lazy initialization does not detect cycles. Immediately prior to the lazy
@@ -26303,7 +30829,7 @@ macros are variants, respectively, of
and
.codn lnew .
-The only difference in behavior in these macros relative to
+The difference in behavior in these macros relative to
.code new
and
.code lnew
@@ -26315,6 +30841,77 @@ which is evaluated. The value of
.meta expr
must be a struct type, or a symbol which is the name of a struct type.
+With one exception, if
+.meta expr0
+is a compound expression, then
+.mono
+.meti (new* < expr0 ...)
+.onom
+is interpreted as
+.mono
+.meti (new* >> ( expr1 << args... ) ...)
+.onom
+where the head of
+.metn expr0 ,
+.metn expr1 ,
+is actually the expression which is evaluated to produce the type, and the remaining
+constituents of
+.metn expr0 ,
+.metn args ,
+become the boa arguments. The same requirement applies to
+.codn lnew* .
+
+The exception is that if
+.meta expr1
+is the symbol
+.codn dwim ,
+this interpretation does not apply. Thus
+.mono
+.meti (new* >> [ fun << args... ] ...)
+.onom
+evaluates the
+.mono
+.meti >> [ fun << args... ]
+.onom
+expression, rather than treating it as
+.mono
+.meti (dwim < fun << args... )
+.onom
+where
+.code dwim
+would be evaluated as a variable reference expected to produce a type.
+
+.TP* Examples:
+
+.verb
+ ;; struct with boa constructor
+ (defstruct (ab a : b) () a b)
+
+ ;; error: find-struct-type is interpreted as a variable
+ (new* (find-struct-type 'ab) a 1) -> ;; error
+
+ ;; OK: extra nesting.
+ (new* ((find-struct-type 'ab)) a 1) -> #S(ab a 1 b nil)
+
+ ;; OK: dwim brackets without nesting.
+ (new* [find-struct-type 'ab] a 1) -> #S(ab a 1 b nil)
+
+ ;; boa construction
+ (new* ([find-struct-type 'ab] 1 2)) -> #S(ab a 1 b 2)
+ (new* ((find-struct-type 'ab) 1 2)) -> #S(ab a 1 b 2)
+
+ ;; mixed construction
+ (new* ([find-struct-type 'ab] 1) b 2) -> #S(ab a 1 b 2)
+
+ (let ((type (find-struct-type 'ab)))
+ (new* type a 3 b 4))
+ -> #S(ab a 3 b 4)
+
+ (let ((type (find-struct-type 'ab)))
+ (new* (type 3 4)))
+ -> #S(ab a 3 b 4)
+.brev
+
.coNP Macro @ with-slots
.synb
.mets (with-slots >> ({ slot | >> ( sym << slot )}*) < struct-expr
@@ -26355,7 +30952,7 @@ After evaluating
the
.code with-slots
macro arranges for the evaluation of
-.metn body-form -s
+.metn body-form s
in the lexical scope in which the aliases are visible.
.TP* "Dialect Notes:"
@@ -26485,7 +31082,7 @@ The slot name being implicitly quoted is the basis of the term
name.
A compound designator indicates that the named slot is a function,
-and arguments are to be applied to it. The following equivalence applies
+which is to be applied to arguments. The following equivalence applies
in this case, except that
.code o
is evaluated only once:
@@ -26494,13 +31091,18 @@ is evaluated only once:
(qref o (n arg ...)) <--> (call (slot o 'n) o arg ...)
.brev
-A DWIM designator indicates that the named slot is a function or an
-indexable or callable object. The following equivalence applies:
+A DWIM designator similarly indicates that the named slot is a function,
+which is to be applied to arguments. The following equivalence applies:
.verb
- (qref obj [name arg ...]) <--> [(slot obj 'name) arg ...]
+ (qref obj [name arg ...]) <--> [(slot obj 'name) o arg ...]
.brev
+Therefore, under this equivalence, this syntax provides the usual Lisp-1-style
+evaluation rule via the
+.code dwim
+operator.
+
If the
.meta object-form
has the syntax
@@ -26540,7 +31142,7 @@ is the slot not accessed, but the argument expressions are not evaluated.
(defvarl s (new foo))
;; access third element of s.array:
- s.[array 2] --> 3
+ [s.array 2] --> 3
;; increment first element of array by 42
s.(increment 0 42) --> 43
@@ -26677,11 +31279,11 @@ That is to say, it returns a function
.meta f
such that
.mono
-.meti >> [ f < arg ... ]
+.meti >> [ f < arg ...]
.onom
calls
.mono
-.meti >> [ struct.slot < struct < arg ... ]
+.meti >> [ struct.slot < struct < arg ...]
.onom
except that
.meta struct
@@ -26700,11 +31302,11 @@ is produced by
.code "(meth struct slot c1 c2 c3 ...)"
then
.mono
-.meti >> [ f < arg ... ]
+.meti >> [ f < arg ...]
.onom
calls
.mono
-.meti >> [ struct.slot < struct < c1v < c2v < c3v ... arg ... ]
+.meti >> [ struct.slot < struct < c1v < c2v < c3v ... < arg ...]
.onom
except that
.meta struct
@@ -26803,7 +31405,7 @@ The slot named
is retrieved from that object, and is expected to be a function.
That function is called with the object, followed by the values
of the
-.metn curried-expr -s,
+.metn curried-expr s,
if any, followed by that function's arguments.
The syntax can be understood as a translation to a call of the
@@ -27047,7 +31649,9 @@ same type,
.desc
The
.code struct-type-p
-function returns t if
+function returns
+.code t
+if
.meta obj
is a structure type, otherwise it returns
.codn nil .
@@ -27059,39 +31663,42 @@ returned by
.coNP Function @ struct-type-name
.synb
-.mets (struct-type-name << type )
+.mets (struct-type-name << type-or-struct )
.syne
.desc
The
.code struct-type-name
-function returns the symbol which serves as the name of
-.metn type ,
-which must be either a struct type object (such as the return value of
+function determines a structure type from the
+.meta type-or-struct
+argument and returns that structure type's symbolic name.
+
+The
+.meta type-or-struct
+argument must be either a struct type object (such as the return value of
a successful lookup via
.codn find-struct-type ),
-or else a struct type name.
+a symbol which names a struct type,
+or else a struct instance.
.coNP Function @ super
.synb
-.mets (super << type )
+.mets (super <> [ type-or-struct ])
.syne
.desc
The
.code super
-function returns the struct type object which is the
-supertype of
-.metn type ,
-or returns
+function determines a structure type from the
+.meta type-or-struct
+argument and returns the struct type object which is
+the supertype of that type, or else
.code nil
-if
-.meta type
-has no supertype.
+if that type has no supertype.
The
-.meta type
-argument must be either a struct type object, a
-a symbol which names a struct type (which is resolved to that type),
-or else a structure instance (which is resolved to its structure type).
+.meta type-or-struct
+argument must be either a struct type object,
+a symbol which names a struct type,
+or else a struct instance.
.coNP Function @ make-struct
.synb
@@ -27123,7 +31730,7 @@ will be stored into the slot of the newly created object. If a slot is
repeated, it is unspecified which value takes effect.
The optional
-.metn arg -s
+.metn arg s
specify arguments to the structure type's boa constructor.
If the arguments are omitted, the boa constructor is not invoked.
Otherwise the boa constructor is invoked on the structure object
@@ -27139,12 +31746,12 @@ functions as described under
Then, the
.meta slot-init-plist
is processed, if not empty, and finally, the
-.metn arg -s
+.metn arg s
are processed, if present, and passed to the boa constructor.
If any of the initializations abandon the evaluation of
.code make-struct
-by a non-local exit such as an exception throw, the object's
+by a nonlocal exit such as an exception throw, the object's
finalizers, if any, are invoked.
.coNP Function @ make-lazy-struct
@@ -27198,14 +31805,14 @@ in the description of
.coNP Functions @ struct-from-plist and @ struct-from-args
.synb
.mets (struct-from-plist < type >> { slot << value }*)
-.mets (struct-from-arg < type << arg *)
+.mets (struct-from-args < type << arg *)
.syne
.desc
The
.code struct-from-plist
and
-.code struct-from-arg
-are interfaces to the
+.code struct-from-args
+functions are interfaces to the
.code make-struct
function.
@@ -27222,13 +31829,13 @@ argument of
It passes no boa constructor arguments.
The
-.code struct-from-plist
+.code struct-from-args
function calls
.meta make-struct
with an empty
.metn slot-init-plist ,
passing down the list of
-.metn arg -s.
+.metn arg s.
The following equivalences hold:
@@ -27303,7 +31910,12 @@ method similar to the following:
my-copy))
.brev
-since this logic is generic, it can be placed in a base
+which can then be invoked on whatever object needs copying.
+(Note that this method is not a special structure function, and is thus
+not taken into account by the
+.code copy
+function.)
+Since this logic is generic, it can be placed in a base
method. The
.code copied
method which it calls is the means by which the new object is notified that it
@@ -27442,7 +32054,9 @@ or
.desc
The
.code structp
-function returns t if
+function returns
+.code t
+if
.meta obj
is a structure, otherwise it returns
.codn nil .
@@ -27662,7 +32276,7 @@ own arguments.
.coNP Function @ umethod
.synb
-.mets (umethod << slot-name << curried-arg *)
+.mets (umethod < slot-name << curried-arg *)
.syne
.desc
The
@@ -27970,7 +32584,7 @@ of one of the direct supertypes of
and invokes it, passing to that function
.meta struct-obj
as the leftmost argument, followed by the given
-.metn argument -s,
+.metn argument s,
if any.
The
@@ -28007,7 +32621,7 @@ retrieves the function stored in the slot
of one of the supertypes of
.meta type
and invokes it, passing to that function the given
-.metn argument -s,
+.metn argument s,
if any.
The
@@ -28145,10 +32759,10 @@ corresponding
.meta sym
which is initialized with the value of that form. The binding
is visible to subsequent
-.metn init-form -s.
+.metn init-form s.
Additionally, the values of the
-.metn init-form -s
+.metn init-form s
are noted as they are produced. When the
.code with-objects
form terminates, by any means, the
@@ -28159,7 +32773,7 @@ and had been noted. These calls are performed in the
reverse order relative to the original evaluation of the forms.
After the variables are established and initialized, the
-.metn body-form -s
+.metn body-form s
are evaluated in the scope of the variables. The value of the
last form is returned, or else
.code nil
@@ -28167,6 +32781,568 @@ if there are no forms. The invocations of
.code call-finalizers
take place just before the value of the last form is returned.
+.coNP Macro @ define-struct-clause
+.synb
+.mets (define-struct-clause < keyword < params <> [ body-form ]*)
+.syne
+.desc
+The
+.code define-struct-clause
+macro makes available a new, application-defined
+.code defstruct
+clause. The clause is named by
+.metn keyword ,
+which must be a keyword symbol, and is implemented as a macro
+transformation by the
+.meta params
+and
+.metn body-form s
+of the definition. The definition established by
+.code define-struct-clause
+is called a
+.IR "struct clause macro" .
+
+A struct clause macro is invoked when
+.code defstruct
+syntax is processed which contains one or more clauses which are
+headed by the matching
+.meta keyword
+symbol.
+
+The
+.meta params
+comprise a macro-style parameter list which must match the
+invoking clause, otherwise an error exception is thrown.
+When
+.meta params
+successfully matches the clause parameters, the parameters
+are destructured into the parameters and the
+.metn body-form s
+are evaluated in the scope of those parameters.
+
+The
+.metn body-form s
+must return a possibly list of
+.code defstruct
+clauses, not a single clause.
+
+Each of the returned clauses is examined for the possibility that
+it may be a struct clause macro; if so, it is expanded.
+
+The built-in clause keywords
+.codn :static ,
+.codn :instance ,
+.codn :function ,
+.codn :method ,
+.codn :init ,
+.codn :postinit ,
+.code :fini
+and
+.codn :postfini .
+may not be used as the names of a struct clause macro; if any of these
+symbols is used as the
+.meta keyword
+parameter of
+.codn define-struct-clause ,
+an error exception is thrown.
+
+The return value of a
+.code define-struct-clause
+macro invocation is the
+.meta keyword
+argument.
+
+.TP* Examples:
+
+.verb
+ ;; Trivial struct clause macro which consumes any number of
+ ;; arguments and produces no slots:
+
+ (define-struct-clause :nothing (. ignored-args))
+
+ ;; Consequently, the following defines a struct with one slot, x:
+ ;; The (:nothing ...) clause disappears by producing no clauses.
+
+ (defstruct foo ()
+ (:nothing 1 2 3 beeblebrox)
+ x)
+
+ ;; struct clause macro called :multi which takes an initial value
+ ;; and zero or more slot names. It produces instance slot definitions
+ ;; which all use that same initial value.
+
+ (define-struct-clause :multi (init-val . names)
+ (mapcar (lop list init-val) names))
+
+ ;; define a struct with three slots initialized to zero:
+
+ (defstruct bar ()
+ (:multi 0 a b c)) ;; expands to (a 0) (b 0) (c 0)
+
+ ;; struct clause macro to define a slot along with a
+ ;; get and set method.
+
+ (define-struct-clause :getset (slot getter setter : init-val)
+ ^((,slot ,init-val)
+ (:method ,getter (obj) obj.,slot)
+ (:method ,setter (obj new) (set obj.,slot new))))
+
+ ;; Example use:
+
+ (defstruct point ()
+ (:getset x get-x set-x 0)
+ (:getset y get-y set-y 0))
+
+ ;; This has exactly the same effect as the following defstruct:
+
+ (defstruct point ()
+ (x 0)
+ (y 0)
+ (:method get-x (obj) obj.x)
+ (:method set-x (ob new) (set obj.x new))
+ (:method get-y (obj) obj.y)
+ (:method set-y (ob new) (set obj.y new)))
+.brev
+
+.coNP Struct Clause Macro @ :delegate
+.synb
+.mets (:delegate < name <> ( param +) < delegate-expr <> [ target-name ])
+.syne
+.desc
+The
+:delegate
+struct clause macro provides a way to define a method which is implemented entirely
+by delegation to a different object. The name of the method is
+.meta name
+and its parameter list is specified in the same way as in the
+.meta :method
+clause. Instead of a method body, the
+.code :delegate
+clause has an expression
+.meta delegate-expr
+and an optional
+.meta target-name
+which defaults to
+.metn name .
+The
+.meta delegate-expr
+must be an expression which the delegate method can evaluate to
+produce a delegate object. The delegate method then passes its
+arguments to the target method, given by the
+.meta target-name
+argument, invoked on the delegate object.
+
+If the delegate method specifies an optional parameter without a default
+initializing expression, and that optional parameter
+is not given an argument value, it receives the colon symbol
+.code :
+as its argument. That value is passed on to the corresponding parameter
+of the delegate target method. Thus, if the target method has
+an optional parameter in that same parameter position, that colon symbol
+argument then has the effect of requesting the default value.
+If the target method has an ordinary parameter in that position, then
+the colon symbol is received as an ordinary argument value.
+
+If the delegate method specifies an optional parameter with a default
+initializing expression, and that optional parameter is not given
+an argument value, then the expression is evaluated to produce a value
+for that parameter, in the usual manner, and that value is passed as
+an argument to the corresponding parameter of the delegate target.
+Thus, delegates are able to specify different optional argument defaulting
+from their targets.
+
+A delegate may have an optional parameter in a position where the target
+has a required parameter and vice versa.
+
+The three-element optional parameter expression, specifying a Boolean variable
+which indicates whether the optional parameter has been given an argument, is
+not supported by the
+.code :delegate
+clause, and is diagnosed.
+
+If the delegate method has variadic parameters, they are passed on to the
+target after the fixed parameters.
+
+.TP* Example:
+
+Structure definitions:
+
+.verb
+ (defstruct worker ()
+ name
+ (:method work (me)
+ `worker @{me.name} works`)
+ (:method relax (me : (min 15))
+ `worker @{me.name} relaxes for @min min`))
+
+ ;; "contractor" class has a sub ("subcontractor") slot
+ ;; which is another contractor of the same type.
+ ;; The subcontractor's own sub slot, however is going
+ ;; to be a worker.
+
+ (defstruct contractor ()
+ sub
+ (:delegate work (me) me.sub.sub)
+ (:delegate break (me : min) me.sub.sub relax))
+.brev
+
+The
+.code contractor
+structure's
+.code work
+and
+.code break
+methods delegate to the sub-subcontractor, which is going to be
+instantiated as a
+.code worker
+object. Note that the
+.code break
+method delegates to a differently named method
+.codn relax .
+
+.verb
+ ;; The objects are set up as described above.
+ ;; general contractor co has a co.sub subcontractor,
+ ;; and co.sub.sub is a worker:
+
+ (defvar co (new contractor
+ sub (new contractor
+ sub (new worker name "foo"))))
+
+ ;; Call work method on general contractor:
+ ;; this invokes co.sub.sub.(work) on the worker.
+
+ co.(work) -> "worker foo works"
+
+ ;; Call break method on general contractor with
+ ;; no argument. This causes co.sub.sub.(relax :)
+ ;; to be invoked, triggering argument defaulting:
+
+ co.(break) -> "worker foo relaxes for 15 min"
+
+ ;; Call break method with argument. This
+ ;; invokes co.sub.sub.(relax 5), specifying a
+ ;; value for the default argument:
+
+ co.(break 5) -> "worker foo relaxes for 5 min"
+.brev
+
+.coNP Struct Clause Macro @ :mass-delegate
+.synb
+.mets (:mass-delegate < self-var < delegate-expr
+.mets \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ < from-type <> [ * ] <> [ method ]*)
+.syne
+.desc
+The
+:mass-delegate
+struct macro provides a way to define multiple methods which are implemented
+as delegates to corresponding methods on another object.
+The implementation of
+.code :mass-delegate
+depends on the
+.code :delegate
+macro.
+
+The
+.meta self-var
+argument must be a bindable symbol. In each generated delegate method,
+this symbol will be the first argument. The purpose of this symbol is
+to enable the
+.meta delegate-expr
+to refer to the delegating object.
+
+The
+.meta delegate-expr
+is an expression which is inserted into every method. Its evaluation
+is expected to produce the delegate object.
+This expression may reference
+.meta self-var
+in order to retrieve or otherwise obtain the delegate from the delegating
+object.
+
+The
+.meta from-type
+argument is a symbol naming an existing structure type. If no such
+structure type has been defined, an error exception is thrown.
+
+After the
+.meta from-type
+argument, either zero or more slot names appear, optionally preceded by the
+.code *
+(asterisk) symbol.
+
+If the
+.code *
+symbol is present, and isn't followed by any other symbols, it indicates
+that all methods from
+.meta from-type
+are to be delegated. If symbols appear after the
+.code *
+then those specify exceptions: methods not to be delegated.
+No validation is performed on the exception list; it may specify
+nonexistent method names which have no effect.
+
+If the
+.code *
+symbol is absent, then every
+.meta method
+symbol specifies a method to be delegated.
+It is consequently expected to name a method of the
+.metn from-type :
+a static slot which contains a function. If any
+.meta method
+isn't a static slot of
+.metn from-type ,
+or not a static slot which contains a function, an error exception is thrown.
+
+The
+.code :mass-delegate
+struct macro iterates over all of the methods of
+.meta from-type
+that selected for delegation, and for each one it generates a
+.code :delegate
+macro clause based on the existing method's parameter list.
+For instance, the delegate for a method which has two required arguments and
+one optional will itself have two required arguments and one optional.
+Delegates are not simply wrapper functions which take any number of arguments
+and try to pass them to the target.
+
+The generated
+.code :delegate
+clauses are then processed by that struct clause macro.
+
+Note: composition with delegation is a useful alternative when
+multiple inheritance is not applicable or desired for various reasons.
+One such reason is that structures that would be used as multiple inheritance
+bases use the same symbols for certain slots, and the semantics of those
+slots conflict. Under inheritance, same-named slots coming from different
+bases become one slot,
+
+Note: a particular
+.meta from-type
+being nominated in the
+.code :mass-delegate
+clause doesn't mean that the specific methods of that type shall be called
+by the generated delegates. The methods that shall be called are those
+of the calculated delegate object selected by the
+.metn delegate-expr .
+The
+.meta from-type
+is used as a source of the argument info, and method existence validation.
+It is up to the application to ensure that the delegation using
+.meta from-type
+makes sense with respect to the delegate object that is selected by the
+.metn delegate-expr :
+for instance, by ensuring that this object is an instance of
+.meta from-type
+or a subtype thereof.
+
+.TP* Example:
+
+.verb
+ (defstruct foo-api ()
+ name
+ (:method begin (me) ^(foo ,me.name begin))
+ (:method increment (me delta) ^(foo ,me.name increment ,delta))
+ (:method end (me) ^(foo ,me.name end)))
+
+ (defstruct bar-api ()
+ name
+ (:method open (me) ^(bar ,me.name open))
+ (:method read (me buf) ^(bar ,me.name read ,buf))
+ (:method write (me buf) ^(bar ,me.name write ,buf))
+ (:method close (me) ^(bar ,me.name close)))
+
+ ;; facade holds the two API objects by composition:
+
+ (defstruct facade ()
+ (foo (new foo-api name "foo"))
+ (bar (new bar-api name "bar"))
+
+ ;; delegate foo-api style calls via me.foo
+ (:mass-delegate me me.foo foo-api *)
+
+ ;; delegate bar-api style calls via me.bar
+ ;; exclude the write method.
+ (:mass-delegate me me.bar bar-api * write))
+
+ ;; instantiate facade as variable fa
+ (defvar fa (new facade)) -> fa
+
+ ;; begin call on facade delegates through foo-api object.
+ fa.(begin) -> (foo "foo" begin)
+
+ fa.(increment) -> ;; error: too few arguments
+
+ fa.(increment 3) -> (foo "foo" increment 3)
+
+ fa.(open) -> (bar "bar" open)
+
+ fa.(write 4) -> ;; error: fa has no such method
+.brev
+
+.coNP Function @ macroexpand-struct-clause
+.synb
+.mets (macroexpand-struct-clause < clause <> [ form ])
+.syne
+.desc
+If
+.code clause
+is a compound expression whose operator symbol was defined by
+.code define-struct-clause
+then
+.code macroexpand-struct-clause
+expands the clause and returns the expansion, which is
+a list of zero or more clauses.
+Otherwise, the function returns a one-element list containing the
+.meta clause
+argument, as if by the
+.mono
+.meti (list << clause )
+.onom
+expression.
+
+The
+.meta form
+parameter, if present, is used for reporting errors.
+Note: clauses are usually expanded during the processing of a
+.code defstruct
+macro; in that situation, the entire unexpanded
+.code defstruct
+form serves the role,
+
+.TP* Examples:
+
+.verb
+ ;; try to expand :delegate, using incorrect syntax.
+ (macroexpand-struct-clause '(:delegate x (a b)))
+ --> error "** source location n/a: nil: too few elements ..."
+
+ ;; same, but with error reporting form.
+ (macroexpand-struct-clause '(:delegate x (a b)) '(abc xyz))
+ --> error: "** expr-1:1: abc: too few elements ..."
+
+ ;; correct :delegate syntax
+ (macroexpand-struct-clause '(:delegate x (a b) a.foo))
+ --> ((:method x (a b) (qref a.foo (x b))))
+
+ ;; not a defstruct macro clause
+ (macroexpand-struct-clause '(1 2 3))
+ -> ((1 2 3))
+.brev
+
+.coNP Special Variable @ *struct-clause-expander*
+.desc
+The
+.code *struct-clause-expander*
+special variable holds the hash table of associations between
+keyword symbols and struct clause expander functions, defined by
+.codn define-struct-clause .
+
+If the expression
+.code "[*struct-clause-expander* :sym]"
+yields a function, then symbol
+.code :sym
+has a binding as a struct clause macro. If that
+expression yields
+.codn nil ,
+then there is no such binding.
+
+The macro expanders in
+.code *struct-clause-expander*
+are two-parameter functions. The first parameter accepts the
+clause to be expanded. The second parameter accepts the
+.code defstruct
+form in which that clause is found; this is useful for error
+reporting.
+
+An expander function returns a list of clauses, which may be any, possibly
+empty mixture of primary clauses accepted by
+.code defstruct
+and clause macros.
+
+.coNP Macro @ define-struct-prelude
+.synb
+.mets (define-struct-prelude < name < struct-name-or-list << clause *)
+.syne
+.desc
+The
+.code define-struct-prelude
+macro defines a
+.IR prelude .
+A prelude is a named entity which implicitly provides clauses to
+.code defstruct
+macro invocations. Preludes are processed during the macroexpansion of
+.codn defstruct ;
+prelude definitions have no effect on previously compiled
+.code defstruct
+forms loaded from a file.
+
+A prelude has a
+.meta name
+which must be a bindable symbol. The purpose of this name is that
+if multiple
+.code define-struct-prelude
+forms are evaluated which specify the same
+.metn name ,
+they replace each others' definition. Only the most recent prelude of
+a given
+.meta name
+is retained; the previous definitions are overwritten.
+
+The
+.meta struct-name-or-list
+argument is either a symbol or a list of symbols, which are valid
+for use as structure names. The prelude being defined shall be
+applicable to each of the structures whose names are given by
+this argument.
+
+The zero or more
+.meta clause
+arguments give the clauses which comprise the prelude. In the future, when a
+.code defstruct
+form is macroexpanded which targets any of the structures given by the
+.meta struct-name-or-list
+argument, the specified clauses will be inserted into that definition, as
+if they appeared in the
+.code defstruct
+form literally.
+
+Multiple preludes may be defined with different names, which each target
+the same structure. When the structure is defined, or redefined, it will
+receive all those preludes, in the order in which they were defined.
+
+.TP* Example:
+
+.verb
+ ;; define init-fini-log prelude which targets fox and bear structs
+
+ (define-struct-prelude init-fini-log (fox bear)
+ (:init (me) (put-line `@me created`))
+ (:fini (me) (put-line `@me finalized`)))
+
+ ;; The behavior is as if the following defstruct forms included
+ ;; the above :init and :fini clauses
+
+ (defstruct fox ())
+
+ (defstruct bear ())
+
+ (with-object ((f (new fox))
+ (b (new bear)))
+ (put-line "inside with-object"))
+.brev
+
+Output:
+
+.verb
+ #S(fox) created
+ #S(bear) created
+ inside with-object
+ #S(bear) finalized
+ #S(fox) finalized
+.brev
+
.SS* Special Structure Functions
Special structure functions are user-defined methods or structure functions
@@ -28189,14 +33365,15 @@ instance as an argument. Their syntax is indicated using the same notation
which may be used to invoke them, such as:
.verb
-.mets << object .(function-name < arg << ... )
+.mets << object .(function-name < arg ...)
.brev
-However, those introduced as "Function" do not operate on an instance. For
-brevity, their syntax is nevertheless exemplified as
+However, those introduced as "Function" do not operate on an instance.
+Their syntax is likewise indicated using the notation that may be used
+to invoke them:
.verb
-.mets << object .'['function-name < arg << ... ']'
+.mets <> '[' object .function-name < arg ...']'
.brev
If such a invocation is actually used, the
@@ -28205,11 +33382,11 @@ instance only serves for identifying the struct type whose static slot
.code function-name
provides the function;
.meta object
-doesn't participate in the call. An object is not required since
+doesn't participate in the call. An object is not strictly required since
the function can be called using
.verb
-.mets [(static-slot < type 'function-name) < arg << ... ]
+.mets [(static-slot < type 'function-name) < arg ...]
.brev
which looks up the function in the struct
@@ -28248,7 +33425,7 @@ its
method is invoked, and the return value is used in place of that
structure for the purposes of the comparison.
-The same applies when an struct is hashed using the
+The same applies when a struct is hashed using the
.code hash-equal
function, or implicitly by an
.code :equal-hash
@@ -28323,7 +33500,7 @@ This method can be called by name, using the syntax given
in the above syntactic description.
However, the intended use is that it allows the structure instance itself to be
-used as a function. When arguments are applied to a structure object as if it
+used as a function. When a structure is applied to arguments as if it
were a function, this is erroneous, unless that object has a
.code lambda
method. In that case, the arguments are passed to the lambda method.
@@ -28504,6 +33681,33 @@ preference is given to
.codn length ,
which is likely to be much more efficient.
+.coNP Method @ length-<
+.synb
+.mets << object .(length-< << len )
+.syne
+.desc
+If a structure has
+.code length-<
+method, then it can be used as the left argument to the
+.code length-<
+function. The
+.meta len
+argument receives the right argument.
+
+If an object doesn't implement the
+.code length-<
+method, but does implement the
+.code length
+it can also be used as an argument to the
+.code length-<
+function. In that situation, the
+.code length-<
+function will call the
+.code length
+method instead, and then compare the returned value against the
+.meta len
+parameter.
+
.coNP Methods @, car @ cdr and @ nullify
.synb
.mets << object .(car)
@@ -28583,7 +33787,7 @@ supports a
.code rplaca
method. If so, then, effectively,
.mono
-.meti << o . (rplaca << v)
+.meti << o . (rplaca << v )
.onom
is invoked. The return value of this method call is ignored;
.code rplaca
@@ -28609,13 +33813,13 @@ method, but does have a
.code lambda-set
method, then
.mono
-.meti << o . (lambda-set 0 << v)
+.meti << o . (lambda-set 0 << v )
.onom
is invoked.
.coNP Function @ from-list
.synb
-.mets << object .'['from-list << list ']'
+.mets <> '[' object .from-list << list ']'
.syne
.desc
If a
@@ -28646,7 +33850,7 @@ will always return a plain list of items.
.coNP Function @ derived
.synb
-.mets << object .'['derived < supertype << subtype ']'
+.mets <> '[' object .derived < supertype << subtype ']'
.syne
.desc
If a structure type supports a function called
@@ -28672,6 +33876,13 @@ The function is not retroactively invoked. If it is defined for
a structure type from which subtypes have already been derived,
it is not invoked for those existing subtypes.
+If
+.meta derived
+directly inherits
+.meta supertype
+more than once, it is not specified whether this function is called
+once, or multiple times.
+
Note: the
.meta supertype
parameter exists because the
@@ -28680,7 +33891,239 @@ function is itself inherited. If the same version of this function is shared by
multiple structure types due to inheritance, this argument informs the function
which of those types it is being invoked for.
+.coNP Methods @ iter-begin and @ iter-reset
+.synb
+.mets << object .(iter-begin)
+.mets << object .(iter-reset << iter )
+.syne
+.desc
+If an object supports the
+.code iter-begin
+method, it is considered iterable; the
+.code iterable
+function will return
+.code t
+if invoked on this object.
+
+The responsibility of the
+.code iter-begin
+method is to return an iterator object: an object which supports
+certain special methods related to iteration, according to one of two
+protocols, described below.
+
+The
+.code iter-reset
+method is optional. It is similar to
+.code iter-begin
+but takes an additional
+.meta iter
+argument, an iterator object that was previously returned by the
+.code iter-begin
+method of the same
+.metn object .
+
+If
+.code iter-reset
+determines that
+.meta iter
+can be reused for a new iteration, then it can suitably mutate the
+state of
+.meta iter
+and return it. Otherwise, it behaves like
+.code iter-begin
+and returns a new iterator.
+
+There are two protocols for iteration: the fast protocol, and the canonical
+protocol.
+Both protocols require the iterator object returned by the
+.code iter-begin
+method to provide the methods
+.code iter-item
+and
+.codn iter-step .
+If the iterator also provides the
+.code iter-more
+method, then the protocol which applies is the canonical protocol. If
+that method is absent, then the fast protocol is followed.
+
+Under the fast protocol, the
+.code iter-more
+method does not exist and is not involved. The iterable object's
+.code iter-begin
+method must return
+.code nil
+if the abstract sequence is empty. If an iterator is returned, it is assumed
+that an object can be retrieved from the iterator by invoking its
+.code iter-item
+method. The iterator's
+.code iter-next
+method should return
+.code nil
+if there are no more objects in the abstract sequence, or else it should
+return an iterator that obeys the fast protocol (possibly itself).
+
+Under the canonical protocol, the iterator implements the
+.code iter-more
+function. The iterable object's
+.code iter-begin
+always returns an iterator object. The iterator object's
+.code iter-more
+method is always invoked to determine whether another item is available
+from the sequence. The iterator object's
+.code iter-step
+method is expected to return an iterator object which conforms to the
+canonical protocol.
+
+.coNP Method @ iter-item
+.synb
+.mets << object .(iter-item)
+.syne
+.desc
+The
+.code iter-item
+method is invoked on an iterator
+.meta object
+to retrieve the next item in the sequence.
+
+Under the fast protocol, it
+is assumed that if
+.meta object
+was returned by an iterable object's
+.code iter-begin
+method, or by an iterator's
+.code iter-step
+method, that an item is available. This method will be unconditionally invoked.
+
+Under the canonical protocol for iteration, the
+.code iter-more
+method will be invoked on
+.meta object
+first. If that method yields true, then
+.code iter-item
+is expected to yield the next available item in the sequence.
+
+Note: calls to the
+.code iter-item
+function, with
+.meta object
+as its argument, invoke the
+.code iter-item
+method. It is possible for an application to call
+.code iter-item
+through this function or directly as a method call
+without first calling
+.codn iter-more .
+No iteration mechanism in the \*(TL standard library behaves this way.
+If the iterator
+.meta object
+has no more items available and
+.code iter-more
+is invoked anyway, no requirements apply to its behavior or return value.
+
+.coNP Method @ iter-step
+.synb
+.mets << object .(iter-step)
+.syne
+.desc
+The
+.code iter-step
+method is invoked on an iterator object to produce an iterator object for the
+remainder of the sequence, excluding the current item.
+
+Under the fast iteration protocol, this method returns
+.code nil
+if there are no more items in the sequence.
+
+Under the canonical iteration protocol, this method always returns
+an iterator object. If no items remain in the sequence, then that
+iterator object's
+.code iter-more
+method returns
+.codn nil .
+Furthermore, under this protocol,
+.code iter-step
+is not called if
+.code iter-more
+returns
+.codn nil .
+
+Note: calls to the
+.code iter-step
+function, with
+.meta object
+as its argument, invoke the
+.code iter-step
+method. It is possible for an application to call
+.code iter-step
+through this function or directly as a method call
+without first calling
+.codn iter-more .
+No iteration mechanism in the \*(TL standard library behaves this way.
+If the iterator
+.meta object
+has no more items available and
+.code iter-step
+is invoked anyway, no requirements apply to its behavior or return value.
+
+.coNP Method @ iter-more
+.synb
+.mets << object .(iter-more)
+.syne
+.desc
+If an iterator
+.meta object
+returned by
+.code iter-begin
+supports the
+.code iter-more
+method, then the canonical iteration protocol applies to that iteration
+session. All subsequent iterators that are involved in the iteration
+are assumed to conform to the protocol and should implement the
+.code iter-more
+method also. The behavior is unspecified otherwise.
+
+The
+.code iter-more
+method is used to interrogate an iterator whether more unvisited items
+remain in the sequence. This method does not advance the iteration,
+and does not change the state of the iterator. It is idempotent: if it is
+called multiple times without any intervening call to any other method,
+it yields the same value.
+
+If an iterator does not implement the
+.code iter-more
+method, then if the
+.code iter-more
+function is applied to that iterator, it unconditionally returns
+.codn t .
+
.SS* Sequence Manipulation
+
+Functions in this category uniformly manipulate abstract sequences. Lists,
+strings and vectors are sequences.
+
+Structure objects can behave
+like sequences, either list-like or vector-like sequences, if they have
+certain methods: see the previous section Special Structure Functions.
+
+Moreover, hash tables behave like sequences of key-value entries represented by
+.code cons
+pairs. Not all sequence-processing functions accept hash-table sequences.
+
+Additionally, some sequence-processing functions work not only with sequences
+but with all iterable objects: objects that can be used as arguments to the
+.code iter-begin
+function. Such arguments are called
+.meta iterable
+rather than
+.metn sequence ,
+possibly abbreviated to
+.meta iter
+with or without a numeric suffix.
+Hash tables are always supported if they appear as
+.meta iterable
+arguments.
+
.coNP Function @ seqp
.synb
.mets (seqp << object )
@@ -28715,67 +34158,193 @@ methods are considered sequences.
No other objects are sequences. However, future revisions of
the language may specify additional objects that are sequences.
-.coNP Functions @ length and @ len
+.coNP Function @ iterable
.synb
-.mets (length << object )
-.mets (len << object )
+.mets (iterable << object )
.syne
.desc
+The
+.code iterable
+function returns
+.code t
+if
+.meta object
+is iterable, otherwise
+.codn nil .
+
If
.meta object
-is a sequence, the
+is a sequence according to the
+.code seqp
+function, then it is iterable.
+
+If
+.meta object
+is a structure which supports the
+.code iter-begin
+method, then it is iterable.
+
+Additional objects that are not sequences are also iterable:
+numeric or character ranges, and numbers. Future revisions
+of the language may specify additional iterable objects.
+
+.coNP Function @ make-like
+.synb
+.mets (make-like < list << object )
+.syne
+.desc
+The
+.meta list
+argument must be a list. If
+.meta object
+is a sequence type,
+then
+.meta list
+is converted to the same type of sequence and returned.
+Otherwise the original
+.meta list
+is returned.
+
+Conversion is supported to string and vector type.
+
+Conversion to a structure type is possible for structures. If
+.meta object
+is an object of a structure type which has a static function
+.codn from-list ,
+then
+.code make-like
+calls that function, passing to it, and the resulting value is returned.
+.meta list
+and returns whatever value that function returns.
+
+If
+.meta object
+is a
+.codn carray ,
+then
+.meta list
+is passed to the
+.code carray-list
+function, and the resulting value is returned. The second argument in the
+.code carray-list
+call is the element type taken from
+.metn object .
+The third argument is
+.codn nil ,
+indicating that the resulting
+.code carray
+is not to be null terminated.
+
+The
+.meta object
+may be an iterator returned by
+.codn iter-begin .
+In this situation, if that object makes the original sequence
+available, then
+.code make-like
+takes that sequence in place of
+.metn object ,
+
+Note: the
+.code make-like
+function is a helper which supports the development of
+unoptimized versions of a generic function that accepts any type of
+sequence as input, and produces a sequence of the same type as output.
+The implementation of such a function can internally accumulate a list, and
+then convert the resulting list to the same type as an input value
+by using
+.codn make-like .
+
+.coNP Functions @, list-seq @ vec-seq and @ str-seq
+.synb
+.mets (list-seq << iterable )
+.mets (vec-seq << iterable )
+.mets (str-seq << iterable )
+.syne
+.desc
+The
+.codn list-seq ,
+.code vec-seq
+and
+.code str-seq
+functions convert an iterable object of any type into a list, vector
+or string, respectively.
+
+The list returned by
+.code list-seq
+is lazy.
+
+The
+.code list-seq
+and
+.code vec-seq
+iterate the items of
+.meta iterable
+and accumulate these items into a new list or vector.
+
+The
+.code str-seq
+similarly iterates the items of
+.metn iterable ,
+requiring them to be a mixture of characters and strings.
+
+.coNP Functions @ length and @ len
+.synb
+.mets (length << iterable )
+.mets (len << iterable )
+.syne
+.desc
+The
.code length
-function returns the number of items it
-contains.
+function returns the number of items contained in
+.metn iterable .
The
.code len
function is a synonym of
.codn length .
-The function supports these additional types:
-.RS
-.coIP hash
-The value of
-.code hash-count
-is returned.
-.coIP range
-The length of the interval
-represented by the range is returned.
-The length of a range
-.code r
-is defined as
-.codn "(- (to r) (from r))" ,
-and thus may be negative.
-The length of
-.code "#R(1 -10)"
-is -11 and of
-.codn "#R(0.5 3)" ,
-2.5.
-.coIP buf
-The buffer length calculated by
-.code length-buf
-is returned.
-.coIP carray
-The number of elements in
-.meta object
-calculated by
-.code length-carray
-is returned.
-.RE
+An attempt to calculate the length of infinite lazy lists will not terminate.
+Iterable objects representing infinite ranges, such as integers and characters
+are invalid arguments.
-.IP
-For other types,
+.coNP Function @ length-<
+.synb
+.mets (length-< < iterable << len )
+.syne
+.desc
+The
+.code length-<
+function efficiently determines whether
+.mono
+.meti (length << iterable)
+.onom
+is less than the integer value
+.metn len .
+In cases when
+.meta iterable
+would have to be fully traversed in order to measure its length, the
+.code length-<
+function avoids this traversal, by making use of the functions
+.code length-str-<
+or
+.code length-list-<
+as appropriate.
+
+Note: this function is useful when a decision must be made between
+two algorithms, depending on whether the length is less than a certain
+small constant. It is also safe on lazy, infinite sequences and
+circular lists, for which
.code length
-throws an error exception.
+will fail to terminate.
.coNP Function @ empty
.synb
-.mets (empty << object )
+.mets (empty << iterable )
.syne
.desc
If
-.meta object
+.meta iterable
is a suitable argument for the
.code length
function, then the
@@ -28784,98 +34353,129 @@ Returns
.code t
if
.mono
-.meti (length << object )
+.meti (length << iterable )
.onom
is zero, otherwise
.codn nil .
-If
-.meta object
-is not a suitable argument for
-.codn length ,
-then
+The
.code empty
-throws an error exception.
+function also supports certain objects not suitable as arguments for
+.codn length .
-.coNP Function @ copy
+An infinite lazy list is not empty, and so
+.code empty
+returns
+.code nil
+for such an object.
+
+The function also returns
+.code nil
+for iterable objects representing nonempty spaces, even if
+those spaces are infinite. For instance
+.code "(empty 0)"
+yields
+.code nil
+because the set of integers beginning with 0 isn't empty.
+
+.coNP Function @ nullify
.synb
-.mets (copy << object )
+.mets (nullify << iterable )
.syne
.desc
The
-.code copy
-function duplicates objects of various supported types: sequences, hashes,
-structures and random states. If
-.meta object
-is
-.codn nil ,
-it
-returns
+.code nullify
+function returns
+.code nil
+if
+.meta iterable
+denotes an empty sequence.
+Otherwise, if
+.meta iterable
+is not an empty sequence, or isn't a sequence, then
+.meta iterable
+itself is returned.
+
+If
+.meta iterable
+is a structure object which supports the
+.code nullify
+method, then that method is called. If it returns
+.code nil
+then
+.code nil
+is returned. If the
+.code nullify
+method returns a substitute object other than the
+.meta iterable
+object itself, then
+.code nullify
+is invoked on that returned substitute object.
+
+Note: the
+.code nullify
+function is a helper to support unoptimized generic
+traversal of sequences. Thanks to the generalized behavior of
+.codn cdr ,
+non-list sequences can be traversed using
+.codn cdr ,
+similarly to proper lists, by checking for
+.code cdr
+returning the terminating value
.codn nil .
-Otherwise,
-.code copy
-is equivalent to invoking a more specific copying function according to
-the type of the argument, as follows:
-.RS
-.coIP cons
-.meti (copy-list << object )
-.coIP str
-.meti (copy-str << object )
-.coIP vec
-.meti (copy-vec << object )
-.coIP hash
-.meti (copy-hash << object )
-.IP "struct type"
-.meti (copy-struct << object )
-.coIP fun
-.meti (copy-fun << object )
-.coIP buf
-.meti (copy-buf << object )
-.coIP carray
-.meti (copy-carray << object )
-.coIP random-state
-.meti (make-random-state << object )
-.coIP tnode
-.meti (copy-tnode << object )
-.coIP tree
-.meti (copy-search-tree << object )
-.RE
+However, empty non-list sequences are handled incorrectly because
+since they are not the
+.code nil
+object, they look nonempty under this paradigm of traversal.
+The
+.code nullify
+function provides a correction: if the input sequence is filtered
+through
+.code nullify
+then the subsequent list-like iteration works correctly.
-.IP
-For all other types of
-.metn object ,
-the invocation is erroneous.
+Examples:
-Except in the case when
-.meta sequence
-is
-.codn nil ,
-.code copy
-returns a value that
-is distinct from (not
-.code eq
-to)
-.metn sequence .
-This is different from
-the behavior of
-.mono
-.meti >> [ sequence 0..t]
-.onom
-or
-.mono
-.meti (sub < sequence 0 t)
-.onom
-which recognize
-that they need not make a copy of
-.metn sequence ,
-and just return it.
+.verb
+ ;; Incorrect for empty strings:
-Note however, that the elements of the returned sequence may be
-eq to elements of the original sequence. In other words, copy is
-a deeper copy than just duplicating the
-.code sequence
-value itself,
-but it is not a deep copy.
+ (defun print-chars (string)
+ (while string
+ (prinl (pop string))))
+
+ ;; Corrected with nullify:
+
+ (defun print-chars (string)
+ (let ((s (nullify string)))
+ (while s
+ (prinl (pop s)))))
+.brev
+
+Note: optimized generic iteration is available in the form of iteration
+based on
+.code iter-begin
+rather than
+.cod3 car / cdr
+and
+.codn nullify .
+
+Examples:
+
+.verb
+ ;; Efficient with iterators,
+ ;; at the cost of verbosity:
+
+ (defun print-chars (string)
+ (let ((i (iter-begin string)))
+ (while (iter-more i)
+ (prinl (iter-item s))
+ (set s (iter-step s)))))
+
+ ;; Using mapping function built on iterators:
+
+ (defun print-chars (string)
+ [mapdo prinl string])
+.brev
.coNP Accessor @ sub
.synb
@@ -28937,7 +34537,36 @@ If
is a
.code buf
object, then the function behaves like
-.codn buf-sub .
+.codn sub-buf .
+
+If
+.meta sequence
+is a
+.code tree
+object, then the function behaves like
+.codn sub-tree .
+Note: because
+.code sub-tree
+is not an accessor, assigning to the
+.code sub
+syntax in this case will produce an error.
+
+The
+.meta sequence
+argument may also be any other object type that is suitable as input to the
+.code iter-begin
+function. In this situation, assigning to
+.code sub
+syntax produces an error. The behavior is complex. In cases where the
+.meta from
+and
+.meta to
+arguments imply that a suffix of
+.meta sequence
+is required, an iterator may be returned which traverses the suffix
+of the sequence. In other cases, a list of the elements selected by
+.code sub
+is returned.
If
.meta sequence
@@ -28961,9 +34590,9 @@ That is to say, the
and
.code to
arguments are converted to range object. If either argument
-is missing, the symbol
+is missing, the
.code :
-is used for the corresponding element of the range.
+(colon) keyword symbol is used for the corresponding element of the range.
When a
.code sub
@@ -29023,7 +34652,7 @@ and must be taken into account.
.coNP Function @ replace
.synb
.mets (replace < sequence < replacement-sequence >> [ from <> [ to ]])
-.mets (replace < sequence < replacement-sequence << index-list )
+.mets (replace < sequence < replacement-sequence << index-seq )
.syne
.desc
The
@@ -29071,9 +34700,9 @@ The
function has two invocation styles, distinguished by the
type of the third argument. If the third argument is a sequence, then it
is deemed to be the
-.meta index-list
+.meta index-seq
parameter of the second form.
-Otherwise, if the third argument is missing, or is not a list, then
+Otherwise, if the third argument is missing, or is not a sequence, then
it is deemed to be the
.meta from
argument of the first form.
@@ -29108,37 +34737,48 @@ The second form of the replace function replaces a subsequence of
elements from
.meta sequence
given by
-.metn index-list ,
+.metn index-seq ,
with their counterparts
from
.metn replacement-sequence .
-This form of the replace function does not insert
-or delete; it simply overwrites elements. If
+If
.meta replacement-sequence
-and
-.meta index-list
-are of different lengths, then the shorter of the two determines
-the maximum number of elements which are overwritten.
+has at least as many elements as are indicated in
+.metn index-seq ,
+then the indicated elements of
+.meta sequence
+are overwritten with successive elements from
+.metn replacement-sequence .
+If
+.meta replacement-sequence
+contains fewer elements than
+.metn index-seq ,
+then the excess elements indicated in
+.meta index-seq
+which have no counterparts in the
+.meta replacement-sequence
+are deleted.
Whenever a negative value occurs in
-.meta index-list
-the length of
+.meta index-seq
+the original length of
.meta sequence
-is added to that value.
+(before any deletions) is added to that value.
Furthermore, similar restrictions apply on
-.meta index-list
+.meta index-seq
as under the
select function. Namely, the replacement stops when an index value
in
-.meta index-list
+.meta index-seq
is encountered which is out of range for
.metn sequence .
furthermore, if
.meta sequence
-is a list, then
-.meta index-list
+is a list, or if any deletions take place, then
+.meta index-seq
must
be monotonically increasing, after consideration of the
-displacement of negative values.
+displacement of negative values, or else the behavior
+is unspecified.
If
.meta replacement-sequence
@@ -29184,8 +34824,8 @@ method according to the following equivalences:
(replace o items from to)
<--> o.(lambda-set (rcons from to) items)
- (replace o items index-list)
- <--> o.(lambda-set index-list items)
+ (replace o items index-seq)
+ <--> o.(lambda-set index-seq items)
.brev
Thus, the
@@ -29194,12 +34834,12 @@ and
.meta to
arguments are converted to single range object,
whereas an
-.meta index-list
+.meta index-seq
is passed as-is.
It is an error if the
.code from
argument is a sequence, indicating an
-.metn index-list ,
+.metn index-seq ,
and a
.code to
argument is also given; the situation is diagnosed. If either
@@ -29208,7 +34848,7 @@ or
.code to
are omitted, the range object contains the
.code :
-symbol in the corresponding place:
+(colon) keyword symbol in the corresponding place:
.verb
(replace o items from)
@@ -29410,14 +35050,14 @@ itself or a copy.
.coNP Accessor @ last
.synb
-.mets (last < seq <> [ num ])
-.mets (set (last < seq <> [ num ]) << new-value)
+.mets (last < sequence <> [ num ])
+.mets (set (last < sequence <> [ num ]) << new-value)
.syne
.desc
The
.meta last
function returns a subsequence of
-.meta seq
+.meta sequence
consisting of the last
.meta num
of its elements, where
@@ -29429,15 +35069,15 @@ If
is zero or negative, then an empty sequence is returned.
If
.meta num
-is positive, and greater than or equal to the length of seq,
-then seq
-.meta seq
+is positive, and greater than or equal to the length of sequence,
+then sequence
+.meta sequence
is returned.
If a
.code last
form is used as a place, then
-.code seq
+.code sequence
must be a place. The following equivalence gives the semantics
of assignment to a
.codn last :
@@ -29523,7 +35163,7 @@ accessor, which operates on lists. That function has useful semantics for
improper lists and treats an atom as the terminator of a zero-length improper
list.
-Dialect note: a destructive function similar to Common Lisp's
+Dialect Note: a destructive function similar to Common Lisp's
.code nbutlast
isn't provided. Assignment to a
.code butlast
@@ -29548,7 +35188,7 @@ function supports the original
semantics when both inputs are lists. It determines whether the
.meta tail-sequence
list is a structural suffix of
-.metn sequence ;
+.metn sequence ,
which is to say: is
.meta tail-sequence
one of the
@@ -29636,7 +35276,7 @@ to a suffix of
then
.meta sequence
is returned.
-.IP 6
+.IP 6.
In all other cases,
.meta sequence
and
@@ -29720,12 +35360,11 @@ The arguments
.meta haystack
and
.meta needle
-are sequences: lists, vectors
-or strings, in any combination.
+are sequences. They may not be hash tables.
If
.meta needle
-is not empty, then occurs at some position N within
+is not empty, then it occurs at some position N within
.meta haystack
if
the first element of
@@ -29803,40 +35442,108 @@ The
.code rsearch
function is like
.code search
-except that if
+except for two differences.
+
+Firstly, if
.meta needle
matches
.meta haystack
in multiple places,
.code rsearch
-returns the right-most matching position rather than
+returns the rightmost matching position rather than
the leftmost.
-.coNP Functions @ ref and @ refset
+Secondly, if
+.meta needle
+is an empty sequence, then
+.code rsearch
+returns the length of
+.codn haystack ,
+thereby effectively declaring that the rightmost match for an empty
+.meta needle
+key occurs at the imaginary position past the element of
+.metn haystack .
+
+.coNP Function @ search-all
.synb
-.mets (ref < seq << index )
-.mets (refset < seq < index << new-value )
+.mets (search-all < haystack < needle >> [ testfun <> [ keyfun ])
.syne
.desc
The
-.code ref
-and
-.code refset
-functions perform array-like indexing into sequences, as well as
-objects of type
-.code buf
+.code search-all
+function is closely related to the
+.code search
and
-.codn carray .
+.code rsearch
+functions. Whereas those two functions return the leftmost or rightmost
+position, respectively, of
+.meta needle
+within
+.metn haystack ,
+the
+.code search-all
+function returns a list of all the positions where
+.meta needle
+occurs. The positions of overlapping matches are included in the list.
+
+If
+.meta needle
+is not found in
+.metn haystack ,
+.code search-all
+returns the empty list
+.codn nil .
+
+If
+.meta needle
+is empty, then
+.code search-all
+returns a list of all positions in
+.meta haystack
+including the one position past the last element. In this situation, if
+.meta haystack
+is empty, the list
+.code "(0)"
+is returned. If
+.meta haystack
+contains one item, then the list
+.code "(0 1)"
+is returned and so forth.
+
+In all situations in which
+.code search-all
+returns a non-empty list, the first element of that list is what
+.code search
+would return for the same arguments, and the last element is what
+.code rsearch
+would return.
+
+.coNP Accessor @ ref
+.synb
+.mets (ref < sequence << index )
+.mets (set (ref < sequence << index ) << new-value )
+.syne
+.desc
+The
+.code ref
+accessor performs array-like indexing into sequences, as well as
+hash tables and objects of type
+.codn buf ,
+.codn carray ,
+.code tree
+as well as structure objects which define a
+.code lambda
+method.
If the
-.meta seq
+.meta sequence
parameter is a hash, then these functions perform
has retrieval and storage; in that case
.meta index
isn't restricted to an integer value.
If
-.meta seq
+.meta sequence
is a structure, it supports
.code ref
directly if it has a
@@ -29856,7 +35563,97 @@ treats it as a list, traversing the structure using
operations. In the absence of support for these operations,
the function fails with an error exception.
-Similarly, a structure supports
+If
+.meta sequence
+is a sequence then
+.meta index
+argument must be an integer. The first element of the sequence
+is indexed by zero. Negative values are permitted,
+denoting backward indexing from the end of the sequence, such that
+the last element is indexed by -1, the second last by -2 and so on.
+See also the Range Indexing section under the
+description of the
+.code dwim
+operator.
+
+If
+.meta sequence
+is a list, then out-of-range indices, whether positive or negative,
+are treated leniently by
+.codn ref :
+such accesses produce the value
+.codn nil ,
+rather than an error. For other sequence types, such accesses
+are erroneous. For hashes, accesses to nonexistent elements
+are treated leniently, and produce
+.codn nil .
+
+If
+.meta sequence
+is a search tree, then
+.code ref
+behaves like
+.codn tree-lookup .
+
+If
+.meta sequence
+is a range object, then
+.code ref
+behaves like
+.codn rangeref .
+
+A
+.code ref
+expression may be used as a place. Storing a value into a
+.code ref
+place is performed using the
+.code refset
+function.
+
+When the
+.code del
+operator is used to delete an index value from a
+.code ref
+place, the
+.meta sequence
+itself must be a place. The deletion calculates a new
+sequence with the item at
+.meta index
+deleted; that new sequence is stored back into the
+.meta sequence
+place. Deletion does not use
+.code refset
+but rather the
+.code replace
+function.
+
+.coNP Function @ refset
+.synb
+.mets (refset < sequence < index << new-value )
+.syne
+.desc
+The
+.code refset
+function performs indexing into
+.meta sequence
+in a manner identical to
+.code ref
+with the purpose of overwriting the indexed element with
+.metn new-value .
+It is a companion function to
+.code ref
+which is used in the implementation of the
+.code ref
+place.
+
+The return value of
+.code ref-set
+is
+.metn new-value .
+
+If
+.meta sequence
+is a structure, it supports
.code refset
directly if it has a
.code lambda-set
@@ -29881,40 +35678,8 @@ In the absence of support for these operations,
the function fails with an error exception.
The
-.code ref
-function retrieves an element of
-.metn seq ,
-whereas
.code refset
-overwrites an
-element of
-.meta seq
-with a new value.
-
-If
-.meta seq
-is a sequence then
-.meta index
-argument must be an integer. The first element of the sequence
-is indexed by zero. Negative values are permitted,
-denoting backward indexing from the end of the sequence, such that
-the last element is indexed by -1, the second last by -2 and so on.
-See also the Range Indexing section under the
-description of the
-.code dwim
-operator.
-
-If
-.meta seq
-is a list, then out-of-range indices, whether positive or negative,
-are treated leniently by
-.codn ref :
-such accesses produce the value
-.codn nil ,
-rather than an error. For other sequence types, such accesses
-are erroneous. For hashes, accesses to nonexistent elements
-are treated leniently, and produce
-.codn nil .
+function is not supported by search trees.
The
.code refset
@@ -29923,61 +35688,172 @@ including lists. In the case of hashes, a
.code refset
of a nonexistent key creates the key.
+.coNP Accessor @ mref
+.synb
+.mets (mref < sequence << index *)
+.mets (set (mref < sequence << index +) new-value)
+.syne
+.desc
The
-.code refset
-function returns
-.codn new-value .
+.code mref
+accessor provides a mechanism for invoking a curried function. Its name
+reflects its usefulness for multi-dimensional indexing into nested sequences.
-The following equivalences hold between
-.code ref
+The associated
+.code mref
+place which makes the operator an accessor provides in-place replacement of
+values in multi-dimensional sequences. There are some restrictions on the
+.meta index
+arguments when
+.code mref
+is used as a place.
+
+The
+.meta sequence
+argument is not necessarily a sequence, but may be object that can be called as
+a function with one argument. Except that
+.code call
+isn't a place, the expression
+.code "(mref x i)"
+is equivalent to
+.codn "(call x i)" :
+invoke the function/object
+.code x
+with argument
+.codn i .
+
+When multiple
+.meta index
+arguments are present, the return value of each previous application
+is expected to be another callable object, to which the next
+.meta index
+argument is applied. Thus
+.code "(mref x i j k)"
+is equivalent to
+.codn "(call (call (call x i) j) k)" .
+This is also equivalent to
+.codn "[[[x i] j] k]" ,
+provided that under the Lisp-1-style name resolution semantics of the DWIM
+brackets, the symbols
+.codn x ,
+.codn i ,
+.code j
and
-.codn refset ,
-and the DWIM bracket syntax, provided that
-.meta idx
-is a scalar index and
-.meta seq
-is a sequence object, rather than a hash.
+.code k
+all resolve to bindings in the variable namespace.
-.verb
- (ref seq idx) <--> [seq idx]
+The expression
+.code "(mref x)"
+is not equivalent to
+.codn "(call x)" ;
+rather, it is equivalent to
+.codn x :
+there are no
+.meta index
+arguments and so the
+.code x
+object is taken as-is, not being applied to any index.
- (refset seq idx new) <--> (set [seq idx] new)
-.brev
+In more detail, the
+.code mref
+function begins by taking
+.meta sequence
+as its an accumulator object. Then if there are
+.meta index
+arguments, it iterates over them. At each iteration step, it
+replaces the accumulator by treating the accumulator as a callable object
+and applying it to
+.meta index
+value and taking the resulting value as the new accumulator.
+After the iteration, the accumulator becomes the return value of
+the function.
-The difference is that
-.code ref
-and
-.code refset
-are first class functions which
-can be used in functional programming as higher order functions, whereas the
-bracket notation is syntactic sugar, and
-.code set
-is an operator, not a function.
-Therefore the brackets cannot replace all uses of
-.code ref
+When
+.code mref
+is used as a place, only the rightmost
+.meta index
+argument may be a range. If any other argument is a range object,
+the behavior is unspecified.
+
+When
+.code mref
+is used as a place, and there is only one
+.meta index
+which is a range object, then the
+.meta sequence
+expression is also required to be a place, if it denotes a list or
+range object. If there are no
+.meta index
+augments then
+.meta sequence
+is unconditionally required to be a place.
+
+Note: the functions
+.code nested-vec
and
-.codn refset .
+.code nested-vec-of
+may be used to create nested vectors which simulate multi-dimensional arrays.
+
+.TP* Examples:
+
+.verb
+ ;; Indexing:
+ (let ((ar '((1 2 3)
+ (4 5 6)
+ (7 8 9))))
+ (mref ar 1 1))
+ --> 5
+
+ ;; Updating value in nested sequence:
+ (let ((ar (vec (vec (vec 0 1 2 3)
+ (vec 4 5 6 7))
+ (vec (vec 8 9 10 11)
+ (vec 12 13 14 15)))))
+ (set (mref ar 0 0 1..3) "AB")
+ ar)
+ --> #(#(#( 0 #\eA #\eB 3)
+ #( 4 5 6 7))
+ #(#( 8 9 10 11)
+ #(12 13 14 15)))
+
+ ;; Invoking curried function:
+ (let ((cf (lambda (x)
+ (lambda (y)
+ (lambda (z)
+ (+ x y z))))))
+ [mref cf 1 2 3])
+ --> 6
+.brev
.coNP Function @ update
.synb
-.mets (update < sequence-or-hash << function )
+.mets (update < sequence << function )
.syne
.desc
The
.code update
-function replaces each elements in a sequence, or each value
-in a hash table, with the value of
+function replaces each elements in
+.meta sequence
+in a hash table, with the result of
.meta function
-applied to that element
-or value.
+being applied to that element value.
+
+The
+.meta sequence
+is returned.
-The sequence or hash table is returned.
+The
+.meta sequence
+may be a hash table. In that case,
+.meta function
+is invoked with each hash value, which is replaced with the function's return
+value.
.coNP Functions @, remq @ remql and @ remqual
.synb
-.mets (remq < object < list <> [ key-function ])
-.mets (remql < object < list <> [ key-function ])
-.mets (remqual < object < list <> [ key-function ])
+.mets (remq < object < sequence <> [ key-function ])
+.mets (remql < object < sequence <> [ key-function ])
+.mets (remqual < object < sequence <> [ key-function ])
.syne
.desc
The
@@ -29985,8 +35861,8 @@ The
.code remql
and
.code remqual
-functions produce a new list based on
-.metn list ,
+functions produce a new sequence based on
+.metn sequence ,
removing the elements whose associated keys are
.codn eq ,
.code eql
@@ -29996,11 +35872,11 @@ to
.metn object .
The input
-.meta list
-is unmodified, but the returned list may share substructure
+.meta sequence
+is unmodified, but the returned sequence may share substructure
with it. If no items are removed, it is possible that the return value
is
-.meta list
+.meta sequence
itself.
If
@@ -30016,9 +35892,9 @@ is that element's key which is compared to
.coNP Functions @, remq* @ remql* and @ remqual*
.synb
-.mets (remq* < object << list )
-.mets (remql* < object << list )
-.mets (remqual* < object << list )
+.mets (remq* < object << sequence )
+.mets (remql* < object << sequence )
+.mets (remqual* < object << sequence )
.syne
.desc
The
@@ -30026,12 +35902,12 @@ The
.code remql*
and
.code remqual*
-functions are lazy versions of
+functions are lazy analogs of
.codn remq ,
.code remql
and
.codn remqual .
-Rather than computing the entire new list
+Rather than computing the entire new sequence
prior to returning, these functions return a lazy list.
Caution: these functions can still get into infinite looping behavior.
@@ -30056,9 +35932,9 @@ does not have to be deleted, in order to instantiate the first lazy value.
.coNP Functions @, keepq @ keepql and @ keepqual
.synb
-.mets (keepq < object < list <> [ key-function ])
-.mets (keepql < object < list <> [ key-function ])
-.mets (keepqual < object < list <> [ key-function ])
+.mets (keepq < object < sequence <> [ key-function ])
+.mets (keepql < object < sequence <> [ key-function ])
+.mets (keepqual < object < sequence <> [ key-function ])
.syne
.desc
The
@@ -30066,8 +35942,8 @@ The
.code keepql
and
.code keepqual
-functions produce a new list based on
-.metn list ,
+functions produce a new sequence based on
+.metn sequence ,
removing the items whose keys are not
.codn eq ,
.code eql
@@ -30077,48 +35953,49 @@ to
.metn object .
The input
-.meta list
-is unmodified, but the returned list may share substructure
+.meta sequence
+is unmodified, but the returned sequence may share substructure
with it. If no items are removed, it is possible that the return value
is
-.meta list
+.meta sequence
itself.
The optional
.meta key-function
is applied to each element from the
-.meta list
+.meta sequence
to convert it to a key which is compared to
.metn object .
If
.meta key-function
is omitted, then each element itself of
-.meta list
+.meta sequence
is compared to
.metn object .
-.coNP Functions @, remove-if @, keep-if @ remove-if* and @ keep-if*
+.coNP Functions @, remove-if @, keep-if @, separate @ remove-if* and @ keep-if*
.synb
-.mets (remove-if < predicate-function < list <> [ key-function ])
-.mets (keep-if < predicate-function < list <> [ key-function ])
-.mets (remove-if* < predicate-function < list <> [ key-function ])
-.mets (keep-if* < predicate-function < list <> [ key-function ])
+.mets (remove-if < predicate-function < sequence <> [ key-function ])
+.mets (keep-if < predicate-function < sequence <> [ key-function ])
+.mets (separate < predicate-function < sequence <> [ key-function ])
+.mets (remove-if* < predicate-function < sequence <> [ key-function ])
+.mets (keep-if* < predicate-function < sequence <> [ key-function ])
.syne
.desc
The
.code remove-if
-function produces a list whose contents are those of
-.meta list
+function produces a sequence whose contents are those of
+.meta sequence
but with those elements removed which satisfy
.metn predicate-function .
Those elements which are not removed appear in the same order.
-The result list may share substructure with the input list,
-and may even be the same list object if no items are removed.
+The result sequence may share substructure with the input sequence,
+and may even be the same sequence object if no items are removed.
The optional
.meta key-function
specifies how each element from the
-.meta list
+.meta sequence
is transformed to an argument to
.metn predicate-function .
If this argument is omitted
@@ -30143,6 +36020,45 @@ will delete, and removes those that
will preserve.
The
+.code separate
+function combines
+.code keep-if
+and
+.code remove-if
+into one,
+returning a list of two elements whose
+.code car
+and
+.code cadr
+are the result of calling
+.code keep-if
+and
+.codn remove-if ,
+respectively,
+on
+.meta sequence
+(with the
+.meta predicate-function
+and
+.meta key-function
+arguments passed through).
+One of the two elements may share substructure with the input sequence,
+and may even be the same sequence object if all items are either kept or
+removed (in which case the other element will be
+.codn nil ).
+
+Note: the
+.code separate
+function may be understood in terms of the following reference implementation:
+
+.verb
+ (defun separate (pred seq : (keyfun :))
+ [(juxt (op keep-if pred @1 keyfun)
+ (op remove-if pred @1 keyfun))
+ seq])
+.brev
+
+The
.code remove-if*
and
.code keep-if*
@@ -30169,11 +36085,63 @@ but produce lazy lists.
-> (("defg" 5))
.brev
+.coNP Functions @ keep-keys-if and @ separate-keys
+.synb
+.mets (keep-keys-if < predicate-fun < sequence <> [ key-fun ])
+.mets (separate-keys < predicate-fun < sequence <> [ key-fun ])
+.syne
+.desc
+The functions
+.code keep-keys-if
+and
+.code separate-keys
+are derived, respectively, from the functions
+.code keep-if
+and
+.codn separate ,
+and have the same syntax and argument semantics. They differ in that
+rather than accumulating the elements of the input
+.codn sequence ,
+they accumulate the transformed values of those elements, as projected
+through the
+.metn key-fun .
+
+Thus when
+.meta key-fun
+is omitted, thus defaulting to
+.codn identity ,
+or else explicitly specified as
+.code identity
+or equivalent function, the behavior of these functions is the
+almost the same as that of
+.code keep-if
+and
+.codn separate .
+However, there may be a difference in whether the output shares structure with
+.metn sequence .
+
+.TP* Example:
+
+.verb
+ ;; square the values 1 to 20, keeping the even squares
+ [keep-keys-if evenp (range 1 20) square]
+ -> (4 16 36 64 100 144 196 256 324 400)
+
+ ;; square the values 1 to 20 separating into even and odd:
+ [separate-keys evenp (range 1 20) square]
+ -> ((4 16 36 64 100 144 196 256 324 400)
+ (1 9 25 49 81 121 169 225 289 361))
+
+ ;; contrast with keep-if: values are of input sequence
+ [keep-if evenp (range 1 20) square]
+ -> (2 4 6 8 10 12 14 16 18 20)
+.brev
+
.coNP Functions @, countqual @ countql and @ countq
.synb
-.mets (countq < object << list )
-.mets (countql < object << list )
-.mets (countqual < object << list )
+.mets (countq < object << iterable )
+.mets (countql < object << iterable )
+.mets (countqual < object << iterable )
.syne
.desc
The
@@ -30183,7 +36151,7 @@ and
.code countqual
functions count the number of objects
in
-.meta list
+.meta iterable
which are
.codn eq ,
.code eql
@@ -30193,37 +36161,114 @@ to
.metn object ,
and return the count.
-.coNP Function @ count-if
+.coNP Functions @ count and @ count-if
.synb
-.mets (count-if < predicate-function < list <> [ key-function ])
+.mets (count < key < sequence >> [ testfun <> [ keyfun ]])
+.mets (count-if < predfun < iterable <> [ keyfun ])
.syne
.desc
The
+.code count
+and
+.code count-if
+functions search through
+.meta sequence
+for items which match
+.metn key ,
+or satisfy the predicate function
+.metn predfun ,
+respectively. They return the number of matching or predicate-satisfying items.
+
+The
+.meta keyfun
+argument specifies a function which is applied to the elements
+of
+.meta sequence
+to produce the comparison key. If this argument is omitted,
+then the untransformed elements of
+.meta sequence
+are examined.
+
+The
+.code count
+function's
+.meta testfun
+argument specifies the test function which
+is used to compare the comparison keys from
+.meta sequence
+to
+.metn key .
+If this argument is omitted, then the
+.code equal
+function is used.
+The
+.code count
+function returns the number of elements of
+.meta sequence
+whose comparison key (as retrieved by
+.metn keyfun )
+matches the
+.meta key
+object, as compared by
+.metn testfun .
+
+The
.code count-if
-function counts the number of elements of
-.meta list
-which satisfy
-.meta predicate-function
-and returns the count.
+function's
+.meta predfun
+argument specifies a predicate function
+which is applied to the successive comparison keys taken from
+.metn sequence .
+The function returns the count of the number keys for which
+.meta predfun
+returns true.
-The optional
-.meta key-function
-specifies how each element from the
-.meta list
-is transformed to an argument to
-.metn predicate-function .
-If this argument is omitted
-then the predicate function is applied to the elements directly, a behavior
-which is identical to
-.meta key-function
-being
-.codn "(fun identity)" .
+.coNP Function @ cons-count
+.synb
+.mets (cons-count < obj < tree <> [ test-function ])
+.syne
+.desc
+The
+.code cons-count
+function returns the number of times the object
+.meta obj
+occurs in the
+.code cons
+cell structure
+.metn tree ,
+under the equality imposed by the
+.metn test-function .
+
+If the optional
+.meta test-function
+argument is omitted, it defaults to
+.codn equal .
+
+First,
+.meta obj
+and
+.meta tree
+are compared using
+.metn test-function .
+If they are equal, that counts as one occurrence.
+
+Then, if
+.meta tree
+is a
+.code cons
+cell, the function recurses over the
+.code car
+and
+.code cdr
+fields.
+
+The sum of all these counts is returned.
.coNP Functions @, posq @ posql and @ posqual
.synb
-.mets (posq < object << list )
-.mets (posql < object << list )
-.mets (posqual < object << list )
+.mets (posq < object << sequence )
+.mets (posql < object << sequence )
+.mets (posqual < object << sequence )
.syne
.desc
The
@@ -30233,7 +36278,7 @@ and
.code posqual
functions return the zero-based position of the
first item in
-.meta list
+.meta sequence
which is, respectively,
.codn eq ,
.code eql
@@ -30244,8 +36289,8 @@ to
.coNP Functions @ pos and @ pos-if
.synb
-.mets (pos < key < list >> [ testfun <> [ keyfun ]])
-.mets (pos-if < predfun < list <> [ keyfun ])
+.mets (pos < key < sequence >> [ testfun <> [ keyfun ]])
+.mets (pos-if < predfun < sequence <> [ keyfun ])
.syne
.desc
The
@@ -30253,10 +36298,10 @@ The
and
.code pos-if
functions search through
-.meta list
+.meta sequence
for an item which matches
.metn key ,
-or satisfies predicate function
+or satisfies the predicate function
.metn predfun ,
respectively.
They return the zero-based position of the matching item.
@@ -30265,10 +36310,10 @@ The
.meta keyfun
argument specifies a function which is applied to the elements
of
-.meta list
+.meta sequence
to produce the comparison key. If this argument is omitted,
then the untransformed elements of
-.meta list
+.meta sequence
are examined.
The
@@ -30277,21 +36322,25 @@ function's
.meta testfun
argument specifies the test function which
is used to compare the comparison keys from
-.meta list
+.meta sequence
to
.metn key .
If this argument is omitted, then the
.code equal
function is used.
-The position of the first element
-.meta list
+The
+.code pos
+function returns the position of the first element of
+.meta sequence
whose comparison key (as
retrieved by
.metn keyfun )
-matches the search (under
-.metn testfun )
-is
-returned. If no such element is found,
+matches
+.metn key ,
+as compared by the
+.meta testfun
+function.
+If no such element is found,
.code nil
is returned.
@@ -30301,7 +36350,7 @@ function's
.meta predfun
argument specifies a predicate function
which is applied to the successive comparison keys taken from
-.meta list
+.meta sequence
by applying
.meta keyfun
to successive elements. The position of
@@ -30314,11 +36363,11 @@ is returned.
.coNP Functions @, rposq @, rposql @, rposqual @ rpos and @ rpos-if
.synb
-.mets (rposq < object << list )
-.mets (rposql < object << list )
-.mets (rposqual < object << list )
-.mets (rpos < key < list >> [ testfun <> [ keyfun ]])
-.mets (rpos-if < predfun < list <> [ keyfun ])
+.mets (rposq < object << sequence )
+.mets (rposql < object << sequence )
+.mets (rposqual < object << sequence )
+.mets (rpos < key < sequence >> [ testfun <> [ keyfun ]])
+.mets (rpos-if < predfun < sequence <> [ keyfun ])
.syne
.desc
These functions are counterparts of
@@ -30328,8 +36377,8 @@ These functions are counterparts of
.code rpos
and
.code rpos-if
-which report position of the right-most matching item,
-rather than the left-most.
+which report position of the rightmost matching item,
+rather than the leftmost.
.coNP Functions @ pos-max and @ pos-min
.synb
@@ -30346,7 +36395,9 @@ differ only in their defaulting behavior with regard to the
.meta testfun
argument. If
.meta testfun
-is not given, then the pos-max function defaults
+is not given, then the
+.code pos-max
+function defaults
.meta testfun
to the
.code greater
@@ -30421,6 +36472,92 @@ elements. To find the rightmost of the maxima, the
function can be substituted. Analogous reasoning applies to other
test functions.
+.coNP Function @ subst
+.synb
+.mets (subst < old < new < seq >> [ testfun <> [ keyfun ]])
+.syne
+.desc
+The
+.code subst
+function returns a sequence of the same type as
+.meta seq
+in which elements of
+.meta seq
+which match the
+.meta old
+object have been replaced with the
+.meta new
+object.
+
+To form the comparison keys, the elements of
+.meta seq
+are projected through the
+.meta testfun
+function, which defaults to
+.codn identity ,
+so the items themselves are used as keys by default.
+
+Keys are compared to the
+.meta old
+value using
+.metn testfun ,
+which defaults to
+.codn equal .
+
+.TP* Examples:
+
+.verb
+ (subst "brown" "black" #("how" "now" "brown" "cow"))
+ -> #("how" "now" "black" "cow"))
+
+ ;; elements are converted to lower case to form keys
+ [subst "brown" "black"
+ #("how" "now" "BROWN" "cow") : downcase-str]
+ -> #("how" "now" "black" "cow")
+
+ ;; using < instead of equality, replace elements
+ ;; greater than 5 with 0
+ [subst 5 0 '(1 2 3 4 5 6 7 8 9 10) <] (1 2 3 4 5 0 0 0 0 0))
+.brev
+
+.coNP Functions @, subq @ subql and @ subqual
+.synb
+.mets (subq < old < new << sequence )
+.mets (subql < old < new << sequence )
+.mets (subqual < old < new << sequence )
+.syne
+.desc
+The
+.codn subq ,
+.code subql
+and
+.code subqual
+functions return a sequence of the same kind as
+.meta sequence
+in which elements matching the
+.meta old
+object are replaced by
+.meta new
+object.
+
+The matching elements are identified by comparing with
+.meta old
+using, respectively, the functions
+.codn eq ,
+.codn eql ,
+and
+.codn equal .
+
+.TP* Examples:
+
+.verb
+ (subq #\eb #\ez "abc") -> "azc"
+ (subql 1 3 #(0 1 2)) -> #(0 3 2)
+
+ (subqual "are" "do" '#"how are you")
+ -> ("how" "do" "you")
+.brev
+
.coNP Function @ mismatch
.synb
.mets (mismatch < left-seq < right-seq >> [ testfun <> [ keyfun ]])
@@ -30464,11 +36601,11 @@ which must accept two arguments, and defaults to
.coNP Function @ where
.synb
-.mets (where < function << object )
+.mets (where < function << iterable )
.syne
.desc
If
-.meta object
+.meta iterable
is a sequence, the
.code where
function returns
@@ -30477,10 +36614,10 @@ a lazy list of the numeric indices of those of its elements which satisfy
The numeric indices appear in increasing order.
If
-.meta object
-is a hash, the
+.meta iterable
+is a hash, the following special behavior applies:
.code where
-function returns a lazy list of
+returns a lazy list of
of keys which have values which satisfy
.metn function .
These keys are not subject to an order.
@@ -30488,7 +36625,7 @@ These keys are not subject to an order.
.meta function
must be a function that can be called with one argument.
For each element of
-.metn object ,
+.metn iterable ,
.meta function
is called with that element
as an argument. If a
@@ -30575,42 +36712,42 @@ which defaults to
.coNP Function @ select
.synb
-.mets (select < object >> { index-list <> | function })
+.mets (select < sequence >> { index-seq | << function })
.syne
.desc
The
.code select
-function returns an object, of the same kind as
-.metn object ,
+function returns a sequence, of the same kind as
+.metn sequence ,
which consists of those elements of
-.meta object
+.meta sequence
which are identified by
the indices in
-.metn index-list ,
-which may be a list or a vector.
+.metn index-seq ,
+which is required to be a sequence.
-If
+If a
.meta function
-is given instead of
-.metn index-list ,
+argument is given instead of
+.metn index-seq ,
then
.meta function
is invoked with
-.meta object
+.meta sequence
as its argument. The return value is then taken as
if it were the
-.meta index-list
+.meta index-seq
argument .
If
-.meta object
+.meta sequence
is a sequence, then
-.meta index-list
+.meta index-seq
consists of numeric
indices. The length of the sequence, as reported by the
.code length
function, is added to every
-.meta index-list
+.meta index-seq
value which is negative.
The
.code select
@@ -30620,13 +36757,13 @@ greater than or equal to the length of the sequence.
this strict behavior,
.code select
would not be able to terminate if
-.meta index-list
+.meta index-seq
is infinite.)
If
-.meta object
+.meta sequence
is, more specifically, a list-like sequence, then
-.meta index-list
+.meta index-seq
must contain monotonically increasing
numeric values, even if no value is out of range, since the
.code select
@@ -30636,25 +36773,25 @@ are ordered. (Rationale: optimization.)
This requirement for monotonicity applies to the values which
result after negative indices are displaced by the sequence length
Also, in this list-like sequence case, values taken from
-.meta index-list
+.meta index-seq
which are still negative after being displaced by the sequence length are
ignored.
If
-.meta object
+.meta sequence
is a hash, then
-.meta index-list
+.meta index-seq
is a list of keys. A new hash is
returned which contains those elements of
-.meta object
+.meta sequence
whose keys appear
in
-.metn index-list .
+.metn index-seq .
All of
-.meta index-list
+.meta index-seq
is processed, even if it contains
keys which are not in
-.metn object .
+.metn sequence .
The nonexistent keys are ignored.
The
@@ -30662,11 +36799,81 @@ The
function also supports objects of type
.codn carray ,
in a manner similar to vectors. The indicated elements are extracted
-from the input object, and a new
+from the input sequence, and a new
.code carray
is returned whose storage is initialized by converting the extracted
values back to the foreign representation.
+.coNP Function @ reject
+.synb
+.mets (reject < sequence >> { index-seq | << function })
+.syne
+.desc
+The
+.code reject
+function returns a sequence, of the same kind as
+.metn sequence ,
+which consists of all those elements of
+.meta sequence
+which are not identified by the indices in
+.metn index-seq ,
+which may be a list or a vector.
+
+If
+.meta function
+is given instead of
+.metn index-seq ,
+then
+.meta function
+is invoked with
+.meta sequence
+as its argument. The return value is then taken as
+if it were the
+.meta index-seq
+argument .
+
+If
+.code sequence
+is a hash, then
+.meta index-seq
+represents a list of keys. The
+.code reject
+function returns a duplicate of the hash, in which
+the keys specified in
+.meta index-seq
+do not appear.
+
+Otherwise if
+.meta sequence
+is a vector-like sequence, then the behavior of
+.code reject
+may be understood by the following equivalence:
+
+.verb
+ (reject seq idx) --> (make-like
+ [apply append (split* seq idx)]
+ seq)
+.brev
+
+where it is to be understood that
+.meta seq
+is evaluated only once.
+
+If
+.meta sequence
+is a list, then, similarly, the following equivalence applies:
+
+.verb
+ (reject seq idx) --> (make-like
+ [apply append* (split* seq idx)]
+ seq)
+.brev
+
+The input sequence is split into pieces at the indicated indices, such that
+the elements at the indices are removed and do not appear in the pieces. The
+pieces are then appended together in order, and the resulting list is coerced
+into the same type of sequence as the input sequence.
+
.coNP Function @ relate
.synb
.mets (relate < domain-seq < range-seq <> [ default-val ])
@@ -30810,7 +37017,7 @@ otherwise
.coNP Function @ partition
.synb
-.mets (partition < sequence >> { index-list | index | << function })
+.mets (partition < sequence >> { index-seq | < index | << function })
.syne
.desc
If
@@ -30826,44 +37033,44 @@ Otherwise,
.code partition
returns a lazy list of partitions of
.metn sequence .
-Partitions are consecutive, non-overlapping, non-empty sub-strings of
+Partitions are consecutive, non-overlapping, nonempty substrings of
.metn sequence ,
of the same kind as
.metn sequence ,
-such that if these sub-strings are catenated together in their order
+such that if these substrings are catenated together in their order
of appearance, a sequence
.code equal
to the original is produced.
If the second argument is of the form
-.metn index-list ,
+.metn index-seq ,
or if an
-.meta index-list
+.meta index-seq
was produced from the
.meta index
or
.meta function
-arguments, each value in that list must be an integer. Each integer
-value which is non-negative specifies the index position
+arguments, each value in that sequence must be an integer. Each integer
+value which is nonnegative specifies the index position
given by its value. Each integer value which is negative
specifies an index position given by adding the length of
.meta sequence
to its value. The sequence index positions thus denoted by
-.meta index-list
-shall be strictly non-decreasing. Each successive element
+.meta index-seq
+shall be strictly nondecreasing. Each successive element
is expected to designate an index position at least as high
as all previous elements, otherwise the behavior is unspecified.
Leading index positions which are (still) negative, or zero, are effectively
ignored.
If
-.meta index-list
+.meta index-seq
is empty then a one-element list containing the entire
.meta sequence
is returned.
If
-.meta index-list
+.meta index-seq
is an infinite lazy list, the function shall terminate if that
list eventually produces an index position which is greater than or equal to
the length of
@@ -30873,20 +37080,20 @@ If the second argument is a function, then this function is applied
to
.metn sequence ,
and the return value of this call is then used in place of the
-second argument, which must be a single index value, which is then
+second argument, which must either be a single index value, which is then
taken as if it were the
.meta index
-argument, or else a list of indices, which are taken as the
-.meta index-list
+argument, or else a sequence of indices, which are taken as the
+.meta index-seq
argument.
-If the second argument is an atom other than a function, it is assumed to be
-an integer index, and is turned into an
-.meta index-list
-of one element.
+If the second argument is neither a sequence, nor a function, then it is
+assumed to be an integer index, and is turned into an
+.meta index-seq
+sequence containing one element.
After the
-.meta index-list
+.meta index-seq
is obtained as an argument, or determined from the
.meta index
or
@@ -30895,11 +37102,11 @@ arguments, the
.code partition
function then divides
.meta sequence
-according to the indices given by that list.
+according to the indices.
The first partition begins with the first element of
.metn sequence .
The second partition begins at the first position in
-.metn index-list ,
+.metn index-seq ,
and so on. Indices beyond the length of the sequence are ignored,
as are indices less than or equal to zero.
@@ -30914,8 +37121,8 @@ as are indices less than or equal to zero.
.coNP Functions @ split and @ split*
.synb
-.mets (split < sequence >> { index-list | index | << function })
-.mets (split* < sequence >> { index-list | index | << function })
+.mets (split < sequence >> { index-seq | < index | << function })
+.mets (split* < sequence >> { index-seq | < index | << function })
.syne
.desc
If
@@ -30933,7 +37140,7 @@ Otherwise,
.code split
returns a lazy list of pieces of
.metn sequence :
-consecutive, non-overlapping, possibly empty sub-strings of
+consecutive, non-overlapping, possibly empty substrings of
.metn sequence ,
of the same kind as
.metn sequence .
@@ -30950,20 +37157,20 @@ in that the elements indicated by the split indices are removed.
The
.metn index ,
-.metn index-list ,
+.metn index-seq ,
and
.meta function
arguments are subject to the same restrictions and treatment
as the corresponding arguments of the
.code partition
function, with the following difference: the index positions indicated by
-.code index-list
-are required to be strictly increasing, rather than non-decreasing.
+.code index-seq
+are required to be strictly increasing, rather than nondecreasing.
If the second argument is of the form
-.metn index-list ,
+.metn index-seq ,
or if an
-.meta index-list
+.meta index-seq
was produced from the
.meta index
or
@@ -30972,19 +37179,21 @@ arguments, then the
.code split
function divides
.meta sequence
-according to the indices indicated in the list. The first piece always begins
+according to the indices indicated in
+.metn index-seq .
+The first piece always begins
with the first element of
.metn sequence .
Each subsequent piece begins with the position indicated by
an element of
-.metn index-list .
+.metn index-seq .
Negative indices are ignored.
If
-.meta index-list
+.meta index-seq
includes index zero,
then an empty first piece is generated.
If
-.meta index-list
+.meta index-seq
includes an index greater than or equal to the length of
.meta sequence
(equivalently, an index beyond the last element of the sequence)
@@ -31025,7 +37234,7 @@ does not produce empty pieces.
.coNP Function @ partition*
.synb
-.mets (partition* < sequence >> { index-list >> | index <> | function })
+.mets (partition* < sequence >> { index-seq | < index | << function })
.syne
.desc
If
@@ -31039,18 +37248,18 @@ it is not called.
The
.metn index ,
-.metn index-list ,
+.metn index-seq ,
and
.meta function
arguments are subject to the same restrictions and treatment
as the corresponding arguments of the
.code partition
function, with the following difference: the index positions indicated by
-.code index-list
-are required to be strictly increasing, rather than non-decreasing.
+.code index-seq
+are required to be strictly increasing, rather than nondecreasing.
If the second argument is of the form
-.metn index-list ,
+.metn index-seq ,
then
.code partition*
produces a
@@ -31060,12 +37269,12 @@ The pieces are formed by deleting from
.meta sequence
the elements at the positions given
in
-.metn index-list ,
-such that the pieces are the remaining non-empty sub-strings from
+.metn index-seq ,
+such that the pieces are the remaining nonempty substrings from
between the deleted elements, maintaining their order.
If
-.meta index-list
+.meta index-seq
is empty then a one-element list containing the entire
.meta sequence
is returned.
@@ -31079,10 +37288,11 @@ is returned.
(partition* "abcd" '(0 1 2 3)) -> nil
.brev
-.coNP Functions @ find and @ find-if
+.coNP Functions @, find @ find-if and @ find-true
.synb
.mets (find < key < sequence >> [ testfun <> [ keyfun ]])
-.mets (find-if < predfun >> { sequence | << hash } <> [ keyfun ])
+.mets (find-if < predfun >> { sequence | << hash } <> [ keyfun ])
+.mets (find-true < predfun >> { sequence | << hash } <> [ keyfun ])
.syne
.desc
The
@@ -31091,6 +37301,12 @@ and
.code find-if
functions search through a sequence for an item which
matches a key, or satisfies a predicate function, respectively.
+The
+.code find-true
+function is a variant of
+.code find-if
+which returns the value of the predicate function instead
+of the item.
The
.meta keyfun
@@ -31151,10 +37367,20 @@ of which are the hash values. If the caller doesn't specify a
.meta keyfun
then these cells are taken as their keys.
+The
+.code find-true
+function's argument conventions and search semantics are identical to those of
+.codn find-if ,
+but the return value is different. Instead of returning the found item,
+.code find-true
+returns the value which
+.meta predfun
+returned for the found item's key.
+
.coNP Functions @ rfind and @ rfind-if
.synb
.mets (rfind < key < sequence >> [ testfun <> [ keyfun ]])
-.mets (rfind-if < predfun >> { sequence | << hash } <> [ keyfun ])
+.mets (rfind-if < predfun >> { sequence | << hash } <> [ keyfun ])
.syne
.desc
The
@@ -31169,7 +37395,7 @@ except that if there are multiple matches for
.meta key
in
.metn sequence ,
-they return the right-most element rather than
+they return the rightmost element rather than
the leftmost.
In the case of
@@ -31186,8 +37412,8 @@ a hash table can change when other items are inserted or deleted.
.coNP Functions @ find-max and @ find-min
.synb
-.mets (find-max >> { sequence | << hash } >> [ testfun <> [ keyfun ]])
-.mets (find-min >> { sequence | << hash } >> [ testfun <> [ keyfun ]])
+.mets (find-max < iterable >> [ testfun <> [ keyfun ]])
+.mets (find-min < iterable >> [ testfun <> [ keyfun ]])
.syne
.desc
The
@@ -31199,8 +37425,9 @@ differ only in their defaulting behavior with regard to the
.meta testfun
argument. If
.meta testfun
-is not given, then the find-max function defaults it to
-the
+is not given, then the
+.code find-max
+function defaults it to the
.code greater
function, whereas
.code find-min
@@ -31214,7 +37441,7 @@ argument, the
.code find-max
function finds the numerically
maximum value occurring in
-.metn sequence ,
+.metn iterable ,
whereas
.code pos-min
without a
@@ -31249,39 +37476,63 @@ is passed through this one-argument function, and
the resulting value is used in its place for the purposes of the
comparison. However, the original element is returned.
-A hash table may be specified instead of a sequence.
-The
-.meta hash
-is treated as if it were a sequence of hash key and hash
-value pairs represented as cons cells, the
-.code car
-slots of which are the hash keys, and the
-.code cdr
-of which are the hash values. If the caller doesn't specify a
-.meta keyfun
-then these cells are taken as their keys. To find the hash
-table's key-value cell with the maximum key, the
-.code car
-function can be specified as
-.metn keyfun .
-To find the entry holding the maximum value, the
-.code cdr
-function can be specified.
-
If there are multiple equivalent maxima, then under the default
.metn testfun ,
that being
.codn less ,
-the leftmost one is reported. See the notes under
+the first one encountered while traversing
+.meta iterable
+is the one that is reported. See the notes under
.code pos-max
regarding duplicate maxima.
-.coNP Functions @, uni @, isec @ diff and @ symdiff
+.coNP Functions @ find-max-key and @ find-min-key
+.synb
+.mets (find-max-key < iterable [ testfun <> [ keyfun ]])
+.mets (find-min-key < iterable [ testfun <> [ keyfun ]])
+.syne
+.desc
+The
+.code find-min-key
+and
+.code find-max-key
+functions have the same argument conventions as, respectively,
+.code find-max
+and
+.code find-min
+and agree with those functions in regard to which element of the
+input sequence is identified: all these functions identify the
+element which maximizes or minimizes the value of
+.metn keyfun .
+
+Whereas
+.code find-max
+and
+.code find-min
+return the maximizing or minimizing element itself, the
+.code find-max-key
+and
+.code find-min-key
+functions return the value of
+.meta keyfun
+applied to the element.
+
+Under the default
+.meta keyfun
+value, that being the
+.code identity
+function, these functions behave the same as
+.code find-max
+and
+.codn find-min .
+
+.coNP Functions @, uni @, isec @, isecp @ diff and @ symdiff
.synb
-.mets (uni < seq1 < seq2 >> [ testfun <> [ keyfun ]])
-.mets (isec < seq1 < seq2 >> [ testfun <> [ keyfun ]])
-.mets (diff < seq1 < seq2 >> [ testfun <> [ keyfun ]])
-.mets (symdiff < seq1 < seq2 >> [ testfun <> [ keyfun ]])
+.mets (uni < iter1 < iter1 >> [ testfun <> [ keyfun ]])
+.mets (isec < iter1 < iter1 >> [ testfun <> [ keyfun ]])
+.mets (isecp < iter1 < iter1 >> [ testfun <> [ keyfun ]])
+.mets (diff < iter1 < iter1 >> [ testfun <> [ keyfun ]])
+.mets (symdiff < iter1 < iter2 >> [ testfun <> [ keyfun ]])
.syne
.desc
The functions
@@ -31291,28 +37542,37 @@ The functions
and
.code symdiff
treat the sequences
-.meta seq1
+.meta iter1
and
-.meta seq2
+.meta iter2
as if they were sets.
They, respectively, compute the set union, set intersection,
set difference and symmetric difference of
-.meta seq1
+.meta iter1
and
-.metn seq2 ,
+.metn iter2 ,
returning a new sequence.
+The
+.code isecp
+is Boolean: it returns
+.code t
+for those arguments for which
+.code isec
+returns a non-empty list, otherwise
+.codn nil .
+
The arguments
-.meta seq1
+.meta iter1
and
-.meta seq2
+.meta iter2
need not be of the same kind. They may be hash tables.
The returned sequence is of the same kind as
-.metn seq1 .
+.metn iter1 .
If
-.meta seq1
+.meta iter1
is a hash table, the returned sequence is a list.
For the purposes of these functions, an input which is a hash table
@@ -31332,68 +37592,67 @@ de-duplicate the sequences.
The union sequence produced by
.code uni
contains all of the elements which occur in both
-.meta seq1
+.meta iter1
and
-.metn seq2 .
+.metn iter2 .
If a given element occurs exactly once only in
-.meta seq1
+.meta iter1
or exactly once only in
-.metn seq2 ,
+.metn iter2 ,
or exactly once in both sequences, then it occurs exactly once in the union
sequence. If a given element occurs at least once in either
-.metn seq1 ,
-.meta seq2
+.metn iter1 ,
+.meta iter2
or both, then it occurs at least once in the union sequence.
The intersection sequence produced by
.code isec
contains all of the elements which occur in both
-.meta seq1
+.meta iter1
and
-.metn seq2 .
+.metn iter2 .
If a given element occurs exactly once in
-.meta seq1
+.meta iter1
and exactly once in
-.metn seq2 ,
+.metn iter2 ,
then in occurs exactly once in the intersection sequence.
If a given element occurs at least once in
-.meta seq1
+.meta iter1
and at least once in
-.metn seq2 ,
+.metn iter2 ,
then in occurs at least once in the intersection sequence.
The difference sequence produced by
.code diff
contains all of the elements which occur in
-.meta seq1
+.meta iter1
but do not occur in
-.metn seq2 .
+.metn iter2 .
If an element occurs exactly once in
-.meta seq1
+.meta iter1
and does not occur in
-.metn seq2 ,
+.metn iter2 ,
then it occurs exactly once in the difference sequence.
If an element occurs at least once in
-.meta seq1
+.meta iter1
and does not occur in
-.metn seq2 ,
+.metn iter2 ,
then it occurs at least once in the difference sequence.
If an element occurs at least once in
-.metn seq2 ,
+.metn iter2 ,
then it does not occur in the difference sequence.
The symmetric difference sequence produced by
.code symdiff
contains all of the elements of
-.meta seq1
+.meta iter1
which do not occur in
-.meta seq2
-and
-.IR "vice versa" :
+.meta iter2
+and vice versa:
it also contains all of the elements of
-.meta seq2
+.meta iter2
which do not occur in
-.metn seq1 .
+.metn iter1 .
Element equivalence is determined by a combination of
.meta testfun
@@ -31423,12 +37682,11 @@ For the
.code set-diff
function, the requirement was specified to preserve the original
order of items from
-.meta seq1
+.meta iter1
that survive into the output sequence.
This requirement is not documented for the
.code diff
-function, but is
-.I "de facto"
+function, but is de facto
honored by the implementation for at as long as the
.code set-diff
synonym continues to be available.
@@ -31444,7 +37702,7 @@ argument is
.codn car ,
and
.meta testfun
-matches the equality used by both hash table inputs.
+matches the equality used by both hash-table inputs.
If applicable, the operations
.codn hash-uni ,
.code hash-isec
@@ -31454,10 +37712,10 @@ should be used instead.
.coNP Functions @, mapcar @, mappend @ mapcar* and @ mappend*
.synb
-.mets (mapcar < function << sequence *)
-.mets (mappend < function << sequence *)
-.mets (mapcar* < function << sequence *)
-.mets (mappend* < function << sequence *)
+.mets (mapcar < function << iterable *)
+.mets (mappend < function << iterable *)
+.mets (mapcar* < function << iterable *)
+.mets (mappend* < function << iterable *)
.syne
.desc
When given only one argument, the
@@ -31472,11 +37730,11 @@ When given two arguments, the
function applies
.meta function
to each elements of
-.meta sequence
+.meta iterable
and returns a sequence of the resulting values
in the same order as the original values.
The returned sequence is the same kind as
-.metn sequence ,
+.metn iterable ,
if possible. If the accumulated values cannot be
elements of that type of sequence, then a list is returned.
@@ -31526,7 +37784,7 @@ Like
.code mappend*
must "consume" empty lists. For instance,
if the function being mapped puts out a sequence of
-.codn nil -s,
+.codn nil s,
then the result must be the empty list
.codn nil ,
because
@@ -31551,7 +37809,7 @@ The
.code mappend*
function is caught in a loop trying to consume
and squash an infinite stream of
-.codn nil -s,
+.codn nil s,
and so doesn't return.
.TP* Examples:
@@ -31572,36 +37830,41 @@ and so doesn't return.
-> (2 4)
.brev
-.coNP Functions @ maprod and @ maprend
+.coNP Functions @, maprod @ maprend and @ maprodo
.synb
-.mets (maprod < function << sequence *)
-.mets (maprend < function << sequence *)
+.mets (maprod < function << iterable *)
+.mets (maprend < function << iterable *)
+.mets (maprodo < function << iterable *)
.syne
.desc
The
-.code maprod
-and
+.codn maprod ,
.code maprend
+and
+.code maprodo
functions resemble
-.code mapcar
+.codn mapcar ,
+.code mappend
and
-.codn mappend ,
+.codn mapdo ,
respectively. When given no
-.meta sequence
+.meta iterable
arguments or exactly one
-.meta sequence
-argument, they behave exactly like those two functions.
+.meta iterable
+argument, they behave exactly like those three functions.
When two or more
-.meta sequence
+.meta iterable
arguments are present,
.code maprod
differs from
.code mapcar
-in the following way. Whereas
+in the following way, as do the remaining functions
+from their aforementioned counterparts.
+Whereas
.code mapcar
iterates over the
-.meta sequence
+.meta iterable
values in parallel, taking successive tuples of element
values and passing them to
.metn function ,
@@ -31614,14 +37877,14 @@ of elements from the sequences: the Cartesian product. The
suffix stands for "product".
If one or more
-.meta sequence
+.meta iterable
arguments specify an empty sequence, then the Cartesian product is empty.
In this situation,
.meta function
is not called. The result of the function is then
.code nil
converted to the same kind of sequence as the leftmost
-.metn sequence .
+.metn iterable .
The
.code maprod
@@ -31631,17 +37894,17 @@ does. Just like
.codn mapcar ,
it converts the resulting list into the same kind of sequence
as the leftmost
-.meta sequence
+.meta iterable
argument, if possible. For instance, if the resulting list is
a list or vector of characters, and the leftmost
-.meta sequence
+.meta iterable
is a character string, then the list or vector of characters
is converted to a character string and returned.
The
.code maprend
function ("map product through function and append") iterates the
-.meta sequence
+.meta iterable
element combinations exactly like
.codn maprod ,
passing them as arguments to
@@ -31654,11 +37917,20 @@ function. The return values are expected to be sequences which
are appended together as if by
.codn append ,
and the final result is converted to the same kind of sequence as the leftmost
-.meta sequence
+.meta iterable
if possible.
+The
+.code maprodo
+function, like
+.codn mapdo ,
+ignores the result of
+.meta function
+and returns
+.codn nil .
+
The combination iteration gives priority to the rightmost
-.metn sequence ,
+.metn iterable ,
which means that the rightmost element of each generated tuple varies
fastest: the tuples are traversed in "rightmost major" order.
This is made clear in the examples.
@@ -31686,7 +37958,7 @@ This is made clear in the examples.
.coNP Function @ mapdo
.synb
-.mets (mapdo < function << sequence *)
+.mets (mapdo < function << iterable *)
.syne
.desc
The
@@ -31711,17 +37983,17 @@ and
is returned.
If a single
-.meta sequence
+.meta iterable
argument is given, then
.code mapdo
iterates over
-.metn sequence ,
+.metn iterable ,
invoking
.meta function
on each element.
If two or more
-.meta sequence
+.meta iterable
arguments are given, then
.code mapdo
iterates over
@@ -31733,31 +38005,31 @@ arguments as there are sequences.
.coNP Functions @ transpose and @ zip
.synb
-.mets (transpose << sequence )
-.mets (zip << sequence *)
+.mets (transpose << iterable )
+.mets (zip << iterable *)
.syne
.desc
The
.code transpose
function performs a transposition on
-.metn sequence .
+.metn iterable .
This means that the
elements of
-.meta sequence
-must be sequences. These sequences are understood to be
+.meta iterable
+must be iterable. These iterables are understood to be
columns; transpose exchanges rows and columns, returning a sequence of the rows
which make up the columns. The returned sequence is of the same kind as
-.metn sequence ,
+.metn iterable ,
and the rows are also the same kind of sequence as the first column
of the original sequence. The number of rows returned is limited by the
shortest column among the sequences.
All of the input sequences (the elements of
-.metn sequence )
+.metn iterable )
must have elements
which are compatible with the first sequence. This means that if the first
element of
-.meta sequence
+.meta iterable
is a string, then the remaining sequences must be
strings, or else sequences of characters, or of strings.
@@ -31791,6 +38063,10 @@ on a list of the arguments. The following equivalences hold:
(transpose #("abc" "def" ("UV" "XY" "WZ")))
-> #("adUV" "beXY" "cfWZ")
+ ;; Transpose list of ranges
+ (transpose (list 1..4 4..8 8..12))
+ -> ((1 4 8) (2 5 9) (3 6 10))
+
(zip '(a b c) '(c d e)) -> ((a c) (b d) (c e))
.brev
@@ -31836,7 +38112,7 @@ they perform a
whose description follows.
The function
-.code window-mappend
+.code window-mapdo
avoids accumulating a sequence, and instead returns
.codn nil ;
it is analogous to
@@ -31880,12 +38156,16 @@ The
parameter specifies the window contents which are used for the
processing of elements which are closer than
.meta range
-to either end of the sequence. The argument may be a sequence containing
-at least twice
+to either end of the sequence. Except if it is of list type,
+.meta boundary
+must be a sequence containing at least twice
.meta range
number of elements (one less than the window size): if it has additional
elements, they are not used. If it is a list, it may be shorter than twice
-.metn range .
+.metn range ;
+in this case, the value
+.code nil
+is substituted for the missing elements.
The argument
may also be one of the two keyword symbols
.code :wrap
@@ -31897,12 +38177,7 @@ If
.meta boundary
is a sequence, it may be regarded as divided into two pieces of
.meta range
-length. If it is a list of insufficient length, then missing elements
-are supplied as
-.code nil
-to make two
-.metn range 's
-worth of elements. These two pieces then flank
+length. These two pieces then flank
.code sequence
on either end. The left half of
.meta boundary
@@ -31916,43 +38191,84 @@ flanking elements obtained from
If
.meta boundary
-is the keyword
+argument is specified as the keyword
.codn :wrap ,
-then the sequence is effectively flanked by copies of itself on both
-ends, repeated enough times to satisfy the window. For instance if
-the sequence is
+then the sequence is imagined to be flanked at either end by an infinite
+repetition of copies of itself. These flanks are trimmed to the window size to
+generate the boundary.
+
+For instance if the sequence is
.code "(1 2 3)"
and the window size is 9 due to the value of
.meta range
-being 7, then the behavior of
+being 4, then the behavior of
.code :wrap
-is as if a
+is as if
.meta boundary
-were specified consisting of
-.codn "(3 1 2 3 1 2 3 1)" .
+value of
+.code "(3 1 2 3 1 2 3 1)"
+were specified.
The left flank is
-.code "(3 1 2 3)"
-and the right flank is
-.code "(1 2 3 4)"
-formed by repetitions of
-.code "(1 2 3)"
-surrounding it on either side, extending out to infinity, and chopped to
-.metn range .
+.codn "(3 1 2 3)" ,
+being the last four elements of an infinite repetition of
+.codn "1 2 3" ;
+and the right flank is similarly
+.codn "(1 2 3 1)" ,
+being the first four elements of an infinite repetition of
+.codn "1 2 3" .
If
.meta boundary
-is the keyword
+is given as the keyword
.codn :reflect ,
-then the sequence is effectively flanked by reversed copies of itself
-on both ends, repeated enough times to satisfy the window.
-For instance if the sequence is
+then the sequence is imagined to be flanked at either end by an infinite
+repetition of reversed copies of itself. These flanks are trimmed to the window
+size to generate the boundary. For instance if the sequence is
.code "(1 2 3)"
-and the window size is 9, then the behavior of
-.code :wrap
-is as if a
+and the window size is 9 due to the value of
+.meta range
+being 4, then the behavior of
+.code :reflect
+is as if
.meta boundary
-were specified consisting of
-.codn "(1 3 2 1 3 2 1 3)" .
+value of
+.code "(1 3 2 1 3 2 1 3)"
+were specified.
+The left flank is
+.codn "(1 3 2 1)" ,
+being the last four elements of an infinite repetition of
+.codn "3 2 1" ;
+and the right flank is similarly
+.codn "(3 2 1 3)" ,
+being the first four elements of an infinite repetition of
+.codn "3 2 1" .
+
+.TP* Examples:
+.verb
+ ;; change characters between angle brackets to upper case.
+ [window-map 1 nil (lambda (x y z)
+ (if (and (eq x #\e<)
+ (eq z #\e>))
+ (chr-toupper y)
+ y))
+ "ab<c>de<f>g"]
+ --> "ab<C>de<F>g"
+
+ ;; collect all numbers which are the centre element of
+ ;; a monotonically increasing triplet
+ [window-mappend 1 :reflect (lambda (x y z)
+ (if (< x y z)
+ (list y)))
+ '(1 2 1 3 4 2 1 9 7 5 7 8 5)]
+ --> (3 7)
+
+ ;; calculate a moving average with a five-element
+ ;; window, flanked by zeros at the boundaries:
+ [window-map 2 #(0 0 0 0)
+ (lambda (. args) (/ (sum args) 5))
+ #(4 7 9 13 5 1 6 11 10 3 8)]
+ --> #(4.0 6.6 7.6 7.0 6.8 7.2 6.6 6.2 7.6 6.4 4.2))
+.brev
.coNP Function @ interpose
.synb
@@ -32006,152 +38322,6 @@ suffix.
(interpose t (range 0 2)) -> (0 t 1 t 2)
.brev
-.coNP Functions @ apply and @ iapply
-.synb
-.mets (apply < function <> [ arg * << trailing-args ])
-.mets (iapply < function <> [ arg * << trailing-args ])
-.syne
-.desc
-The
-.code apply
-function invokes
-.metn function ,
-optionally passing to it an argument
-list. The return value of the
-.code apply
-call is that of
-.metn function .
-
-If no arguments are present after
-.metn function ,
-then
-.meta function
-is invoked without arguments.
-
-If one argument is present after
-.metn function ,
-then it is interpreted as
-.metn trailing-args .
-If this is a sequence (a list, vector or string),
-then the elements of the sequence are passed as individual arguments to
-.metn function .
-If
-.meta trailing-args
-is not a sequence, then
-.meta function
-is invoked
-with an improper argument list, terminated by the
-.meta trailing-args
-atom.
-
-If two or more arguments are present after
-.metn function ,
-then the last of these arguments is interpreted as
-.metn trailing-args .
-The previous arguments represent leading arguments which are applied to
-.metn function ,
-prior to the arguments taken from
-.metn trailing-args .
-
-Note that if
-.meta trailing-args
-value is an atom or an improper list, the function is then
-invoked with an improper argument list. Only a variadic
-function may be invoked with an improper argument lists.
-Moreover, all of the function's required and optional
-parameters must be satisfied by elements of the
-improper list, such that the terminating atom either
-matches the
-.meta rest-param
-directly (see the
-.code lambda
-operator) or else the
-.meta rest-param
-receives an improper list terminated by that atom.
-To treat the terminating atom of an improper list as an
-ordinary element which can satisfy a required or optional
-function parameter, the
-.code iapply
-function may be used, described next.
-
-The
-.code iapply
-function ("improper apply") is similar to
-.codn apply ,
-except with regard to the treatment of
-.metn trailing-args .
-Firstly, under
-.codn iapply ,
-if
-.meta trailing-args
-is an atom other than
-.code nil
-(possibly a sequence, such as a vector or string),
-then it is treated as an ordinary argument:
-.meta function
-is invoked with a proper argument list, whose last element is
-.metn trailing-args .
-Secondly, if
-.meta trailing-args
-is a list, but an improper list, then the terminating atom of
-.meta trailing-args
-becomes an individual argument.
-This terminating atom is not split into multiple arguments,
-even if it is a sequence.
-Thus, in all possible cases,
-.code iapply
-treats an extra
-.cod2 non- nil
-atom as an argument, and never calls
-.meta function
-with an improper argument list.
-
-.TP* Examples:
-.verb
- ;; '(1 2 3) becomes arguments to list, thus (list 1 2 3).
- (apply (fun list) '(1 2 3)) -> (1 2 3)
-
- ;; this effectively invokes (list 1 2 3 4)
- (apply (fun list) 1 2 '(3 4)) -> (1 2 3 4)
-
- ;; this effectively invokes (list 1 2 . 3)
- (apply (fun list) 1 2 3)) -> (1 2 . 3)
-
- ;; "abc" is separated into characters
- ;; which become arguments of list
- (apply (fun list) "abc") -> (#\ea #\eb #\ec)
-.brev
-
-.TP* "Dialect Note:"
-Note that some uses of this function that are necessary in other Lisp dialects
-are not necessary in \*(TL. The reason is that in \*(TL, improper list
-syntax is accepted as a compound form, and performs application:
-
-.verb
- (foo a b . x)
-.brev
-
-Here, the variables
-.code a
-and
-.code b
-supply the first two arguments for
-.codn foo .
-In
-the dotted position,
-.code x
-must evaluate to a list or vector. The list or
-vector's elements are pulled out and treated as additional arguments for
-.codn foo .
-This syntax can only be used if
-.code x
-is a symbolic form or an atom. It
-cannot be a compound form, because
-.code "(foo a b . (x))"
-and
-.code "(foo a b x)"
-are equivalent structures.
-
.coNP Functions @ reduce-left and @ reduce-right
.synb
.mets (reduce-left < binary-function < list
@@ -32173,6 +38343,18 @@ and
to a single value by the repeated application of
.metn binary-function .
+In the case of
+.codn reduce-left ,
+the
+.meta list
+argument is required to be an object which is iterable according to the
+.code iter-begin
+function. The
+.code reduce-right
+function treats the
+.meta list
+argument using list operations.
+
An effective list of operands is formed by combining
.meta list
and
@@ -32247,7 +38429,7 @@ Omitting
.meta init-value
is the same as specifying a value of
.code :
-(the colon symbol).
+(the colon keyword symbol).
It is possible to specify
.meta key-function
while omitting an
@@ -32320,7 +38502,7 @@ The
.code all
and
.code none
-functions apply a predicate test function
+functions apply a predicate-test function
.meta predicate-fun
over a list of elements. If the argument
.meta key-fun
@@ -32337,17 +38519,27 @@ applied to the resulting values. If
is omitted, the behavior is
as if
.meta key-fun
-is the identity function. If
+were the
+.code identity
+function. If
.meta predicate-fun
is omitted,
the behavior is as if
.meta predicate-fun
-is the identity function.
+were the
+.code identity
+function.
These functions have short-circuiting semantics and return conventions similar
-to the and and or operators.
+to the
+.code and
+and
+.code or
+operators.
-The some function applies
+The
+.code some
+function applies
.meta predicate-fun
to successive values
produced by retrieving elements of
@@ -32362,13 +38554,15 @@ first
return value returned by a call to
.meta predicate-fun
and
-stops evaluating more elements. If
+stops evaluating the elements. If
.meta predicate-fun
returns
.code nil
for all
-elements, it returns
-.metn nil .
+elements,
+.code some
+returns
+.codn nil .
The
.code all
@@ -32391,8 +38585,9 @@ function immediately
returns without invoking
.meta predicate-fun
on any more elements.
-If all the elements are processed, then the all function returns
-the value which
+If all the elements are processed, then the
+.code all
+function returns the value which
.meta predicate-fun
yielded for the last element.
@@ -32411,11 +38606,17 @@ Otherwise, if
.meta predicate-fun
yields
.cod2 non- nil
-for any value, the none function
-immediately returns nil. If
+for any value, the
+.code none
+function immediately returns
+.codn nil .
+If
.meta predicate-fun
-yields nil for all
-values, the none function returns
+yields
+.code nil
+for all values, the
+.code none
+function returns
.codn t .
.TP* Examples:
@@ -32469,9 +38670,8 @@ is a transformed list of rows which is reconstituted into a list of columns.
.TP* Example:
.verb
- ;; Take three lists in parallel, and remove from all of them
- ;; them the element at all positions where the third list
- ;; has an element of 20.
+ ;; Take three lists in parallel, and remove from all of them the
+ ;; element at all positions where the third list has an element of 20.
(multi (op remove-if (op eql 20) @1 third)
'(1 2 3)
@@ -32488,13 +38688,16 @@ is a transformed list of rows which is reconstituted into a list of columns.
;; (op remove-if (ap eql @3 20))
.brev
-.coNP Function @ sort
+.coNP Functions @, sort @, nsort @ ssort and @ snsort
.synb
.mets (sort < sequence >> [ lessfun <> [ keyfun ]])
+.mets (nsort < sequence >> [ lessfun <> [ keyfun ]])
+.mets (ssort < sequence >> [ lessfun <> [ keyfun ]])
+.mets (snsort < sequence >> [ lessfun <> [ keyfun ]])
.syne
.desc
The
-.code sort
+.code nsort
function destructively sorts
.metn sequence ,
producing a sequence
@@ -32534,11 +38737,84 @@ function.
The
.code sort
-function is stable for sequences which are lists. This means that the
+function has the same argument requirements as
+.code nsort
+but is non-destructive: it returns a new object, leaving the input
+.meta sequence
+unmodified, as if a copy of the input object were made using the
+function
+.code copy
+and then that copy were sorted in-place using
+.codn nsort .
+
+The
+.code sort
+and
+.code nsort
+functions are stable for sequences which are lists. This means that the
original order of items which are considered identical is preserved.
For strings and vectors,
.code sort
-is not stable.
+and
+.code nsort
+are not stable.
+
+The
+.code ssort
+and
+.code nsort
+functions have the same argument syntax and semantics as, respectively,
+.code sort
+and
+.codn nsort .
+These functions provide a stable sort for all sequences, not only
+lists, at the cost of temporarily allocating memory.
+
+All of these functions can be applied to hashes. They produce meaningful
+behavior for a hash table which contains
+.I N
+keys which are the integers from 0 to
+.IR "N - 1" .
+Such as hash is treated as if it were a vector. The values are sorted
+and reassigned to sorted order to the integer keys.
+The behavior is not specified for hashes whose contents do not conform to this
+convention.
+
+Note:
+.code nsort
+was introduced in \*(TX 238. Prior to that version,
+.code sort
+behaved like
+.codn nsort .
+
+.coNP Functions @, csort @, cnsort @ cssort and @ csnsort
+.synb
+.mets (csort < sequence >> [ lessfun <> [ keyfun ]])
+.mets (cnsort < sequence >> [ lessfun <> [ keyfun ]])
+.mets (cssort < sequence >> [ lessfun <> [ keyfun ]])
+.mets (csnsort < sequence >> [ lessfun <> [ keyfun ]])
+.syne
+.desc
+The functions
+.codn csort ,
+.codn cnsort ,
+.code cssort
+and
+.code csnsort
+are caching counterparts of, respectively,
+.codn sort ,
+.codn nsort ,
+.code ssort
+and
+.codn snsort .
+They have exactly the same argument syntax and semantics.
+
+Caching refers to eliminating repeated calls to
+.meta keyfun
+for the same element of
+.metn sequence ,
+in order to reduce the execution time, at the cost of
+using more storage.
.coNP Function @ grade
.synb
@@ -32585,14 +38861,15 @@ in the APL language.
[grade "Hello" >] -> (4 2 3 1 0)
.brev
-.coNP Function @ shuffle
+.coNP Functions @ shuffle and @ nshuffle
.synb
-.mets (shuffle << sequence )
+.mets (shuffle < sequence <> [ random-state ])
+.mets (nshuffle < sequence <> [ random-state ])
.syne
.desc
The
-.code shuffle
-function pseudo-randomly rearranges the elements of
+.code nshuffle
+function pseudorandomly rearranges the elements of
.metn sequence .
This is performed in place:
.meta sequence
@@ -32602,11 +38879,153 @@ The return value is
.meta sequence
itself.
-The rearrangement depends on pseudo-random numbers obtained from the
+The rearrangement depends on pseudorandom numbers obtained from the
.code rand
+function. The
+.meta random-state
+argument, if present, is passed to that function.
+
+The
+.code nshuffle
+function supports hash tables in a manner analogous to the way
+.code nsort
+supports hash tables; the same remarks apply as in the description
+of that function.
+
+The
+.code shuffle
+function has the same argument requirements and
+semantics, but differs from
+.code nshuffle
+in that it avoids in-place modification of
+.metn sequence :
+a new, shuffled sequence is returned, as if a copy of
+.meta sequence
+were made using
+.code copy
+and then that copy were shuffled in-place and returned.
+
+Note:
+.code nshuffle
+was introduced in \*(TX 238. Prior to that version,
+.code shuffle
+behaved like
+.codn nshuffle .
+
+.coNP Functions @ rot and @ nrot
+.synb
+.mets (rot < sequence <> [ displacement ])
+.mets (nrot < sequence <> [ displacement ])
+.syne
+.desc
+The
+.code nrot
+and
+.code rot
+functions rotate the elements of
+.metn sequence ,
+returning a rotated sequence.
+
+The
+.code nrot
+function does this destructively; it modifies
+.meta sequence
+in-place, whereas
+.code rot
+returns a new sequence without modifying the original.
+
+The
+.code rot
+function always returns a new sequence. In cases when no rotation
+is performed, it copies
+.meta sequence
+as if using the
+.code copy
function.
+In cases when no rotation is performed, the
+.code nrot
+function returns the original sequence, which is unmodified.
+
+The
+.meta displacement
+parameter, an integer, has a default value of 1.
+
+To rotate elements means to displace their position within the
+.meta sequence
+by some amount, that being given by the
+.meta displacement
+parameter, while partially preserving their circular order.
+Circular order means that for the purposes of rotation, the sequence
+is regarded to be cyclic: the first element of the sequence is
+considered to be the successor of the last element and vice versa.
+Thus, when an element is displaced past the first or last position, it wraps to
+the end or beginning of the sequence.
+
+If the sequence is empty, or contains only one element, then
+.code rot
+and
+.code nrot
+terminate, performing no rotation. The following remarks apply to situations when
+.meta sequence
+has two or more elements.
+
+The
+.meta displacement
+parameter, which may be negative, is first reduced to the smallest positive
+residue modulo the length of the sequence, resulting in a value ranging from
+zero to one less than the sequence length. If the resulting value is zero,
+then no rotation is performed.
+
+The
+.meta displacement
+has a negative orientation: each element's position is decreased by this
+amount. Those elements whose position would become negative move to the end of
+the sequence.
+
+The default displacement of 1 causes the first element to become last,
+the second element to become first, and so forth. The opposite rotation can be
+obtained using -1 as the displacement.
+
+Note: even though
+.code nrot
+operates destructively, the returned object may not be the same object as
+.metn sequence .
+Only the returned object is required to be the rotated sequence. If this
+is different from the original
+.meta sequence
+input, the contents of that original object are unspecified.
+
+Note: the symbol
+.code rotate
+is the name of a place-mutating macro, which is much older than these functions.
+If
+.code S
+is a three-element sequence, then:
+
+.verb
+ (set S (nrot S)) ;; alternatively: (upd S nrot)
+.brev
+
+has the same effect as:
+
+.verb
+ (rotate [S 0] [S 1] [S 2])
+.brev
+
+.TP* Examples:
-.coNP Function @ sort-group
+.verb
+ (rot "abc") -> "bca"
+ (rot #(1 2 3) -1) -> (3 1 2)
+
+ ;; lower-case rot-13
+ (mapcar (relate (range #\ea #\ez)
+ (rot (range #\ea #\ez) 13))
+ "hello, world!")
+ -> "uryyb, jbeyq!"
+.brev
+
+.coNP Functions @ sort-group and @ csort-group
.synb
.mets (sort-group < sequence >> [ keyfun <> [ lessfun ]])
.syne
@@ -32623,6 +39042,15 @@ arguments, and then breaks the resulting sequence into groups,
based on the equivalence of the elements under
.metn keyfun .
+The
+.code csort-group
+differs from
+.code sort-group
+in that it is based on the caching
+.code csort
+rather than
+.codn sort .
+
The following equivalence holds:
.verb
@@ -32630,7 +39058,7 @@ The following equivalence holds:
<-->
- (partition-by kf (sort (copy sq) kf lf))
+ (partition-by kf (sort sq kf lf))
.brev
Note the reversed order of
@@ -32673,7 +39101,7 @@ That is to say, this equivalence holds:
.coNP Function @ unique
.synb
-.mets (unique < sequence >> [ keyfun <> { hash-arg }* ])
+.mets (unique < sequence >> [ keyfun <> { hash-arg }*])
.syne
.desc
The
@@ -32687,9 +39115,9 @@ but with duplicates removed.
If neither
.meta keyfun
nor
-.metn hash-arg -s
+.metn hash-arg s
are specified, then elements of sequence are considered equal under the
-.code eql
+.code equal
function. The first occurrence of each element is retained,
and the subsequent duplicates of that element, of any, are suppressed,
such that the order of the elements is otherwise preserved.
@@ -32705,7 +39133,7 @@ were the
function.
If one or more
-.metn hash-arg -s
+.metn hash-arg s
are present, these specify the arguments for the construction of
the internal hash table used by
.codn unique .
@@ -32762,6 +39190,72 @@ are lists, and not lazy lists.
(tuples 3 (list 1 2) #\ez) -> ((1 2 #\ez))
.brev
+.coNP Function @ tuples*
+.synb
+.mets (tuples* < length < sequence <> [ fill-value ])
+.syne
+.desc
+The
+.code tuples*
+function produces a lazy list of overlapping tuples taken from
+.metn sequence .
+The length of the tuples is given by the
+.meta length
+argument.
+
+The
+.meta length
+argument must be a positive integer.
+
+Tuples are subsequences of consecutive items from the input
+.metn sequence ,
+beginning with consecutive elements. The first tuple in the returned list
+begins with the first item of
+.metn sequence ;
+the second tuple begins with the second item, and so forth.
+
+The output of the function is a list, but the tuples themselves are sequences
+of the same kind as
+.metn sequence .
+If
+.meta sequence
+is any kind of list, they
+are lists, and not lazy lists.
+
+If
+.meta sequence
+is shorter than
+.meta length
+then it contains no tuples of that length. In this case, if no
+.meta fill-value
+argument is specified, then the empty list is returned.
+In this same situation, if
+.meta fill-value
+is specified, then a one-element list is returned, consisting of
+a tuple of the required length, consisting of the elements from
+.meta sequence
+followed by repetitions of
+.metn fill-value ,
+which must be of a type suitable as an element of the sequence.
+The
+.meta fill-value
+is otherwise ignored.
+
+.TP* Examples:
+
+.verb
+.brev
+ (tuples* 1 "abc") -> ("a" "b" "c")
+ (tuples* 2 "abc") -> ("ab" "bc")
+ (tuples* 3 "abc") -> ("abc")
+ (tuples* 4 "abc") -> nil
+ (tuples* 4 "abc" #\z) -> ("abcz")
+ (tuples* 6 "abc" #\z) -> ("abczzz")
+ (tuples* 6 "abc" 4) -> error
+ (tuples* 2 '(a b c)) -> ((a b) (b c))
+ (take 3 (tuples* 3 0)) -> ((0 1 2) (1 2 3) (2 3 4))
+.brev
+
.coNP Function @ partition-by
.synb
.mets (partition-by < function << sequence )
@@ -32780,7 +39274,7 @@ Otherwise,
.code partition-by
returns a lazy list of partitions of the sequence
.metn sequence .
-Partitions are consecutive, non-empty sub-strings of
+Partitions are consecutive, nonempty substrings of
.metn sequence ,
of the same kind as
.metn sequence .
@@ -32815,141 +39309,660 @@ function.
#(4 5 6 7))
.brev
-.coNP Function @ make-like
+.coNP Function @ partition-if
.synb
-.mets (make-like < list << ref-sequence )
+.mets (partition-if < function < iterable <> [ count ])
.syne
.desc
The
-.meta list
-argument must be a list. If
-.meta ref-sequence
-is a sequence type,
-then
-.meta list
-is converted to the same type of sequence and returned.
-Otherwise the original
-.meta list
-is returned.
+.code partition-if
+function separates the
+.meta iterable
+sequence into partitions which are identified by the two-argument
+.metn function .
+The principal idea is that successive overlapping pairs from
+.meta iterable
+are passed as arguments to
+.metn function ,
+and whenever
+.meta function
+yields true, those elements are identified as belonging to separate partitions:
+a partitioning division shall take place between them. The detailed semantics
+is given below, as a procedure.
-Conversion is supported to string and vector type.
+Firstly, if
+.meta sequence
+is empty, then
+.code partition-if
+returns an empty list,
+and
+.meta function
+is never called.
-Conversion to a structure type is possible for structures. If
-.meta ref-sequence
-is an object of a structure type which has a static function
-.codn from-list ,
-then
-.code make-like
-calls that function, passing to it, and the resulting value is returned.
-.meta list
-and returns whatever value that function returns.
+Otherwise,
+.code partition-if
+returns a lazy list of partitions of
+.metn iterable .
+Partitions are consecutive, nonempty substrings of
+.metn iterable ,
+of the same kind as
+.metn iterable .
+
+The partitioning begins with the first element of
+.meta iterable
+being placed into the first partition.
+
+The subsequent partitioning is done according to a Boolean
+.metn function ,
+which must accept two arguments. Whenever the function yields true, it
+indicates that a partition is to be terminated and a new partition to begin.
+The
+.meta count
+argument, if present, must be a nonnegative integer. It indicates
+a limit on how many partitions will be delimited; after this limit
+is reached, the remainder of the
+.meta iterable
+sequence is placed into a single partition.
+
+After the first element is placed into a partition, the following
+partition-building process is repeated until the partition is terminated.
+.RS
+.IP 1.
If
-.meta ref-sequence
-is a
-.codn carray ,
-then
-.meta list
-is passed to the
-.code carray-list
-function, and the resulting value is returned. The second argument in the
-.code carray-list
-call is the element type taken from
-.metn ref-sequence .
-The third argument is
+.meta iterable
+contains no more elements, then the partition terminates.
+.IP 2.
+Otherwise, if the
+.meta count
+is present, and has a value of zero, then the next available
+element is unconditionally deposited into the current partition,
+and the process repeats from step 1.
+.IP 3.
+Otherwise,
+.meta function
+is invoked on two values: the previous element which has most
+recently been deposited into the partition, and its successor from
+.metn iterable .
+.IP 4.
+If
+.meta function
+returns
.codn nil ,
-indicating that the resulting
-.code carray
-is not to be null terminated.
-
-Note: the
+then the partition continues: the next element is
+added to the partition, and the process repeats from step 1.
+.IP 5.
+Otherwise,
+.meta function
+has returned true and the partition is terminated. In this case, if
+.meta count
+is present, it is decremented.
+.RE
+.IP
+When the current partition is terminated, it is converted to a sequence of the
+same kind as
+.meta iterable
+as if by using the
.code make-like
-function is a helper which supports the development of
-unoptimized versions of a generic function that accepts any type of
-sequence as input, and produces a sequence of the same type as output.
-The implementation of such a function can internally accumulate a list, and
-then convert the resulting list to the same type as an input value
-by using
-.codn make-like .
+function, and incorporated as the next element of the lazy list of partitions.
-.coNP Function @ nullify
+If, after a partition is thus produced, a next element is available, it is
+placed into a new partition, and the above partition-building process takes
+place from step 1. Otherwise, the lazy list terminates.
+
+.TP* Examples:
+
+.verb
+ ;; Start new partition for unequal characters.
+ [partition-if neql "aaaabbcdee"] -> ("aaaa" "bb" "c" "d" "ee")
+
+ ;; As above, but partition only twice
+ [partition-if neql "aaaabbcdee" 2] -> ("aaaa" "bb" "cdee")
+
+ ;; Start new partition when non-digit follows digit:
+ [partition-if (do and
+ (chr-isdigit @1)
+ (not (chr-isdigit @2)))
+ "a13cd9foo42z"]
+ -> ("a13" "cd9" "foo42" "z")
+
+ ;; Place ascending runs of consecutive integers
+ ;; into partitions. I.e. start a partition whenever the
+ ;; difference from the previous element isn't 1:
+ (partition-if (op /= (- @2 @1) 1)
+ '(1 3 4 5 7 8 9 10 9 8 6 5 3 2))
+ -> ((1) (3 4 5) (7 8 9 10) (9) (8) (6) (5) (3) (2))
+
+ ;; Place runs of adjacent integers into partitions.
+ ;; I.e. start a new partition if the the absolute value of
+ ;; the difference from the previous exceeds 1:
+ (partition-if (op > (abs (- @2 @1)) 1)
+ '(1 3 4 5 7 8 9 10 9 8 6 5 3 2))
+ -> ((1) (3 4 5) (7 8 9 10 9 8) (6 5) (3 2))
+.brev
+
+.SS* Open Sequence Traversal
+
+Functions in this category perform efficient traversal of sequences.
+
+There are two flavors of these functions: functions in the
+.code iter-begin
+group, and functions in the
+.code seq-begin
+group. The latter are obsolescent.
+
+User-defined iteration is possible via defining special methods on
+structures. An object supports iteration by defining the special method
+.code iter-begin
+which is different from the
+.code iter-begin
+function. This special function returns an iterator object which supports
+special methods
+.codn iter-item ,
+.code iter-more
+and
+.codn iter-step .
+Two protocols are supported, one of which is more efficient by eliminating the
+.code iter-more
+method. Details are specified in the section
+.BR "Special Structure Functions" .
+
+.coNP Function @ iter-begin
.synb
-.mets (nullify << obj )
+.mets (iter-begin << seq )
.syne
.desc
The
-.code nullify
-function returns
-.code nil
-if
-.meta obj
-is an empty sequence.
-Otherwise, if
-.meta obj
-is not an empty sequence, or isn't a sequence, then
-.meta obj
-itself is returned.
+.code iter-begin
+function returns an iterator object suitable for traversing the
+elements of the sequence denoted by the
+.meta seq
+object.
If
-.meta obj
-is a structure, then
-.meta obj
-is returned if it doesn't support the
-.code nullify
-method, even if it has other methods such as
+.meta seq
+is a list-like sequence, then
+.code iter-begin
+may return
+.meta seq
+itself as the iterator. Likewise if
+.meta seq
+is a number.
+
+If
+.meta seq
+is an iterator produced by
+.code iter-begin
+then an iterator similar to that iterator is returned, which can continue
+iterating the same sequence. The iterator may be
+.meta seq
+itself or share state with
+.metn seq ,
+and thus may not be relied on to produce an independent, parallel iteration.
+
+If
+.meta seq
+is a structure which supports the
+.code iter-begin
+method, then that method is called and its return value is returned.
+A structure which does not support this method is possibly considered
+to be a sequence according to the usual criteria, based on whether
+it supports the
+.codn nullify ,
.code length
-by which it could be inferred that it represents an empty sequence.
+or
+.code car
+methods. A struct object supporting none of these methods is deemed
+not iterable.
+
+In all other cases, if
+.meta seq
+is iterable, an object of type
+.code seq-iter
+is returned.
+
+Range objects are iterable if they are numeric. A range consisting of
+two strings may also be iterable, as described below.
+
+A range is considered to be a numeric or character range if the
+.code from
+element is a number or character. The
+.code to
+is then required to be either a value which is comparable with that number
+or character using the
+.code <
+function, or else it must be one of the two objects
+.code t
+or
+.codn : ,
+either of which indicate that the range is unbounded. In this unbounded range
+case, the expressions
+.code "(iter-begin X..:)"
+and
+.code "(iter-begin X..t)"
+are equivalent to
+.codn "(iter-begin X)" .
+Numeric ranges are half-open: the
+.code to
+value of ascending ranges is excluded, as is the
+.code from
+value of descending ranges, so that
+.code 0..10
+steps through the values
+.code 0
+through
+.codn 9 ,
+and
+.code 10..0
+steps through the same values in reverse order.
+
+A string range consists of two strings of equal length. If the strings are
+of unequal length, an error exception is thrown. For the range to operate
+as intended, the strings must meet some additional requirements. If the
+.code from
+string is lexicographically lesser than the
+.code to
+string, as determined by the
+.code less
+function, then the range is ascending, otherwise it is descending. The string
+range iterates by incrementing (or decrementing, in the case of a descending range)
+the characters of the
+.code from
+string until they are equal to those of the
+.code to
+string. The last character has priority. For instance, the range
+.code "\(dqAA\(dq..\(dqCC\(dq"
+iterates over the strings
+.codn "AA" ,
+.codn "AB" ,
+.codn "AC" ,
+.codn "BA" ,
+.codn "BB" ,
+.codn "BC" ,
+.codn "CA" ,
+.code "CB"
+and
+.codn "CC" .
+The descending range
+.code "\(dqCC\(dq..\(dqAA\(dq"
+iterates over the same strings, in reverse order. Whenever the incrementing
+character attains the value of the corresponding character in the
+.code to
+string, that character is reset to its starting value, and its left neighbor,
+if it exists, is incremented instead. If no left neighbor exists, the
+iteration terminates.
+
+Search trees are iterable. Iteration entails an in-order visits of the elements
+of a tree. A tree iterator created by
+.code tree-begin
+is also iterable. It is unspecified whether iteration over a
+.code tree-iter
+object modifies that object to perform the traversal, or whether it uses a copy
+of the iterator.
If
-.meta obj
-has a
-.code nullify
-method, then the
-.code nullify
-function invokes that method and returns whatever value
-that method returns.
+.code seq
+is not an iterable object, an error exception is thrown.
+.coNP Function @ iter-more
+.synb
+.mets (iter-more << iter )
+.syne
+.desc
+The
+.code iter-more
+function returns
+.code t
+if there remain more elements to be traversed.
+Otherwise it returns
+.codn nil .
+
+The
+.meta iter
+argument must be a valid iterator returned by a call to
+.metn iter-begin ,
+.meta iter-step
+or
+.metn iter-reset .
+
+The
+.code iter-more
+function doesn't change the state of
+.metn iter .
+
+If
+.code iter
+is the object
+.code nil
+then
+.code nil
+is returned.
Note: the
-.code nullify
-function is a helper to support unoptimized generic
-programming over sequences. Thanks to the generic behavior of
-.codn cdr ,
-any sequence can be traversed using
-.code cdr
-functions, checking for the
+.code iter-begin
+may return
.code nil
-value as a terminator. This, however, breaks for empty sequences which are not
-lists, because they are not equal to
-.codn nil :
-to
-.code car
+if its argument is
+.code nil
+or any empty sequence, or an empty range (a range whose
+.code to
and
-.code cdr
-they look like
-a one-element sequence containing
+.code from
+fields are the same number or character).
+
+If
+.meta iter
+is a
+.code cons
+cell, then
+.code iter-more
+returns
+.codn t .
+
+If
+.meta iter
+is a number, then
+.code iter-more
+returns
+.codn t .
+This is the case even if calculating the successor of that number isn't possible
+due to floating-point overflow or insufficient system resources.
+
+If
+.meta iter
+is a character, then
+.code iter-more
+returns
+.code t
+if
+.meta iter
+isn't the highest possible character code, otherwise
.codn nil .
+
+If
+.meta iter
+was formed from a descending range, meaning that
+.code iter-begin
+was invoked on a range with a
+.code from
+fielding exceeding its
+.code to
+value, then
+.code iter-begin
+returns true while the current iterator value is greater than the
+the limiting value given by the
+.code to
+field. For an ascending range, it returns true if the current iterator value is
+lower than the limiting value. However, note the peculiar semantics of
+.code iter-item
+with regard to descending range iteration.
+
+If
+.meta iter
+is a structure, then if it supports an
+.code iter-more
+method, then that method is called with no arguments, and its return value
+is returned. If the structure does not have an
+.code iter-more
+method, then
+.code t
+is returned.
+
+.coNP Function @ iter-item
+.synb
+.mets (iter-item << iter )
+.syne
+.desc
+If the
+.code iter-more
+function indicates that more items remain to be visited, then
+the next item can be retrieved using
+.codn iter-item .
+
The
-.code nullify
-function reduces all empty
-sequences to
+.meta iter
+argument must be a valid iterator returned by a call to
+.metn iter-begin ,
+.meta iter-step
+or
+.metn iter-reset .
+
+The
+.code iter-more
+function doesn't change the state of
+.metn iter .
+
+If
+.code iter-more
+is invoked on an iterator which indicates that no more items
+remain to be visited, the return value is
+.codn nil .
+
+If
+.meta iter
+is a
+.code cons
+cell, then
+.code iter-item
+returns the
+.code car
+field of that cell.
+
+If
+.meta iter
+is a character or number, then
+.code iter-item
+returns that character or number itself.
+
+If
+.meta iter
+is based on an ascending numeric or character range, then
+.code iter-item
+returns the current iteration value, which is initialized by
+.code iter-begin
+as a copy of the range's
+.code from
+field. Thus, the range
+.code 0..3
+traverses the values
+.codn 0 ,
+.code 1
+and
+.codn 2 ,
+excluding the
+.codn 3 .
+
+If
+.meta iter
+is based on a descending numeric or character range, then
+.code iter-item
+returns the predecessor of the current iteration value, which is initialized
+.code iter-begin
+as a copy of the range's
+.code from
+field.
+Thus, the range
+.code 3..0
+traverses the values
+.codn 2 ,
+.code 1
+and
+.codn 0 ,
+excluding the
+.codn 3 :
+exactly the same values are visited as for the range
+.code 0..3
+only in reverse order.
+
+If
+.meta iter
+is a structure which supports the
+.code iter-item
+method, then that method is called and its return value is returned.
+
+.coNP Function @ iter-step
+.synb
+.mets (iter-step << iter )
+.syne
+.desc
+If the
+.code iter-more
+function indicates that more items remain to be visited, then the
+.code iter-step
+function may be used to consume the next item.
+
+The function returns an iterator denoting the traversal of the
+remaining items in the sequence.
+
+The
+.meta iter
+argument must be a valid iterator returned by a call to
+.metn iter-begin ,
+.meta iter-step
+or
+.metn iter-reset .
+
+The
+.code iter-step
+function may return a new object, in which case it avoids
+changing the state of
+.metn iter ,
+or else it may change the state of
+.meta iter
+and return it.
+
+If the application discontinues the use of
+.metn iter ,
+and continues the
+traversal using the returned iterator, it will work correctly in either
+situation.
+
+If
+.code iter-step
+is invoked on an iterator which indicates that no more items
+remain to be visited, the return value is unspecified.
+
+If
+.meta iter
+is a
+.code cons
+cell, then
+.code iter-step
+returns the
+.code cdr
+field of that cell. That value must itself be a
+.code cons
+or else
.codn nil ,
-thereby correcting the behavior of code which traverses
-sequences using
-.codn cdr ,
-and tests for termination with
+otherwise an error is thrown. This is to prevent iteration
+from wrongly iterating into the non-null terminators of improper
+lists. Without this rule, iteration of a list like
+.code "(1 2 . 3)"
+would reach the
+.code cons
+cell
+.code "(2 . 3)"
+at which point a subsequent
+.code iter-step
+would return the
+.code cdr
+field
+.codn 3 .
+But that value is a valid iterator which will then continue by
+stepping through
+.codn 4 ,
+.code 5
+and so on.
+
+If
+.meta iter
+is a list-like sequence, then
+.code cdr
+is invoked on it and that value is returned.
+The value must also be a list-like sequence, or else
.codn nil .
+The reasoning for this is the same as for the similar
+restriction imposed in the case when
+.meta iter
+is a
+.codn cons .
-.SS* Open Sequence Traversal
+If
+.meta iter
+is a character or number, then
+.code iter-step
+returns its successor, as if using the
+.code succ
+function.
+
+If
+.meta iter
+is a structure which supports the
+.code iter-step
+method, then that method is called and its return value is returned.
-Functions in this category perform efficient traversal of sequences
-of various kinds.
+.coNP Function @ iter-reset
+.synb
+.mets (iter-reset < iter << seq )
+.syne
+.desc
+The
+.code iter-reset
+function returns an iterator object specialized for the task of traversing
+the sequence
+.metn seq .
+
+If it is possible for
+.meta iter
+to be that object, then the function may adjust the state of
+.meta iter
+and return it.
+
+If
+.code iter-reset
+doesn't use
+.metn iter ,
+then it behaves exactly like
+.code iter-begin
+being invoked on
+.metn seq .
+
+If
+.meta seq
+is a structure which supports the
+.code iter-reset
+method, then that method is called and its return value is returned.
+Note the reversed arguments. The
+.code iter-reset
+method is of the
+.meta seq
+object, not of
+.metn iter .
+That is to say, the call
+.mono
+.meti (iter-reset < iter << obj )
+.onom
+results in the
+.mono
+.meti << obj .(iter-reset << iter )
+.onom
+call. If
+.meta seq
+is a structure which doesn't support
+.code iter-reset
+then
+.meta iter
+is ignored,
+.code iter-begin
+is invoked on
+.meta seq
+and the result is returned.
.coNP Function @ seq-begin
.synb
.mets (seq-begin << object )
.syne
.desc
-The
+The obsolescent
.code seq-begin
function returns an iterator object specialized to the task of traversing
the sequence represented by the input
@@ -32972,7 +39985,7 @@ is not suitable for indefinite iteration over infinite lists.
.mets (seq-next < iter << end-value )
.syne
.desc
-The
+The obsolescent
.code seq-next
function retrieves the next available item from the sequence iterated by
.metn iter ,
@@ -32993,9 +40006,9 @@ freshly allocated object.
.mets (seq-reset < iter << object )
.syne
.desc
-The
+The obsolescent
.code seq-reset
-re-initializes the existing iterator object
+reinitializes the existing iterator object
.meta iter
to begin a new traversal over the given
.metn object ,
@@ -33014,7 +40027,7 @@ function returns
which encapsulates state and methods for constructing lists procedurally.
Among the advantages of using
.code list-builder
-is that lists can be constructed in the left to right direction without
+is that lists can be constructed in the left-to-right direction without
requiring multiple traversals or reversal. For example,
.code list-builder
naturally combines with iteration or recursion: items visited in an
@@ -33044,13 +40057,23 @@ method, which is also how the final version of the list is eventually
retrieved.
The
+.code list-builder
+methods which add material to the list all return the list builder,
+making chaining possible.
+
+.verb
+ (new list-builder).(add 1).(add 2).(pend '(3 4 5)).(get)
+ -> (1 2 3 4 5)
+.brev
+
+The
.code build
macro is provided which syntactically streamlines the process.
It implicitly creates a
.code list-builder
instance and binds it to a hidden lexical variable.
It then evaluates forms in a lexical scope in which
-short-hand macros are available for building the list.
+shorthand macros are available for building the list.
.coNP Structure @ list-builder
.synb
@@ -33084,14 +40107,14 @@ function instantiates and returns an object of struct type
If no
.meta initial-list
argument is supplied, then the object is implicitly
-with an empty list.
+initialized with an empty list.
If the argument is supplied, then it is equivalent
to calling
.code build-list
without an argument to produce an object
.meta obj
-the invoking the method call
+by invoking the method call
.mono
.meti << obj .(ncon << initial-list )
.onom
@@ -33134,8 +40157,9 @@ whereas
.code add*
adds elements at the front.
-These methods return
-.codn nil .
+These methods return the
+.meta list-builder
+object.
The precise semantics is as follows.
All of the
@@ -33183,7 +40207,7 @@ methods extend the list being constructed by a
object by adding lists to it. The
.code pend
method catenates the
-.code list
+.meta list
arguments together as if by the
.code append
function, then appends the resulting list to
@@ -33207,8 +40231,9 @@ however, they avoid mutating those parts of the current list
that are shared with inputs that were given in earlier
calls to these functions.
-These methods return
-.codn nil .
+These methods return the
+.meta list-builder
+object.
.TP* Example:
@@ -33274,8 +40299,9 @@ installed as the terminating atom of the
list being constructed, if the current list is
an ordinary list.
-These methods return
-.codn nil .
+These methods return the
+.meta list-builder
+object.
.TP* Example:
@@ -33290,6 +40316,56 @@ These methods return
-> (1 2 3 4 . 5)
.brev
+.coNP Method @ oust
+.synb
+.mets << list-builder .(oust << list *)
+.syne
+.desc
+The
+.code oust
+method discards the list constructed so far, optionally
+replacing it with new material.
+
+The
+.code oust
+method catenates the
+.meta list
+arguments together as if by the
+.code append
+function. The resulting list, which is empty
+if there are no
+.meta list
+arguments, then replaces the object's
+list constructed so far.
+
+The
+.code oust
+method returns the
+.meta list-builder
+object.
+
+.TP* Examples:
+
+.verb
+ ;; Build the list (3 4) by first building (1 2),
+ ;; then discarding that and adding 3 and 4:
+
+ (let ((lb (build-list)))
+ lb.(add 1 2)
+ lb.(oust)
+ lb.(add 3 4)
+ lb.(get))
+ -> (3 4)
+
+ ;; Build the list (3 4 5 6) by first building (1 2),
+ ;; then replacing with catenation of (3 4) and (5 6):
+ (let ((lb (build-list)))
+ lb.(pend '(1 2))
+ lb.(oust '(3 4) '(5 6))
+ lb.(get))
+ -> (3 4 5 6)
+.brev
+
.coNP Method @ get
.synb
.mets << list-builder .(get)
@@ -33382,6 +40458,7 @@ This lexical environment also provides local functions named
.codn pend* ,
.codn ncon ,
.codn ncon* ,
+.codn oust ,
.codn get ,
.code del
and
@@ -33397,9 +40474,11 @@ and
.codn del* ,
the local functions return
.codn nil ,
-like the same-named
+unlike like the same-named
+.code list-builder
+methods, which return the
.code list-builder
-methods.
+object.
In this lexical environment, each
.meta form
@@ -33481,7 +40560,7 @@ macro for deleting a place.
.syne
.desc
The
-.code rperm
+.code perm
function returns a lazy list which consists of all
length
.meta len
@@ -33516,7 +40595,7 @@ If
exceeds the length of
.metn seq ,
then an empty list is returned,
-since it is impossible to make a single non-repeating permutation that
+since it is impossible to make a single nonrepeating permutation that
requires more items than are available.
The permutations are lexicographically ordered.
@@ -33593,9 +40672,9 @@ The
function returns a lazy list which consists of all
length
.meta len
-non-repeating combinations formed by taking items taken from
+nonrepeating combinations formed by taking items taken from
.metn seq .
-"Non-repeating combinations" means that the combinations do not use any
+"Nonrepeating combinations" means that the combinations do not use any
element of
.meta seq
more than once. If
@@ -33622,7 +40701,7 @@ If
exceeds the number of elements in
.metn seq ,
then an empty list is returned, since it is impossible to make a single
-non-repeating combination that requires more items than are available.
+nonrepeating combination that requires more items than are available.
If
.meta seq
@@ -33647,7 +40726,7 @@ is a hash table.
.syne
.desc
The
-.code comb
+.code rcomb
function returns a lazy list which consists of all
length
.meta len
@@ -33684,27 +40763,38 @@ The combinations are lexicographically ordered.
.SS* Macros
-\*(TL supports structural macros. \*(TX's model of macroexpansion is that
-\*(TL code is processed in two phases: the expansion phase and the
-evaluation phase. The expansion phase is invoked on Lisp code early during the
-processing of source code. For instance when a \*(TX file containing a
-.code "@(do ...)"
-directive
-is loaded, expansion of the Lisp forms are its arguments takes place during the
-parsing of the entire source file, and is complete before any of the code in
-that file is executed. If the
-.code "@(do ...)"
-form is later executed,
-the expanded forms are then evaluated.
-
-\*(TL also supports symbol macros, which are symbolic forms that stand
-for forms, with which they are replaced at macro expansion time.
+Because \*(TL supports structural macros, \*(TX processes \*(TL expressions in
+two separate phases: the expansion phase and the evaluation/compilation phase.
+During the expansion phase, a top-level expression is recursively traversed,
+and all macro invocations in it are expanded. The result is a transformed
+expression which contains only function calls and invocations of special
+operators. This expanded form is then evaluated or compiled, depending on the
+situation.
-When Lisp data is processed as code by the
-.code eval
-function, it is first expanded,
-and so processed in its entirety in the expansion phase. Then it is processed
-in the evaluation phase.
+Macro invocations are compound forms and whose operator symbol has a macro
+definition in scope. A macro definition is a kind of function which operates
+on syntax during macro-expansion, called upon to calculate a transformation of
+the syntax. The return value of a macro replaces its invocation, and is
+traversed to look for more opportunities for macro expansion.
+Macros differ from ordinary functions in three ways: they are called
+at macro-expansion time, they receive pieces of unevaluated syntax as their
+arguments, and their parameter lists are macro parameter lists which
+support destructuring, as well as certain special parameters.
+
+\*(TL also supports symbol macros. A symbol macro definition associates
+a symbol with an expansion. When that symbol appears as a form, the
+macro-expander replaces it with the expansion.
+
+\*(TX source files are treated somewhat differently with regard to macro
+expansion compared to \*(TL. When \*(TL forms are read from a file by
+.code load
+or
+.code compile
+or read by the interactive listener, each form is expanded and evaluated
+or compiled before the subsequent form is processed. In contrast,
+when a \*(TX file is loaded, expansion of the Lisp forms are its arguments
+takes place during the parsing of the entire source file, and is complete
+for the entire file before any of the code is executed.
.NP* Macro parameter lists
@@ -33762,6 +40852,21 @@ and
.codn "(d e)" .
These compounds express nested macro parameter lists.
+Starting in \*(TX 285, the symbol
+.code t
+can be used in a macro parameter list in place of a parameter name.
+This indicates that an object is expected at that position in the
+corresponding structure, but no variable will be bound.
+For completeness, the
+.code t
+symbol may also be used for a presence-indicating variable.
+When the name of an optional parameter is specified as
+.codn t ,
+and the corresponding structure is missing, the
+.meta init-val
+expression, if present, is still evaluated under the same
+circumstances as it would if a variable were present.
+
Nested macro parameter lists recursively match the corresponding structure
in the argument object. For instance if a simple argument would capture
the structure
@@ -33846,17 +40951,15 @@ list: its parameter will capture just that part of the argument material which
matches that parameter list, rather than the entire argument list.
The processing of macro parameter lists omits the feature that when the
-keyword symbol
.code :
-(colon) given as the argument to an optional parameter, that argument is
-treated as a missing argument. This special logic is implemented only
+(colon) keyword symbol is given as the argument to an optional parameter,
+that argument is treated as a missing argument.
+This special logic is implemented only
in the function argument passing mechanism, not in the binding of macro
parameters to object structure. If the colon symbol appears in the object
structure and is matched against an optional parameter, it is an
ordinary value. That parameter is considered present, and takes on
-that
-.code :
-keyword symbol as its value.
+the colon symbol as its value.
.TP* "Dialect Note:"
@@ -33867,10 +40970,10 @@ binds its corresponding variable to the entire macro form, whereas
.code :whole
binds its variable only to the arguments of the macro form.
-Note, however, that ANSI CL distinguishes destructuring lambda lists
-and macro lambda lists and the
+Note, however, that ANSI CL distinguishes between destructuring and
+macro lambda lists, and the
.code &whole
-parameter has a different behavior between the two. Under
+parameter has a different behavior in each. Under
.codn destructuring-bind ,
the
.code &whole
@@ -33879,7 +40982,8 @@ of \*(TL's
.code :whole
parameter.
-\*(TL does not distinguish destructuring and macro lambda lists;
+\*(TL does not distinguish between destructuring and
+macro lambda lists;
they are the same and behave the same way. Thus
.code :whole
is treated the same way in macros as in
@@ -33894,137 +40998,140 @@ and binds to the entire
.code tree-bind
form.
-.coNP Operator @ macro-time
-.synb
-.mets (macro-time << form *)
-.syne
-.desc
-The
-.code macro-time
-operator has a syntax similar to the
-.code progn
-operator. Each
-.meta form
-is evaluated from left to right, and the resulting value is that of the last
-form.
+ANSI CL doesn't support the convention that the
+.code t
+symbol may appear instead of a parameter symbol to
+suppress the binding of a variable.
-The special behavior of
-.code macro-time
-is that the evaluation takes place during
-the expansion phase, rather than during the evaluation phase.
+.NP* The Macro Expansion Process
-Also,
-.code macro-time
-macro-expands each
-.meta form
-and evaluates it before processing the next
-.meta form
-in the same way. Thus, for instance, if a
-.meta form
-introduces a global definition, that definition will be visible not
-only during the evaluation of a subsequent
-.metn form ,
-but also during its macro-expansion time.
-
-During the expansion phase, all
-.code macro-time
-expressions which occur in a context
-that calls for evaluation are evaluated, and replaced by their quoted values.
-For instance
-.code "(macro-time (list 1 2 3))"
-evaluates
-.code "(list 1 2 3)"
-to the object
-.code "(1 2 3)"
-and the entire
-.code macro-time
-form is replaced by that value, quoted:
-.codn "'(1 2 3)" .
-If the form is evaluated again at evaluation-time, the resulting value will be
-that of the quote, in this case
-.codn "(1 2 3)" .
+The following description omits the treatment of top-level forms by
+.code eval
+and the compiler. This is described, respectively, in the description of
+.code eval
+and the section Top-Level Forms inside the LISP COMPILATION chapter.
+Certain other details are also omitted, such as the dynamic evolution of the
+macro-time environment, the expansion of macrolet forms.
+
+Macro expansion is, generally speaking, a recursive process. The expression to
+be expanded is classified into cases, and as necessary, the constituent
+expressions are recursively expanded, depending on these cases. Certain aspects
+of the process may be regarded as iterative.
+Macro expansion maintains a macro-time lexical environment which is extended
+and contracted as the expander descends into various nested binding constructs.
+
+The expander may encounter a bindable symbol. If such a symbol has a binding
+as a symbol macro, then it is replaced by its expansion, and the expander
+iterates on the resulting form. The form may be another object, including a
+symbol. If it is the same symbol, than macro expansion terminates; the
+symbol remains unsubstituted. Symbols are treated differently by the
+expander if they are in the Lisp-1-style context of the
+.code dwim
+operator, or the equivalent square bracket notation. The expander takes into
+consideration the semantics of the combined function and variable namespace.
+
+The expander may encounter a compound form headed by a symbol which has a macro
+binding. In this situation, the macro expander function is called, and the form
+is replaced by the resulting form. That form is considered again as a potential
+macro. In any case, the expander makes a note that it has expanded a macro,
+
+If a form isn't a macro, then it's either a function call, special from or an
+atomic form: a symbol (that has no binding as a symbol macro) or other atom.
+The interesting cases are special forms and function calls, since the atomic
+forms are simply returned as-is without expansion. Special forms and function
+call forms contain other forms, some or all of which require expansion. The
+expander recognizes the shape of each special form or function call, pulls out
+the constituent expressions and expands them recursively, combining the results
+into a new version of the special form or function call form.
+
+Because \*(TL allows the same symbol to have a macro and function binding, the
+expander allows for interplay between the two, which produces useful behaviors.
+Recall from two paragraphs ago that whenever the expander expands a macro, it
+makes a note that it has done so. Subsequently, suppose that the rounds of
+macro expansion happen to terminate in such a way that the result is a function
+call form. The form's constituents are expanded, If the expansion of those
+constituents produces any change, then the resulting replacement function call
+form is again examined for the possibility that it may be a macro. This
+special requirement, not typically implemented by Lisp macro expanders, greatly
+simplifies the writing of macros which provide algebraic optimizations of
+function calls.
+
+An example follows to illustrate the benefit of the rule. Note that the
+example involves some simple macros which change the number of times that
+an argument expression is evaluated. A more careful handling of this issue
+is omitted in order to keep the examples simple.
+
+Suppose a macro is written for the
+.code sqrt
+function like this:
-.code macro-time
-forms do not see the surrounding lexical environment; the see only
-global function and variable bindings and macros.
+.verb
+ (defmacro sqrt (:match :form f)
+ (((* @exp @exp)) exp)
+ (@else f))
+.brev
-Note:
-.code macro-time
-supports techniques that require a calculation to be performed in the
-environment where the program is being compiled, and inserting the result of
-that calculation as a literal into the program source. Possibly, the
-calculation can have some useful effect in that environment, or use
-as an input information that is available in that environment.
-The
-.code load-time
-operator also inserts a calculated value as a
-.I "de facto"
-literal into the program, but it performs that calculation in the
-environment where the compiled file is being loaded.
-The two operators may be considered complementary in this sense.
+The macro uses pattern matching to recognize cases like
+.code "(sqrt (* a a))"
+when the argument is a product expression with two identical terms. This
+pattern implements the arithmetic identity that the positive square root of a
+real term multiplied by itself is just that term.
-Consider the source file:
+Now suppose that a similar macro is written to optimize a certain
+case of the
+.code expt
+function:
.verb
- (defun host-name-c () (macro-time (uname).nodename))
-
- (defun host-name-l () (load-time (uname).nodename))
+ (defmacro expt (:match :form f)
+ ((@exp 2) ^(* ,exp ,exp))
+ (@else f))
.brev
-If this is compiled via
-.codn compile-file ,
-the
-.code uname
-call in
-.code host-name-c
-takes place when it is macro-expanded. Thereafter, the compiled version
-of the function returns the name of the machine where the
-compilation took place, no matter in what environment it is subsequently
-loaded and called.
-
-In contrast, the compilation of
-.code host-name-l
-arranges for that function's
-.code uname
-call to take place just one time, whenever the compiled file is loaded.
-Each time the function is subsequently called, it will
-return the name of the machine where it was loaded, without making
-any additional calls to
-.codn uname .
+This macro recognizes when the argument is being squared, turning
+.code "(expt x 2)"
+into
+.codn "(* x x)" :
+a strength reduction from exponentiation to multiplication.
-The
-.code macro-time
-operator can occasionally be required in order for some constructs to evaluate
-or compile. One way that occurs is when a construct that is being fully
-expanded itself defines a macro which is later required in that same construct.
-For example:
+What if the following expression is then written:
.verb
- (progn (defmacro mac () 42) (mac))
+ (sqrt (expt x 2))
.brev
-This specific example actually works under
-.code eval
-or file compilation, because in that situation it isn't fully expanded
-all at once. When
-.code eval
-and
-.code compile-file
-process a top-level form that is a
-.codn progn ,
-they treat its argument forms as individual, separate top-level forms. In
-general, \*(TL is designed in such a way as to not to require, in most ordinary
-programs, extra verbiage to tell the compiler or evaluator that certain
-definitions are required by macros. However, somewhat unusual situations can
-arise which are not handled in this way.
-
-Also,
-.codn macro-time ,
-or the related
-.code @(mdo)
-directive, can be occasionally necessary in \*(TX
-queries, which are parsed and subject to macro-expansion in their entirety
-before being executed.
+The special provision in the expander algorithm allows the above combination
+to reduce to just
+.codn x ,
+as follows. Firstly, the
+.code "(sqrt (expt x 2))"
+expression is treated as a macro call. It doesn't match the main case
+in the macro, only the fallback case which returns the form unexpanded.
+The expander notes that it has invoked a macro, and then proceeds to treat
+the form as a function call. The function call's argument expression
+.code "(expt x 2)"
+is expanded as a macro. This produces a transformation: our
+.code expt
+macro reduces this quadratic term to
+.codn "(* x x)" .
+Here is where the special rule comes into play. The expander sees that
+the function's arguments have been transformed. It knows that the original
+function call was the result of expansion. To promote more opportunities
+for expansion, it tries the transformed function call again as a macro.
+The
+.code "(sqrt (* x x))"
+form is handed to the
+.code sqrt
+macro, which this time has a match for the
+.code "(* x x)"
+argument pattern, reducing the entire form to
+.codn x .
+Effectively, the
+.code sqrt
+macro has the opportunity to work with both the unexpanded argument syntax
+.code "(expt x 2)"
+as well as its expanded version. It is first offered the one, and when it
+declines to expand, then the other.
.coNP Operator @ defmacro
.synb
@@ -34079,13 +41186,13 @@ declines, more complicated requirements apply; see the description of
.TP* "Dialect Notes:"
A macro in the global namespace introduced by
.code defmacro
-may co-exist with a function of the same name introduced by
+may coexist with a function of the same name introduced by
.codn defun .
This is not permitted in ANSI Common Lisp.
ANSI Common Lisp doesn't describe the concept of declining to expand, except in
the area of compiler macros. Since TXR Lisp allows global macros and functions
-of the same name to co-exist, ordinary macros can be used to optimize functions
+of the same name to coexist, ordinary macros can be used to optimize functions
in a manner similar to Common Lisp compiler macros. A macro can be written
of the same name as a function, and can optimize certain cases of the function
call by expanding them to some alternative syntax. Cases which it doesn't
@@ -34102,12 +41209,12 @@ as the original function call.
;; and return 42.
;;
;; (dolist (x '(1 2 3) 42)
- ;; (format t "~s\en"))
+ ;; (format t "~s\en" x))
(defmacro dolist ((var list : result) . body)
- (let ((i (my-gensym)))
- ^(for ((i ,list)) (i ,result) ((set i (cdr i)))
- (let ((,var (car i)))
+ (let ((i (gensym)))
+ ^(for ((,i ,list)) (,i ,result) ((set ,i (cdr ,i)))
+ (let ((,var (car ,i)))
,*body))))
.brev
@@ -34131,7 +41238,7 @@ Each definition is a form which begins with a
followed by
.meta macro-style-params
which is a macro parameter list, and zero or more
-.metn macro-body-form -s.
+.metn macro-body-form s.
These macro definitions are similar
to those globally defined by the
.code defmacro
@@ -34144,7 +41251,7 @@ The macros specified in the definitions are visible to these
forms.
Forms inside the macro definitions such as the
-.metn macro-body-form -s,
+.metn macro-body-form s,
and initializer forms appearing in the
.meta macro-style-params
are subject
@@ -34152,7 +41259,7 @@ to macro-expansion in a scope in which none of the new macros being
defined are yet visible. Once the macro definitions are themselves
macro-expanded, they are placed into a new macro environment, which
is then used for macro expanding the
-.metn body-form -s.
+.metn body-form s.
A
.code macrolet
@@ -34160,7 +41267,7 @@ form is fully processed in the expansion phase of a form, and is
effectively replaced by
.code progn
form which contains expanded versions of
-.metn body-form -s.
+.metn body-form s.
This expanded structure shows no evidence that any
macrolet forms ever existed in it. Therefore, it is impossible for the code
evaluated in the bodies and parameter lists of
@@ -34170,7 +41277,7 @@ which are only instantiated in the evaluation phase, after expansion is done
and macros no longer exist.
A local macro defined using
-.code defmacro
+.code macrolet
may decline to expand a macro form. Declining to expand is achieved by returning the original
unexpanded form, which may be captured using the
.code :form
@@ -34401,7 +41508,7 @@ one or more argument forms to be treated in a Lisp-1 context, in situations
when such a macro needs to itself expand the material, rather than merely
insert it as-is into the output code template.
-.coNP Functions @ expand and @ *expand
+.coNP Functions @ expand and @ expand*
.synb
.mets (expand < form <> [ env ])
.mets (expand* < form <> [ env ])
@@ -34438,7 +41545,20 @@ and
.code expand*
is that
.code expand
-suppresses any warning exceptions that are issued during expansion.
+suppresses expansion-time deferred warnings (exceptions of type
+.codn defr-warning ),
+issued for unbound variables or functions.
+To suppress a warning means to intercept the warning exception with a handler
+which throws a
+.code continue
+exception to resume processing.
+What this requirement means is that if unbound functions or variables
+occur in the
+.meta form
+being expanded by expand, the warning is effectively squelched. Rationale:
+.code expand
+is may be used by macros for expanding fragments which contain references to
+variables or functions which are not defined in those fragments.
.coNP Function @ expand-with-free-refs
.synb
@@ -34729,13 +41849,15 @@ to discover the identities of the variables and functions which are used inside
that form, whose definitions come from a specific, bounded scope surrounding
that form.
-.coNP Functions @ lexical-var-p and @ lexical-fun-p
+.coNP Functions @, lexical-var-p @, lexical-fun-p @ lexical-symacro-p and @ lexical-macro-p
.synb
.mets (lexical-var-p < env << form )
.mets (lexical-fun-p < env << form )
+.mets (lexical-symacro-p < env << form )
+.mets (lexical-macro-p < env << form )
.syne
.desc
-These two functions are useful to macro writers. They are intended
+These four functions are useful to macro writers. They are intended
to be called from the bodies of macro expanders, such as the bodies of
.code defmacro
or
@@ -34748,12 +41870,58 @@ via the special
parameter. Using these functions, a macro can enquire whether
a given
.meta form
-is a symbol which has a variable binding or a function binding
-in the lexical environment.
+is, respectively, a symbol which has a variable binding, a function binding,
+a symbol macro (defined by
+.codn symacrolet )
+or a macro (defined by
+.codn macrolet )
+in the environment of the macro's invocation.
This information is known during macro expansion. The macro expander
recognizes lexical function and variable bindings, because these
bindings can shadow macros.
+Special variables are not lexical. The function
+.code lexical-var-p
+returns
+.code nil
+if
+.meta form
+satisfies
+.code special-var-p
+function, indicating that it is the name of a special variable.
+
+The
+.code lexical-var-p
+function also returns
+.code nil
+for global lexical variables. If
+.meta form
+is a symbol for which only a global lexical variable binding is apparent,
+.code lexical-var-p
+returns
+.codn nil .
+Testing for the existence for a global variable can be done using
+.codn boundp ;
+if a symbol is
+.code boundp
+but not
+.codn special-var-p ,
+then it is a global lexical variable.
+
+Similarly,
+.code lexical-fun-p
+returns
+.code nil
+for global functions,
+.code lexical-symacro-p
+returns
+.code nil
+for global symbol macros and
+.code lexical-macro-p
+returns
+.code nil
+for global macros.
+
.TP* Example:
.verb
@@ -34770,27 +41938,84 @@ bindings can shadow macros.
(t :not-lex-fun-var)))
;;
- ;; This returns:
- ;;
- ;; (:lexical-var :not-lex-fun-var :lexical-fun)
+ ;; Use classify macro above to report classification
+ ;; of the x, y and f symbols in the given scope
;;
(let ((x 1) (y 2))
(symacrolet ((y x))
(flet ((f () (+ 2 2)))
(list (classify x) (classify y) (classify f)))))
+ --> (:lexical-var :not-lex-fun-var :lexical-fun)
+
+ ;; Locally bound specials are not lexical
+
+ (let ((*stdout* *stdnull*))
+ (classify *stdout*))
+ --> :not-lex-fun-var
.brev
.TP* Note:
-These functions do not call
-.code macroexpand
-on the form. In most cases, it is necessary for the macro writers
-to do so. Not that in the above example, symbol
-.code y
-is classified as neither a lexical function nor variable.
-However, it can be macro-expanded to
-.code x
-which is a lexical variable.
+.coNP Function @ lexical-binding-kind
+.synb
+.mets (lexical-binding-kind < env << symbol )
+.syne
+.desc
+The
+.code lexical-binding-kind
+function inspects the macro-time environment
+.meta env
+to determine what kind of binding, if any, does
+.meta symbol
+have in the the variable namespace of that environment.
+
+If the innermost binding for
+.meta symbol
+is a variable binding, then either
+.code :var
+is returned if the variable is lexical, otherwise
+.code nil
+is returned if the variable is special.
+
+If the innermost binding for
+.meta symbol
+is a symbol macro, then
+.code :symacro
+is returned.
+
+In all other cases,
+.code nil
+is returned. The function does not consider global symbol macros
+or global lexical variables.
+
+.coNP Function @ lexical-fun-binding-kind
+.synb
+.mets (lexical-fun-binding-kind < env << symbol )
+.syne
+.desc
+The
+.code lexical-fun-binding-kind
+function inspects the macro-time environment
+.meta env
+to determine what kind of binding, if any, does
+.meta symbol
+have in the the function namespace of that environment.
+
+If the innermost binding for
+.meta symbol
+is a function binding, then
+.code :fun
+is returned.
+
+If the innermost binding for
+.meta symbol
+is a macro, then
+.code :macro
+is returned.
+
+In all other cases,
+.code nil
+is returned. The function does not consider global macros or functions.
.coNP Function @ lexical-lisp1-binding
.synb
@@ -34821,12 +42046,27 @@ If no such lexical binding is found, then the function
returns
.codn nil .
+Note that
+.code :var
+is never returned for a special variable, but such a variable
+can be shadowed by a symbol macro, in which case
+.code :symacro
+is returned.
+
Note that a
.code nil
return doesn't mean that the symbol doesn't have a lexical binding. It could
have an operator macro lexical binding (a macro binding in the function
namespace established by
.codn macrolet ).
+Unlike the
+.code lexical-binding-kind
+function, the
+.code lexical-lisp1-binding
+function never returns
+.code :macro
+because Lisp-1-style evaluation of symbols is blind to the existence of macros,
+other than symbol macros.
.coNP Operator @ defsymacro
.synb
@@ -34840,15 +42080,30 @@ between a symbol
.meta sym
and and a
.metn form .
-The binding denotes the form itself, rather than its value. How the
-symbol macro works is that if
+The binding denotes the form itself, rather than its value.
+
+The
+.meta form
+argument is not subject to macro expansion; it is associated with
.meta sym
-occurs as a form in a scope where the symbol macro definition is
-in scope,
+in its unexpanded state, as it appears in the
+.code defmacro
+form.
+
+The
+.code defsymacro
+form must be evaluated for its defining to take place; therefore,
+the definition is not available in the top-level form which contains the
+.code defsymacro
+invocation; it becomes available to a subsequent top-level form.
+
+Subsequent to the evaluation of the
+.code defsymacro
+definition, whenever the macro expander encounters
.meta sym
-is replaced by
+sym as a form, it replaces it by
.metn form .
-Immediately after this replacement takes place,
+After this replacement takes place,
.meta form
itself is then processed for further replacement of macros and
symbol macros.
@@ -34861,14 +42116,6 @@ like
.code set
and similar.
-A
-.code defsymacro
-form is implicitly executed at expansion time, and thus need
-not be wrapped in a
-.code macro-time
-form, just like
-.codn defmacro .
-
Note: if a symbol macro expands to itself directly, expansion stops. However,
if a symbol macro expands to itself through a chain of expansions,
runaway expansion-time recursion will occur.
@@ -34951,7 +42198,7 @@ corresponding
.meta sym
is established as an alias for the storage location which that place denotes,
over the scope of the
-.metn body-form -s.
+.metn body-form s.
This binding takes place in such a way that each
.meta place
@@ -34960,7 +42207,7 @@ storage location. The corresponding
.meta sym
then serves as an alias for that location, over the
scope of the
-.metn body-form -s.
+.metn body-form s.
This means that whenever
.meta sym
is evaluated, it stands for the value of the storage
@@ -34979,7 +42226,7 @@ bound to an earlier
form. In other words, a given
.meta sym
binding is visible not only to the
-.metn body-form -s
+.metn body-form s
but also to
.meta place
forms which occur later.
@@ -35032,6 +42279,26 @@ Rather it may be substituted by one kind of form when it
is treated as a pure value, and another kind of form
when it is treated as a place.
+Note: multiple accesses to an alias created by
+.code placelet
+denote multiple accesses to the aliased storage location.
+That can mean multiple function calls or array indexing operations and such.
+If the target of the alias is
+.mono
+.meti (read-once << place )
+.onom
+instead of
+.metn place ,
+then a single access occurs to fetch the prior value of
+.meta place
+and stored into a hidden variable. All of the multiple occurrences of the
+alias then simply retrieve this cached prior value from the hidden
+variable, rather than accessing the place. The
+.code read-once
+macro is independent of
+.code placelet
+and separately documented.
+
.TP* "Example:"
Implementation of
@@ -35053,6 +42320,175 @@ emanating from the
.code delta
form.
+.coNP Macro @ expander-let
+.synb
+.mets (expander-let >> ({( sym << init-form )}*) << body-form *)
+.syne
+.desc
+The
+.code expander-let
+operator strongly resembles
+.code let*
+but has different semantics, relevant to expansion.
+It also has a stricter syntax in that variables may not
+be symbols without a
+.metn init-form :
+only variable binding specifications of the form
+.mono
+.meti >> (sym << init-form )
+.onom
+are allowed.
+
+Symbols bound using
+.code expander-let
+are expected to be special variables. For every
+.metn sym ,
+the expression
+.mono
+.meti (special-var-p << sym )
+.onom
+should be true. The behavior is unspecified for any
+.meta sym
+which doesn't name a special variable.
+
+The
+.code expander-let
+macro establishes a new dynamic environment which each given
+.meta sym
+has the value of the specified
+.meta init-form
+which is evaluated in the top-level environment.
+Then, the
+.metn body-form s
+are turned into the arguments of a
+.code progn
+form, and that form is then expanded in the new environment in which the
+dynamic bindings are visible.
+
+Thus
+.code expander-let
+may be used to bind special variables which are visible to expansion-time
+computations occurring within
+.metn body-form s.
+A macro may generate an
+.code expander-let
+form in order to communicate values to macros contained in that form.
+
+.coNP Macro @ macro-time
+.synb
+.mets (macro-time << form *)
+.syne
+.desc
+The
+.code macro-time
+macro evaluates its arguments immediately during macro expansion.
+
+The
+.meta form
+arguments are processed from left to right. Each
+.meta form
+is fully expanded and evaluated in the top-level environment
+before the next form is considered.
+
+The value of the last
+.metn form ,
+or else
+.code nil
+if there aren't any arguments, is converted into a literal expression
+which denotes that value, and the resulting literal is produced
+as the expansion of
+.metn macro-time .
+
+Note:
+.code macro-time
+supports techniques that require a calculation to be performed in the
+environment where the program is being compiled, and inserting the result of
+that calculation as a literal into the program source. Possibly, the
+calculation can have some useful effect in that environment, or use
+as an input information that is available in that environment.
+The
+.code load-time
+operator also inserts a calculated value as a de facto
+literal into the program, but it performs that calculation in the
+environment where the compiled file is being loaded.
+The two operators may be considered complementary in this sense.
+
+Consider the source file:
+
+.verb
+ (defun host-name-c () (macro-time (uname).nodename))
+
+ (defun host-name-l () (load-time (uname).nodename))
+.brev
+
+If this is compiled via
+.codn compile-file ,
+the
+.code uname
+call in
+.code host-name-c
+takes place when it is macro-expanded. Thereafter, the compiled version
+of the function returns the name of the machine where the
+compilation took place, no matter in what environment it is subsequently
+loaded and called.
+
+In contrast, the compilation of
+.code host-name-l
+arranges for that function's
+.code uname
+call to take place just one time, whenever the compiled file is loaded.
+Each time the function is subsequently called, it will
+return the name of the machine where it was loaded, without making
+any additional calls to
+.codn uname .
+
+Note:
+.code macro-time
+can be understood in terms of the following implementation. Note that
+this implementation always produces a
+.code quote
+expression, which
+.code macro-time
+is not required to do if
+.meta val
+is self-evaluating:
+
+.verb
+ (defmacro macro-time (. forms)
+ (let (val)
+ (each ((f forms))
+ (set val (eval f)))
+ ^(quote ,val)))
+.brev
+
+Because
+.code eval
+treats a top-level
+.code progn
+specially, this implementation is also possible:
+
+.verb
+ (defmacro macro-time (. forms)
+ ^(quote ,(eval ^(progn ,*forms))))
+.brev
+
+.TP* Examples:
+
+.verb
+ ;; The (1 2 3) object is produced at macro-expansion time, becoming
+ ;; a quoted literal which evaluates to (1 2 3).
+ (macro-time (list 1 2 3)) -> (1 2 3)
+
+ ;; The above fact is revealed by macroexpand: the list form was
+ ;; evaluated, and then quote was inserted to produce (quote (1 2 3))
+ ;; which is notated '(1 2 3):
+ (macroexpand '(macro-time (list 1 2 3))) -> '(1 2 3)
+
+ ;; Quote isn't required on a self-evaluating object; it serves
+ ;; as a literal expression denoting itself:
+ (macroexpand '(macro-time (join-with "-" "a" "b"))) -> "a-b"
+.brev
+
.coNP Macro @ equot
.synb
.mets (equot << form )
@@ -35101,14 +42537,16 @@ but that expansion is reduced to 4.
The
.code equot
-operator is a mongrel of these two semantics: it permits expansion to proceed,
-but then suppresses evaluation of the result.
+operator is a an intermediate point between these two semantics: it permits
+expansion to proceed, but then suppresses evaluation of the result.
-.coNP Operators @ tree-bind and @ mac-param-bind
+.coNP Operators @, tree-bind @ mac-param-bind and @ mac-env-param-bind
.synb
.mets (tree-bind < macro-style-params < expr << form *)
.mets (mac-param-bind < context-expr
.mets \ \ < macro-style-params < expr << form *)
+.mets (mac-env-param-bind < context-expr < env-expr
+.mets \ \ < macro-style-params < expr << form *)
.syne
.desc
The
@@ -35119,20 +42557,22 @@ and then uses the
resulting value as a counterpart to a macro-style parameter list.
If the value has a tree structure which matches the parameters,
then those parameters are established as bindings, and the
-.metn form -s,
+.metn form s,
if any, are evaluated in the scope of those bindings. The value
of the last
.meta form
is returned. If there are no forms,
.code nil
is returned.
-
-Note: this operator throws an exception if there is a
-structural mismatch between the parameters and the value of
-.codn expr .
-
-One way to avoid this exception is to use
-.codn tree-case .
+Under
+.codn tree-bind ,
+the value of the
+.code :form
+available to
+.meta macro-style-params
+is the
+.code tree-bind
+form itself.
The
.code mac-param-bind
@@ -35149,6 +42589,54 @@ operator's error diagnostic refers to the
.code tree-bind
form, which is cryptic if the binding is used for the implementation
of some other construct, hidden from the user of that construct.
+In addition,
+.meta context-expr
+specifies the value for the
+.code :form
+parameter that
+.meta macro-style-params
+may refer to.
+
+The
+.code mac-env-param-bind
+is an extension of
+.code mac-param-bind
+which takes one more argument,
+.codn env-expr ,
+before the macro parameters. This expression is evaluated,
+and becomes the value of the
+.code :env
+parameter that
+.meta macro-style-params
+may refer to.
+
+Under
+.code tree-bind
+and
+.codn mac-param-bind ,
+the
+.code :env
+parameter takes on the value
+.codn nil .
+
+Under all three operators, the
+.code :whole
+parameter takes on the value of
+.metn expr .
+
+These operators throw an exception if there is a
+structural mismatch between the parameters and the value of
+.codn expr .
+One way to avoid this exception is to use
+.codn tree-case ,
+which is based on the conventions of
+.codn tree-bind .
+There exists no
+.code tree-case
+analog for
+.code mac-param-bind
+or
+.codn mac-env-param-bind .
.coNP Operator @ tree-case
.synb
@@ -35169,7 +42657,7 @@ If the object produced by
matches
.metn macro-style-params ,
then the parameters are bound, becoming local variables, and the
-.metn form -s,
+.metn form s,
if any, are evaluated in order in the environment in which those variables are
visible. If there are forms, the value of the last
.meta form
@@ -35246,7 +42734,7 @@ as if by
If the match is successful, then the parameters are bound to the
corresponding elements from the argument structure and each successive
.meta form
-is evaluated an environment in which those bindings are visible.
+is evaluated in an environment in which those bindings are visible.
The value of the last
.meta form
is the return value of the function. If there are no forms,
@@ -35300,7 +42788,7 @@ should be understood to be a globally unique symbol:
The
.code with-gensyms
evaluates the
-.metn body-form -s
+.metn body-form s
in an environment in which each variable name symbol
.meta sym
is bound to a new uninterned symbol ("gensym").
@@ -35344,8 +42832,14 @@ have a binding in the parameter macro namespace: a global namespace
which associates keyword symbols with parameter list expander
functions.
+Parameter list macros are recognized in both function parameter
+lists and macro parameter lists. A macro parameter list can,
+via nesting, contain multiple nested parameter lists. Each
+such nested list may contain parameter macro invocations; those
+are all traversed and processed.
+
Expansion of a parameter list macro occurs at macro-expansion
-time, when a function's parameter list is traversed by the
+time, when a function's or macro's parameter list is traversed by the
macro expander. It takes place as follows.
First, the keyword is removed from the parameter list.
The keyword's binding in the parameter macro namespace is
@@ -35365,15 +42859,21 @@ final parameter list and its accompanying body are then
taken in place of the original parameter list and
body.
-\*(TL provides a built-in parameter list macro bound to the symbol
+\*(TL provides a two built-in parameter list macros.
+The
.code :key
-which endows a function keyword parameters. The implementation is
-written entirely using this parameter list macro mechanism, by means
-of the
+parameter macro endows a function keyword parameters.
+The
+.code :match
+parameter macro allows a function to be expressed using pattern matching,
+which requires the body to consist of pattern-matching clauses.
+
+The implementation of both of these macros is written entirely using this
+parameter list macro mechanism, by means of the public
.code define-param-expander
macro.
-.coNP Special variable @ *param-macro*
+.coNP Special Variable @ *param-macro*
.desc
The variable
.code *param-macro*
@@ -35430,6 +42930,16 @@ or
.code lambda
form. This is intended for error reporting.
+A parameter transformer returns the transformed parameter list and body as a
+single object: a list whose first element is the parameter list,
+and whose remaining elements are the forms of the body. Thus, the following
+is a correct null transformer:
+
+.verb
+ (lambda (params body env form)
+ (cons params body))
+.brev
+
.coNP Macro @ define-param-expander
.synb
.mets (define-param-expander < name >> ( pvar < bvar : < evar << fvar )
@@ -35477,6 +42987,10 @@ The
form returns
.metn name .
+The parameter macro returns the transformed parameter list and body as a
+single object: a list whose first element is the parameter list,
+and whose remaining elements are the forms of the body.
+
.TP* Example:
The following example shows the implementation
@@ -35522,7 +43036,7 @@ All that is required is the insertion of the
.code :memo
keyword.
-.coNP Parameter list macro @ :key
+.coNP Parameter List Macro @ :key
.synb
.mets (:key << non-key-param *
.mets \ \ [ -- >> { sym | >> ( sym >> [ init-form <> [ p-sym ]])}* ]
@@ -35624,8 +43138,7 @@ Arguments specifying unrecognized keywords are ignored.
If the function has a
.metn rest-param ,
then that parameter receives the keyword arguments as a list.
-Since that list contains indicators and values, it is a
-.I "de facto"
+Since that list contains indicators and values, it is a de facto
property list. In detail, the
.code :key
mechanism generates a regular variadic function which receives the keyword
@@ -35683,6 +43196,72 @@ Boolean indicator params:
(keyfun) -> (10 nil 20 nil)
.brev
+.coNP Function @ macroexpand-params
+.synb
+.mets (expand-params < proto-form <> [ env ])
+.syne
+.desc
+The
+.code expand-param
+function expands all of the parameter list macros expressed in the
+.I "prototype form"
+.metn proto-form ,
+returning an expanded version of the form.
+
+The
+.meta proto-form
+is a compound form which has a shape very similar to a lambda
+expression, and may be a lambda expression.
+
+The first element of
+.meta proto-form
+is a name, which is an arbitrary object, though the use of a symbol
+is strongly recommended. This object plays no role in
+.code expand-params
+other than for composing diagnostic messages if errors occur.
+
+The second element of
+.meta proto-form
+is the parameter list.
+
+The remaining elements of
+.meta proto-form
+are zero or more body forms.
+
+If
+.meta proto-form
+contains no parameter macro invocations, then it is returned.
+
+The optional
+.meta env
+parameter specifies the macro environment which is passed to the
+parameter macro expanders, which they can receive via the
+.code :env
+parameter. The default value
+.code nil
+specifies the top-level environment.
+
+.TP* Examples:
+
+.verb
+ ;; No expansion: argument is returned
+ (macroexpand-params '(foo (arg) body)) -> (foo (arg) body)
+
+ ;; Expand :key macro
+ (macroexpand-params '(bar (:key a b c -- d (e 1234 f-p)) body))
+ --> (bar (a b c . #:g0014)
+ (let (d e f-p)
+ (let ((#:g0015 (memp :d #:g0014)))
+ (when #:g0015
+ (set d (cadr #:g0015))))
+ (let ((#:g0015 (memp :e #:g0014)))
+ (cond
+ (#:g0015 (set e (cadr #:g0015))
+ (set f-p t))
+ (t (set e 1234))))
+ body))
+.brev
+
.SS* Mutation of Syntactic Places
.coNP Macro @ set
.synb
@@ -35713,7 +43292,7 @@ the value is also returned as the result value.
If there are more than two arguments, then
.code set
-performs multiple assignments in left to right order.
+performs multiple assignments in left-to-right order.
Effectively,
.code "(set v1 e1 v2 e2 ... vn en)"
is precisely equivalent to
@@ -35871,7 +43450,9 @@ using the comparison function given by the function name
.metn cmp-fun .
This comparison takes places as if by evaluating the expression
+.mono
.meti >> ( cmp-fun < value << cmp-val )
+.onom
where
.meta value
denotes the current value of
@@ -35893,6 +43474,41 @@ expression, stores the resulting value into
and returns
.codn t .
+.coNP Macro @ ensure
+.synb
+.mets (ensure < place << init-expr )
+.syne
+.desc
+The
+.code ensure
+macro examines the value of
+.metn place .
+
+If the current value is
+.codn nil ,
+then
+.meta init-expr
+is evaluated. The value is stored in
+.meta place
+and becomes the result of the
+.code ensure
+form.
+
+If the value of
+.meta place
+is other than
+.codn nil ,
+then the form yields that value.
+In this case,
+.meta init-expr
+isn't evaluated, and
+.meta place
+isn't modified.
+
+The
+.meta place
+expression is evaluated only once to determine the place.
+
.coNP Macros @ inc and @ dec
.synb
.mets (inc < place <> [ delta ])
@@ -36192,7 +43808,7 @@ the value of the first (leftmost) place. The leftmost place
receives the value of the second place, and so on.
If there are two arguments, this equivalent to
.codn swap .
-The prior value of the first place, which is the the value
+The prior value of the first place, which is the value
rotated into the last place, is returned.
More precisely, the
@@ -36262,6 +43878,59 @@ place denotes a value stored in a dynamic data set such as a hash table,
then deletion of that place implies deletion of the entry which holds
that value. If the entry is identified by a key, that key is also removed.
+If
+.code place
+is a DWIM bracket expression indexing into a structure, the structure
+is expected to implement the
+.code lambda
+and
+.code lambda-set
+methods. Moreover, the place form must have only two arguments:
+the object and an index argument. In other words, the
+.code del
+form must have this syntax:
+
+.mono
+.mets (del >> [ obj << index ])
+.onom
+
+The
+.code lambda
+method will be invoked with the unmodified
+.meta obj
+and
+.meta index
+arguments to determine the prior value to be returned.
+Then the
+.code lambda-set
+method will be invoked with three arguments:
+.metn obj ,
+a possibly modified
+.meta index
+value and the argument
+.code nil
+representing an empty replacement sequence.
+
+If
+.meta index
+is a sequence or range, it is passed to the
+.code lambda-set
+method unmodified. Otherwise it is expected to be an integer, and
+converted into a one-element range spanning the indicated element.
+For instance, if the
+.meta index
+value is
+.codn 3 ,
+it is converted to the range
+.codn "#R(3 4)" .
+In effect, the
+.code lambda-set
+method is thereby asked to replace the one-element subsequence starting at
+index
+.code 3
+with the empty sequence
+.codn nil .
+
.coNP Macro @ lset
.synb
.mets (lset <> { place }+ << sequence-expr )
@@ -36441,7 +44110,7 @@ occurs. The first abstract action is to evaluate
exactly one time, in order to determine the actual run-time location to which
that form refers.
The second abstract action is to evaluate the caller's
-.metn body-form -s,
+.metn body-form s,
in a lexical environment in which bindings exist for some lexical
functions or (more usually) lexical macros. These lexical macros
are explicitly referenced by the
@@ -36938,7 +44607,7 @@ style, as in:
(assign 42 a) ;; store 42 in variable a
.brev
-Now, the new value must be evaluated prior to the place, if left to right
+Now, the new value must be evaluated prior to the place, if left-to-right
evaluation order is to be maintained. The standard
.code push
macro has this property: the push value is on the left, and the place
@@ -37240,7 +44909,7 @@ the place to be updated, and its value, respectively.
The
.meta parameter-list
-specifies the additional parameters for update function, which will also
+specifies the additional parameters for the update function, which will also
become additional parameters of the macro. Because it is a
function parameter list, it cannot use the special destructuring features of
macro parameter lists, or the
@@ -37313,9 +44982,9 @@ again.
.coNP Macro @ defplace
.synb
.mets (defplace < place-destructuring-args < body-sym
-.mets \ \ \ \ \ \ \ \ \ >> ( getter-sym < setter-sym << update-body )
-.mets \ \ \ \ \ \ \ \ \ >> [( ssetter-sym << clobber-body )
-.mets \ \ \ \ \ \ \ \ \ \ >> [( deleter-sym << delete-body )]])
+.mets \ \ >> ( getter-sym < setter-sym << update-body )
+.mets \ \ >> [( ssetter-sym << clobber-body )
+.mets \ \ \ >> [( deleter-sym << delete-body )]])
.syne
.desc
The
@@ -37331,7 +45000,7 @@ call contains only code fragments for the expander functions.
The name and syntax of the place is determined by the
.meta place-destructuring-args
argument, which is macro-style parameter list whose structure
-mimics that of the the place. In particular, its leftmost symbol
+mimics that of the place. In particular, its leftmost symbol
gives the name under which the place is registered.
The
.code defplace
@@ -37345,7 +45014,7 @@ parameter must be be a symbol. This symbol will capture the
.meta body-forms
parameter which is passed to the update expander, clobber
expander or delete expander. The code fragments then have
-access to the the body forms via this name.
+access to the body forms via this name.
The
.metn getter-sym ,
@@ -37454,9 +45123,9 @@ and
.metn params .
The
.code defset
-form expresses the request that call to the function or operator named
+form expresses the request that a call to the function or operator named
.meta name
-is to be treated as a syntactic place, which has arguments described by
+be treated as a syntactic place, which has arguments described by
the parameter list
.metn params .
@@ -37805,6 +45474,75 @@ in terms of
^(car ,obj))
.brev
+.coNP Functions @ macroexpand-place and @ macroexpand-1-place
+.synb
+.mets (macroexpand-1-place < form <> [ env ])
+.mets (macroexpand-place < form <> [ env ])
+.syne
+.desc
+If
+.meta form
+is a place macro form (a form whose operator symbol has been defined
+as a place macro using
+.codn define-place-macro )
+these functions expand the place macro form and return the expanded form.
+Otherwise, they return
+.metn form .
+
+.code macroexpand-1-place
+performs a single expansion, expanding only the place the macro
+that is referenced by the symbol in the first position of
+.metn form ,
+and returns the expansion. Note that if
+.meta form
+is an ordinary macro form, this function will not expand it,
+even if such an expansion would reveal a place macro form.
+
+.code macroexpand-place
+performs a full place expansion of
+.meta form
+by the following process.
+If
+.meta form
+is a place macro call, it is expanded, and the result is
+checked again to see whether it is a place macro, and
+expanded. This is repeated as many times as necessary
+until the result is no longer a place macro call.
+Then, if the resulting form is an ordinary macro invocation,
+it is expanded once as if by
+.codn macroexpand-1 .
+This process is iterated until a fixed point is reached.
+
+The optional
+.meta env
+parameter is a macro environment. Note: the
+.code macroexpand-1-place
+function ignores the
+.meta env
+parameter, which could change in the future.
+
+.TP* Examples
+
+Given this ordinary macro definition
+
+.verb
+ (defmacro leftmost (x) ^(first ,x))
+.brev
+
+the following results are obtained:
+
+.verb
+ ;; ordinary macro leftmost expands to first,
+ ;; then first place macro expands to car:
+ (macroexpand-place '(leftmost x)) -> (car x)
+
+ ;; macroexpand-1-place won't expand ordinary macro:
+ (macroexpand-1-place '(leftmost x)) -> (leftmost x)
+
+ ;; macroexpand-1-place expands place macro
+ (macroexpand-1-place '(first x)) -> (car x)
+.brev
+
.coNP Macro @ rlet
.synb
.mets (rlet >> ({( sym << init-form )}*) << body-form *)
@@ -37815,9 +45553,9 @@ The macro
is similar to the
.code let
operator. It establishes bindings for one or more
-.metn sym -s,
+.metn sym s,
which are initialized using the values of
-.metn init-form -s.
+.metn init-form s.
Note that the simplified syntax for a variable which initializes to
.code nil
@@ -37826,7 +45564,9 @@ by default is not supported by
that is to say, the syntax
.meta sym
cannot be used in place of the
+.mono
.meti >> ( sym << init-form )
+.onom
syntax when
.meta sym
is to be initialized to
@@ -37839,9 +45579,9 @@ macro differs from
in that
.code rlet
assumes that those
-.metn sym -s
+.metn sym s
whose
-.metn init-form -s,
+.metn init-form s,
after macro expansion,
are constant expressions
(according to the
@@ -37901,7 +45641,7 @@ into
.desc
The macro
.code slet
-a weaker form of the
+is a stronger form of the
.code rlet
macro. Just like
.codn rlet ,
@@ -37910,8 +45650,30 @@ reduces bindings initialized by constant expressions
to symbol macros. In addition, unlike
.codn rlet ,
.code slet
-also reduces to symbol macros those bindings which
-are initialized by symbol expressions (values of variables).
+also reduces to symbol macros those bindings whose initializing
+expressions are simple references to lexical variables.
+
+.TP* Examples:
+
+.verb
+ ;; reduces to let
+ (slet ((a (list x y)))
+ a)
+
+ ;; b is a free variable, so this is also let
+ (slet ((a b))
+ a)
+
+ ;; b is lexical, so a becomes a symbol macro
+ ;; the (slet ...) form becomes b.
+ (let (b)
+ (slet ((a b))
+ a))
+
+ ;; a becomes symbol macro; form transforms to 1.
+ (slet ((a 1))
+ a)
+.brev
.coNP Macro @ alet
.synb
@@ -37924,7 +45686,7 @@ The macro
.code slet
macro. All bindings initialized by constant expressions are
turned to symbol macros. Then, if all of the remaining bindings are
-all initialized by symbol expressions, they are also turned to
+all initialized by lexical variables, they are also turned to
symbol macros. Otherwise, none of the remaining bindings
are turned to symbol macros.
@@ -37936,7 +45698,7 @@ others' evaluations. In this situation
.code alet
still propagates constants via symbol macros, and can eliminate the
remaining temporaries if they can all be made symbol macros for
-existing variables: i.e. there doesn't exist any initialization form
+existing lexicals: i.e. there doesn't exist any initialization form
with interfering side effects.
.coNP Macro @ define-accessor
@@ -38016,7 +45778,156 @@ Note:
is similar to the short form of
.codn defset .
-.coNP Special variables @, *place-update-expander* @ *place-clobber-expander* and @ *place-delete-expander*
+.coNP Accessor @ read-once
+.synb
+.mets (read-once << expression )
+.mets (set (read-once << place ) << new-value )
+.syne
+.desc
+When the
+.code read-once
+accessor is invoked as a function, it behaves like
+.codn identity ,
+simply returning the value of
+.metn expression ,
+which is not required to be a syntactic place.
+
+If a
+.code read-once
+form is used as a syntactic place then its argument must also be a
+.metn place .
+The
+.code read-once
+syntactic place denotes the same place as the enclosed
+.code place
+form, but with somewhat altered semantics, which is most useful in conjunction
+with
+.codn placelet ,
+and in writing place-mutating macros which make multiple accesses to a place.
+
+Firstly, if the
+.code read-once
+place is evaluated, it accesses the existing value of
+.meta place
+exactly once, even if it occurs in a place-mutating form which
+normally doesn't use the prior value, such as the
+.code set
+macro.
+
+When
+.code read-once
+accesses
+.metn place ,
+it stores the value in a hidden variable.
+Then, within the same place-mutating form, multiple references to the same
+.code read-once
+form all access the value of this hidden variable.
+Whenever the
+.code read-once
+form is assigned, both the the hidden variable and the underlying
+.meta place
+receive the new value.
+
+Multiple references to the same
+.code read-once
+form can be produced using the
+.code placelet
+or
+.code placelet*
+macros, or by making multiple calls to the getter function obtained using
+.code with-update-expander
+in the implementation of a user-defined place-mutating operator,
+or user-defined place.
+
+.TP* Example:
+
+In both of the following two examples, there is no question that the
+.code array
+and
+.code i
+expressions are themselves evaluated only once; the issue is the access to the
+array itself; under the plain placelet, the array referencing takes place more
+times.
+
+.verb
+ ;; without read-once, array element [array i] is
+ ;; accessed twice to fetch its current value: once
+ ;; in the plusp expression, and then once again in
+ ;; the dec expression.
+
+ (placelet ((cell [array i]))
+ (if (plusp cell)
+ (dec cell)))
+
+ ;; with read-once, it is accessed once. plusp refers
+ ;; to a hidden lexical variable to obtain the prior
+ ;; value, and so does dec. dec stores the new value
+ ;; through to [array i] and the hidden variable.
+
+ (placelet ((cell (read-once [array i])))
+ (if (plusp cell)
+ (dec cell)))
+.brev
+
+The following is
+.B not
+an example of multiple references to the same
+.code read-once
+form:
+
+.verb
+ (defmacro inc-positive (place)
+ ^(if (plusp (read-once ,place))
+ (inc (read-once ,place))))
+.brev
+
+Here, even though the
+.code read-once
+forms may be structurally identical, they are separate instances.
+The first instance isn't even a syntactic place, but a call to the
+.code read-once
+function. Multiple references to the same place can only be
+generated using
+.code placelet
+or else by multiple explicit calls to the same getter function or macro
+generated for a place by an update expander.
+
+The following is a corrected version of
+.codn inc-positive :
+
+.verb
+ (defmacro inc-positive (place :env env)
+ (with-update-expander (getter setter) ^(read-once ,place) env
+ ^(if (plusp (,getter))
+ (,setter (succ (,getter))))))
+.brev
+
+To write the macro without
+.code read-once
+requires that it handles the job of providing a temporary variable
+for the value:
+
+.verb
+ (defmacro inc-positive (place :env e)
+ (with-update-expander (getter setter) place env
+ (with-gensym (value)
+ ^(slet ((,value (,getter)))
+ ^(if (plusp ,value)
+ (,setter (succ ,value)))))))
+.brev
+
+The
+.code read-once
+accessor wrapped around
+.meta place
+allows
+.code inc-positive
+to simply make multiple references to
+.code "(,getter)"
+which will cache the value; the macro doesn't have to introduce its own
+hidden caching variable.
+
+.coNP Special Variables @, *place-update-expander* @ *place-clobber-expander* and @ *place-delete-expander*
.desc
These variables hold hash tables, by means of which update expanders,
clobber expanders and delete expanders are registered, as associations
@@ -38033,7 +45944,7 @@ then forms beginning with
are not syntactic places. (The situation of a clobber accessor or delete
accessor being defined without an update expander is improper).
-.coNP Special variable @ *place-macro*
+.coNP Special Variable @ *place-macro*
.desc
The
.code *place-macro*
@@ -38051,6 +45962,3169 @@ then there is no such binding: compound forms beginning with
.code sym
do not undergo place macro expansion.
+.SS* Structural Pattern Matching
+
+.NP* Introduction
+
+\*(TL provides a structural pattern-matching system. Structural pattern
+matching is a syntax which allows for the succinct expression of code
+which classifies objects according to their shape and content, and which
+accesses the elements within objects, or both.
+
+The central concept in structural pattern matching is the resolution of a
+pattern against an object. The pattern is specified as syntax which is part of
+the program code. The object is a run-time value of unknown type, shape and
+other properties. The primary pattern-matching decision is Boolean: does the
+object match the pattern? If the object matches the pattern, then it is
+possible to execute an associated body of code in a scope in which variables
+occurring in the pattern take on values from the corresponding parts of the
+object.
+
+.NP* Pattern-Matching Operators
+
+Structural pattern matching is available via several different macro
+operators, which are:
+.codn when-match ,
+.codn if-match ,
+.codn match ,
+.codn match-case ,
+.codn match-cond ,
+.codn match-ecase ,
+.code lambda-match
+and
+.codn defun-match .
+Function and macro argument lists may also be augmented with pattern
+matching using the
+.code :match
+parameter macro.
+
+The
+.code when-match
+macro is the simplest. It tests an object against a pattern, and if there is a
+match, evaluates zero or more forms in an environment in which the pattern
+variables have bindings to the corresponding elements of the object.
+
+The
+.code if-match
+macro evaluates a single form if there is a match, in the scope of the
+bindings established by the pattern, otherwise an alternative
+form evaluated in a scope in which those bindings are absent.
+
+The
+.code match
+macro tests and object against a pattern, expecting a match. If the match
+fails, an exception is thrown. Otherwise, it evaluates zero or more forms
+in the scope of the bindings established by the pattern.
+
+The
+.code match-case
+macro evaluates the same object against multiple clauses, each consisting of a
+pattern and zero or more forms. At most one matching clause is identified
+and evaluated.
+
+The
+.code match-ecase
+macro is similar to
+.code match-case
+except that if no matching case is identified, an exception is thrown.
+
+The
+.code match-cond
+macro evaluates multiple clauses, each of which specifies a pattern and an
+object expression. If the object produced by the expression matches the
+pattern, the forms in the clause are evaluated in scope of the variables
+bound by the clause's pattern.
+
+The
+.code lambda-match
+macro provides a way to express an anonymous function whose argument list
+is matched against multiple clauses similarly to
+.code match-case
+and
+.code defun-match
+provides a way to define a top-level function using the same concept.
+
+Additionally, there exist
+.code each-match
+and
+.code while-match
+macro families.
+
+.NP* Syntax and Key Concepts
+
+\*(TL's structural pattern-matching notation is template-based.
+With the exception of structures and hash tables, objects are matched using
+patterns which are based on their printed notation. For instance, the pattern
+.code "(1 2 @a)"
+is a pattern matching the list
+.code "(1 2 3)"
+binding
+.code a
+to
+.codn 3 .
+The notation supports lists, vectors, ranges and atoms. Atoms are compared
+using the
+.code equal
+function. Thus, in the above pattern, the 1 and 2 in the pattern match the
+corresponding 1 and 2 atoms in the object using
+.codn equal .
+
+All parts of a pattern are static material which matches literally,
+except those parts introduced by the meta prefix
+.codn @ .
+This prefix denotes variables like
+.code @a
+as well as useful pattern-matching operators like
+.mono
+.meti @(all << pattern )
+.onom
+which matches a list or sublist whose elements all match
+.metn pattern .
+
+The quasiquote syntax is specially supported for expressing matching,
+in an alternative style. For instance the quasiquote
+.code "^(1 2 ,a)"
+is a pattern equivalent to the
+.codn "(1 2 @a)" .
+
+Structure objects are matched using a dedicated
+.code "@(struct name ...)"
+operator, or else in the quasiquote style using
+.code "^#S(name ...)"
+syntax. The non-quasiquoted literal syntax
+.code "#S(name ...)"
+cannot be used for matching.
+
+Similarly, hash objects are matched using a
+.code "@(hash ...)"
+operator, or else
+.code "^#H(...)"
+syntax in the quasiquote style.
+.code "#H(...)"
+cannot be used.
+
+Note: the non-quasiquoted
+.code #S
+and
+.code #H
+literals are not and cannot be used for matching because they produce structure
+and hash objects which lose important information about how they were specified
+in the syntax, and carry restrictions which are unacceptable for pattern
+matching. The order of sub-patterns is important in pattern syntax, but struct
+and hash objects do not preserve the order in which their elements were
+specified. A struct literal is required to specify the name of an existing
+struct type, and slot names which are valid for that type, otherwise it is
+erroneous. This is not acceptable for pattern matching, because patterns may
+appear in place of those elements. The pattern match for a hash may specify the
+same key pattern more than once, which means that the key pattern cannot be an
+actual key in an actual hash, which requires every key to be unique. Structure
+and hash quasiquotes do not have these issues; they are not actually literal
+structure and hash objects, but list-based syntax.
+
+.NP* Variables in Patterns
+
+Patterns use meta-symbols for denoting variables. Variables must
+be either bindable symbols, or else
+.codn nil ,
+which has a special meaning: the pattern variable
+.code @nil
+matches any object, and binds no variable.
+
+Pattern variables are ordinary Lisp variables. Whereas in ordinary non-pattern
+matching Lisp code, it is always unambiguous whether a variable is being bound
+or referenced, this is deliberately not the case in patterns. A variable
+occurring in a pattern may be a fresh variable, or a reference to an existing
+one. The difference between these situations is not apparent from the syntax
+of the pattern; it depends on the context established by the scope.
+
+With one exception, if a pattern contains a variable which is already bound in
+the surrounding scope, then it refers to that binding. Otherwise, it freshly
+binds the variable. The exception is that pattern operator
+.code @(as)
+always binds a fresh variable. A variable being already bound includes
+as a lexical or global symbol macro
+.cod2 ( symacrolet
+or
+.codn defsymacro ).
+
+When a pattern variable refers to an existing variable, then each occurrence
+of that variable must match an object which is
+.code equal
+to the value of that variable.
+For instance, the following function returns the third element of a list, if
+the first two elements are repetitions of the
+.code x
+argument, otherwise
+.codn nil :
+
+.verb
+ (defun x-x-y (list x)
+ (when-match (@x @x @y) list y))
+
+ (x-x-y '(1 1 2) 1) -> 2
+ (x-x-y '(1 2 3) 1) -> nil ;; no @x @x match
+ (x-x-y '(1 1 2 r2) 1) -> nil ;; list too long
+.brev
+
+If the variable does not exist in the scope surrounding the pattern,
+then the leftmost occurrence of the variable establishes a binding,
+taking the value from is corresponding object being matched by that
+occurrence of the variable. The remaining
+occurrences of the variable, if any, must correspond to objects which are
+.code equal
+to that value, or else there is no match.
+For instance, the pattern
+.code "(@a @a)"
+matches the list like
+.code "(1 1)"
+as follows. First
+.code @a
+binds to the leftmost
+.code 1
+and then the second
+.code 1
+matches the existing value of that
+.codn a .
+An input such as
+.code "(1 2)"
+fails to match because the second occurrence of
+.code @a
+retrieves an object that is not
+.code equal
+to that variable's existing value.
+
+A pattern can contain multiple occurrences of the same symbol as a variable.
+These may or may not refer to the same variable. Two occurrences of the same
+symbol refer to distinct variables if:
+
+.RS
+.IP 1.
+they are freshly bound in separate
+branches of the
+.code @(or)
+operator; or
+.IP 2.
+one of the two variables is freshly bound by the
+.code @(as)
+operator and the other variable occurs outside of that
+.codn @(as) ;
+or
+.IP 3.
+or both of the variables are freshly bound using
+.codn @(as) .
+.RE
+
+Any other two or more occurrences same symbol occurring in the same pattern
+refer to the same variable.
+
+.NP* Comparison to Macro Parameter Lists
+
+\*(TL's macro-style parameter lists, appearing in
+.code tree-bind
+and related macros, also provide a form of structural pattern matching.
+Macro-style parameter list pattern matching is limited to objects of
+one kind: tree structures made of
+.code cons
+cells. It is only useful for matching on
+shape, not content. For example,
+.code tree-bind
+cannot express the idea of matching a list whose first element is the symbol
+.code a
+and whose third element is
+.codn 42 .
+Moreover, every position in the tree pattern much specify a variable
+which captures the corresponding element of the structure. For instance,
+a pattern which matches a three-element list must specify three variables,
+one for each list position. This is because macro-style parameter lists are
+oriented toward writing macros, and macros usually make use of every parameter
+position.
+
+.NP* User-Defined Patterns
+
+User-defined pattern operators are possible. When the
+.meta operator
+symbol in the
+.mono
+.meti >> @( operator << argument *)
+.onom
+syntax doesn't match any built-in operator, a search takes
+place to determine whether
+.meta operator
+is a pattern macro. If so, the pattern macro is expanded, and
+its result of the expansion treated as a pattern to process recursively,
+unless it is the original macro form, in which case it is treated
+as a predicate pattern. User-defined pattern macros are defined
+using the
+.code defmatch
+macro.
+
+.SS* Pattern-Matching Notation
+
+The pattern-matching notation is documented in the following
+sections; a section describing the pattern-matching macros follows.
+
+.NP* Atom match
+A pattern consisting of an atom other than a vector
+matches a similar object. The similarity is determined using the
+.code equal
+function.
+
+The atom is not subject to evaluation, which means that a symbolic atom stands
+for itself, and not the value of a variable.
+
+.TP* Examples:
+.verb
+ ;; the pattern 1 matches the object 1
+ (if-match 1 1 'yes 'no) --> yes
+
+ ;; the object 0 does not match
+ (if-match 1 0 'yes 'no) --> no
+
+ ;; a matches a, does not match b
+ (let ((sym 'a))
+ (list (if-match a sym 'yes 'no)
+ (if-match b sym 'yes 'no)))
+ --> (yes no)
+.brev
+
+.NP* Variable match
+.synb
+.mets >> @ symbol
+.syne
+.desc
+A meta-symbol can be used as a pattern expression.
+This pattern unconditionally matches an object of any kind.
+
+The
+.meta symbol
+is required to be a either a bindable symbol according to the
+.code bindable
+function, or else the symbol
+.codn nil .
+
+If
+.meta symbol
+is a bindable symbol, which has not binding in scope,
+then a variable by that name is freshly bound, and takes
+on the corresponding object as its value.
+
+If
+.meta symbol
+is a bindable symbol with an existing binding, then
+the corresponding object must be
+.code equal
+to that variable's existing value, or else the match fails.
+
+If
+.meta symbol
+is
+.codn nil ,
+then the match succeeds unconditionally, without binding a variable.
+
+.TP* Examples:
+
+.verb
+ (when-match @a 42 (list a)) -> (42)
+
+ (when-match (@a @b @c) '(1 2 3) (list c b a)) -> (3 2 1)
+
+ ;; No match: list is longer than pattern
+ (when-match (@a @b) '(1 2 3) (list a b)) -> nil
+
+ ;; Use of nil in dot position to match longer list
+ (when-match (@a @b . @nil) '(1 2 3) (list a b)) -> (1 2)
+.brev
+
+.NP* List match
+.synb
+.mets <> ( pattern +)
+.mets <> ( pattern + . << pattern )
+.syne
+.desc
+Pattern syntax consisting of a nonempty, possibly improper list
+matches list structure. A pattern expression may be specified in the
+dotted position. If it is omitted, then there is an implicit terminating
+.code nil
+which constitutes an atom expression matching
+.codn nil .
+
+A list pattern matches a list of the same shape. For each
+.meta pattern
+expressions, there must exist an item in the list.
+
+A match occurs when every
+.meta pattern
+matches the corresponding element of the list, including the
+.meta pattern
+in the dotted position.
+
+Because the dotted position
+.meta pattern
+matches a list, it is possible for a short pattern
+to match a longer list.
+
+The syntax is indicated as requiring at least one
+.meta pattern
+because otherwise the list is empty, which corresponds to the
+atom pattern
+.codn nil .
+
+The syntax
+.mono
+.meti (. << pattern )
+.onom
+is valid, but indistinguishable from
+.meta pattern
+and therefore is not a list pattern.
+
+.TP* Examples:
+
+.verb
+ (if-match (@a @b @c . @d) '(1 2 3 . 4) (list d c b a))
+ --> (4 3 2 1)
+
+ ;; 2 doesn't satisfy oddp
+ (if-match (@(oddp @a) @b @c . @d) '(2 x y z)
+ (list a b c d)
+ :no-match)
+ --> :no-match
+
+ ;; 1 and 2 match, a takes (3 4)
+ (if-match (1 2 . @a) '(1 2 3 4) a) --> (3 4)
+
+ ;; nesting
+ (if-match ((1 2 @a) @b) '((1 2 3) 4) (list a b)) -> (3 4)
+.brev
+
+.NP* Vector match
+.synb
+.mets <> #( pattern *)
+.syne
+.desc
+A pattern match for a vector is expressed using vector notation enclosing
+pattern expressions. This pattern matches a vector object which contains
+exactly as many elements as there are patterns. Each pattern is applied
+against the corresponding vector element.
+
+.TP* Examples:
+
+.verb
+ ;; empty vector pattern matches empty vector
+ (if-match #() #() :yes :no) -> :yes
+
+ ;; empty vector pattern fails to match nonempty vector
+ (if-match #() #(1) :yes :no) -> :no
+
+ ;; match with nested list and vector
+ (if-match #((1 @a) #(3 @b)) #((1 2) #(3 4)) (list a b))
+ --> (2 4)
+.brev
+
+.NP* Range match
+.synb
+.mets >> #R( from-pattern << to-pattern )
+.syne
+.desc
+A pattern match for a range can be expressed by embedding pattern
+expressions in the
+.code #R
+notation. The resulting pattern requires the corresponding object
+to be a range, otherwise the match fails. If the corresponding
+object is a range, then the
+.meta from-pattern
+is matched against its
+.code from
+and the
+.meta to-pattern
+is matched against its
+.code to
+part.
+
+Note that if the range expression notation
+.code a..b
+is used as a pattern, that is actually a list pattern, due to
+that being a syntactic sugar for
+.codn "(rcons a b)" .
+
+.TP* Examples:
+
+.verb
+ (if-match #R(10 20) 10..20 :yes :no) -> :yes
+ (if-match #R(10 20) #R(10 20) :yes :no) -> :yes
+ (if-match #R(10 20) #R(1 2) :yes :no) -> :no
+
+ (when-match #R(@a @b) 1..2 (list a b)) -> (1 2)
+
+ ;; not a range match! rcons syntax match
+ (when-match @a..@b '1..2 (list a b)) -> (1 2)
+
+ ;; above, de-sugared:
+ (when-match (rcons @a @b) '(rcons 1 2) (list a b)) -> (1 2)
+
+.brev
+
+.NP* Quasiliteral match
+.synb
+.mets <> "`...@" var "...`"
+.mets <> "@`...@" var "...`"
+.syne
+.desc
+The quasiliteral syntax is supported as a pattern-matching operator.
+The corresponding object is required to be a character string, which
+is analyzed according to the structure of the quasiliteral pattern,
+and portions of the string are captured by variables. If the corresponding
+object isn't a string according to
+.code stringp
+then the match fails. The quasiliteral pattern must match the entire
+input string.
+
+In order that the quasiliteral's syntactic structure is not misinterpreted
+as a predicate pattern, and in order to make certain situations work
+in quasiquoted pattern matching, a quasiliteral pattern may be specified
+as either
+.code "`...`"
+or
+.codn "@`...`" .
+The latter form, which is structurally
+.code "(sys:expr (sys:quasi ...))"
+is specially recognized and treated as equivalent to the unadorned
+quasiliteral pattern.
+
+A quasiliteral pattern matches in a linear fashion, from left to right.
+Variables bound earlier in the pattern can be referenced later in the pattern
+as bound variables.
+
+With one exception, bound variables denote character strings in accordance with the usual
+quasiliteral conversion and formatting rules. All of the modifier notations may
+be used. For instance, if
+.code x
+is a bound variable, then
+.code "@{x -40}"
+denotes the value of
+.code x
+converted to a string, and right-aligned in a forty-character-wide field.
+Consequently, the notation matches exactly such a forty-character text.
+The exception is that if a bound variable has a regular expression modifier,
+as in
+.code "@{x #/re/}"
+then it has a special meaning as a pattern. Moreover, this syntax has no
+meaning in a quasiliteral.
+
+In the following description of the quasiliteral pattern-matching rules, the
+symbols
+.metn uv ,
+.meta uv0
+and
+.meta uv1
+represent to unbound variables: variables which have no apparent
+lexical binding and are not defined as global variables. Unless indicated
+otherwise,
+.mono
+.meti >> @ uv
+.onom
+refers to a plain variable syntax such as
+.code @abc
+or else to braced syntax without modifiers, such as
+.codn @{abc} .
+The same remarks apply to
+.meta uv0
+and
+.metn uv1 .
+The symbol
+.meta bv
+represents a bound variable: a variable which has an existing binding,
+which can occur in the form of the ordinary notation, or the braced notation
+with or without modifiers.
+The notation
+.codn {P} ,
+.codn {P0} ,
+.codn {P1} ...
+denotes a substring of the pattern, possibly empty.
+
+.RS
+.coIP ``
+The empty quasiliteral pattern matches an empty string.
+.coIP `text{P}`
+A quasiliteral pattern which begins with a portion of text matches a string
+which begins with the same text. The remaining portion
+.code {P}
+of the pattern is then matched against a suffix of the input string which
+excludes the matched text.
+.meIP <> `@ uv `
+A simple unbound variable occurring as the last element of the pattern
+matches and binds the entire rest of the input string.
+.meIP <> `@ uv text{P}`
+A simple unbound variable followed by a text element matches the input string if
+.str text
+occurs in that string as a substring. In that case,
+.meta uv
+is bound to the possibly empty prefix of the input string consisting of the
+characters before the leftmost match for
+.strn text .
+The rest of the pattern
+.code {P}
+is then matched against that suffix of the input string which begins after the
+last character of the leftmost match for
+.strn text .
+.meIP <2> `@ uv @ bv {P}`
+The bound variable
+.meta bv
+is converted to text in the manner of an ordinary quasiliteral substitution.
+The situation then reduces to the
+.mono
+.meti <> `@ uv text{P}`
+.onom
+pattern, where
+.code text
+denotes the character string produced by substitution of
+.metn bv .
+.meIP >> `@{ uv << integer }{P}`
+An unbound variable
+.meta uv
+which uses the brace notation to specify a literal
+.meta integer
+modifier denotes
+a match for that many characters. It is an error if the value is zero or
+negative. The match succeeds if the input string has at least that
+many characters, in which case the variable
+.meta uv
+takes on those characters, and the rest of the pattern is matched against
+a suffix of the string with those characters removed.
+.meIP >> `@{ uv <> #/ regex /}{P}`
+An unbound variable
+.meta uv
+which carries a regular-expression modifier specifies a regular-expression
+match. If a prefix of the input string matches
+.metn regex ,
+then the match is successful and
+.meta uv
+captures that prefix. The rest of the pattern
+.code {P}
+is then matched against the rest of the string after the prefix.
+.meIP >> `@{ bv <> #/ regex /}{P}`
+A bound variable
+.meta bv
+which carries a regular expression modifier specifies a regular expression
+match exactly like an unbound variable. This syntax produces a successful
+match if two conditions are met: a prefix of the input string matches
+.metn regex ,
+and the matched prefix is
+.meta equal
+to the value of
+.metn bv .
+The rest of the pattern
+.code {P}
+is then matched against the rest of the string after the prefix.
+.meIP <> `@ bv {P}`
+The bound variable
+.meta bv
+is converted to text the manner of an ordinary quasiliteral substitution.
+The situation then reduces to the
+.code `text{P}`
+pattern, where
+.code text
+denotes the character string produced by substitution of
+.metn bv .
+.meIP <2> `@ uv0 @ uv1 {P0}`
+Two consecutive unbound variables, where
+.meta uv0
+is a plain variable with no modifiers, constitutes an invalid pattern.
+This situation is diagnosed as an error. If
+.meta uv0
+is braced, carrying an integer or regular-expression modifier
+.metn mod ,
+then the situation is treated as the pattern
+.mono
+.meti >> `@{ uv << mod }{P}`
+.onom
+where
+.code {P}
+refers to the
+.mono
+.meti <> @ uv1 {P0}
+.onom
+portion.
+.RE
+.IP
+No other quasiliteral syntax, or combination of variable modifiers, is
+supported in quasiliteral patterns.
+
+.TP* Examples:
+
+.verb
+ (when-match `@a-@b` "foo-bar" (list a b)) -> ("foo" "bar")
+
+ (when-match `@{a #/\ed+/}@b` "123xy" (list a b)) -> ("123" "xy")
+
+ (let ((a 42))
+ (when-match `[@{a -8}] @b` "[ 42] packets` b))
+ -> "packets"
+
+.brev
+
+.NP* Quasiquote matching notation
+.synb
+.mets >> ^ qq-syntax
+.syne
+.desc
+Quasiquoting provides an alternative pattern-matching syntax. It uses a subset
+of the quasiquoting notation. Only specific kinds of quasiquoted objects listed
+in this description are supported. Within a quasiquote used for
+pattern-matching, unquotes indicate operators and variables instead of the
+.code @
+prefix. Splicing unquote syntax plays no role; its presence produces
+unspecified behavior.
+
+The quasiquote matching notation is described, understood and implementing
+in terms of a translation to the standard pattern-matching syntax, according
+to the following rules. The
+.code [X]
+notation used here indicates that the element enclosed in brackets is
+subject to a recursive translation according to the rules:
+.RS
+.meIP >> , expr
+An unquoted expression occurring in the quasiquote is translated to the
+.mono
+.meti >> @ expr
+.onom
+pattern-matching syntax. If
+.meta expr
+is a symbol, then this is a meta-variable:
+.mono
+.meti (sys:var << expr )
+.onom
+otherwise it is translated to the
+.mono
+.meti (sys:expr << expr )
+.onom
+syntax.
+.coIP ",`...quasilit...`"
+An unquoted quasiliteral is treated uniformly as
+.mono
+.meti >> , expr
+.onom
+and is therefore translated into
+.codn "@`...quasilit...`" .
+Since that is equivalent to
+.codn "`...quasilit...`" ,
+quasiliteral matching is supported within quasiquote notation
+in a straightforward way.
+.meIP >> ~ expr
+In JSON syntax, unquotes are given the same above treatment as
+.code ,
+(comma) unquotes in ordinary syntax.
+.coIP ~`...quasilit...`
+Similarly, quasiliterals are supported in JSON syntax.
+.meIP #H(() >> ( k0 << v0 ) >> ( k1 << v1 ) ...)
+Hash quasiliteral syntax is translated according to the
+.mono
+.meti @(hash <> ([ k0 ] <> [ v0 ]) <> ([ k0 ] <> [ v0 ]) ...)
+.onom
+pattern, with each key and value recursively translated.
+The syntax must specify
+.code ()
+for the hash construction arguments part, otherwise an error is diagnosed.
+That is to say, it must be of the form
+.codn "#H(() ...)" .
+where the first element is
+.codn () .
+.meIP >> #S( type < e0 < e1 ...)
+Structure quasiliteral syntax is translated according to the
+.mono
+.meti @(struct <> [ type ] <> [ e0 ] <> [ e1 ] ...)
+.onom
+pattern.
+.meIP >> #( e0 < e1 ...)
+Vector quasiliteral syntax is translated according to the
+.mono
+.meti <> #([ e0 ] <> [ e1 ] ...)
+.onom
+pattern: it becomes a vector object containing embedded patterns.
+.meIP <> #J[ e0 , << e1 , ...]
+A JSON array quasiquote is translated into
+.mono
+.meti <> #([ e0 ] <> [ e1 ] ...)
+.onom
+exactly like a vector. Here, the
+.code [X]
+transformation recognizes JSON
+.code ~
+(tilde) unquotes, and recursively recognizes and transform JSON syntax not
+prefixed by
+.codn #J .
+.meIP >> #J{ k0 : << v0 , < k1 : << v1 , ...}
+A JSON hash quasiquote is translated into
+.mono
+.meti @(hash <> ([ k0 ] <> [ v0 ]) <> ([ k0 ] <> [ v0 ]) ...)
+.onom
+exactly like a hash.
+.meIP >> ( car . << cdr )
+Tree structure is translated according to the
+.mono
+.meti <> ([ car ] . <> [ cdr ])
+.onom
+pattern: it is recursively examined for translations.
+.meIP >> ^ nested-qq-syntax
+A nested quasiquote pattern is diagnosed as an error.
+.meIP >> ,* expr
+Splicing syntax is diagnosed as an error.
+.meIP >> ~* expr
+Splicing JSON syntax is diagnosed as an error inside a JSON quasiliteral.
+.meIP >> ~* expr
+.meIP < obj
+Any other quasiquoted object is left untranslated.
+.RE
+.IP
+.TP* Examples:
+.verb
+ ;; basic unquote: variables embedded via unquote,
+ ;; not requiring @ prefix.
+ (when-match ^(,a ,b) '(1 2) (list a b))
+ --> (1 2)
+
+ ;; operators embedded via unquote; interior of operators
+ ;; is regular non-quasiquoting pattern syntax.
+ (when-match ^(,(oddp @a) ,(evenp @b)) '(1 2) (list a b))
+ --> (1 2)
+
+ (when-match ^#(,a ,b) #(1 2) (list a b))
+ --> (1 2)
+
+ (when-match ^#S(,type year ,y) #S(time year 2021)
+ (list (struct-type-name type) y))
+ --> (time 2021)
+
+ (when-match ^#H(() (x ,y) (,(symbolp @y) ,datum))
+ #H(() (x k) (k 42))
+ datum)
+ --> (42)
+
+ ;; JSON syntax
+
+ (when-match ^#J~a 42.0 a) --> 42.0
+
+ (when-match ^#J[~a, ~b] #J[true, false] (list a b)) --> (t nil)
+
+ (when-match ^#J{"x" : ~y, ~(symbolp @y) : ~datum}
+ #J{"x" : true, true : 42}
+ datum)
+ --> (42.0)
+
+ (when-match ^#J{"foo" : {"x" : ~val}}
+ #J{"foo" : {"x" : "y"}} val)
+ --> "y"
+.brev
+
+.coNP Pattern Operator @ struct
+.synb
+.mets @(struct < name >> { slot-name << pattern }*)
+.mets @(struct < pattern >> { slot-name << pattern }*)
+.syne
+.desc
+The
+.code struct
+pattern operator matches a structure object. The operator
+supports two modes of matching, the choice of which depends on whether the
+first argument is a
+.meta name
+or a
+.metn pattern .
+
+The first argument is considered a
+.meta name
+if it is a bindable symbol according to the
+.code bindable
+function. In this situation, the operator operates in
+strict mode. Otherwise, the operator is in loose mode.
+
+The
+.meta name
+or
+.meta pattern
+argument is followed by zero or more
+.meta "slot-name pattern"
+pairs, which are not enclosed in lists, similarly to the way
+slots are presented in the
+.code #S
+struct syntax and in the argument conventions of the
+.code new
+macro.
+
+In strict mode,
+.meta name
+is assumed to be the name of an existing struct type.
+The object being matched is tested whether it is a subtype of this type, as
+if using the
+.code subtypep
+function. If it isn't, the match fails.
+
+In loose mode, the object being matched is tested whether it is a structure
+object of any structure type. If it isn't, the match fails.
+
+In strict mode, each
+.meta "slot-name pattern"
+pair requires that the object's slot of that name contain
+a value which matches
+.metn pattern .
+The operator assumes that all the
+.metn slot-name s
+are slots of the struct type indicated by
+.metn name .
+
+In loose mode, no assumption is made that the object actually has the
+slots specified by the
+.meta slot-name
+arguments. The object's structure type is inquired to
+determine whether it has each of those slots. If it doesn't, the match fails.
+If the object has the required slots, then the values of those slots are
+matched against the patterns.
+
+In loose mode, the
+.meta pattern
+given in the first argument position of the syntax is matched against the
+object's structure type: the type itself, rather than its symbolic name.
+
+.TP* Examples:
+
+.verb
+ ;; extract the month from a time structure
+ ;; that is required to have a year of 2021.
+
+ (when-match @(struct time year 2021 month @m)
+ #S(time year 2021 month 1)
+ m) -> 1
+
+ ;; match any structure with name and value slots,
+ ;; whose name is foo, and extract the value.
+
+ (defstruct widget ()
+ name
+ value)
+
+ (defstruct grommet ()
+ name
+ value)
+
+ (append-each ((obj (list (new grommet name "foo" value :grom)
+ (new widget name "foo" value :widg))))
+ (when-match @(struct @type name "foo" value @v) obj
+ (list (list type v))))
+
+ --> ((#<struct-type grommet> :grom)
+ (#<struct-type widget> :widg))
+.brev
+
+.coNP Pattern Operator @ hash
+.synb
+.mets @(hash >> {( key-pattern <> [ value-pattern ])}*)
+.syne
+.desc
+The
+.code hash
+pattern operator matches a hash-table object by means of patterns
+which target keys, values or both.
+
+An important concept in the requirements governing the operation of the
+.code hash
+operator is that of a trivial pattern.
+
+A pattern is nontrivial if it is a variable or operator pattern.
+A pattern is also nontrivial if it is a list, vector or range pattern
+containing at least one nontrivial pattern. Otherwise, it is trivial.
+
+The
+.code hash
+operator requires the corresponding object to be a hash table,
+otherwise the match fails.
+
+If the corresponding object is a hash table, then matches each
+.meta key-pattern
+and
+.meta value-pattern
+pair against that object as described below. Each of
+the pairs must successfully match, otherwise the overall
+match fails.
+
+The following requirements apply to key-value pattern pairs in which
+the value pattern is specified.
+
+If
+.meta key-pattern
+is a trivial pattern, then the semantics of the match is that
+.meta key-pattern
+is taken as a literal object representing a hash key. The hash
+table is searched for that key. If the key is not found,
+the match fails. Otherwise, the value corresponding to
+that key is matched against the
+.meta value-pattern
+which may be trivial or nontrivial.
+
+If
+.meta key-pattern
+is a simple variable pattern
+.mono
+.meti >> @ sym
+.onom
+and if
+.meta sym
+has an existing binding, then the value of
+.meta sym
+is looked up in the hash table. If it is not found, then
+the match fails, otherwise the corresponding value is matched
+against
+.metn value-pattern ,
+which may be trivial or nontrivial.
+
+If
+.meta key-pattern
+is a nontrivial pattern other than a variable pattern
+for a variable which has an existing binding, and if
+.meta value-pattern
+is trivial, then
+.meta value-pattern
+is taken as a literal object, which is used for searching
+the hash table for one or more keys, as if it were the
+.meta value
+argument in a call to the
+.code hash-keys-of
+function, to find all keys which have a value
+.code equal
+to that value. If no keys are found, then the match
+fails. Otherwise, the
+.code key-pattern
+is then matched against the retrieved list of hash keys.
+
+Finally, if both
+.meta key-pattern
+and
+.meta value-pattern
+are nontrivial, then an exhaustive search is performed of the hash table.
+Every key in the hash table is matched against
+.meta key-pattern
+and if it matches, the value is matched against
+.metn value-pattern .
+If both match, then the values from the matches are collected into lists.
+At least one matching key-value pair must be found, otherwise
+the overall match fails.
+Note: this situation can be understood as if the hash table were
+an association list of
+.code cons
+cells of the form
+
+.verb
+.mets >> ( key . << value )
+.brev
+
+and as if the two patterns were combined into a
+.code coll
+operator against this list in the following way:
+
+.verb
+.mets @(coll >> ( key-pattern . << value-pattern ))
+.brev
+
+such that the semantics can then be understood in terms of the
+.code coll
+operator matching against an association list.
+
+The following requirements apply when the
+.meta value-pattern
+is omitted.
+
+If
+.meta key-pattern
+is a nontrivial pattern other than a variable pattern
+for a variable which has an existing binding, then the pattern
+is applied against the list of keys from the hash table, which
+are retrieved as if using the
+.code hash-keys
+function.
+
+If
+.meta key-pattern
+is a variable pattern referring to an existing binding, then that pattern is
+taken as a literal object. The match is successful if that object occurs as a
+key in the hash table.
+
+.TP* Example:
+
+.verb
+ ;; First, (x @y) has a trivial key pattern so the x
+ ;; entry from the hash table is retrieved, the
+ ;; value being the symbol k. This k is bound to @y.
+ ;; Because y now a bound variable the pattern (@y @datum)
+ ;; is interpreted as search of the hash table for
+ ;; a single entry matching the value of @y. This
+ ;; is the k entry, whose value is 42. The @datum
+ ;; value match takes this 42.
+ (when-match @(hash (x @y) (@y @datum))
+ #H(() (x k) (k 42)) datum)
+ --> 42
+
+ ;; Again, (x @y) has a trivial key pattern so the x
+ ;; entry from the hash table is retrieved, the
+ ;; value being the symbol k. This k is bound to @y.
+ ;; This time the second pattern has a @(symbolp)
+ ;; predicate operator. This is not a variable, and
+ ;; so the pattern searches the entire
+ ;; hash table. The @y variable has a binding to k,
+ ;; so only the (k 42) entry is matched. The 42
+ ;; value matches @datum, and is collected into a list.
+ (when-match @(hash (x @y) (@(symbolp @y) @datum))
+ #H(() (x k) (k 42)) datum)
+ --> (42)
+.brev
+
+.coNP Pattern Operator @ as
+.synb
+.mets @(as < name << pattern )
+.syne
+.desc
+The
+.code as
+pattern operator binds the corresponding object to a fresh variable given by
+.metn name ,
+similarly to the Lisp
+.code let
+operator. If another variable called
+.meta name
+exists, it is shadowed; thus, no back-referencing is performed.
+
+The
+.meta name
+argument must be a bindable symbol, or else
+.codn nil .
+If
+.meta name
+is
+.codn nil ,
+then no name is bound. Thus
+.mono
+.meti @(as nil << pattern )
+.onom
+is equivalent to
+.metn pattern .
+Otherwise,
+.meta pattern
+processed in a scope in which the new
+.meta name
+binding is already visible.
+
+The
+.code as
+operator succeeds if
+.meta pattern
+matches.
+
+Note: in a situation when it is necessary to bind a variable to an object
+in parallel with one or more patterns, such that the variable can back-reference
+to an existing occurrence, the
+.code and
+pattern operator can be used.
+
+.TP* Example:
+
+.verb
+ ;; w captures the entire (1 2 3) list:
+
+ (when-match @(as w (@a @b @c)) '(1 2 3) (list w a b c))
+ --> ((1 2 3) 1 2 3)
+
+ ;; match a list which has itself as the third element
+ (when-match @(as a (1 2 @a 4)) '#1=(1 2 #1# 4) :yes)
+ --> :yes
+.brev
+
+.coNP Pattern Operator @ with
+.synb
+.mets @(with <> [ main-pattern ] >> { side-pattern | << name } << expr )
+.syne
+.desc
+The
+.code with
+pattern operator matches the optional
+.meta main-pattern
+against a corresponding object, while matching a
+.meta side-pattern
+or
+.meta name
+against the value of the expression
+.meta expr
+which is embedded in the syntax.
+
+First, if
+.meta main-pattern
+is present in the syntax,
+it is matched against its corresponding object. This match must
+succeed, or else the
+.code with
+operator fails to match, in which case
+.meta expr
+is not evaluated.
+
+Next, if
+.meta main-pattern
+successfully matched, or is absent,
+.meta expr
+is evaluated in the scope of earlier pattern variables, including any
+which that emanate from
+.metn main-pattern .
+It is unspecified
+whether later pattern variables are visible.
+
+Finally,
+.meta side-pattern
+is matched against the value of
+.metn expr .
+If that succeeds, then the operator has successfully matched.
+
+If a
+.meta name
+is specified instead of a
+.metn side-pattern ,
+it must be a bindable symbol or else
+.codn nil .
+
+.TP* Examples:
+
+.verb
+ (when-match (@(with @a x 42) @b @c) '(1 2 3) (list a b c x))
+ --> (1 2 3 42)
+
+ (let ((o 3))
+ (when-match (@(evenp @x) @(with @z @(oddp y) o)) '(4 6)
+ (list x y z)))
+ --> (4 3 6)
+.brev
+
+.coNP Pattern Operator @ require
+.synb
+.mets @(require < pattern << condition *)
+.syne
+.desc
+The pattern operator
+.code require
+applies the specified
+.meta pattern
+to the corresponding object.
+If the
+.meta pattern
+matches, the operator then imposes the additional constraints
+specified by zero or more
+.meta condition
+forms.
+Each
+.meta condition
+is evaluated in a scope in which the variables from
+.meta pattern
+have already been established.
+
+For the
+.code require
+operator to be a successful match, every
+.meta condition
+must evaluate true, otherwise the match fails.
+
+The
+.meta condition
+forms behave as if they were the arguments of an implicit
+.code and
+operator, which implies left-to-right evaluation behavior, stopping
+evaluation on the first
+.meta condition
+which produces
+.codn nil ,
+and defaulting to a result of
+.code t
+when no
+.meta condition
+forms are specified.
+
+.TP* Examples:
+
+.verb
+ ;; Match a (+ a b) expression where a and b are similar:
+
+ (when-match @(require (+ @a @b) (equal a b)) '(+ z z) (list a b))
+ --> (z z)
+
+ ;; Mismatched case
+ (if-match @(require (+ @a @b) (equal a b)) '(+ y z)
+ (list a b)
+ :no-match)
+ --> :no-match
+.brev
+
+.coNP Pattern Operators @ all and @ all*
+.synb
+.mets @(all << pattern )
+.mets @(all* << pattern )
+.syne
+.desc
+The
+.code all
+and
+.code all*
+pattern operators require the corresponding object to be a sequence.
+
+The specified
+.meta pattern
+is applied against every element of the sequence. The match is successful if
+.meta pattern
+matches every element.
+
+Furthermore, in the case of a successful match, each variable that
+is freshly bound by
+.meta pattern
+is converted into a list of all of the objects which that variable
+encounters from all elements of the sequence. Those variables which already
+have a binding from another
+.meta pattern
+are not converted to lists. Their existing values are merely required to match
+each corresponding object they encounter.
+
+The difference between
+.code all
+and
+.code all*
+is as follows. The
+.code all
+operator respects the vacuous truth of the match when the sequence is empty.
+In that case, the match is successful, and the variables are all bound to
+the empty list
+.codn nil .
+In contrast, the alternative
+.code all*
+operator behaves like a failed match when the sequence is empty.
+
+.TP* Examples:
+
+.verb
+ ;; all elements of list match the pattern (x @a @b)
+ ;; a is bound to (1 2 3); b to (a b c)
+
+ (when-match @(all (x @a @b))
+ '((x 1 a) (x 2 b) (x 3 c))
+ (list a b))
+ --> ((1 2 3) (a b c))
+
+ ;; Match a two element list whose second element
+ ;; consists of nothing but zero or more repetitions
+ ;; of the first element. x is not turned into a list
+ ;; because it has a binding due to @x.
+ (when-match @(@x @(all x)) '(1 (1 1 1 1)) x) -> 1
+
+ ;; no match because of the 2
+ (when-match @(@x @(all x)) '(1 (1 1 1 2)) x) -> nil
+.brev
+
+.coNP Pattern Operator @ some
+.synb
+.mets @(some << pattern )
+.syne
+.desc
+The
+.code some
+pattern operator requires the corresponding object to be a sequence.
+The specified
+.meta pattern
+is applied against every element of the sequence. The match is successful if
+.meta pattern
+matches at least one element.
+
+Variables are extracted from the first matching which is found.
+
+.TP* Example:
+
+.verb
+ ;; the second (x 2 b) element is the leftmost one
+ ;; which matches the (x @a @b) pattern
+
+ (when-match @(some (x @a @b))
+ '((y 1 a) (x 2 b) (z 3 c))
+ (list a b))
+ -> (2 b)
+.brev
+
+.coNP Pattern Operator @ coll
+.synb
+.mets @(coll << pattern )
+.syne
+.desc
+The
+.code coll
+pattern operator requires the corresponding object to be a sequence.
+The specified
+.meta pattern
+is applied against every element of the sequence. The match is successful if
+.meta pattern
+matches at least one element.
+
+Each variable that is freshly bound by the
+.meta pattern
+is converted into a list of all of the objects which that variable
+encounters from the matching elements of the sequence. Those variables which
+already have a binding from another
+.meta pattern
+are not converted to lists. Their existing values are merely required to match
+each corresponding object they encounter.
+
+Variables are extracted from all matching elements, and collected into
+parallel lists, just like with the
+.code @(all)
+operator.
+
+.TP* Example:
+
+.verb
+ (when-match @(coll (x @a @b))
+ '((y 1 a) (x 2 b) (z 3 c) (x 4 d))
+ (list a b))
+ -> ((2 4) (b d))
+.brev
+
+.coNP Pattern Operator @ scan
+.synb
+.mets @(scan << pattern )
+.syne
+.desc
+The
+.code scan
+operator matches
+.meta pattern
+against the corresponding object. If the match fails, and the object
+is a
+.code cons
+cell, the match is tried on the
+.code cdr
+of the cons cell. The
+.code cdr
+traversal repeats until a successful match is found,
+or a match failure occurs against against an atom.
+
+Thus, a list object, possibly improper, matches
+.meta pattern
+under
+.code scan
+if any suffix of that object matches.
+
+.TP* Examples:
+
+.verb
+ ;; mismatch: 1 doesn't match 2
+ (when-match @(scan 2) 1 t) -> t
+
+ ;; simple atom match: 42 matches 42
+ (when-match @(scan 42) 42 t) -> t
+
+ ;; (2 3) is a sublist of (1 2 3 4)
+ (when-match @(scan (2 3 . @nil)) '(1 2 3 4) t) -> t
+
+ ;; (2 @x 4 . @nil) matches (2 3 4), binding x to 3:
+ (when-match @(scan (2 @x 4 . @nil)) '(1 2 3 4 5) x) -> 3
+
+ ;; The entire matching suffix can be captured.
+ (when-match @(scan @(as sfx (2 @x 4 . @nil)))
+ '(1 2 3 4 5)
+ sfx)
+ -> (2 3 4 5)
+
+ ;; Missing . @nil in pattern anchors search to end:
+ (when-match @(scan (@x 2))
+ '(1 2 3 2 4 2)
+ x)
+
+ ;; Terminating atom anchors to improper end:
+ (when-match @(scan (@x . 4))
+ '(1 2 3 . 4)
+ x)
+ -> 3
+
+ ;; Atom pattern matches only terminating atom
+ (when-match @(scan #(@x @y))
+ '(1 2 3 . #(4 5))
+ (list x y))
+ -> (4 5)
+.brev
+
+.coNP Pattern Operators @ and and @ or
+.synb
+.mets @(and << pattern *)
+.mets @(or << pattern *)
+.syne
+.desc
+The
+.code and
+and
+.code or
+operators match multiple patterns in parallel, against
+the same object.
+The
+.code and
+operator matches if every
+.meta pattern
+matches the object, otherwise there is no match.
+The
+.code or
+operator requires one
+.meta pattern
+to match. It tries the patterns in left-to-right order, and
+stops at the first matching one, declaring failure if none match.
+
+The
+.code and
+and
+.code or
+operators have different scoping rules.
+Under
+.codn and ,
+later patterns are processed in the scopes of earlier patterns,
+just like with other pattern operators. Duplicate variables
+back-reference.
+Under
+.codn or ,
+the patterns are processed in separate, parallel scopes.
+No back-referencing takes place among same-named variables
+introduced in separate patterns of the same
+.codn or .
+
+When the
+.code and
+matches, the variables from all of the
+patterns are bound.
+When the
+.code or
+operator matches, the variables from all of the patterns
+are also bound. However, only the variables from the matching
+.meta pattern
+take on the values implied by that pattern.
+The variables from the nonmatching patterns that do not have
+the same names as variables in the matching
+.metn pattern ,
+and that have been newly introduced in the
+.code or
+operator, take on
+.code nil
+values.
+
+.TP* Examples
+
+.verb
+ (if-match @(and (@x 2 3) (1 @y 3) (1 2 @z)) '(1 2 3)
+ (list x y z)) -> (1 2 3)
+
+ (if-match @(or (@x 3 3) (1 @x 3) (1 2 @x)) '(1 2 3)
+ x) -> 2
+.brev
+
+.coNP Pattern Operator @ not
+.synb
+.mets @(not << pattern )
+.syne
+.desc
+The pattern operator
+.code not
+provides logical inverse semantics. It matches if and only if the
+.meta pattern
+does not match.
+
+Whether or not the
+.code not
+operator matches, no variables are bound. If the embedded
+.meta pattern
+matches, the variables which it binds are suppressed by the
+.code not
+operator.
+
+.TP* Examples:
+
+.verb
+ ;; @a matches unconditionally, so @(not @a) always fails:
+ (if-match @(not @a) 1 :yes :no) -> :no
+
+ ;; error: a is not bound
+ (if-match @(not @a) 1 :yes a) -> error
+
+ (match-case '(1 2 3)
+ ((@(not 1) @b @c) (list :case1 b c))
+ ((@(not 0) @b @c) (list :case2 c b)))
+ --> (:case2 3 2)
+.brev
+
+.NP* Pattern predicate operator
+.synb
+.mets >> @( function << arg *)
+.mets >> @( function << arg * >> @ avar << arg *)
+.mets >> @( function << arg * . <> @ avar )
+.mets >> @(@ rvar >> ( function << arg *))
+.mets >> @(@ rvar >> ( function << arg * >> @ avar << arg *))
+.mets >> @(@ rvar >> ( function << arg * . <> @ avar ))
+.syne
+.desc
+Whenever the operator position of a pattern consists of a symbol which is
+neither the name of a pattern operator, nor the name of a macro, the expression
+denotes a predicate pattern. An expression is also a predicate pattern if
+it is handled by a pattern macro which declines to expand it by yielding
+the original expression.
+
+An operator pattern is expected to conform to one of the first three
+syntactic variations above.
+Together, these three variations constitute the
+.I "first form"
+of the pattern predicate operator.
+Whenever the operator position of a pattern consists of a meta-symbol, it is
+also a predicate pattern, expected to conform to one of the second three syntax
+variations above. These three variations constitute the
+.I "second form"
+of the operator.
+
+The first form of the predicate pattern consists of a compound form consisting
+of an operator and arguments. Exactly one of the arguments may be a pattern
+variable
+.meta avar
+("argument variable") which must be a bindable symbol or else
+.codn nil .
+The pattern variable may also appear in the dot position, rather than as an
+argument. The role of
+.meta avar
+and the consequences of omitting it are described below.
+
+The second form of the predicate pattern consists of a meta-symbol
+.meta rvar
+("result variable")
+which must be a bindable symbol or else
+.codn nil .
+This is followed by a compound form which consists of an operator
+symbol, followed by arguments, one of which may be a pattern
+.code avar
+as in the simple form.
+If
+.meta rvar
+is
+.codn nil ,
+then the predicate pattern is equivalent to the first form. That is to say,
+the following are equivalent:
+
+.verb
+ @(@nil (f ...)) <--> @(f ...)
+.brev
+
+The matching of the predicate pattern is processed as follows.
+If the
+.meta avar
+variable is present, then the predicate pattern first binds the
+corresponding object to the
+.meta avar
+variable, performing an ordinary variable match with the potential
+back-referencing which that implies. If that succeeds, then the object is
+inserted into the compound form, substituted in the position indicated by the
+.mono
+.meti >> @ avar
+.onom
+variable, either an ordinary argument position or the dot position. This form
+is then evaluated. If it yields true, then the match is successful, otherwise
+the match fails.
+
+If the
+.meta avar
+variable is absent, then no initial variable matching takes place.
+The corresponding object is added as an extra rightmost argument into the
+compound form, which is evaluated. Its truth value then determines the success
+of the match, just like in the case with
+.metn avar .
+
+If the second form is being processed, and specifies a
+.meta rvar
+that is not
+.codn nil ,
+and if the predicate has succeeded, then then an extra processing step takes
+place. A variable match is performed to bind the
+.meta rvar
+variable to the result of the predicate, with potential back-referencing.
+If that match succeeds, then the predicate pattern succeeds.
+
+The compound form may be headed by the
+.code dwim
+operator, and therefore the DWIM bracket notation may be used.
+For instance
+.code "@[f @x]"
+is equivalent to
+.code "@(dwim f @x)"
+and is processed accordingly. Similarly,
+.code "@(@y [f @x])"
+is equivalent to
+.codn "@(@y (dwim f @x))" .
+
+The dot position of
+.meta avar
+in the predicate syntax denotes function application. So that is to say, the
+pattern predicate form
+.code "(f . @a)"
+where
+.code @a
+is in the dotted position invokes the function
+.code f
+as if by evaluation of the form
+.code "(f . x)"
+where
+.code x
+is hidden temporary variable holding the object corresponding to the pattern.
+The form
+.code "(f . x)"
+is a standard \*(TL notation with the same meaning as
+.codn "(apply (fun f) x)" .
+
+If
+.meta avar
+is the
+.code nil
+symbol, then no variable is bound. The matched object is substituted
+into the predicate expression at the position indicated by
+.codn @nil .
+
+.TP* Examples:
+
+.verb
+ (when-match (@(evenp) @(oddp @x)) '(2 3) x) -> 3
+
+ (when-match @(<= 1 @x 10) 4 x) -> 4
+
+ (when-match @(@d (chr-digit @c)) #\e5 (list d c)) -> (5 #\e5)
+
+ (when-match @(<= 1 @x 10) 11 x) -> nil
+
+ ;; use hash table as predicate:
+ (let ((h #H(() (a 1) (b 2))))
+ (when-match @[h @x] 'a x))
+ -> a
+
+ ;; as above, also capture hash value
+ (let ((h #H(() (a 1) (b 2))))
+ (when-match @(@y [h @x]) 'a (list x y)))
+ -> (a 1)
+
+ ;; apply (1 2 3) to < using dot position
+ (when-match @(@x (< . @sym)) '(1 2 3) (list x sym))
+ -> (t (1 2 3))
+
+ ;; Match three-element list whose middle element
+ ;; is a number in the range 10 20, without
+ ;; binding any variables:
+ (when-match (@nil @(<= 10 @nil 20) @nil) obj
+ (prinl "obj matches"))
+.brev
+
+.coNP Pattern Macro @ sme
+.synb
+.mets @(sme < spat < mpat < epat >> [ mvar <> [ evar ]])
+.syne
+.desc
+The pattern macro
+.code sme
+(start, middle, end) is a notation defined using the
+.code defmatch
+macro.
+
+The
+.code sme
+macro generates a complex pattern which matches three non-overlapping
+parts of a list object using three patterns. The
+.meta spat
+pattern is required to match a prefix of the input list. If that match is
+successful, then the remainder of the list is searched for a match for
+.metn mpat ,
+using the
+.code scan
+operator. If that match, in turn, is successful, then the suffix of
+the remainder of the list is required to match
+.codn epat .
+
+The optional
+.meta mvar
+and
+.meta evar
+arguments must be bindable symbols, if they are specified.
+These symbols specify lexical variables which are bound to, respectively,
+the object matched by
+.meta mpat
+and
+.metn epat ,
+using the fresh binding semantics of the
+.code as
+pattern operator.
+
+The first two patterns,
+.meta spat
+and
+.metn mpat ,
+must be possibly dotted list patterns.
+The last pattern,
+.metn epat ,
+may be any pattern: it may be an atom match for the terminating
+atom, or a possibly dotted list pattern matching the list suffix.
+
+Important to the semantics of
+.code sme
+is the concept of the length of a list pattern.
+
+The length of a pattern with a pattern variable or operator
+in the dotted position is the number of items before that variable
+or operator. The length of
+.code "(1 2 . @(and a b))"
+is 2; likewise the length of
+.code "(1 2 . @nil)"
+is also 2.
+The length of a pattern which does not have a variable or
+operator in the dotted position is simply its list length.
+For instance, the pattern
+.code "(1 2 3)"
+has length 3, and so does the pattern
+.codn "(1 2 3 . 4)" .
+The length is determined by the list object structure of the
+pattern, and not the printed syntax used to express it. Thus,
+.code "(1 . (2 3))"
+is still a length 3 pattern, because it denotes the same
+.code "(1 2 3)"
+object, using the dot notation unnecessarily.
+
+The non-overlapping semantics of
+.code sme
+evolves as follows. In the following description, it is understood
+that a match is required at every step. If that match fails, then
+the entire
+.code sme
+operator fails:
+
+.RS
+.IP 1.
+First,
+.meta spat
+is required to match a a prefix of the input list. If the match
+succeeds, then a
+.I "middle suffix"
+of the input is calculated by dropping from it leading
+elements. The number of elements dropped is equal to the length of
+.metn spat .
+.IP 2.
+The middle suffix is then searched for an occurrence of the middle pattern
+.metn mpat ,
+as if using the
+.code scan
+pattern operator. All elements skipped by the search are dropped,
+until a match is found.
+.IP 3.
+At that point, if
+.meta mvar
+has been specified, it is bound to the remaining input, which still
+includes the part which just matched
+.metn mpat .
+.IP 4.
+Next, a number of elements equal to the length of
+.metn mpat ,
+are dropped from the middle suffix, leaving a residue comprising the
+.IR "final suffix" .
+.IP 5.
+The end pattern
+.meta epat
+must then match a suffix of the final suffix.
+.IP 6.
+If the
+.meta evar
+variable has been specified, it is bound to the entire suffix that
+was matched by
+.metn epat .
+.RE
+
+.TP* Examples:
+
+.verb
+ (when-match @(sme (1 2) (3 4) (5 . 6) m e)
+ '(1 2 3 4 5 . 6)
+ (list m e))
+ -> ((3 4 5 . 6) (5 . 6))
+
+ (when-match @(sme (1 2) (3 4) (5 . 6) m e)
+ '(1 2 abc 3 4 def 5 . 6)
+ (list m e))
+ ((3 4 def 5 . 6) (5 . 6))
+
+ ;; backreferencing
+ (when-match @(sme (1 @y) (@z @x @y @z) (@x @y)) '(1 2 3 1 2 3 1 2)
+ (list x y z))
+ -> (1 2 3))
+
+ ;; collect odd items starting at 3, before 7
+ (when-match @(and @(sme (1 @x) (3) (7) m e)
+ @(with @(coll @(oddp @y)) (ldiff m e)))
+ '(1 2 3 4 5 6 7)
+ (list x y))
+ -> (2 (3 5)))
+
+ ;; no overlap
+ (when-match @(sme (1 2) (2 3) (3 4)) '(1 2 3 4) t) -> nil
+
+ ;; The atom 5 is like a "zero-length improper list".
+ (when-match @(sme () () 5) 5 t) -> t
+.brev
+
+.coNP Pattern Macro @ end
+.synb
+.mets @(end < pattern <> [ var ])
+.syne
+.desc
+The pattern macro
+.code end
+is a notation defined using the
+.code defmatch
+macro, which matches
+.meta pattern
+against the suffix of a corresponding list object,
+which may be an improper list or atom.
+
+The optional argument
+.meta var
+specifies the name of a variable which captures the matched portion of the
+object.
+
+The
+.code end
+macro is related to the
+.code sme
+macro according to the following equivalence:
+
+.verb
+ @(end pat var) <--> @(sme () () pat : var)
+.brev
+
+All of the requirements given for
+.code sme
+apply accordingly.
+
+.TP* Examples:
+
+.verb
+ ;; atom match
+ (when-match @(end 3 x) 3 x) -> 3
+
+ ;; y captures (2 3)
+ (when-match @(end (2 @x) y)
+ '(1 2 3)
+ (list x y))
+ -> (3 (2 3))
+
+ ;; variable in dot position
+ (when-match @(end (2 . @x) y)
+ '(1 2 . 3)
+ (list x y))
+ -> (3 (2 . 3))
+
+ ;; z captures entire object
+ (when-match @(as z @(end (2 @x) y))
+ '(1 2 3)
+ (list x y z))
+ -> (3 (2 3) (1 2 3)))
+.brev
+
+.SS* Pattern-Matching Macros
+
+.coNP Macros @, when-match @ match and @ if-match
+.synb
+.mets (when-match < pattern < expr << form *)
+.mets (match < pattern < expr << form *)
+.mets (if-match < pattern < expr < then-form <> [ else-form ])
+.syne
+.desc
+The
+.codn when-match ,
+.code match
+and
+.code if-match
+macros conditionally evaluate code based on whether the value of
+.meta expr
+matches
+.metn pattern .
+
+The
+.code when-match
+macro arranges for every
+.meta form
+to be evaluated in the scope of the variables established by
+.meta pattern
+when it matches the object produced by
+.metn expr .
+The value of the last
+.meta form
+is returned, or else
+.code nil
+if there are no forms.
+If the match fails, the forms are not evaluated, and
+.code nil
+is produced.
+
+The
+.code match
+macro behaves exactly like
+.code when-match
+when the match is successful. When the match fails,
+.code match
+throws an exception of type
+.codn match-error .
+
+The
+.code if-match
+macro evaluates
+.meta then-form
+in the scope of the variables established by
+.meta pattern
+if the match is successful, and yields the value of that form.
+Otherwise, it evaluates
+.metn else-form ,
+which defaults to
+.code nil
+if it is not specified.
+
+.coNP Macros @ match-case and @ match-ecase
+.synb
+.mets (match-case < expr >> {( pattern << form *)}*)
+.mets (match-ecase < expr >> {( pattern << form *)}*)
+.syne
+.desc
+The
+.code match-case
+macro matches the value of
+.meta expr
+against zero or more patterns.
+
+Normally, the patterns are considered in left-to-right order.
+If the value
+.meta expr
+matches more than one
+.metn pattern ,
+the leftmost
+.meta pattern
+is selected and that clause is evaluated. Under certain conditions,
+detailed below, it is possible for
+.code match-case
+and
+.code match-ecase
+to be transformed into a
+.code casequal
+form. In that case, if there are multiple clauses with equivalent
+patterns, it is not specified which one is evaluated.
+
+The syntax of
+.code match-case
+consists of an expression
+.meta expr
+followed by zero or more clauses.
+Each clause is a compound expression whose first element is
+.metn pattern ,
+which is followed by zero or more forms.
+
+First,
+.meta expr
+is evaluated. Then, the value is matched against each
+.meta pattern
+in succession, stopping at the first pattern which provides
+a successful match.
+If no pattern provides a successful match, then
+.code match-case
+terminates and returns
+.codn nil .
+
+If a
+.meta pattern
+matches successfully, then each
+.meta form
+associated with the pattern is evaluated in the scope of the variable
+bindings established by that
+.metn pattern .
+Then
+.code match-case
+terminates, returning the value of the last
+.meta form
+or else
+.code nil
+if there are no forms.
+
+The
+.code match-ecase
+macro differs from
+.code match-case
+as follows. When none of the clauses match under
+.codn match-case ,
+then that form terminates with a value of
+.codn nil .
+In the same situation, the
+.code match-ecase
+form throws an exception of type
+.codn match-error .
+
+An
+.code match-ecase
+form may be transformed to a
+.code casequal
+form if all the
+.mets pattern s
+are trivial. A trivial pattern is either an atom, or else a vector or list
+expression containing no variables.
+
+A
+.code match-case
+form may be transformed to a
+.code casequal
+form under the same conditions as
+.codn match-case .
+Additionally,
+.code match-case
+may also be transformed if it contains exactly one
+clause which matches any object by means of the key
+.code @nil
+or else a variable match such as
+.codn @abc ,
+if that clause appears last. That clause is transformed into an
+.meta else-clause
+of the
+.code casequal
+form.
+
+.TP* Examples:
+
+.verb
+ ;; classify sequence of objects by pattern matching,
+ ;; returning a list of the results
+
+ (collect-each ((obj (list '(1 2 3)
+ '(4 5)
+ '(3 5)
+ #S(time year 2021 month 1 day 1)
+ #(vec tor))))
+ (match-case obj
+ (@(struct time year @y) y)
+ (#(@x @y) (list x y))
+ ((@nil @nil @x) x)
+ ((4 @x) x)
+ ((@x 5) x)))
+
+ --> (3 5 3 2021 (vec tor))
+
+ ;; default case can be represented by a guaranteed match
+
+ (match-case 1
+ (2 :two)
+ (@x :default)) --> :default
+.brev
+
+.coNP Macro @ match-cond
+.synb
+.mets (match-cond >> {( pattern < expr << form *)}*)
+.syne
+.desc
+The
+.code match-cond
+macro's arguments are zero or more clauses, each of which
+specifies a
+.metn pattern ,
+an expression
+.metn expr ,
+and zero or more
+.metn form s.
+
+The clauses are processed in order. Successive
+.metn expr s
+are evaluated, and matched against their corresponding pattern.
+If there is no match, processing continues with the next
+clause. If no match is found in any clause, the
+.code match-cond
+form terminates, returning
+.codn nil .
+
+If an
+.metn expr 's
+value matches the corresponding
+.metn pattern ,
+then every
+.code form
+is evaluated in scope of the variables established by the pattern.
+The
+.code match-form
+then terminates, yielding the value of the last
+.codn form ,
+or else the value of
+.meta expr
+if there are no
+.codn form s.
+
+Note: the pattern
+.code "(t t ...)"
+is recommended for specifying an unconditionally matching clause.
+
+.TP* Example:
+
+.verb
+ (let ((x 42))
+ (match-cond
+ (`@x-73` "73-73" :a)
+ (`@x-@y` "42-24" y)))
+ --> "24"
+.brev
+
+.coNP Macro @ lambda-match
+.synb
+.mets (lambda-match >> {( pattern << form *)}*)
+.syne
+.desc
+The
+.code lambda-match
+is conceptually similar to
+.codn match-case .
+
+The arguments of
+.code lambda-match
+are zero or more clauses similar to those of
+.codn match-case ,
+each consisting of a compound expression headed by a
+.meta pattern
+followed by zero or more
+.metn form s.
+
+The macro generates a
+.code lambda
+expression which evaluates to an anonymous function
+in the usual way.
+
+When the anonymous function is called, each clause's
+.meta pattern
+is matched against the function's actual arguments. When a
+match occurs, each
+.meta form
+associated with the
+.meta pattern
+is evaluated, and the value of the last
+.meta form
+becomes the return value of the function.
+If none of the clauses match, then
+.code nil
+is returned.
+
+Whenever
+.meta pattern
+is a list-like pattern, it is not matched against a list object, as is the
+usual case with a list-like pattern, but against the actual arguments.
+For instance, the pattern
+.code "(@a @b @c)"
+expects that the function was called with exactly three arguments. If
+that is the case, the patterns are then matched to the arguments. The pattern
+.code @a
+takes the first argument, binding it to variable
+.code a
+and so forth.
+
+If
+.meta pattern
+is a dotted list-like pattern, then the dot position is matched
+against the remaining arguments. For instance, the pattern
+.code "(@a @b . @c)"
+requires at least two arguments. The first two are bound to
+.code a
+and
+.codn b ,
+respectively. The list of remaining arguments, if any, is bound to
+.codn c ,
+which will be
+.code nil
+if there are no remaining arguments.
+
+Any non-list-like
+.meta pattern
+.code P
+is analyzed as an equivalent list-like dotted pattern due to
+.code P
+syntax being equivalent to
+.code "(. P)"
+syntax. Such a pattern matches the list of all arguments.
+Thus, the following are all equivalent:
+
+.verb
+ (lambda-match (@a a))
+ (lambda-match ((. @a) a))
+ (lambda a a)
+ (lambda (. a) a)
+.brev
+
+The characteristics of the resulting anonymous function are determined as
+follows.
+
+If at least one
+.meta pattern
+specified in a
+.meta lambda-match
+is a dotted pattern, the function is variadic.
+
+The arity of the resulting anonymous function is determined as follows, from
+the lengths of the patterns. The length of a pattern is the number of
+elements, not including the dotted element.
+
+The length of the longest pattern determines the number of fixed
+arguments. Unless the function is variadic, it may not be called with more
+arguments than can be matched by the longest pattern.
+
+The length of the shortest pattern determines the number of required arguments.
+The function may not be called with fewer arguments than can be matched
+by the shortest pattern.
+
+If these two lengths are unequal, then the function has a number of optional
+arguments, equal to the difference.
+
+Note: an anonymous function which takes one argument and matches that
+object against clauses using
+.code match-case
+can be obtained with the
+.code do
+operator, using the pattern:
+.codn "(do match @1 ...)" .
+
+Note: the parameter macro
+.code :match
+can also define a
+.code lambda
+with pattern matching. Any
+.code "(lambda-match clauses ...)"
+form can be written as
+.codn "(lambda (:match) clauses ...)" .
+The parameter macro offers the additional ability of defining
+named arguments which are inserted before the implicit arguments
+generated from the clauses, and combining with other parameter
+macros.
+
+.TP* Examples:
+
+.verb
+ (let ((f (lambda-match
+ (() (list 0 :args))
+ ((@a) (list 1 :arg a))
+ ((@a @b) (list 2 :args a b))
+ ((@a @b . @c) (list* '> 2 :args a b c)))))
+ (list [f] [f 1] [f 1 2] [f 1 2 3]))
+ -->
+ ((0 :args) (1 :arg 1) (2 :args 1 2) (> 2 :args 1 2 3))
+
+ [(lambda-match
+ ((0 1) :zero-one)
+ ((1 0) :one-zero)
+ ((@x @y) :no-match)) 1 0] --> :one-zero
+
+ [(lambda-match
+ ((0 1) :zero-one)
+ ((1 0) :one-zero)
+ ((@x @y) :no-match)) 1 1] --> :no-match
+
+ [(lambda-match
+ ((0 1) :zero-one)
+ ((1 0) :one-zero)
+ ((@x @y) :no-match)) 1 2 3] --> ;; error
+.brev
+
+.coNP Macro @ defun-match
+.synb
+.mets (defun-match < name >> {( pattern << form *)}*)
+.syne
+.desc
+The
+.code defun-match
+macro can be used to define a top-level function in the style of
+.codn lambda-match .
+
+It produces a form which has all of the properties of
+.codn defun ,
+such as a block of the same
+.meta name
+being established around the implicit
+.code match-case
+so that
+.code return-from
+is possible.
+
+The
+.mono
+.meti >> ( pattern << form *)
+.onom
+clauses of
+.code defun-match
+have exactly the same syntax and semantics as those of
+.codn lambda-match .
+
+Note: instead of
+.codn defun-match ,
+the parameter macro
+.code :match
+may be used. The following equivalence holds:
+
+.verb
+ (defun name (:match) ...) <--> (defun-match ...)
+.brev
+
+The parameter macro offers the additional ability of defining
+named arguments which are inserted before the implicit arguments
+generated from the clauses, and combining with other parameter
+macros.
+
+.TP* Examples:
+
+.verb
+ ;; Fibonacci
+ (defun-match fib
+ ((0) 1)
+ ((1) 1)
+ ((@x) (+ (fib (pred x)) (fib (ppred x)))))
+
+ (fib 0) -> 1
+ (fib 1) -> 1
+ (fib 2) -> 2
+ (fib 3) -> 3
+ (fib 4) -> 5
+ (fib 5) -> 8
+
+ ;; Ackermann
+ (defun-match ack
+ ((0 @n) (+ n 1))
+ ((@m 0) (ack (- m 1) 1))
+ ((@m @n) (ack (- m 1) (ack m (- n 1)))))
+
+ (ack 3 7) -> 1021
+ (ack 1 1) -> 3
+ (ack 2 2) -> 7
+.brev
+
+.coNP Parameter List Macro @ :match
+.synb
+.mets (:match << left-param * [-- << extra-param *]) << clause *
+.syne
+.desc
+Parameter list macro
+.code :match
+allows any function to be expressed in the style of
+.codn lambda-match ,
+with extra features.
+
+The
+.code :match
+macro expects the body of the function to consist of
+.code lambda-match
+clauses, which are semantically treated in exactly the same manner as
+under
+.codn lambda-match .
+
+The following restrictions apply. The parameter list may not include
+optional parameters delimited by
+.code :
+(the colon keyword symbol). The parameter list may not be dotted.
+
+The macro produces a function which the
+.meta left-param
+parameters, if any, are inserted to the left of the implicit parameters
+generated by the
+.code lambda-match
+transformation.
+
+Furthermore, the
+.code :match
+parameter macro supports integration with the
+.code :key
+parameter macro, or any other macro which uses a compatible
+.code --
+convention for delimiting special arguments.
+If the parameter list includes the symbol
+.code --
+then that portion of the parameter list is set aside and not included in the
+.code lambda-match
+transformation. Then, that list is integrated into the resulting lambda.
+
+A complete transformation can be described by the following diagram:
+
+.verb
+ (lambda (:match a b c ... -- s t u ...) clauses ...)
+
+ -->
+
+ (lambda (a b c ... m n p ... -- s t u ... . z) body ...)
+.brev
+
+In this diagram,
+.code "a b c ..."
+denote the
+.meta left-param
+parameters.
+The
+.code "m n p ..."
+symbols denote the fixed parameters generated by the
+.code lambda-match
+transformation from the semantic analysis of
+.metn clauses .
+The
+.code "s t u ..."
+symbols denote the original
+.meta extra-param
+parameters. Finally,
+.code z
+denotes the dotted parameter generated by the
+.code lambda-match
+transform. If the transform produces no dotted parameter, then this is
+.codn nil .
+The dotted parameter is thus separated from the
+.code "m n p ..."
+group to which it belongs.
+
+When no
+.code --
+and
+.meta extra-params
+are present, the transformation reduces to:
+
+.verb
+ (lambda (:match a b c ...) clauses ...)
+
+ -->
+
+ (lambda (a b c ... m n p ... . z) body ...)
+.brev
+
+Note: these requirements harmonize with the
+.code :key
+parameter macro. If that is present to the left of
+.code :match
+it removes the
+.code --
+and the
+.code "s t u ..."
+keyword parameters, reuniting the
+.code z
+parameter with the
+.code "m n p"
+group. Furthermore, the
+.code :key
+macro generates code which refers to the existing
+.code z
+dotted parameter as the source for the keyword parameters, unless
+.code z
+is
+.codn nil ,
+in which case it inserts its own generated symbol.
+
+.TP* Examples:
+
+.verb
+ ;; Match-style cond-like macro with unreachability diagnosis.
+ ;; Demonstrates usefulness of :match, which allows the :form
+ ;; parameter to be promoted through to the macro definition.
+
+ (defmacro my-cond (:match :form f)
+ (() nil)
+ (((@(and @(constantp @test) @(eval))) . @rest)
+ (when rest
+ (compile-error f "unreachable code after ~s" test))
+ test)
+ (((@(and @(constantp @test) @(eval)) . @forms) . @rest)
+ (when (and rest)
+ (compile-error f "unreachable code after ~s" test))
+ ^(progn ,*forms))
+ (((@test) . @rest)
+ ^(or ,test (my-cond ,*rest)))
+ (((@test . @forms) . @rest)
+ ^(if ,test (progn ,*forms)
+ (my-cond ,*rest)))
+ ((@else . @rest) (compile-error f "bad syntax")))
+
+ (my-cond (3)) --> 3
+ (my-cond (3 4)) --> 4
+ (my-cond (3 4) (5)) --> ;; my-cond: unreachable code after 3
+ (my-cond 42) --> ;; my-cond: bad syntax
+.brev
+
+.verb
+ ;; Keyword parameter example.
+
+ (defstruct simple-widget ()
+ name)
+
+ (defstruct widget (simple-widget)
+ frobosity
+ luminance)
+
+ (defstruct simple-point-widget (simple-widget)
+ (:static width 0)
+ (:static height 0))
+
+ (defstruct point-widget (widget)
+ (:static width 0)
+ (:static height 0))
+
+ (defstruct general-widget (widget)
+ width
+ height)
+
+ ;; Note that in clauses with no . @rest parameter, there
+ ;; is a mismatch if keyword arguments are present. The (0 0)
+ ;; clause exploits this to match only when keywords are absent.
+
+ (defun make-widget (:key :match name -- frob lum)
+ ((0 0) (new simple-point-widget name name))
+ ((0 0 . @rest) (new point-widget name name
+ frobosity frob
+ luminance lum))
+ ((@x @y . @rest) (new general-widget name name
+ width x
+ height x
+ frobosity frob
+ luminance lum)))
+
+ (make-widget "abc" 0 0) --> #S(simple-point-widget name "abc")
+
+ (make-widget "abc" 0 0 :frob 42)
+ --> #S(point-widget name "abc" frobosity 42 luminance nil)
+
+ (make-widget "abc" 0 0 :lum 9)
+ --> #S(point-widget name "abc" frobosity nil luminance 9)
+
+ (make-widget "abc" 0 1 :lum 9)
+ --> #S(general-widget name "abc" frobosity nil luminance 9
+ width 0 height 0)
+.brev
+
+.coNP Macro @ defmatch
+.synb
+.mets (defmatch < name < macro-style-params
+.mets \ \ << body-form *)
+.syne
+.desc
+The
+.code defmatch
+macro allows for the definition of pattern macros: user-defined pattern
+operators which are implemented via expansion into existing operator syntax.
+
+The
+.code defmatch
+macro has the same syntax as
+.codn defmacro .
+It specifies a macro transformation for a compound form which has the
+.meta name
+symbol in its leftmost position.
+
+This macro transformation is performed when
+.meta name
+is used as a pattern operator: an expression of the form
+.mono
+.meti >> @( name << argument *)
+.onom
+occurring in pattern-matching syntax.
+
+The behavior is unspecified if
+.meta name
+is the name a built-in pattern operator, or a predefined pattern macro.
+
+The pattern macro bindings are stored in a hash table held by the variable
+.code *match-macro*
+whose keys are symbols, and whose values are expander functions.
+There are no lexically scoped pattern macros.
+
+Pattern macros defined with
+.code defmatch
+may specify the special macro parameters
+.code :form
+and
+.code :env
+in their parameter lists. The values of these parameters are determined
+in a manner particular to
+.codn defmatch .
+
+The
+.code :form
+parameter captures the pattern-matching form, or a constituent thereof, in
+which the macro is being invoked. For instance, if the operator is being
+used inside a pattern given to a
+.code when-match
+macro invocation, then the form will be that entire
+.code when-match
+form.
+
+The
+.code :env
+parameter captures a specially constructed macro-time environment object in
+which all of the variables to the left of the pattern appear as lexical
+variables. The parent of this environment is the surrounding macro environment.
+If the pattern macro needs to treat a variable which already has a binding
+differently from an unbound variable, it can look up the variable in this
+environment.
+
+.TP* Example:
+
+.verb
+ ;; Create an alias called let for the @(as var pattern) operator:
+ ;; Note that the macro produces @(as ...) and not just (as ...)
+
+ (defmatch let (var pattern)
+ ^@(as ,var ,pattern))
+
+ ;; use the macro in matching:
+ (when-match @(let x @(or foo bar)) 'foo x)
+
+ ;; Error reporting example using :form
+
+ (defmatch foo (sym)
+ (unless (bindable sym)
+ (compile-error *match-form*
+ "~s: bindable symbol expected, not ~s"
+ 'foo sym))
+ ...)
+
+ ;; Pattern macro which uses = equality to backreference
+ ;; an existing lexical binding, or else binds the variable
+ ;; if it has no existing lexical binding.
+ (defmatch var= (sym :env e)
+ (if (lexical-var-p e sym)
+ (with-gensyms (obj)
+ ^@(require (sys:var ,obj)
+ (= ,sym ,obj)))
+ ^(sys:var ,sym)))
+
+ ;; example use:
+ (when-match (@(var= a) @(var= a)) '(1 1.0) a)
+ -> 1
+
+ ;; no match: (equal 1 1.0) is false
+ (when-match (@a @a) '(1 1.0) a)
+ -> nil
+.brev
+
+.coNP Function @ macroexpand-match
+.synb
+.mets (macroexpand-match < pattern <> [ env ])
+.syne
+.desc
+If
+.code pattern
+is a compound form whose operator symbol has been defined as a macro
+pattern using
+.codn defmatch ,
+then
+.code macroexpand-match
+will expand that pattern and return the expansion. Otherwise it returns the
+.code pattern
+argument.
+
+In order to be recognized by
+.code macroexpand-match
+the
+.meta pattern
+argument must not include the
+.code @
+prefix that would normally be used to invoke it. The expansion, however, will
+include that syntax.
+
+The
+.code env
+parameter specifies the macro-time environment for the expander.
+Note: pattern expanders, like built-in patterns, may use the macro environment
+for deciding whether a variable is an existing lexical variable, or a free
+variable, based on which a pattern may be expanded differently.
+
+.TP* Example:
+
+Given:
+.verb
+ (defmatch point (x y)
+ ^@(struct point x @,x y @,y))
+.brev
+a result similar to the following may be obtained:
+.verb
+ (macroexpand-match '(point a b)) -> @(struct point x @a y @b)
+.brev
+Note that the pattern is specified plainly as
+.code "(point a b)"
+rather than
+.codn "@(point a b)" ,
+yet the expansion is
+.codn "@(struct ...)" .
+
+.coNP Special Variable @ *match-macro*
+.desc
+The
+.code *match-macro*
+special variable holds the hash table of associations between
+symbols and pattern macro expanders.
+
+If the expression
+.code "[*match-macro* 'sym]"
+yields a function, then symbol
+.code sym
+has a binding as a pattern macro. If that
+expression yields
+.codn nil ,
+then there is no such binding: pattern operator forms based on
+.code sym
+do not undergo place macro expansion.
+
+The macro expanders in
+.code *match-macro*
+are two-parameter functions. The first argument passes the operator
+syntax to be expanded. The second argument is used for passing the
+environment object which the expander can capture using
+.code :env
+in its macro parameter list.
+
+.coNP Macros @ each-match and @ each-match-product
+.synb
+.mets (each-match >> ({ pattern << seq-form }*) << body-form *)
+.mets (each-match-product >> ({ pattern << seq-form }*) << body-form *)
+.syne
+.desc
+The
+.code each-match
+macro arranges for elements from multiple sequences to be
+visited in parallel, and each to be matched against respective patterns.
+For each matching tuple of parallel elements, a body of forms is evaluated in
+the scope of the variables bound in the patterns.
+
+The first argument of
+.code each-match
+specifies a list of alternating
+.meta pattern
+and
+.meta seq-form
+expressions. Each
+.meta pattern
+is associated with the sequence which results from evaluating the
+immediately following
+.metn seq-form .
+Items coming from that sequence correspond with that pattern.
+
+The remaining arguments are
+.metn body-form s
+to evaluated for successful matches.
+
+The
+.metn body-form s
+are surrounded by an implicit anonymous block. If any of the forms
+.code return
+invoke a return out of this block, then the iteration terminates, and
+the result value of the block becomes the result value of
+the loop.
+
+The processing takes place as follows:
+.RS
+.IP 1.
+Every
+.meta seq-form
+is evaluated in left-to-right order and is expected to produce an
+iterable sequence or object that would be a suitable argument to
+.code mapcar
+or
+.codn iter-begin .
+This evaluation takes place in the scope surrounding the macro form,
+in which none of the variables that are bound in the
+.meta pattern
+expressions are yet visible.
+.IP 2.
+The next available item is taken from each of the sequences.
+If any of the sequences has no more items available, then
+.code each-match
+terminates and returns
+.codn nil .
+.IP 3.
+Each item taken in step 2 is matched against the
+.meta pattern
+which is corresponds with its sequence. Each successive pattern can
+refer to the variables bound in the previous patterns in the same
+iteration. If any pattern match fails, then the process continues with step 2.
+.IP 4.
+If all the matches are successful, then
+.metn body-form s,
+if any, are executed in the scope of variables bound in the
+.metn pattern s.
+Processing then continues at step 2.
+.RE
+.IP
+The
+.code each-match-product
+differs from
+.code each-match
+in that instead of taking parallel tuples of items from the sequences,
+it iterates over the tuples of the Cartesian product of the sequences
+similarly to the
+.code maprod
+function. The product tuples are ordered in such a way that the rightmost
+element, which always coming coming from sequence produced by the last
+.metn seq-form ,
+varies the fastest. If there are two sequences
+.code "(1 2)"
+and
+.codn "(a b)" ,
+then
+.code each-match
+iterates over the tuples
+.code "(1 a)"
+and
+.codn "(2 b)" ,
+whereas
+.code each-match-product
+iterates over
+.codn "(1 a)" ,
+.codn "(1 b)" ,
+.code "(2 a)"
+and
+.codn "(2 b)" .
+
+.TP* Examples:
+.verb
+ ;; Number all the .JPG files in the current directory.
+ ;; For instance foo.jpg becomes foo-0001.jpg, if it is
+ ;; the first file.
+ (each-match (@(as name `@base.jpg`) (glob "*.jpg")
+ @(@num (fmt "~,04a")) 1)
+ (rename-path name `@base-@num.jpg`))
+
+ ;; Iterate over combinations of matching phone
+ ;; numbers and odd integers from the (1 2 3) list
+ (build
+ (each-match-product (`(@a) @b-@c` '("x"
+ ""
+ "(311) 555-5353"
+ "(604) 923-2323"
+ "133"
+ "4-5-6-7")
+ @(oddp @x) '(1 2 3))
+ (add (list x a b c))))
+ -->
+ ((1 "311" "555" "5353") (3 "311" "555" "5353")
+ (1 "604" "923" "2323") (3 "604" "923" "2323")))
+.brev
+
+.coNP Macros @ append-matches and @ append-match-products
+.synb
+.mets (append-matches >> ({ pattern << seq-form }*) << body-form *)
+.mets (append-match-products >> ({ pattern << seq-form }*) << body-form *)
+.syne
+.desc
+The macro
+.code append-matches
+is subject to all of the requirements specified for
+.code each-match
+in regard to the argument conventions and semantics,
+and the presence of the implicit anonymous block around the
+.metn body-form s.
+
+Whereas
+.code each-match
+returns
+.codn nil ,
+the
+.code append-matches
+macro requires, in each iteration which produces a match for each
+.metn pattern ,
+that the last
+.meta body-form
+evaluated must produce a list.
+
+These lists are catenated together as if by the
+.code append
+function and returned.
+
+It is unspecified whether the nonmatching iterations produce
+empty lists which are included in the append operation.
+
+If the last tuple of items which produces a match is absolutely the
+the last tuple, the corresponding
+.meta body-form
+evaluation may yield an atom which then becomes the terminator
+for the returned list, in keeping with the semantics of
+.codn append .
+an atom.
+
+The
+.code append-match-products
+macro differs from
+.code append-matches
+in that it iterates over the Cartesian product tuples of the sequences,
+rather than parallel tuples. The difference is exactly like that between
+.code each-match
+and
+.codn each-match-product .
+
+.TP* Examples:
+
+.verb
+ (append-matches
+ ((:foo @y) '((:foo a) (:bar b) (:foo c) (:foo d))
+ (@x :bar) '((1 :bar) (2 :bar) (3 :bar) (4 :foo)))
+ (list x y))
+ --> (1 a 3 c)
+
+ (append-matches (@x '((1) (2) (3) 4)) x)
+ --> (1 2 3 . 4)
+
+ (append-match-products (@(oddp @x) (range 1 5)
+ @(evenp @y) (range 1 5))
+ (list x y))
+ --> (1 2 1 4 3 2 3 4 5 2 5 4)
+.brev
+
+.coNP Macros @ keep-matches and @ keep-match-products
+.synb
+.mets (keep-matches >> ({ pattern << seq-form }*) << body-form *)
+.mets (keep-match-products >> ({ pattern << seq-form }*) << body-form *)
+.syne
+.desc
+The macro
+.code keep-matches
+is subject to all of the requirements specified for
+.code each-match
+in regard to the argument conventions and semantics,
+and the presence of the implicit anonymous block around the
+.metn body-form s.
+
+Whereas
+.code each-match
+returns
+.codn nil ,
+the
+.code keep-matches
+macro returns a list of the values produced by all matching iterations which
+led to the execution of the
+.metn body-form s.
+
+The
+.code keep-match-products
+macro differs from
+.code keep-matches
+in that it iterates over the Cartesian product tuples of the sequences,
+rather than parallel tuples. The difference is exactly like that between
+.code each-match
+and
+.codn each-match-product .
+
+.TP* Examples:
+
+.verb
+ (keep-matches ((:foo @y) '((:foo a) (:bar b) (:foo c) (:foo d))
+ (@x :bar) '((1 :bar) (2 :bar) (3 :bar) (4 :foo)))
+ (list x y))
+ --> ((1 a) (3 c))
+
+ (keep-match-products (@(oddp @x) (range 1 5)
+ @(evenp @y) (range 1 5))
+ (list x y))
+ --> ((1 2) (1 4) (3 2) (3 4) (5 2) (5 4))
+.brev
+
+.coNP Macro @ while-match
+.synb
+.mets (while-match < pattern < expr << form *)
+.syne
+.desc
+The
+.code while-match
+macro evaluates
+.meta expr
+and matches it against
+.meta pattern
+similarly to
+.codn when-match .
+
+If the match is successful, every
+.meta form
+is evaluated in an environment in which new bindings from
+.meta pattern
+are visible. In this case, the process repeats:
+.meta expr
+is evaluated again, and tested against
+.metn pattern .
+
+If the match fails,
+.code while-match
+terminates and produces
+.code nil
+as its result value.
+
+Each iteration produces fresh bindings for any variables
+that are implicated for binding in
+.metn pattern .
+
+The
+.meta expr
+and
+.meta form
+expressions are surrounded by an anonymous block.
+
+.coNP Macros @ while-match-case and @ while-true-match-case
+.synb
+.mets (while-match-case < expr >> {( pattern << form *)}*)
+.mets (while-true-match-case < expr >> {( pattern << form *)}*)
+.syne
+.desc
+The macros
+.code while-match-case
+and
+.code while-true-match-case
+combine iteration with the semantics of
+.codn match-case .
+
+The
+.code while-match-case
+evaluates
+.meta expr
+and matches it against zero or more clauses in the manner of
+.code match-case.
+If there is a match, this process is repeated.
+If there is no match,
+.code while-match-case
+terminates, and returns
+.codn nil .
+
+In each iteration, the matching clause produces fresh bindings for any
+variables implicated for binding in its respective
+.metn pattern .
+
+The
+.meta expr
+and
+.meta form
+expressions are surrounded by an anonymous block.
+
+The
+.code while-true-match-case
+macro is identical in almost every respect to
+.codn while-match-case ,
+except that it terminates the loop if
+.meta expr
+evaluates to
+.codn nil ,
+without attempting to match that value against the clauses.
+
+Note: the semantics of
+.code while-true-match-case
+can be obtained in
+.code while-match-case
+by inserting a
+.code return
+clause. That is to say, a construct of the form
+
+.verb
+ (while-true-match-case expr
+ ...)
+.brev
+
+may be rewritten into
+
+.verb
+ (while-match-case expr
+ (nil (return)) ;; match nil and return
+ ...)
+.brev
+
+except that
+.code while-true-match-case
+isn't required to rely on performing a block return.
+
.SS* Quasiquote Operator Syntax
.coNP Macro @ qquote
.synb
@@ -38192,17 +49266,17 @@ be found when the recursion pops back to the outer quasiquote, which will
then traverse the result of the inner compilation and find the
.codn "(unquote x)" .
-.TP* "Dialect note:"
+.TP* "Dialect Note:"
In Lisp dialects which have a published quasiquoting operator syntax, there is
the expectation that the quasiquote read syntax corresponds to it. That is to
-say, that for instance the read syntax
+say, the read syntax
.code "^(a b ,c)"
-is expected translated to
-.codn "(qquote b (unquote c))" .
+is expected to translate to
+.codn "(qquote a b (unquote c))" .
In \*(TL, this is not true! Although
-.code "^(b b ,c)"
+.code "^(a b ,c)"
is translated to a
quasiquoting macro, it is an internal one, not based on the public
.codn qquote ,
@@ -38335,7 +49409,35 @@ must evaluate to a list. That list is
integrated into the surrounding list.
.SS* Math Library
-.coNP Functions @ + and @ -
+
+The following documentation describes the behavior of the Math Library
+functions as they apply to the native numeric and character types.
+
+The functions also support application-defined structure types.
+That feature is not described here but in the section User-Defined
+Arithmetic Types.
+
+When one or more operands of a Math Library function is a user-defined
+arithmetic structure, no conversions are performed on the operands,
+and the stated restrictions do not apply. The operands are passed to
+the methods as described in the User-Defined Arithmetic Types section.
+The operands need not be numeric.
+
+User-defined arithmetic structures can work with operands which
+are not numbers. If
+.code a
+is such a type, it is possible for an expression such as
+.code "(+ a \(dqabc\(dq)"
+to be meaningful and correct. Similarly, it is possible for an
+apparent division by zero such as
+.code "(/ a 0)"
+to be meaningful and correct, since the
+.code /
+method of the
+.code a
+object decides how to handle zero.
+
+.coNP Functions @, + @ - and @ *
.synb
.mets (+ << number *)
.mets (- < number << number *)
@@ -38428,20 +49530,18 @@ the displacement from the NUL character.
The rules can be stated as a set of restrictions:
.RS
-.IP 1
+.IP 1.
Two characters may not be added together.
-.IP 2
+.IP 2.
A character may not be subtracted from an integer (which also rules out
the possibility of computing the additive inverse of a character).
-.IP 3
+.IP 3.
A character operand may not be opposite to a floating point operand
in any operation.
-.IP 4
+.IP 4.
A character may not be an operand of multiplication.
.RE
-.PP
-
.coNP Function @ /
.synb
.mets (/ << divisor )
@@ -38486,7 +49586,9 @@ The
and
.code prod
functions operate on an effective sequence of numbers derived from
-.metn sequence .
+.metn sequence ,
+which is an object suitable for iteration according to
+.codn seq-begin .
If the
.meta keyfun
@@ -38733,7 +49835,7 @@ else 0.0.
The
.codn trunc ,
.codn floor ,
-.code ceiling
+.code ceil
and
.code round
functions perform division of the
@@ -38759,7 +49861,7 @@ floating-point, the others are converted to floating-point
and the result is floating-point.
The
-.code dividend
+.meta dividend
input may be a range. In this situation, the operation is
recursively distributed over the
.code from
@@ -38796,13 +49898,13 @@ yields
.code -1
and
.code "(round 1 2)"
-yields 1,
+yields 1.
Note that for large floating point values, due to the limited
precision, the integer value corresponding to the mathematical
floor or ceiling may not be available.
-.TP* "Dialect note:"
+.TP* "Dialect Note:"
In ANSI Common Lisp, the
.code round
function chooses the nearest even integer, rather than
@@ -39014,7 +50116,7 @@ similarly to the way nested exponents work in standard algebraic
notation.
Exponentiation is done pairwise using a binary operation.
-If both operands to this binary operation are non-negative integers, then the
+If both operands to this binary operation are nonnegative integers, then the
result is an integer.
If the exponent is negative, and the base is zero, the situation is
@@ -39028,6 +50130,9 @@ operand is converted to a float, and a floating point exponentiation
is performed. Exponentiation that would produce a complex number is
not supported.
+If the exponent is zero, then the return value is 1.0 if at least one operand
+is floating-point, otherwise 1.
+
The
.code sqrt
function produces a floating-point square root of
@@ -39055,7 +50160,7 @@ The
function performs modular exponentiation and accepts only integer
arguments. Furthermore,
.meta exponent
-must be a non-negative and
+must be a nonnegative and
.meta modulus
must be positive.
@@ -39079,7 +50184,7 @@ function returns the product of
with itself. The following
equivalence holds, except that
.code x
-is evaluated only once in the the
+is evaluated only once in the
.code square
expression:
@@ -39204,6 +50309,28 @@ a
or
.codn float .
+.coNP Function @ arithp
+.synb
+.mets (arithp << object )
+.syne
+.desc
+The
+.code arithp
+function returns true if
+.meta object
+is a character, integer, floating-point number, range or a user-defined arithmetic object.
+For a range,
+.code t
+is returned without examining the values of the
+.code from
+and
+.code to
+fields.
+A user-defined arithmetic object is identified as a struct type which
+implements the
+.code +
+method as a static slot.
+
.coNP Functions @ zerop and @ nzerop
.synb
.mets (zerop << number )
@@ -39251,8 +50378,7 @@ for those arguments for which
.code zerop
returns
.code nil
-and
-.IR "vice versa" .
+and vice versa.
.coNP Functions @ plusp and @ minusp
.synb
@@ -39333,15 +50459,17 @@ subtract 2 and 3 from their argument.
.coNP Functions @, > @, < @, >= @ <= and @ =
.synb
-.mets (> < number << number *)
-.mets (> < number << number *)
-.mets (>= < number << number *)
-.mets (<= < number << number *)
-.mets (= < number << number *)
+.mets (> < object << object *)
+.mets (< < object << object *)
+.mets (>= < object << object *)
+.mets (<= < object << object *)
+.mets (= < object << object *)
.syne
.desc
-These relational functions compare characters and numbers for numeric equality
-or inequality. The arguments must be one or more numbers or characters.
+These relational functions compare characters, numbers, ranges and sequences of
+characters or numbers for numeric equality or inequality. The arguments must be
+one or more numbers, characters, ranges, or sequences of these objects,
+or, recursively, of sequences.
If just one argument is given, then these functions all return
.codn t .
@@ -39351,7 +50479,7 @@ First, if the numbers do not have the same type, then the one
which has the lower ranking type is converted to the type of
the other, according to this ranking: character < integer < float.
For instance if a character and integer are compared, the character
-is converted to integer. Then a straightforward numeric comparison
+is converted to its integer character code. Then a numeric comparison
is applied.
Three or more arguments may be given, in which case the comparison proceeds
@@ -39385,6 +50513,109 @@ and if that comparison succeeds, then in the second comparison,
will be converted to integer so that it can be compared to
.metn integer .
+Ranges may only be compared with ranges. Corresponding
+fields of ranges are compared for equality by
+.code =
+such that
+.code "#R(0 1)"
+and
+.code "#R(0 1.0)"
+are reported as equal.
+The inequality comparisons are lexicographic, such that the
+.code from
+field of the range is considered more major than the
+.code to
+field. For example the inequalities
+.code "(< #R(1 2) #R(2 0))"
+and
+.code "(< #R(1 2) #R(1 3))"
+hold.
+
+Sequences may only be compared with sequences, but
+mixtures of any kinds of sequences may be compared:
+lists with vectors, vectors with strings, and so on.
+
+The
+.code =
+function considers a pair of sequences of unequal length
+to be unequal, reporting
+.codn nil .
+Sequences are equal if they have the same length
+and their corresponding elements are recursively
+equal under the
+.code =
+function.
+
+The inequality functions treat sequences lexicographically.
+A pair of sequences is compared by comparing corresponding
+elements. The
+.code <
+function tests each successive pair of corresponding
+elements recursively using the
+.code <
+function. If this recursive comparison reports
+.codn t ,
+then the function immediately returns
+.code t
+without considering any more pairs of elements.
+Otherwise the same pair of elements is compared again
+using the
+.code =
+function. If that reports false, then the function reports false without
+considering any more pairs of elements. Otherwise processing continues with the
+next pair, if any. If all corresponding elements are equal, but the right
+sequence is longer,
+.code <
+returns
+.codn t ,
+otherwise the function reports
+.codn nil .
+The
+.code <=
+function tests each successive pair of corresponding
+elements recursively using the
+.code <=
+function. If this returns
+.code nil
+then the function returns
+.code nil
+without considering any more pairs. Otherwise processing continues
+with the next pair, if any.
+If all corresponding elements satisfy the test, but the
+left sequence is longer, then
+.code nil
+is returned. Otherwise
+.code t
+is returned.
+
+The inequality relations exhibit symmetry, which means that
+the functions
+.code >
+and
+.code >=
+functions are equivalent, respectively, to
+.code <
+and
+.code <=
+with the order of the argument values reversed. For instance, the expression
+.code "(< a b c)"
+is equivalent to
+.code "(> c b a)"
+except for the difference in evaluation order of the
+.codn a ,
+.code b
+and
+.code c
+operands themselves. Any semantic description of
+.code <
+or
+.code <=
+applies, respectively, also to
+.code >
+or
+.code >=
+with the appropriate adjustment for argument order reversal.
+
.coNP Function @ /=
.synb
.mets (/= << number *)
@@ -39412,7 +50643,7 @@ Otherwise it returns
.coNP Functions @ max and @ min
.synb
.mets (max < first-arg << arg *)
-.mets (min < first-arg << args *)
+.mets (min < first-arg << arg *)
.syne
.desc
The
@@ -39528,7 +50759,7 @@ arguments.
Each of the
.meta level
arguments, of which there may be none, is associated with
-an integer index, starting at zero, in left to right order. The
+an integer index, starting at zero, in left-to-right order. The
.meta level
arguments are examined in that order. When a
.meta level
@@ -39602,7 +50833,7 @@ represent a digit whose value is 10,
represents 11 and
so forth until
.codn Z .
-Upper and lower case letters are recognized.
+Uppercase and lowercase letters are recognized.
Any character which is not a digit of the specified radix is regarded
as the start of trailing junk at which the extraction of the digits stops.
@@ -39681,12 +50912,14 @@ floating point value.
.mets (toint < value <> [ radix ])
.syne
.desc
-These convenience functions convert
+These functions convert
+.meta value
+to floating-point or integer, respectively. The
.meta value
-to floating-point or integer, respectively.
+can be of several types, including string.
If a floating-point value is passed into tofloat, or an integer value into
-toint, then the value is simply returned.
+toint, then that value is simply returned.
If
.meta value
@@ -39699,7 +50932,7 @@ is a string, then it is converted by
.code tofloat
as if by the function
.metn flo-str ,
-, and by
+and by
.code toint
as if by the function
.codn int-str .
@@ -39718,6 +50951,15 @@ is a floating-point number, then it is converted by
as if by the function
.codn int-flo .
+If
+.meta value
+is a structure, then it is expected to implement the
+.code tofloat
+or
+.code toint
+method. This method is invoked by the same-named function, and the value is
+returned.
+
.coNP Variables @ fixnum-min and @ fixnum-max
.desc
These variables hold, respectively, the most negative value of the
@@ -39837,7 +51079,7 @@ represented in the base given by
The
.meta number
-argument must be a non-negative integer, and
+argument must be a nonnegative integer, and
.meta radix
must be an integer greater than one.
@@ -39879,7 +51121,7 @@ argument into a power series whose terms add up to
The
.meta number
-argument must be a non-negative integer, and
+argument must be a nonnegative integer, and
.meta radix
must be an integer greater than one.
@@ -40011,6 +51253,149 @@ benefits from ordering the operations on multiple integer operands
according to the magnitudes of those operands. The function provides an
estimate of magnitude which trades accuracy for efficiency.
+.coNP Function @ quantile
+.synb
+.mets (quantile < p >> [ group-size <> [ rate ]])
+.syne
+.desc
+The
+.code quantile
+function returns a function which estimates a specific quantile
+of a set of real-valued samples. The desired quantile is indicated
+by the
+.meta p
+parameter, which is a number in the range 0 to 1.0. If
+.meta p
+is specified as 0.5, then the median is estimated.
+The
+.meta p
+value of 0.9 leads to the estimation of the 90th percentile:
+a value such that approximately 90% of the samples are below that value.
+
+If the
+.meta group-size
+parameter is specified, it must be a positive integer.
+The returned function then operates in grouped mode. The
+.meta rate
+parameter is relevant only to grouped mode. Grouped mode is
+described below.
+
+The function returned by
+.code quantile
+maintains internal state in relation to calculating the quantile.
+The function may be called with any number of arguments, including
+none. It expects every argument to be either a number, or a sequence
+of numbers. These numbers are accumulated into the quantile calculation,
+and a revised estimate of the quantile is then returned.
+
+Note: the algorithm used is the P-Squared algorithm invented in 1985 by Raj
+Jain and Imrich Chlamtac, which avoids accumulating and sorting the entire data
+set, while still obtaining good quality estimates of the quantile.
+The algorithm requires an initial seed of five samples. Then additional
+samples input into the algorithm produce quantile estimates. To eliminate this
+special case from the abstract interface, the \*(TX implementation is capable of
+producing an estimate when five or fewer samples have been presented, including
+none. In this low situation, the
+.meta p
+value is ignored in reporting the estimate. When no samples have been given,
+the estimate is zero. When one sample has been given, the estimate is that
+sample itself. When between two and five samples have been given, the estimate
+is their median. Using the median as the estimate ensures a smooth transition
+from these early estimates into the estimates produced by the P-Squared
+algorithm. This is because the P-Squared algorithm always reports the value of
+the middle height accumulator as the estimate, and that accumulator's initial
+value is the median of the first five samples.
+
+The function returned by
+.codn quantile ,
+though not accumulating all of the samples passed to it, nevertheless has
+a limited sample capacity, because the registers it uses for tracking the
+sample group positions are fixed-width integers. The sample capacity is
+approximately 4 times the value of
+.codn fixnum-max .
+
+.TP* Example:
+
+.verb
+ (defparm q (quantile 0.9)) ;; create 90-th percentile accumulator
+
+ [q] -> 0.0 ;; no samples given: estimate is 0.
+ [q 3.14] -> 3.14 ;; one sample: estimate is that sample
+ [q 13.3 7.9 5.2 6.3] -> 7.9 ;; five samples: estimate is median.
+ [q 6.8 7.3 9.1 4.0] ;; more than five samples; estimate now
+ -> 8.44651234567901 ;; from P-Square algorithm
+ [q #(13.1 5 2.5)] ;; vector argument
+ -> 9.68660493827161
+ [q] -> 9.68660493827161 ;; no arguments: repeat current estimate
+.brev
+
+If the
+.meta group-size
+argument is specified, then the quantile accumulator operates in grouped mode.
+Grouped mode allows infinite sample operation without overflow: an unlimited
+number of samples can be accepted. However, old samples lose their influence
+over the estimated value: newer samples are considered more significant than
+old samples.
+
+In grouped mode, the quantile accumulator is reset to its initial state whenever
+.meta group-size
+samples have been accumulated, and begins freshly calculating the quantile.
+Prior to the reset, an estimate is obtained and retained in an internal
+register. Going forward, this remembered previous estimate is blended in with
+the newly calculated estimate values, as described below. The cycle repeats
+itself whenever
+.meta group-size
+samples accumulate: the state is reset, and the current estimate is loaded into
+the previous estimate register, which is then blended with newly computed
+values.
+
+The
+.meta rate
+parameter, whose default value is 0.999, controls the estimate blending.
+It should be a value between 0 and 1.
+
+Upon each reset, a blend value register is initialized to 1.0. Each time
+a new sample is accumulated, the blend register is multiplied by the rate
+parameter, and the product is stored back into the blend register.
+Thus if the rate is between 0 and 1, exclusive, then the blend register
+exponentially decreases as the number of samples grows. The blend register
+indicates the fraction of the estimate which comes from the remembered previous
+estimate.
+
+For instance, if the current blend value is 0.8, then the returned estimate
+value is 0.8 times the remembered previous estimate, plus 0.2 times the newly
+computed estimate for the current sample in the new group: the previous and
+current estimate are blended 80:20.
+
+The default
+.meta rate
+value of 0.999 is chosen for a slow transition to the new estimates, which
+helps to conceal inaccuracies in the algorithm associated with having
+accumulated a small number of samples. At this rate, it requires about 290
+samples before the blend value drops to 75% of the old estimate.
+
+If
+.code rate
+is specified as 0, then no blending of the previous estimate value
+takes place, since the blend factor will drop to zero upon the first
+sample being received after the group reset, causing the newly calculated
+estimates to be returned without blending. The previous sample groups
+therefore have no influence over newer estimates. If
+.code rate
+is specified as 1, then the blend factor will stay at 1, and so the
+estimate will forever remain at the previous value, ignoring the
+calculations driven by the new samples.
+
+Note: it is recommended that if
+.meta group-size
+is specified, the value should be at least several hundred. Too small
+a group size will prevent the estimation algorithm from settling on
+good results. The
+.meta rate
+parameter should not much smaller than 1. A rate too low will cause
+the previous estimate's contribution to the quantile value to diminish,
+too quickly, before the new estimation settles.
+
.coNP Variables @, flo-near @, flo-down @ flo-up and @ flo-zero
.desc
These variables hold integer values suitable as arguments to the
@@ -40035,7 +51420,6 @@ Round to zero: the result of an operation is rounded to the nearest
representable value that lies in the direction of zero.
.RE
.IP
-
.coNP Functions @ flo-get-round-mode and @ flo-set-round-mode
.synb
.mets (flo-get-round-mode)
@@ -40084,16 +51468,69 @@ if it is successful, otherwise the return value is
.code nil
and the rounding mode is not changed.
-If a value is is passed to
+If a value is passed to
.code flo-set-round-mode
which is not the value of one of the above
four rounding mode variables, and the function succeeds anyway, then the
rounding behavior of floating-point operations depends on the host
environment's interpretation of that value.
+.SS* Supplementary Math Library
+
+The following functions are defined, if they are available from the host
+platform. They corresponds to same-named functions in the ISO C language
+standard, which appeared in the 1999 revision ("C99").
+
+Even if some of these functions happen not to be defined, it is nevertheless
+possible to define them as methods in a user-defined arithmetic structure.
+See the section User-Defined Arithmetic Types below
+
+.coNP Functions @, cbrt @, erf @, erfc @, exp10 @, exp2 @, expm1 @, gamma @, j0 @, j1 @, lgamma @, log1p @, logb @, nearbyint @, rint @, significand @, tgamma @ y0 and @ y1
+.synb
+.mets (cbrt << arg )
+.mets (erf << arg )
+.mets (erfc << arg )
+.mets (exp10 << arg )
+.mets (exp2 << arg )
+.mets (expm1 << arg )
+.mets (gamma << arg )
+.mets (j0 << arg )
+.mets (j1 << arg )
+.mets (lgamma << arg )
+.mets (log1p << arg )
+.mets (logb << arg )
+.mets (nearbyint << arg )
+.mets (rint << arg )
+.mets (significand << arg )
+.mets (tgamma << arg )
+.mets (y0 << arg )
+.mets (y1 << arg )
+.syne
+.desc
+These are one-argument functions, which take a numeric argument, and return a floating-point result.
+
+.coNP Functions @, copysign @, drem @, fdim @, fmax @, fmin @, hypot @, jn @, ldexp @, nextafter @, remainder @, scalb @ scalbln and @ yn
+.synb
+.mets (copysign < arg1 << arg2 )
+.mets (drem < arg1 << arg2 )
+.mets (fdim < arg1 << arg2 )
+.mets (fmax < arg1 << arg2 )
+.mets (fmin < arg1 << arg2 )
+.mets (hypot < arg1 << arg2 )
+.mets (jn < arg1 << arg2 )
+.mets (ldexp < arg1 << arg2 )
+.mets (nextafter < arg1 << arg2 )
+.mets (remainder < arg1 << arg2 )
+.mets (scalb < arg1 << arg2 )
+.mets (scalbln < arg1 << arg2 )
+.mets (yn < arg1 << arg2 )
+.syne
+.desc
+These are two-argument functions, which take numeric arguments, and return a floating-point result.
+
.SS* Bit Operations
In \*(TL, similarly to Common Lisp, bit operations on integers are based
-on a concept that might be called "infinite two's-complement".
+on a concept that might be called "infinite two's complement".
Under infinite two's complement, a positive number is regarded as having
a binary representation prefixed by an infinite stream of zero digits (for
example
@@ -40125,7 +51562,7 @@ Each one of the
digits in the infinite sequence is replaced by
.codn 1 ,
And this leading sequence means that the number
-is negative, in fact corresponding to the two's-complement representation of
+is negative, in fact corresponding to the two's complement representation of
the value
.codn -2 .
Hence, the infinite digit concept corresponds to an arithmetic
@@ -40134,7 +51571,7 @@ interpretation.
In fact \*(TL's bignum integers do not use a two's complement
representation internally. Numbers are represented as an array which holds a
pure binary number. A separate field indicates the sign: negative,
-or non-negative. That negative numbers appear as two's-complement under the
+or nonnegative. That negative numbers appear as two's complement under the
bit operations is merely a carefully maintained illusion (which makes bit
operations on negative numbers more expensive).
@@ -40157,7 +51594,7 @@ limit on the number of bits.
These operations perform the familiar bitwise and, inclusive or, and exclusive
or operations, respectively. Positive values inputs are treated as
pure binary numbers. Negative inputs are treated as infinite-bit
-two's-complement.
+two's complement.
For example
.code "(logand -2 7)"
@@ -40167,7 +51604,7 @@ This is because
.code -2
is
.code ...111110
-in infinite-bit two's-complement. And-ing this value with
+in infinite-bit two's complement. And-ing this value with
.code 7
(or
.codn ...000111 )
@@ -40199,7 +51636,7 @@ so that the three-argument case
.code "(logand a b c)"
is equivalent to the expression
.codn "(logand (logand a b) c)" ,
-which features two two-argument cases..
+which features two two-argument cases.
.coNP Function @ logtest
.synb
@@ -40232,8 +51669,7 @@ function performs a bitwise complement of
When the one-argument form of lognot is used, then if
.meta value
is nonnegative,
-then the result is negative, and
-.IR "vice versa" ,
+then the result is negative, and vice versa,
according to the infinite-bit
two's complement representation. For instance
.code "(lognot -2)"
@@ -40263,10 +51699,10 @@ function truncates the integer
to the specified number
of bits. If
.meta value
-is negative, then the two's-complement representation
+is negative, then the two's complement representation
is truncated. The return value of
.code logtrunc
-is always a non-negative integer.
+is always a nonnegative integer.
.coNP Function @ sign-extend
.synb
@@ -40281,8 +51717,8 @@ the integer
to the specified number of bits, similarly to the
.code logtrunc
function. Then, this truncated value is regarded as a
-.meta bits
-wide two's complement integer. The value of this integer is
+.metn bits -wide
+two's complement integer. The value of this integer is
calculated and returned.
.TP* Examples:
@@ -40314,7 +51750,7 @@ new value. If
is positive, then a left shift takes place. If
.meta bits
is negative, then a right shift takes place. If
-.meta bit
+.meta bits
is zero, then
.meta value
is returned unaltered. For positive numbers, a left shift by n bits is
@@ -40324,8 +51760,8 @@ A right shift by n bits of a positive integer is equivalent to integer
division by
.codn "(expt 2 n)" ,
with truncation toward zero.
-For negative numbers, the bit shift is performed as if on the two's-complement
-representation. Under the infinite two's-complement representation,
+For negative numbers, the bit shift is performed as if on the two's complement
+representation. Under the infinite two's complement representation,
a right shift does not exhaust the infinite sequence of
.code 1
digits which
@@ -40352,9 +51788,9 @@ has a 1 in bit position
.metn bit .
The
.meta bit
-argument must be a non-negative integer. A value of zero of
+argument must be a nonnegative integer. A value of
.meta bit
-indicates the least significant bit position of
+of zero indicates the least-significant-bit position of
.metn value .
The
@@ -40370,10 +51806,13 @@ is set, otherwise
If
.meta value
-is negative, it is treated as if it had an infinite-bit two's
-complement representation. For instance, if value is
+is negative, it is treated as if it had an infinite-bit
+two's complement representation. For instance, if
+.meta value
+is
.codn -2 ,
-then the bit
+then the
+.code bit
function returns
.code nil
for a
@@ -40394,8 +51833,8 @@ is
The
.code mask
function takes zero or more integer arguments, and produces an integer
-value which corresponds a bitmask made up of the bit positions specified by the
-integer values.
+value which corresponds to a bitmask made up of the bit positions specified by
+the integer arguments.
If
.code mask
@@ -40457,7 +51896,7 @@ is zero, the empty list
.code nil
is returned.
-A negative integer is treated as an infinite bit two's complement
+A negative integer is treated as an infinite-bit two's complement
representation.
The argument may be a character.
@@ -40465,7 +51904,7 @@ The argument may be a character.
If
.meta integer
.code x
-is non-negative, the following equivalence holds:
+is nonnegative, the following equivalence holds:
.verb
x <--> [apply mask (bitset x)]
@@ -40541,6 +51980,32 @@ is zero, the value returned is zero.
The argument may be a character.
+.coNP Macros @ set-mask and @ clear-mask
+.synb
+.mets (set-mask < place << integer *)
+.mets (clear-mask < place << integer *)
+.syne
+.desc
+The
+.code set-mask
+and
+.code clear-mask
+macros set to 1 and 0, respectively, the bits in
+.meta place
+corresponding to bits that are equal to 1 in the mask resulting from
+applying the inclusive or operation to the
+.meta integer
+arguments.
+The following equivalences hold:
+
+.verb
+ (set-mask place integer ...)
+ <--> (set place (logior place integer ...)
+
+ (clear-mask place integer ...)
+ <--> (set place (logand place (lognot (logior integer ...))))
+.brev
+
.SS* User-Defined Arithmetic Types
\*(TL makes it possible for the user application program to define structure
@@ -40571,7 +52036,7 @@ method, then an
exception is thrown. A few unary methods are not named after the corresponding function.
The unary case of the
.code -
-function excepts an object to have a method named
+function expects an object to have a method named
.codn neg ;
thus,
.code "(- x)"
@@ -40923,6 +52388,28 @@ takes place, and its return value is taken as the result
of the operation.
..
+.um tofloat
+
+The method should return a floating-point value.
+It is also permissible for the method to return
+.codn nil ,
+in which case if it is invoked via
+.codn tofloatz ,
+that function will replace the
+.code nil
+return with value of 0.0.
+
+.um toint
+
+The method should return an integer value.
+It is permissible for the method to return
+.codn nil ,
+in which case if it is invoked via
+.codn tointz ,
+that function will replace the
+.code nil
+return with value of 0.
+
.bmcv +
.bmnl -
.bmnr -- -
@@ -40999,6 +52486,37 @@ arguments must be integers.
.bmnl logtrunc
.bmnr r-logtrunc logtrunc
.bmnl sign-extend
+.um cbrt
+.um erf
+.um erfc
+.um exp10
+.um exp2
+.um expm1
+.um gamma
+.um j0
+.um j1
+.um lgamma
+.um log1p
+.um logb
+.um nearbyint
+.um rint
+.um significand
+.um tgamma
+.um y0
+.um y1
+.bmnr r-copysign copysign
+.bmnr r-drem drem
+.bmnr r-fdim fdim
+.bmnr r-fmax fmax
+.bmnr r-fmin fmin
+.bmnr r-hypot hypot
+.bmnr r-jn jn
+.bmnr r-ldexp ldexp
+.bmnr r-nextafter nextafter
+.bmnr r-remainder remainder
+.bmnr r-scalb scalb
+.bmnr r-scalbln scalbln
+.bmnr r-yn yn
Note: the
.code sign-extend
@@ -41031,45 +52549,81 @@ which must be an integer.
An
.I exception
in \*(TX is a special event in the execution of the program which
-results in transfer of control. An exception is identified by a symbol,
-known as the
+potentially results in a transfer of control. An exception is identified by a
+symbol, known as the
.IR "exception type" ,
and it carries zero or more arguments, called the
.IR "exception arguments" .
When an exception is initiated, it is said to be
.IR thrown .
+This action is initiated by the following functions:
+.codn throw ,
+.code throwf
+and
+.codn error ,
+and possibly other functions which invoke these.
When an exception is thrown, \*(TX enters into exception processing
mode. Exception processing mode terminates in one of several ways:
.IP -
A
.I catch
is found which matches the exception, and control is transferred
-to the catch. Catches are defined by the
+to the catch by a nonlocal transfer which performs unwinding. Catches are
+defined by the
.code catch
macro.
.IP -
-A handler accepts the exception by performing a non-local transfer.
+A
+.I handler
+is found which matches the exception, and control is transferred to
+the handler by invoking its function. The handler function accepts the
+exception by performing a nonlocal transfer to a destination of its choice, or
+else declines to accept the exception by returning.
Handlers are defined by the
.code handler-bind
operator or
.code handle
macro.
.IP -
-If no catch or accepting handler is found, control is transferred
-to the function stored in the
-.code *unhandled-hook*
-variable. If that function returns, then unwinding is performed
-after which the process terminates (unless the unwinding actions
-intercept the control to prevent that).
-.IP -
-If no catch or accepting handler is found and
+If no catch or accepting handler is found for an exception derived from
+.code error
+and
.code *unhandled-hook*
is
.codn nil ,
then a built-in strategy for handling the exception is invoked,
consisting of unwinding, and then printing some informational messages and
terminating.
+If the
+.code *unhandled-hook*
+variable contains a value that isn't
+.codn nil ,
+then control is transferred to the function stored in the
+that variable first; only if that function returns is the above
+built-in strategy invoked.
+.IP -
+If no catch or accepting handler is found for an exception derived from
+.codn warning ,
+then a warning diagnostic is issued on the
+.code *stderr*
+stream and a
+.code continue
+exception is thrown with no arguments. If no catch or handler is found
+for that exception, then control returns normally to the site which
+threw the warning exception.
+.IP -
+If no catch or accepting handler is found for an exception that is
+neither derived from
+.code error
+nor from
+.codn warning ,
+then no control transfer takes place; control returns to the
+.code throw
+or
+.code throwf
+function which returns normally, with a return value of
+.codn nil .
.PP
.NP* Catches and Handlers
@@ -41082,16 +52636,21 @@ takes place to the catch site, which receives the exception type and arguments.
A handler is also associated with an active scope. However, it is a function,
and not a dynamic exit point. When an exception is passed to handler,
unwinding does not take place; rather, the function is called. The function then
-either completes the exception handling by performing a non-local transfer,
+either completes the exception handling by performing a nonlocal transfer,
or else declines the exception by performing an ordinary return.
Catches and handlers are identified by exception type symbols. A catch or
handler is eligible to process an exception if it handles a type which is
a supertype of the exception which is being processed. Handles and catches
-are located in a combined search which proceeds from the innermost nesting
-to the outermost. When an eligible handle is encountered, it is called. If
-it returns, the search continues. When an eligible catch is encountered,
-the search stops and a control transfer takes place to the catch site.
+are found by means of a combined search which proceeds from the innermost
+nesting of dynamic scope to the outermost, without performing any unwinding.
+When an eligible handler is encountered, its registered function is called, thereby suspending the
+search. If the handler function returns, the search continues from that scope
+to yet unvisited outer scopes. When an eligible catch is encountered rather
+than a handler, the search terminates and a control transfer takes place to the
+catch site. That control transfer then performs unwinding, which requires it to
+make a second pass through the same nestings of dynamic scope that had just
+been traversed in order to find that catch.
.NP* Handlers and Sandboxing
@@ -41126,7 +52685,7 @@ established.
Exception type symbols are arranged
in an inheritance hierarchy, at whose top the symbol
.code t
-is is the supertype of every exception type, and the
+is the supertype of every exception type, and the
.code nil
symbol is at the bottom, the subtype of every exception type.
@@ -41185,6 +52744,12 @@ subtype of every exception type:
+--- syntax-error
|
+--- eval-error
+ |
+ +--- match-error
+ |
+ +--- case-error
+ |
+ +--- opt-error
.brev
Program designers are encouraged to derive new error exceptions from the
@@ -41225,7 +52790,7 @@ arguments. The symbols are related by inheritance.
When a condition is raised in ANSI CL, the dynamic scope is searched for a
handler, which is an ordinary function which receives the condition. No
-unwinding or non-local transfer takes place. The handler can return, in which
+unwinding or nonlocal transfer takes place. The handler can return, in which
case the search continues. Matching the condition to the handler is by
inheritance. Handler functions are bound to exception type names.
If a handler chooses to actually handle a condition (thereby terminating
@@ -41236,6 +52801,30 @@ may invoke a particular restart handler. Restart handlers are similar to
exception handlers: they are functions associated with symbols in the
dynamic environment.
+In \*(TL, the special behavior which occurs for exceptions derived from
+.code error
+and those from
+.code warning
+is built into the exception handling system, and tied to those types.
+When an error or warning exception is unhandled, the exception handling system
+itself reacts, so the special behaviors occur no matter how these exceptions
+are raised. In ANSI CL, the special behavior for unhandled
+.code error
+conditions (of invoking the debugger) is implemented only in the
+.code error
+function;
+.code error
+conditions signalled other than via that function are not subject to
+any special behavior. There is a parallel situation with regard to
+warnings: the
+ANSI CL
+.code warn
+function implements a special behavior for unhandled warnings (of emitting
+a diagnostic) but warnings not signalled via that function are not
+treated that way.
+Thus in \*(TL, there is no way to raise an error or warning that is simply
+ignored due to being unhandled.
+
In \*(TL exceptions are a unification of conditions and restarts. From an ANSI CL
perspective, \*(TL exceptions are a lot like CL restarts, except that the
symbols are arranged in an inheritance hierarchy. \*(TL exceptions are used
@@ -41361,6 +52950,36 @@ symbol, either by inheriting directly from
.code restart
or from an exception subtype of that symbol.
+.coNP Treatment of @ errno In Built-in Exceptions
+Some \*(TL library functions generate exceptions in response to
+conditions arising in the operating system, and those conditions
+are associated with a numeric code in the POSIX/ISO C variable
+.codn errno .
+This code isn't represented as an exception argument. Rather,
+in many of these situations, the
+.code errno
+value is attached to the error message string which is passed
+as the first and only exception argument. The value can be
+retrieved by using the function
+.code string-get-code
+on the error message string. If this function returns
+.codn nil ,
+then no such code is available in connection with the given
+error.
+
+.TP* Example:
+
+.verb
+ (catch
+ (open-file "AsDf")
+ (error (msg)
+ ;; the value 2 is retrieved from msg
+ ;; 2 is the common value of ENOENT
+ (list (string-get-code msg) msg)))
+
+ -> (2 "error opening \e"AsDf\e": 2/\e"No such file or directory\e"")
+.brev
+
.coNP Functions @, throw @ throwf and @ error
.synb
.mets (throw < symbol << arg *)
@@ -41403,6 +53022,26 @@ using the
.code format
string and additional arguments.
+Because
+.code error
+throws an error exception, it does not return. If an error exception
+is not handled, \*(TX will issue diagnostic messages and terminate.
+Likewise,
+.code throw
+or
+.code throwf
+are used to generate an error exception, they do not return.
+
+If the
+.code throw
+and
+.code throwf
+functions are used to generate an exception not derived from
+.codn error ,
+and no handler is found which accepts the exception, they return normally, with
+a value of
+.codn nil .
+
.coNP Macros @, catch @ catch* and @ catch**
.synb
.mets (catch < try-expression
@@ -41500,7 +53139,7 @@ and
as well as the
.code handler-bind
operator and
-.code handler
+.code handle
macro.
.coNP Operator @ unwind-protect
@@ -41515,20 +53154,20 @@ operator evaluates
in such a way that no matter how the execution of
.meta protected-form
terminates, the
-.metn cleanup-form -s
+.metn cleanup-form s
will be executed.
The
-.metn cleanup-form -s,
+.metn cleanup-form s,
however, are not protected. If a
.meta cleanup-form
terminates via
-some non-local jump, the subsequent
-.metn cleanup-form -s
+some nonlocal jump, the subsequent
+.metn cleanup-form s
are not evaluated.
-.metn cleanup-form -s
-themselves can "hijack" a non-local control transfer such
+.metn cleanup-form s
+themselves can "hijack" a nonlocal control transfer such
as an exception. If a
.meta cleanup-form
is evaluated during the processing of
@@ -41645,7 +53284,7 @@ The
.code handler-bind
operator establishes a handler for one or more
exception types, and evaluates zero or more
-.metn body-form -s
+.metn body-form s
in a dynamic scope in which that handler is visible.
When the
@@ -41687,7 +53326,7 @@ If the function throws an exception for which the handler is eligible,
the handler will not receive that exception; it will be skipped by the
exception search as if it didn't exist. When the handler function terminates,
either via a normal return or a nonlocal control transfer, then the handler is
-re-enabled.
+reenabled.
.coNP Macros @ handle and @ handle*
.synb
@@ -41727,7 +53366,7 @@ gathered from every clause.
The handler function established in the generated
.code handler-bind
-is synthesized from of all of the clauses, together with dispatch logic which
+is synthesized from all of the clauses, together with dispatch logic which
which passes the exception and its arguments to the first
eligible clause.
@@ -41760,7 +53399,7 @@ only the exception arguments are passed to the clauses of
.coNP Macro @ with-resources
.synb
-.mets (with-resources >> ({ sym >> [ init-form <> [ cleanup-form *])}*)
+.mets (with-resources >> ({( sym >> [ init-form <> [ cleanup-form *]])}*)
.mets \ \ << body-form *)
.syne
.desc
@@ -41771,12 +53410,12 @@ macro provides a sequential binding construct similar to
Every
.meta sym
is established as a variable which is visible to the
-.metn init-form -s
+.metn init-form s
of subsequent variables, to all subsequent
-.metn cleanup-form -s
+.metn cleanup-form s
including that of the same variable,
and to the
-.metn body-form -s.
+.metn body-form s.
If no
.meta init-form
@@ -41788,39 +53427,39 @@ is bound to the value
If an
.meta init-form
is supplied, but no
-.metn cleanup-form -s,
+.metn cleanup-form s,
then
.meta sym
is bound to the value of the
.metn init-form .
If one or more
-.metn cleanup-form -s
+.metn cleanup-form s
are supplied in addition to
.metn init-form ,
-they specifies forms to be executed upon the termination of the
+they specify forms to be executed upon the termination of the
.code with-resources
construct.
When an instance of
.code with-resources
-terminates, either normally or by a non-local control transfer,
+terminates, either normally or by a nonlocal control transfer,
then for each
.meta sym
whose
.meta init-form
had executed, thus causing that
-.code sym
+.meta sym
to be bound to a value, the
-.metn cleanup-form -s
+.metn cleanup-form s
corresponding to
.meta sym
are evaluated in the usual left-to-right order.
The
-.metn sym -s
+.metn sym s
are cleaned up in reverse (right-to-left) order. The
-.metn cleanup-form -s
+.metn cleanup-form s
of the most recently bound
.meta sym
are processed first; those of the least recently bound
@@ -41834,9 +53473,17 @@ form terminates normally, the value of the last
is returned, or else
.code nil
if no
-.metn body-form -s
+.metn body-form s
are present.
+.TP* Note:
+
+From its inception, until \*(TX 265,
+.code with-resources
+featured an undocumented behavior. Details are given in the
+COMPATIBILITY section's Compatibility Version Values subsection,
+in the notes for compatibility value 265.
+
.TP* "Example:"
The following expression opens a text file and reads a line from it,
@@ -41849,9 +53496,13 @@ immediately:
(put-line l)))
.brev
+Note that a better way to initialize exactly one stream resource
+is with the
+.code with-stream
+macro, which implicitly closes the stream when it terminates.
-
-.coNP Special variable @ *unhandled-hook*
+.coNP Special Variable @ *unhandled-hook*
+.desc
The
.code *unhandled-hook*
variable is initialized with
@@ -41925,7 +53576,7 @@ symbols must be specified for a useful effect to take place. If exactly two
symbols are specified, then, subject to error checks,
.code defex
makes the left symbol an
-.I exception subtype
+.I "exception subtype"
of the right symbol.
This behavior generalizes to three or more arguments: if three or more symbols
@@ -42096,7 +53747,7 @@ macro) and handlers
(see
.code handler-bind
and
-.codn handler ).
+.codn handle ).
The
.code frame
@@ -42149,11 +53800,11 @@ The
slot of a
.code handle-frame
is the registered handler function. Note that all the clauses of a
-.code handler
+.code handle
macro are compiled to a single function, which is established via
.codn handler-bind ,
so an instance of the
-.code handler
+.code handle
macro corresponds to a single
.codn handle-frame .
@@ -42166,8 +53817,8 @@ The
.code get-frames
function inquires the current dynamic environment in order to retrieve
information about established exception catch and handler frames.
-The function returns a list, ordered from the inner-most nesting
-level to the outer-most nesting, of structure objects derived from the
+The function returns a list, ordered from the innermost nesting
+level to the outermost nesting, of structure objects derived from the
.code frame
structure type. The list contains two kinds of objects: structures
of type
@@ -42251,8 +53902,8 @@ The
.code find-frames
function is similar to
.code find-frame
-except that it returns all matching frames, ordered from the inner-most nesting
-level to the outer-most nesting. If called with no arguments, it returns a
+except that it returns all matching frames, ordered from the innermost nesting
+level to the outermost nesting. If called with no arguments, it returns a
list of the catch frames.
.coNP Function @ invoke-catch
@@ -42263,7 +53914,7 @@ list of the catch frames.
The
.code invoke-catch
function abandons the current evaluation context to perform
-a non-local control transfer directly to the catch
+a nonlocal control transfer directly to the catch
described by the
.meta catch-frame
argument, which must be a structure of type
@@ -42294,7 +53945,7 @@ argument should be an exception symbol. It is passed to the
exception frame, as if it had appeared as the first argument of the
.code throw
function. Similarly, the
-.metn argument -s
+.metn argument s
are passed to the catch frame as if they were the trailing arguments
of a
.codn throw .
@@ -42310,6 +53961,41 @@ The frame receives control even if it it is not otherwise eligible for
catching the exception type denoted by
.metn symbol .
+.coNP Macro @ assert
+.synb
+.mets (assert < expr >> [ format-string << format-arg *])
+.syne
+.desc
+The
+.code assert
+macro evaluates
+.metn expr .
+If
+.meta expr
+yields any true value, then
+.code assert
+terminates normally, and that value is returned.
+
+If instead
+.meta expr
+yields
+.codn nil ,
+then
+.code assert
+throws an exception of type
+.codn assert .
+The exception carries an informative character string that contains
+a diagnostic detailing the expression which yielded
+.codn nil ,
+and the source location of that expression, if available.
+
+If the
+.meta format-string
+and possibly additional format arguments are given to
+.code assert
+then those arguments are used to format additional text which is appended to
+the diagnostic message after a separating character such as a colon.
+
.SS* Static Error Diagnosis
This section describes a number of features related to the diagnosis
@@ -42335,18 +54021,25 @@ more information which is deduced.
.code warning
to identify certain situations of interest. Ordinary non-deferrable
warnings have a structure identical to errors, except for the exception
-symbol. \*(TX's built-in handling of warnings expects these exceptions
-to be continuable. What this means is that a
-.code catch
-for the
+symbol. \*(TX's provides built-in "auto continue" handling for warnings. If a warning
+exception is not intercepted by a catch or an accepting handler, then a
+diagnostic is issued on the
+.code *stderr*
+stream, after which a
.code continue
-exception is expected to be visible. The handler for a warning exception
-issues a diagnostic which incorporates the warning message. Then the
-handler throws a
+exception is thrown with no arguments. If that
.code continue
+exception is not handled, then control returns normally to the point that
exception to resume the computation which generated the warning.
-The generation of a warning thus conforms to the following pattern:
+Callers which invoke code that may generate warning exceptions are therefore
+not required to handle them. However, callers which do handle warning
+exceptions expect to be able to throw a
+.code continue
+exception in order to resume the computation that triggered the warning,
+without allowing other handlers to see the exception.
+
+The generation of a warning should thus conform to the following pattern:
.verb
(catch
@@ -42424,11 +54117,26 @@ The
.code compile-warning
function throws an exception of type
.code warning
-and internally provides the expected
+and internally provides a
.code catch
for the
.code continue
-exception needed to resume after the warning.
+exception which allow a warning handler to resume execution
+after the warning. If a handler throws a
+.code continue
+exception which is caught by
+.codn compile-warning ,
+then
+.code compile-warning
+returns
+.codn nil .
+
+Because
+.code compile-warning
+throws a non-error exception, it returns
+.code nil
+in the event that no catch is found for the exception, and no handler which
+accepts it.
The argument conventions are the same for both functions.
The
@@ -42445,7 +54153,7 @@ and the
arguments
.meta fmt-string
and its
-.metn fmt-arg -s.
+.metn fmt-arg s.
.coNP Function @ compile-defr-warning
.synb
@@ -42457,7 +54165,7 @@ The
.code compile-defr-warning
function throws an exception of type
.code defr-warning
-and internally provides the expected
+and internally provides a
.code catch
for the
.code continue
@@ -42472,12 +54180,23 @@ and the
arguments
.meta fmt-string
and its
-.metn fmt-arg -s.
+.metn fmt-arg s.
This diagnostic message constitutes the first
argument of the exception. The
.meta tag
argument is taken as the second argument.
+If the exception isn't intercepted by a catch or by
+an accepting handler,
+.code compile-defr-warning
+returns
+.codn nil .
+In also returns
+.code nil
+if it catches a
+.code continue
+exception.
+
.coNP Function @ purge-deferred-warning
.synb
.mets (purge-deferred-warning << tag )
@@ -42618,7 +54337,7 @@ function since deferred warnings are issued automatically.
.coNP Function @ dump-deferred-warnings
.synb
-.mets (dump-deferred-warning << stream )
+.mets (dump-deferred-warnings << stream )
.syne
.desc
The
@@ -42862,7 +54581,13 @@ and
.code hlet*
can be used instead. These macros create variable bindings whose storage is
always outside of the stack, and therefore the variables will exhibit
-consistent
+consistent interpreted and compiled semantics under continuations.
+All contexts which capture the same lexical binding of a given
+.cod3 hlet / hlet*
+variable share a single instance. The most recent assignment
+to the variable taking place in any context establishes its value,
+as seen by any other context. The resumption of a continuation will not restore
+such a variable to a previous value.
If the affected variables are other kinds of bindings such as
function parameters or variables created with specialized binding
@@ -42915,7 +54640,7 @@ returns whatever value
returns.
Resuming a continuation is done by invoking the continuation function.
-When this happens, the entire continuation context is restored by re-creating
+When this happens, the entire continuation context is restored by recreating
its captured evaluation frames on top of the current stack. Inside the
continuation, the
.code sys:capture-cont
@@ -42930,7 +54655,7 @@ evaluating the last form contained in the block. Secondly, can use
.code return-from
against its delimiting block to explicitly abandon all evaluations in between
and terminate that block. Or it may perform
-a non-local control transfer past the delimited block somewhere into the
+a nonlocal control transfer past the delimited block somewhere into the
evaluation frames of the caller. In the first two cases, the termination
of the block turns into an ordinary return from the continuation function, and
the result value of the terminated block becomes the return value of that
@@ -42987,7 +54712,7 @@ of special variables. That is to say, if
.code *var*
is a special variable, then a lexical closure created inside a
.code "(let ((*var* 42)) ...)"
-form will not capture the local re-binding of
+form will not capture the local rebinding of
.code *var*
which holds 42. When the closure is invoked and accesses
.codn *var* ,
@@ -43075,7 +54800,7 @@ that control will return into a restarted copy of that context.
.desc
The
.code sys:abscond*
-function is similar to the the
+function is similar to the
.code sys:abscond-from
operator, except that
.code name
@@ -43109,16 +54834,16 @@ The
.code obtain
and
.code yield-from
-macros closely inter-operate.
+macros closely interoperate.
The
.code obtain
macro treats zero or more
-.metn form -s
+.metn form s
as a suspendable execution context called the
.IR "obtain block" .
It is expected that
-.metn form -s
+.metn form s
establish a block named
.meta name
and return its result value to
@@ -43242,7 +54967,7 @@ function suspends execution and yields a question out of the
.code map
block. It then classifies
the item as a fruit or not according to the reply it receives. The reply
-emerges as a the result value of the
+emerges as the result value of the
.code yield-from
call.
@@ -43252,8 +54977,12 @@ macro converts the block to a generating function. The first call to the
function is made with no argument, because the argument would be ignored
anyway. The function returns a question, asking whether the first item
in the list, the potato, is a fruit.
-To answer negatively, the user calls the function again, passing in
-.codn nil .
+To answer positively or negatively, the user calls the function again,
+passing in
+.code t
+or
+.codn nil ,
+respectively.
The function returns the next question, which is answered in the
same manner.
@@ -43336,7 +55065,7 @@ and
.code obtain
into a single expression.
The
-.metn form -s
+.metn form s
are evaluated in a block named
.codn name .
@@ -43489,7 +55218,7 @@ is then evaluated in the scope of the variable
When the last
.meta body-form
-is evaluated, a non-local exit takes place to the block
+is evaluated, a nonlocal exit takes place to the block
named by
.meta block-name
(using the
@@ -43500,7 +55229,7 @@ When the continuation bound to
.meta var-name
is invoked, a copy of the entire block
.meta block-name
-is re-started, and in that copy, the
+is restarted, and in that copy, the
.code suspend
call appears to return normally, yielding the value which had been
passed to the continuation.
@@ -43521,13 +55250,14 @@ and
(defun amb (. args)
(suspend amb-scope cont
(each ((a args))
- (when (and a (call cont a))
- (return-from amb a)))))
+ (if a
+ (iflet ((r (call cont a)))
+ (return-from amb-scope r))))))
.brev
Use
.code amb
-to bind the of
+to bind the
.code x
and
.code y
@@ -43535,7 +55265,7 @@ which satisfy the predicate
.mono
.meti (eql (* x y) 8)
.onom
-non-deterministically:
+nondeterministically:
.verb
(amb-scope
@@ -43568,14 +55298,14 @@ The
in the names stands for "heap", serving as a mnemonic based on the
implementation concept of these bindings being "heap-allocated".
-.SS* Regular Expression Library
+.SS* Regular-Expression Library
-\*(TX provides a "pure" regular expression implementation based on automata
+\*(TX provides a "pure" regular-expression implementation based on automata
theory, which equates regular expressions, finite automata and sets of strings.
A regular expression determines whether or not a string of input characters
belongs to a set. \*(TX regular expressions do not support features such
-as as "anchoring" a match to the start or end of a string, or capture of
-parenthesized sub-expression matches into registers. Parenthesis syntax
+as "anchoring" a match to the start or end of a string, or capturing
+parenthesized subexpression matches into registers. Parenthesis syntax
denotes only grouping, with no additional meaning.
The semantics of whether a regular expression is used for a substring
@@ -43584,7 +55314,7 @@ the functions which use regular expressions to perform these operations.
.NP* Regular Expressions as Functions
.synb
-.mets >> [ regex >> [ start <> [ from-end ]] < string ]
+.mets >> [ regex >> [ start <> [ from-end ]] << string ]
.syne
.desc
A regular expression is callable as a function in \*(TL.
@@ -43597,7 +55327,7 @@ found, it returns
A regex takes one, two, or three arguments. The required
.meta string
is always the rightmost argument. This allows for convenient
-partial application of the optional arguments using
+partial application over optional arguments using
macros in the
.code op
family, and macros in which the
@@ -43651,7 +55381,7 @@ proceeds in reverse, from the position just beyond the last character of
toward
.metn start .
-if
+If
.meta start
exceeds the length of the string, then
.code search-regex
@@ -43863,7 +55593,7 @@ the matching substring of
.desc
The
.code regex-prefix-match
-determines whether the input string might
+determines whether the input string
might be the prefix of a string which matches regular expression
.metn regex .
@@ -43927,7 +55657,9 @@ and
.coNP Function @ regsub
.synb
-.mets (regsub >> { regex | << function } < replacement << string )
+.mets (regsub < regex < replacement << string )
+.mets (regsub < substring < replacement << string )
+.mets (regsub < function < replacement << string )
.syne
.desc
The
@@ -43936,10 +55668,14 @@ function operates in two modes, depending on whether
the first argument is a regular expression,
or function.
-If the first argument is a regular expression it searches
+If the first argument is a regular expression or string, then
+.code regsub
+searches
.meta string
for multiple occurrences of non-overlapping matches for that
-.metn regex .
+.meta regex
+or
+.metn substring .
A new string is constructed
similar to
.meta string
@@ -43975,7 +55711,7 @@ which indicates that no replacement is to take place.
.TP* Examples:
.verb
- ;; match every lower case e or o, and replace by filtering
+ ;; match every lowercase e or o, and replace by filtering
;; through the upcase-str function:
[regsub #/[eo]/ upcase-str "Hello world!"] -> "HEllO wOrld!"
@@ -43983,6 +55719,9 @@ which indicates that no replacement is to take place.
;; Replace Hello with Goodbye:
(regsub #/Hello/ "Goodbye" "Hello world!") -> "Goodbye world!"
+ ;; Same, as a simple substring match, rather than regex:
+ (regsub "Hello" "Goodbye" "Hello world!") -> "Goodbye world!"
+
;; Left-anchored replacement with r^ function:
(regsub (fr^ #/H/) "J" "Hello, hello!") -> "Jello, hello!"
.brev
@@ -43998,10 +55737,81 @@ function returns
.code t
if
.meta obj
-is a compiled regular expression
+is a compiled regular-expression
object. For any other object type, it returns
.codn nil .
+.coNP Functions @ trim-left and @ trim-right
+.synb
+.mets (trim-left >> { regex | << prefix } << string )
+.mets (trim-right >> { regex | << suffix } << string )
+.syne
+.desc
+The
+.code trim-left
+and
+.code trim-right
+functions return a new string, equivalent to
+.meta string
+with a leading or trailing portion removed.
+
+If the first argument is a regular expression
+.metn regex ,
+then, respectively,
+.code trim-left
+and
+.code trim-right
+find a prefix or suffix of
+.meta string
+which matches the regular expression.
+If there is no match, or if the match is empty, then
+.meta string
+is returned. Otherwise, a copy of
+.meta string
+is returned in which the matching characters are removed.
+If
+.meta regex
+matches all of
+.meta string
+then the empty string is returned.
+
+If the first argument is a character string, then it is treated
+as an exact match for that sequence of
+characters. Thus,
+.code trim-left
+interprets that string as a
+.meta prefix
+to be removed, and
+.code trim-right
+as a
+.metn suffix .
+If
+.meta string
+starts with
+.metn prefix ,
+then
+.code trim-left
+returns a copy of
+.meta string
+with
+.meta prefix
+removed. Otherwise,
+.meta string
+is returned.
+Likewise, if
+.meta string
+ends with
+.metn suffix ,
+then
+.code trim-right
+returns a copy of
+.meta string
+with
+.meta suffix
+removed. Otherwise,
+.meta string
+is returned.
+
.coNP Function @ regex-compile
.synb
.mets (regex-compile < form-or-string <> [ error-stream ])
@@ -44012,7 +55822,7 @@ The
function takes the source code of a regular expression,
expressed as a Lisp data structure representing an abstract syntax tree, or
else a regular expression specified as a character string, and compiles it to a
-regular expression object.
+regular-expression object.
If
.meta form-or-string
@@ -44042,7 +55852,7 @@ stream.
.TP* Examples:
.verb
- ;; the equivalent of #/[a-zA-Z0-9_/
+ ;; the equivalent of #/[a-zA-Z0-9_]/
(regex-compile '(set (#\ea . #\ez) (#\eA . #\eZ)
(#\e0 . #\e9) #\e_))
@@ -44083,12 +55893,12 @@ function parses a character string which contains a regular expression and
turns it into a Lisp data structure (the abstract syntax tree representation of
the regular expression).
-The regular expression syntax
+The regular-expression syntax
.code #/RE/
produces the same structure, but as a
literal which is processed at the time \*(TX source code is read; the
.code regex-parse
-function performs this parsing at run-time.
+function performs this parsing at run time.
If there are parse errors, the function returns
.codn nil .
@@ -44116,11 +55926,11 @@ which is suitable as input to
There is a small difference in the syntax accepted by
.code regex-parse
-and the syntax of regular expression literals. Any
+and the syntax of regular-expression literals. Any
.code /
(slash) characters occurring in any position within
.meta string
-are treated as ordinary characters, not as regular expression delimiters.
+are treated as ordinary characters, not as regular-expression delimiters.
The call
.mono
(regex-parse "/a/")
@@ -44145,6 +55955,51 @@ The double backslash in the string literal produces a single backslash
in the resulting string object that is processed by
.codn regex-parse .
+.coNP Function @ regex-optimize
+.synb
+.mets (regex-optimize << regex-tree-syntax )
+.syne
+.desc
+The
+.code regex-compile
+function accepts the source code of a regular expression,
+expressed as a Lisp data structure representing an abstract syntax tree,
+and calculates an equivalent structure in which certain simplifications
+have been performed, or in some cases substitutions which eliminate the
+dependence on derivative-based processing.
+
+The
+.meta regex-tree-syntax
+argument is assumed to be correct, as if it were produced by the
+.code regex-parse
+or
+.code regex-from-trie
+functions. Incorrect syntax produces unspecified results: an exception may be
+thrown, or some object may appear to be successfully returned.
+
+Note: it is unnecessary to call this function to prepare the input for
+.code regex-compile
+because that function optimizes internally. However, the source code attached
+to a compiled regular-expression object is the original unoptimized syntax
+tree, and that is used for rendering the
+.code #/.../
+notation when the object is printed. If the syntax is passed through
+.code regex-optimize
+before
+.codn regex-compile ,
+the resulting object will have the optimized code attached to it, and
+subsequently render that way in printed form.
+
+.TP* Examples:
+
+.verb
+ ;; a|b|c -> [abc]
+ (regex-optimize '(or #\ea (or #\eb #\ec))) -> (set #\ea #\eb #\ec)
+
+ ;; (a|) -> a?
+ (regex-optimize '(or #\ea nil)) -> (? #\ea)
+.brev
+
.coNP Function @ read-until-match
.synb
.mets (read-until-match < regex >> [ stream <> [ include-match ]])
@@ -44183,7 +56038,7 @@ If
matches the stream before any characters are accumulated,
then an empty string is returned.
-If the stream ends or an non-exception-throwing error occurs before any
+If the stream ends or a non-exception-throwing error occurs before any
characters are accumulated, the function returns
.codn nil .
@@ -44195,7 +56050,7 @@ removed from the stream. If
is true, that matching text is included in
the returned string. Otherwise, it is discarded.
The next available character in the stream is the first
-non-matching character following the matched text.
+nonmatching character following the matched text.
However, the next available character, as well as some number of
subsequent characters, may originate from the stream's push-back buffer,
rather than from the underlying operating system object,
@@ -44252,7 +56107,7 @@ The text matched by
.meta regex
is as long as possible, and is removed from the stream.
The next available character in the stream is the first
-non-matching character following the matched text.
+nonmatching character following the matched text.
However, the next available character, as well as some number of
subsequent characters, may originate from the stream's push-back buffer,
rather than from the underlying operating system object,
@@ -44270,9 +56125,9 @@ is unspecified.
.syne
.desc
These functions provide functionality similar to the
-.meta match-regst
+.code match-regst
and
-.meta match-regst-right
+.code match-regst-right
functions, but under alternative interfaces which are more
convenient.
@@ -44281,7 +56136,7 @@ The
and
.code $
notation used in their names are an allusion to the
-regular expression search anchoring operators found in
+regular-expression search-anchoring operators found in
familiar POSIX utilities such as
.codn grep .
@@ -44536,7 +56391,7 @@ If this situation is true of
.metn end ,
then
.meta end
-is is curtailed to the the string length.
+is curtailed to the string length.
The
.code rra
@@ -44552,7 +56407,7 @@ character. If so, these are included.
.mets (f$ < regex <> [ end-position ])
.syne
.desc
-These regular expression functions do not directly
+These regular-expression functions do not directly
perform regex operations. Rather, they each return
a function of one argument which performs a regex
operation.
@@ -44632,7 +56487,7 @@ and
.mets (frr < regex <> [[ start-position ] << from-end ])
.syne
.desc
-These regular expression functions do not directly
+These regular-expression functions do not directly
perform regex operations. Rather, they each return
a function of one argument which performs a regex
operation.
@@ -44651,7 +56506,7 @@ functions on the right side produced by op
can accept additional arguments after the input string,
whereas the functions on the left produced by
.code f^$
-.I "et al."
+et al.
accept only one parameter: the input string.
.verb
@@ -44705,7 +56560,7 @@ and
.SS* Hashing Library
A hash table is an object which retains an association between pairs of
-objects. Each pair consists of a key and value. Given an object which is
+objects. Each pair consists of a key and a value. Given an object which is
similar to a key in the hash table, it is possible to retrieve the
corresponding value. Entries in a hash table are not ordered in any way, and
lookup is facilitated by hashing: quickly mapping a key object to a numeric
@@ -44716,8 +56571,10 @@ In addition to keys and values, a hash table contains a storage location
which allows it to be associated with user data.
Important to the operation of a hash table is the criterion by which keys are
-considered same. By default, this similarity follows the eql function. A hash
-table will search for a stored key which is
+considered same. By default, this similarity follows the
+.code eql
+function.
+A hash table will search for a stored key which is
.code eql
to the given search key.
A hash table constructed with the
@@ -44745,7 +56602,7 @@ requiring protection against collision attacks may use
to create a randomized hash seed, and, depending on their specific need, either
store that value in
.codn *hash-seed* ,
-or pass the value to hash table constructors like
+or pass the value to hash-table constructors like
.codn make-hash ,
or both.
Note: randomization of hash seeding isn't a default behavior because it affects
@@ -44780,14 +56637,24 @@ collector. That is to say, when the garbage collector discovers that the only
references to some object are weak references, then that object is considered
garbage, just as if it had no references to it. The object is reclaimed, and
the weak references "lapse" in some way, which depends on what kind they are.
-Hash table weak references lapse by entry removal. When an object used
-as a key in in one or more weak-key hash tables becomes unreachable, those
-hash entries disappear. Similarly, when an object appearing as a value in
-one or more hash table entries in weak-value hash tables becomes unreachable,
-those entries disappear. When a hash table has both weak keys and weak values,
-then its entries are removed when either keys or values become unreachable.
-In other words, both the key and value must be reachable in order to
-retain the entry.
+Hash-table weak references lapse by entry removal. When an object used
+as a key in one or more weak-key hash tables becomes unreachable, those hash
+entries disappear. This happens even if the values are themselves reachable.
+Vice versa, when an object appearing as a value in one or more weak-value hash
+tables becomes unreachable, those entries disappear, even if the keys are
+reachable. When a hash table has both weak keys and weak values, then an
+the behavior is one of two possible semantics. Under the
+.codn or -semantics,
+the hash table entry is removed if either the key or the value is unreachable.
+Under the
+.codn and -semantics,
+the entry is removed only if both the key and value are unreachable.
+
+If the keys of a weak-key hash table are reachable from the values, or if the
+values of a weak-key hash table are reachable from the keys, then the weak
+semantics is defeated for the affected entries: the hash table retains those
+entries as if it were an ordinary table. A hash table with both weak keys and
+values does not have this issue, regardless of its semantics.
An open traversal of a hash table is performed by the
.code maphash
@@ -44830,7 +56697,7 @@ becomes unspecified.
.synb
.mets (make-hash < weak-keys < weak-vals
.mets \ \ \ \ \ \ \ \ \ \ < equal-based <> [ hash-seed ])
-.mets (hash {:weak-keys | :weak-vals |
+.mets (hash {:weak-keys | :weak-vals | :weak-or | :weak-and
.mets \ \ \ \ \ \ :eql-based | :equal-based |
.mets \ \ \ \ \ \ :eq-based | :userdata << obj }*)
.syne
@@ -44838,7 +56705,7 @@ becomes unspecified.
These functions construct a new hash table.
.code make-hash
-takes three mandatory Boolean arguments. The
+takes three mandatory Boolean arguments. The Boolean
.meta weak-keys
argument specifies whether the hash table shall have weak keys. The
.meta weak-vals
@@ -44846,9 +56713,44 @@ argument specifies whether it shall have weak values, and
.meta equal-based
specifies whether it is
.codn equal -based.
-The hash function defaults
-all three of these properties to false, and allows them to be overridden to
-true by the presence of keyword arguments.
+
+If the
+.meta weak-keys
+argument is one of the keywords
+.code :weak-and
+or
+.code :weak-or
+then the hash table shall have both weak keys and weak values, with the
+semantics implied by the keyword:
+.code :weak-and
+specifies
+.codn and -semantics
+and
+.code :weak-or
+specifies
+.codn or -semantics.
+The
+.meta weak-vals
+argument is then ignored.
+
+If both
+.meta weak-keys
+and
+.meta weak-vals
+are true, and
+.meta weak-keys
+is not one of the keywords
+.code :weak-and
+or
+.codn :weak-or ,
+then the hash table has
+.codn or -semantics.
+
+The
+.code hash
+function defaults all three of these properties to false,
+and allows them to be overridden to true
+by the presence of keyword arguments.
The optional
.meta hash-seed
@@ -44872,6 +56774,8 @@ function provides an alternative interface. It accepts optional
keyword arguments. The supported keyword symbols are:
.codn :weak-keys ,
.codn :weak-vals ,
+.codn :weak-and ,
+.codn :weak-or ,
.codn :equal-based ,
.code :eql-based
.code :eq-based
@@ -44898,11 +56802,33 @@ function produces an
hash table by default.
If
-.code :weak-keys
+.codn :weak-keys ,
+.code :weak-and
+or
+.code :weak-or
is specified, then
.code :equal-based
may not be specified.
+At most one of
+.code :weak-and
+or
+.code :weak-or
+may be specified. If either of these is specified, then the
+.code :weak-keys
+and
+.code :weak-vals
+keywords are redundant and unnecessary.
+
+If
+.code :weak-keys
+and
+.code :weak-vals
+are both specified, and
+.code :weak-and
+isn't specified, the situation is equivalent to
+.codn :weak-or .
+
If
.code :userdata
is present, it must be followed by an argument value; that value
@@ -44929,7 +56855,8 @@ The
.code hash-construct
function constructs a populated hash in one step. The
.meta hash-args
-argument specifies a list suitable as an argument list in a call to the hash
+argument specifies a list suitable as an argument list in a call to the
+.code hash
function. The
.meta key-val-pairs
is a sequence of pairs, which are two-element
@@ -45015,8 +56942,64 @@ If
.meta key-seq
is longer than
.metn value-seq ,
-then the excess keys are ignored, and
-.IR "vice versa" .
+then the excess keys are ignored, and vice versa.
+
+.coNP Function @ hash-props
+.synb
+.mets (hash-props >> { key << value }*)
+.syne
+.desc
+The
+.code hash-props
+function constructs a populated hash table without requiring
+the caller to construct a list of entries. The hash table
+contents are specified as direct arguments.
+
+The
+.code hash-props
+function requires an even number of arguments, which
+are interleaved key-value pairs.
+
+The returned hash table is
+.codn equal -based,
+and no parameters are available for customizing any of
+its properties, such as weakness.
+
+.coNP Function @ hash-map
+.synb
+.mets (hash-map < function < sequence << hash-arg *)
+.syne
+.desc
+The
+.code hash-map
+function constructs a a hash table from a
+.meta sequence
+of keys and a
+.meta function
+which maps them to values.
+
+The
+.meta function
+argument must be a function that can be called with one argument.
+
+The elements of
+.meta sequence
+become the keys of the returned hash table. The value associated with each key
+is determined by passing that value to function
+.meta fun
+and taking the returned value.
+
+The remaining
+.meta hash-arg
+arguments determine what kind of hash table is created,
+as if the
+.code hash
+function were applied to them.
+
+If the sequence contains duplicate elements (according to the
+hash table equality in effect for the hash table being
+constructed), duplicate elements later in the sequence
+replace earlier elements.
.coNP Function @ hash-update
.synb
@@ -45081,22 +57064,22 @@ with the value returned by
as the datum. This value
is also returned.
-.coNP Function @ group-by
+.coNP Functions @ group-by and @ group-map
.synb
-.mets (group-by < func < sequence << option *)
+.mets (group-by < by-fun < sequence << option *)
+.mets (group-map < by-fun < filter-fun < sequence << option *)
.syne
.desc
The
.code group-by
function produces a hash table from
-.metn sequence ,
-which is a
-list or vector. Entries of the hash table are not elements of
+.metn sequence .
+Entries of the hash table are not elements of
.metn sequence ,
but lists of elements of
.metn sequence .
The function
-.meta func
+.meta by-fun
is applied to
each element of
.meta sequence
@@ -45107,20 +57090,52 @@ The trailing arguments
.mono
.meti << option *
.onom
-if any, consist of the same keywords
-that are understood by the hash function, and determine the properties
-of the hash.
+if any, consist of the same keywords that are understood by the
+.code hash
+function, and determine the properties of the hash.
-.TP* Example:
+The
+.code group-map
+fun extends the semantics of
+.code group-by
+with a filtering step. It groups the elements of
+.meta sequence
+in exactly the same manner, using
+.metn by-fun .
+These lists of elements are then passed to
+.meta filter-fun
+whose return values become the values associated with the hash table keys.
+
+The effect of
+.code group-map
+may be obtained by a combination of
+.code group-by
+and
+.code hash-update
+according to the following equivalence:
+
+.verb
+ (group-map bf ff seq) <--> (let ((h (group-by bf seq)))
+ (hash-update h ff))
+.brev
+
+.TP* Examples:
Group the integers from 0 to 10 into three buckets keyed on 0, 1 and 2
according to the modulo 3 congruence:
.verb
- (group-by (op mod @1 3) (range 0 10)))
-
+ (group-by (op mod @1 3) 0..11)
-> #H(() (0 (0 3 6 9)) (1 (1 4 7 10)) (2 (2 5 8)))
.brev
+Same as above, but associate the keys with the sums of the
+buckets:
+
+.verb
+ [group-map (op mod @1 3) sum 0..11]
+ -> #H(() (0 18) (1 22) (2 15))
+.brev
+
.coNP Function @ group-reduce
.synb
.mets (group-reduce < hash < classify-fun < binary-fun < seq
@@ -45199,13 +57214,81 @@ Frequency histogram:
(#\eu 1) (#\ev 1) (#\ey 1))
.brev
-Separate the integers 1-10 into even and odd, and sum these groups:
+Separate the integers 1\(en10 into even and odd, and sum these groups:
.verb
- [group-reduce (hash) evenp + (range 1 10) 0]
+ [group-reduce (hash) evenp + 1..11 0]
-> #H(() (t 30) (nil 25))
.brev
+.coNP Functions @ hist-sort and @ hist-sort-by
+.synb
+.mets (hist-sort < sequence << option *)
+.mets (hist-sort-by < by-fun < sequence << option *)
+.syne
+.desc
+The
+.code hist-sort
+function produces a histogram in the form of an association list,
+which is sorted in descending order of frequency. The keys in the
+association list are elements of
+.meta sequence
+and the values are the frequency values: positive integers
+indicating how many times the keys occur in
+.metn sequence .
+
+Note: for a description of association lists, see the
+.code assoc
+function, and the section Association Lists in which its description is
+contained.
+
+The
+.code hist-sort
+function works by internally constructing a hash table, which is not
+returned. Elements of
+.meta sequence
+serve as keys in that hash. The trailing arguments
+.mono
+.meti << option *
+.onom
+if any, consist of the same keywords that are understood by the
+.code hash
+function, and determine the properties of that hash.
+
+The
+.code hist-sort-by
+function differs from
+.code hist-sort
+in that it requires an additional argument
+.meta by-fun
+with the following semantics: every element of
+.meta sequence
+is passed to
+.meta by-fun
+such that the resulting value is used as the hash key in the resulting
+histogram.
+
+Thus, an invocation of
+.code hist-sort
+is equivalent to an invocation of
+.code hist-sort-by
+where the
+.meta by-fun
+argument is specified as the
+.code identity
+function.
+
+.TP* Examples
+
+.verb
+(hist-sort nil) -> nil
+
+(hist-sort '(3 4 5)) -> ((3 . 1) (4 . 1) (5 . 1))
+
+(hist-sort '("a" "b" "c" "a" "b" "a" "b" "a"))
+-> (("a" . 4) ("b" . 3) ("c" . 1))
+.brev
+
.coNP Functions @ make-similar-hash and @ copy-hash
.synb
.mets (make-similar-hash << hash )
@@ -45214,7 +57297,9 @@ Separate the integers 1-10 into even and odd, and sum these groups:
.desc
The
.code make-similar-hash
-and copy-hash functions create a new hash object based on
+and
+.code copy-hash
+functions create a new hash object based on
the existing
.meta hash
object.
@@ -45231,11 +57316,12 @@ function).
The
.code copy-hash
-function is like
-.codn make-similar-hash ,
-except that instead of
-producing an empty hash table, it produces one which has all the same elements
-as
+also produces a hash table similar to
+.metn hash ,
+in the same way as
+.codn make-similar-hash .
+However, rather than producing producing an empty hash table, it returns a
+duplicate table which has all the same elements as
.metn hash :
it contains the same key and value objects.
@@ -45399,7 +57485,7 @@ value is added to the front of that list,
and the extended list then becomes the new value under
.metn key .
-The return value is Boolean. If true, indicates that the hash table entry was
+The return value is Boolean. If true, indicates that the hash-table entry was
newly created. If false, it indicates that the push took place on an existing
entry.
@@ -45429,7 +57515,7 @@ is returned.
.desc
The
.code clearhash
-function removes all keys-value pairs from
+function removes all key-value pairs from
.metn hash ,
causing it to be empty.
@@ -45467,7 +57553,7 @@ function retrieves the user data object associated with
A hash table can be created with user data using the
.code :userdata
-keyword in a hash table literal or in a call to the
+keyword in a hash-table literal or in a call to the
.code hash
function, directly, or via other hash-constructing functions which take the
hash construction keywords, such as
@@ -45525,7 +57611,7 @@ otherwise it returns
.coNP Function @ maphash
.synb
-.mets (maphash < hash << binary-function )
+.mets (maphash < binary-function << hash )
.syne
.desc
The
@@ -45536,14 +57622,15 @@ for each entry stored in
.metn hash .
Each entry's key and value are passed as arguments
to
-.codn binary-function .
+.metn binary-function .
The function returns
.codn nil .
-.coNP Function @ hash-revget
+.coNP Functions @ hash-revget and @ hash-keys-of
.synb
.mets (hash-revget < hash < value >> [ testfun <> [ keyfun ]])
+.mets (hash-keys-of < hash < value >> [ testfun <> [ keyfun ]])
.syne
.desc
The
@@ -45565,6 +57652,14 @@ If multiple matching entries exist, it is not specified which entry's
key is returned.
The
+.code hash-keys-of
+function has exactly the same argument conventions, and likewise
+searches the
+.metn hash .
+However, it returns a list of all keys whose values match
+.metn value .
+
+The
.meta keyfun
function is applied to each value in
.meta hash
@@ -45582,12 +57677,12 @@ The comparison is performed using
The default
.meta testfun
is the
-.code eql
+.code equal
function.
.coNP Function @ hash-invert
.synb
-.mets (hash-invert >> hash >> [ joinfun >> [ unitfun << hash-arg *]])
+.mets (hash-invert < hash >> [ joinfun >> [ unitfun << hash-arg *]])
.syne
.desc
The
@@ -45724,11 +57819,13 @@ The optional
.meta hash-seed
value perturbs the hashing function used by
.code hash-equal
-for strings and buffer objects. This seed value must be a non-negative integer
-no wider than 32 bits: that is, in the range 0 to 4294967295.
-If the value isn't specified, it defaults to zero.
-Effectively, each possible value of the seed specifies a different hashing
-function. If two objects
+for strings and buffer objects. This seed value must be a nonnegative integer
+no wider than 64 bits: that is, in the range 0 to 18446744073709551615.
+If the value isn't specified, it defaults to zero. On systems with 32-bit
+addresses, only the low 32 bits of this value may be significant.
+
+Effectively, each possible value of the significant part of the seed specifies
+a different hashing function. If two objects
.code A
and
.code B
@@ -45741,7 +57838,14 @@ and
each produce the same integer hash value for any valid seed value
.codn S .
-.coNP Functions @, hash_keys @, hash_values @ hash_pairs and @ hash_alist
+The value returned is a
+.code fixnum
+value, and may be negative. It may be any value in the range
+.code fixnum-min
+to
+.codn fixnum-max .
+
+.coNP Functions @, hash-keys @, hash-values @ hash-pairs and @ hash-alist
.synb
.mets (hash-keys << hash )
.mets (hash-values << hash )
@@ -45801,13 +57905,13 @@ The
operator iterates over a hash table. The
.meta hash-form
expression must
-evaluate to an object of hash table type. The
+evaluate to an object of hash-table type. The
.meta key-var
and
.meta value-var
arguments must be symbols suitable for use as variable names.
Bindings are established for these variables over the scope of the
-.metn body-form -s
+.metn body-form s
and the optional
.metn result-form .
@@ -45831,7 +57935,7 @@ the return value is
The
.meta result-form
and
-.metn body-form -s
+.metn body-form s
are in the scope of an implicit anonymous
block, which means that it is possible to terminate the execution of
dohash early using
@@ -45843,7 +57947,8 @@ or
.coNP Functions @, hash-uni @, hash-diff @ hash-symdiff and @ hash-isec
.synb
-.mets (hash-uni < hash1 < hash2 >> [ joinfun >> [ map1fun <> [ map2fun ]]])
+.mets (hash-uni < hash1 < hash2 >> [ joinfun >> [ map1fun <> [ map2fun ]]])
+.mets (hash-join < hash1 < hash2 < joinfun >> [ hash1dfl <> [ hash2dfl ]])
.mets (hash-diff < hash1 << hash2 )
.mets (hash-symdiff < hash1 << hash2 )
.mets (hash-isec < hash1 < hash2 <> [ joinfun ])
@@ -45908,7 +58013,51 @@ Similarly, if
.meta map2fun
is present, specifies a function through which values from
.meta hash2
-are projected.
+are projected. These two functions are independent of
+.metn joinfun ;
+they are applied to values without regard for whether their
+keys exist in both hashes or just one.
+
+The
+.code hash-join
+function performs a union operation similar to, but usefully different from
+.codn hash-uni .
+The
+.meta joinfun
+argument is mandatory in
+.codn hash-join ,
+and is applied to all items, regardless of whether they are present
+in just one hash or both hashes.
+The arguments
+.meta hash1dfl
+and
+.meta hash2dfl
+specify default values used in invocations of
+.meta joinfun
+for keys that are present only in one hash. These values default to
+.codn nil .
+For every key that is present only in
+.metn hash1 ,
+.meta joinfun
+is invoked with that key's value as its left argument, and the
+.meta hash2dfl
+value as the right argument.
+Conversely, for every key that is present only in
+.metn hash2 ,
+.meta joinfun
+is invoked with the
+.meta hash1dfl
+value as the left argument,
+and that key's value as its right argument.
+For every key that is present in both hashes,
+.meta joinfun
+is invoked with the values, respectively, from
+.meta hash1
+and
+.metn hash2 .
+The returned hash contains all the keys from both hashes,
+associated with the values returned by
+.metn joinfun .
The
.code hash-diff
@@ -45928,8 +58077,7 @@ contains all of the keys from
.meta hash1
that are not in
.meta hash2
-and
-.IR "vice versa" :
+and vice versa:
all of the keys from
.meta hash2
that are not in
@@ -46084,7 +58232,7 @@ remains unvisited by the iterator.
The
.code with-hash-iter
macro evaluates
-.metn body-form -s
+.metn body-form s
in an environment in which a lexically scoped function is visible.
The function is named by
@@ -46094,10 +58242,10 @@ which must be a symbol suitable for naming functions with
The
.meta hash-form
-argument must be a form which evaluates to a hash table object.
+argument must be a form which evaluates to a hash-table object.
Invocations of the function retrieve successive entries of the hash table
-as cons cell pairs of keys and values. The function returns
+as cons-cell pairs of keys and values. The function returns
.code nil
to indicate no more entries remain.
@@ -46107,7 +58255,7 @@ or
.meta vsym
arguments are present, they must be symbols suitable as variable names. They
are bound as variables visible to
-.metn body-form -s,
+.metn body-form s,
initialized to the value
.codn nil .
@@ -46115,7 +58263,7 @@ If
.meta ksym
is specified, then whenever the function
.meta isym
-macro is invoked and retrieves a hash table entry, the
+macro is invoked and retrieves a hash-table entry, the
.meta ksym
variable is set to the key. If the function returns
.code nil
@@ -46132,7 +58280,7 @@ to
.code nil
if there is no next value.
-.coNP Special variable @ *hash-seed*
+.coNP Special Variable @ *hash-seed*
.desc
The
.code *hash-seed*
@@ -46156,12 +58304,14 @@ hash tables make use of their seed, and only for keys which are strings and
buffers. The purpose of the seed is to scramble the hashing function, to make
a hash table resistant to a type of denial-of-service attack, whereby a
malicious input causes a hash table to be populated with a large number of keys
-which all map to the same hash table chain, causing the performance to severely
+which all map to the same hash-table chain, causing the performance to severely
degrade.
The value of
.code *hash-seed*
-must be a non-negative integer, no wider than 32 bits.
+must be a nonnegative integer, no wider than 64 bits.
+On systems with 32-bit addresses, only the least significant 32 bits of
+this value may be significant.
.coNP Function @ gen-hash-seed
.synb
@@ -46233,9 +58383,29 @@ objects as arguments or return
.code tnode
objects.
+Trees may store duplicate elements. The
+.code #T
+literal syntax may freely specify duplicate elements.
+The
+.code tree
+constructor function specifies an initial sequence of elements to
+be populated into the newly constructed tree. If this initial
+sequence contains duplicate elements, they are preserved if the optional
+.meta allow-dupes
+argument is true, otherwise only the rightmost member of any duplicate
+group appears in the tree.
+
+The insertion functions
+.code tree-insert
+and
+.code tree-insert-node
+also overwrite duplicates by default, but optionally allow them.
+Duplicates are ordered by insertion: most recently inserted duplicate
+is rightmost. However, tree lookup chooses an unspecified duplicate.
+
.coNP Function @ tnode
.synb
-.mets (tnode < key < left << right)
+.mets (tnode < key < left << right )
.syne
.desc
The
@@ -46271,7 +58441,6 @@ is a tree node. Otherwise, it returns
.mets (key << node )
.mets (left << node )
.mets (right << node )
-.mets (set (car << object ) << new-value )
.mets (set (key << node ) << new-key )
.mets (set (left << node ) << new-left )
.mets (set (right << node ) << new-right )
@@ -46349,7 +58518,7 @@ The
.code copy-tnode
function creates a new
.code tnode
-objects, whose
+object, whose
.codn key ,
.code left
and
@@ -46359,7 +58528,8 @@ fields are copied from
.coNP Function @ tree
.synb
-.mets (tree >> [ elems >> [ keyfun >> [ lessfun <> [ equalfun ]]]])
+.mets (tree >> [ elems
+.mets \ \ \ \ \ \ >> [ keyfun >> [ lessfun >> [ equalfun <> [ allow-dupes ]]]])
.syne
.desc
The
@@ -46375,7 +58545,7 @@ tree is created.
The
.meta keyfun
argument specifies the function which is applied to every element
-to produce a key. If omitted, the the tree object shall behave as if the
+to produce a key. If omitted, the tree object shall behave as if the
.code identity
function were used, taking the elements themselves to be keys.
@@ -46404,6 +58574,44 @@ properties of an equivalence relation.
These three functions are collectively referred to as the tree's
.IR "key abstraction functions" .
+The
+.meta allow-dupes
+argument, which defaults to
+.codn nil ,
+is relevant if an
+.meta elems
+sequence is specified containing some elements which which appear to be
+duplicates, according to the tree object's
+.meta equalfun
+function. If
+.meta allow-dupes
+is true then duplicates are preserved: the tree will have as many nodes as
+there are elements in the
+.meta elems
+sequence. Moreover, the duplicates appear in the same relative order in
+the tree as they appear in the original
+.meta elems
+sequence.
+If
+.meta allow-dupes
+is false, then duplicates are suppressed: if any element appears more
+than once in
+.metn elements ,
+then only the last occurrence of that element appears in the tree.
+
+Note: the
+.code tree-insert
+and
+.code tree-insert-node
+functions also has an optional argument indicating whether a duplicate
+insertion replaces an existing element.
+
+Note: although the order of duplicate elements is preserved, when the
+.code tree-lookup
+function is used look up a key which is duplicated, the element
+which is retrieved is unspecified, and can change when the tree is
+reorganized due to insertions and deletions.
+
.coNP Function @ treep
.synb
.mets (treep << value )
@@ -46418,9 +58626,21 @@ if
is a tree. Otherwise, it returns
.codn nil .
+.coNP Function @ tree-count
+.synb
+.mets (tree-count << tree )
+.syne
+.desc
+The
+.code tree-count
+function returns an integer indicating the number of nodes currently
+inserted into
+.metn tree ,
+which must be a search tree object.
+
.coNP Function @ tree-insert-node
.synb
-.mets (tree-insert-node < tree << node )
+.mets (tree-insert-node < tree < node <> [ allow-dupe ])
.syne
.desc
The
@@ -46446,7 +58666,7 @@ object holds the element that is being inserted. The actual search key
which is associated with this element is determined by applying
.metn tree 's
.meta keyfun
-to the the
+to the
.metn node 's
.code key
value.
@@ -46463,11 +58683,31 @@ fields of
are overwritten as required by the semantics of the insertion operation.
Their original values are ignored.
+The
+.meta allow-dupe
+argument, defaulting to
+.codn nil ,
+is concerned with what happens if the tree already contains one or more
+nodes having a key equal to the
+.metn node 's
+key.
If
-.meta tree
-already contains node with with a matching key, then
+.meta allow-dupe
+is false, then
.meta node
-replaces that node; that node is deleted from the tree.
+replaces an unspecified one of those existing nodes: that replaced node is
+deleted from the tree. Key equivalence is determined using tree's equality
+function (see the
+.meta equalfun
+argument of the
+.code tree
+function).
+If
+.meta allow-dupe
+is true, then the new node is inserted without replacing any node, and
+appears together with the existing duplicate or duplicates. Among
+the duplicates, the newly inserted node is the rightmost node in the
+tree order.
The
.code tree-insert-node
@@ -46475,9 +58715,9 @@ function returns the
.meta node
argument.
-.coNP Function @ tree-insert-node
+.coNP Function @ tree-insert
.synb
-.mets (tree-insert < tree << elem )
+.mets (tree-insert < tree < elem <> [ allow-dupe ])
.syne
.desc
The
@@ -46512,6 +58752,17 @@ as if by using the
.code tree-insert-node
function.
+If one or more elements equal to
+.meta elem
+already exist in the tree, then the behavior is determined by the
+.meta allow-dupe
+argument, which defaults to
+.codn nil .
+The semantics of
+.meta allow-dupe
+is as given in the description of
+.codn tree-insert-node .
+
The
.code tree-insert
function returns the newly inserted
@@ -46562,6 +58813,9 @@ If no such element is found, then
returns
.codn nil .
+If multiple nodes exist in the tree which have a matching key,
+it is unspecified which one of those nodes is retrieved.
+
.coNP Function @ tree-lookup
.synb
.mets (tree-lookup < tree << key )
@@ -46590,6 +58844,10 @@ A possible implementation is this:
(key node)))
.brev
+If the tree contains multiple elements which match
+.metn key ,
+it is unspecified which element is retrieved.
+
.coNP Function @ tree-delete-node
.synb
.mets (tree-delete-node < tree << key )
@@ -46620,6 +58878,12 @@ Otherwise, if a matching element is not found, then
.code nil
is returned.
+If more than one element exists inside
+.meta tree
+which matches
+.metn key ,
+it is unspecified which node is deleted and returned.
+
.coNP Function @ tree-delete
.synb
.mets (tree-delete < tree << key )
@@ -46635,6 +58899,12 @@ the element which matches
If successful, it returns that element, otherwise it returns
.codn nil .
+If more than one element exists inside
+.meta tree
+which matches
+.metn key ,
+it is unspecified which one is deleted.
+
Note: the semantics of the
.code tree-delete
function can be understood in terms of
@@ -46647,9 +58917,93 @@ A possible implementation is this:
(key node)))
.brev
+.coNP Function @ tree-delete-specific-node
+.synb
+.mets (tree-delete-specific-node < tree << node )
+.syne
+.desc
+The
+.code tree-delete-specific-node
+function searches
+.meta tree
+to find the specific node given by the
+.meta node
+argument. If
+.meta node
+is inserted into the tree, then it is deleted, and returned.
+
+If
+.meta node
+is not found in the tree, then the tree is unchanged, and
+.code nil
+is returned.
+
+Note: the search for
+.meta node
+is informed by
+.metn node 's
+key, for efficiency. However, if the tree contains duplicates of that key, then
+a linear search takes place among the duplicates.
+
+.coNP Functions @ tree-min-node and @ tree-min
+.synb
+.mets (tree-min-node << tree )
+.mets (tree-min << tree )
+.syne
+.desc
+The
+.code tree-min-node
+function returns the node in
+.meta tree
+which holds the lowest element. If the tree is empty, it returns
+.codn nil .
+
+The
+.code tree-min
+function returns the lowest element, or else
+.code nil
+if the tree is empty.
+
+.coNP Functions @ tree-del-min-node and @ tree-del-min
+.synb
+.mets (tree-del-min-node << tree )
+.mets (tree-del-min << tree )
+.syne
+.desc
+The
+.code tree-del-min-node
+function returns the node in
+.meta tree
+which has the lowest key, and removes that node from the tree.
+If the tree is empty, it returns
+.codn nil .
+
+The
+.code tree-del-min
+function returns the lowest element and removes it from the tree, or else
+.code nil
+if the tree is empty.
+
+The following equivalence holds:
+
+.verb
+ (tree-del-min tr) <--> (iflet ((node (tree-del-min-node tr)))
+ (key node))
+.brev
+
+Note:
+.code tree-insert
+together with
+.code tree-del-min
+provide the basis for using a tree as a priority queue. Elements are
+inserted into the queue using
+.code tree-insert
+and then removed in priority order using
+.codn tree-del-min .
+
.coNP Function @ tree-root
.synb
-.mets (tree-root < tree )
+.mets (tree-root << tree )
.syne
.desc
The
@@ -46668,7 +59022,7 @@ is returned.
.coNP Function @ tree-clear
.synb
-.mets (tree-root < tree )
+.mets (tree-clear << tree )
.syne
.desc
The
@@ -46708,58 +59062,229 @@ and contains the same elements.
The nodes held inside the new tree are freshly allocated,
but their key objects are shared with the original tree.
+.coNP Function @ make-similar-tree
+.synb
+.mets (make-similar-tree << tree )
+.syne
+.desc
+The
+.code copy-search-tree
+returns a new, empty search tree object.
+
+The
+.meta tree
+argument must be an object of type
+.codn tree .
+
+The returned object has the same key abstraction functions as
+.metn tree .
+
.coNP Function @ tree-begin
.synb
-.mets (tree-begin < tree )
+.mets (tree-begin < tree >> [ low-key <> [ high-key ]])
.syne
.desc
The
.code tree-begin
function returns a new object of type
.code tree-iter
-which provides in-order traversal of the elements stored in the tree.
+which provides in-order traversal of nodes stored in
+.metn tree .
The
.meta tree
argument must be an object of type
.codn tree .
-Note: the elements are traversed by applying the
+If the
+.meta low-key
+argument is specified, then nodes with keys lesser than
+.meta low-key
+are omitted from the traversal.
+
+If the
+.meta high-key
+argument is specified, then nodes with keys equal to
+or greater than
+.meta high-key
+are omitted from the traversal.
+
+The nodes are traversed by applying the
.code tree-next
-function to the
+function to the returned
.code tree-iter
object.
-.coNP Function @ tree-next
+A
+.code tree-iter
+object is iterable.
+
+.TP* Example:
+
+.verb
+ (collect-each ((el (tree-begin #T(() 1 2 3 4 5)
+ 2 5)))
+ (* 10 el))
+ --> (20 30 40)
+.brev
+
+.coNP Function @ tree-reset
.synb
-.mets (tree-next < iter )
+.mets (tree-reset < iter < tree >> [ low-key <> [ high-key ]])
+.syne
+.desc
+The
+.code tree-reset
+functions is closely analogous to
+.codn tree-begin .
+
+The
+.meta iter
+argument must be an existing
+.code tree-iter
+object, previously returned by a call to
+.codn tree-begin .
+
+Regardless of its current state, the
+.meta iter
+object is re-initialized to traverse the specified
+.meta tree
+with the specified parameters, and is then returned.
+
+The
+.code tree-reset
+function prepares
+.meta iter
+to traverse in the same manner as would new iterator returned by
+.code tree-begin
+for the specified
+.metn tree ,
+.meta low-key
+and
+.meta high-key
+arguments.
+
+.coNP Functions @ tree-next and @ tree-peek
+.synb
+.mets (tree-next << iter )
+.mets (tree-peek << iter )
.syne
.desc
The
.code tree-next
+and
+.code tree-peek
function returns the next node in sequence from the tree iterator
-.metn iter ,
-which must be an object of type
-.codn tree-iter .
-Note: the
+.metn iter .
+The iterator must be an object of type
+.codn tree-iter ,
+returned by the
.code tree-begin
-function returns such a
-.code tree-iter
-object.
+function.
-If there are no more nodes to be visited, the function returns
+If there are no more nodes to be visited, these functions
.codn nil .
If, during the traversal of a tree, nodes are inserted or deleted,
the behavior of
.code tree-next
+and
+.code tree-peek
on
.code tree-iter
-object that were obtained prior to the insertion or deletion is
+objects that were obtained prior to the insertion or deletion is
not specified. An attempt to complete the iteration may not successfully
visit all keys that should be visited.
-.coNP Special variable @ *tree-fun-whitelist*
+The
+.code tree-next
+function changes the state of the iterator. If
+.code tree-next
+is invoked repeatedly on the same iterator, it returns successive
+nodes of the tree.
+
+If
+.code tree-peek
+is invoked more than once on the same iterator without any intervening calls to
+.codn tree-next ,
+it returns the same node; it does not appear to change the state of
+the iterator and therefore does not advance through successive nodes.
+
+.coNP Function @ sub-tree
+.synb
+.mets (sub-tree < tree >> [ from-key <> [ to-key ]])
+.syne
+.desc
+The
+.code sub-tree
+function selects elements from
+.metn tree ,
+which must be a search tree.
+
+If
+.meta from-key
+is specified, then elements lesser than
+.meta from-key
+are omitted from the selection.
+
+If
+.meta to-key
+is specified, the elements greater than or equal to
+.meta to-key
+are omitted from the selection.
+
+A list of the selected elements is returned, in which the elements appear in
+the same order as they do in
+.metn tree .
+
+.coNP Function @ copy-tree-iter
+.synb
+.mets (copy-tree-iter << iter )
+.syne
+.desc
+The
+.code copy-tree-iter
+function creates and returns a duplicate of the
+.meta iter
+object, which must be a tree iterator returned by
+.codn tree-begin .
+
+The returned object has the same state as the original; it references the same
+traversal position in the same tree. However, it is independent of the original.
+Calls to
+.code tree-next
+on the original have no effect on the duplicate and vice versa.
+
+.coNP Function @ replace-tree-iter
+.synb
+.mets (replace-tree-iter < dest-iter << src-iter )
+.syne
+.desc
+The
+.code replace-tree-iter
+function causes the tree iterator
+.meta dest-iter
+to be in the same state as
+.metn src-iter .
+
+Both
+.meta dest-iter
+and
+.meta src-iter
+must be tree iterator objects returned by
+.codn tree-begin .
+
+The contents of
+.meta dest-iter
+are updated such that it now references the same tree as
+.metn src-iter ,
+at the same position.
+
+The
+.meta dest-iter
+argument is returned.
+
+.coNP Special Variable @ *tree-fun-whitelist*
.desc
The
.code *tree-fun-whitelist*
@@ -46813,7 +59338,7 @@ operator).
The argument forms of
.code op
are arbitrary expressions, within which special
-conventions is permitted regarding the use of certain implicit variables:
+conventions are permitted regarding the use of certain implicit variables:
.RS
.meIP >> @ num
A number preceded by a
@@ -46844,27 +59369,27 @@ There is no way to use
.code op
to generate functions which have optional arguments. The positional
arguments are mutable; they may be assigned.
-.meIP < @rest
+.coIP @rest
If the meta-symbol
-.meta @rest
+.code @rest
appears in the
.code op
syntax as an expression, it explicitly denotes and evaluates to the list of
trailing arguments. Like the metanumber positional arguments, it
may be assigned.
-.meIP < @rec
+.coIP @rec
If the meta-symbol
-.meta @rec
+.code @rec
appears in the
.code op
syntax as an expression, it denotes a mutable variable which is bound to the
function itself which is generated by that
.code op
expression.
-.meIP >> @( rec ...)
+.coIP "@(rec ...)"
If this syntax appears inside
.codn op ,
-it specifies a recursive call the function.
+it specifies a recursive call to the function.
.RE
.IP
@@ -46872,14 +59397,16 @@ Functions generated by
.code op
are always variadic; they always take additional arguments after
any required ones, whether or not the
-.meta @rest
+.code @rest
syntax is used.
If the body does not contain
any
-.meta @num
+.mono
+.meti >> @ num
+.onom
or
-.meta @rest
+.code @rest
syntax, then
.code @rest
is implicitly inserted. What this means is that, for example, since
@@ -46891,14 +59418,17 @@ and does not contain
.codn @rest ,
it is actually a shorthand for
.codn "(op foo . @rest)" :
-a function which applies all of its arguments to
-.codn foo .
+a function which applies
+.code foo
+to all of its arguments.
If the body does contain at least one
-.meta @num
+.mono
+.meti >> @ num
+.onom
or
-.metn @rest ,
+.codn @rest ,
then
-.meta @rest
+.code @rest
isn't implicitly inserted. The notation
.code "(op foo @1)"
denotes a function which takes any number of arguments, and ignores
@@ -46908,8 +59438,8 @@ all but the first one, which is passed to
The
.code do
operator is similar to
-.code op
-op, with the following three differences:
+.codn op ,
+with the following three differences:
.RS
.IP 1.
The first argument of
@@ -46921,7 +59451,7 @@ implicit variables. Thus for instance
.code "(do @1 ...)"
is invalid. By contrast,
.code "(op @1 ...)"
-is possible and make sense under the right circumstances.
+is possible, and makes sense under the right circumstances.
The
.meta oper
argument may be the name of a macro or special operator, whereas
@@ -46959,18 +59489,21 @@ is effectively a shorthand for
Because it accepts operators,
.code do
can be used with imperative constructs
-which are not functions, like set: like set: for instance
+which are not functions, like
+.codn set .
+For example,
.code "(do set x)"
produces an anonymous function which, if called with one argument, stores that
argument into
-.codn x .
+.metn x .
The actions of
.code op
and
.code do
-be understood by these examples, which convey how the syntax is
-is rewritten to lambda. However, note that the real translator
+can be understood by the following examples,
+which convey how the syntax is rewritten to lambda.
+However, note that the real translator
uses generated symbols for the arguments, which are not equal to any
symbols in the program.
@@ -46981,8 +59514,6 @@ symbols in the program.
(op + foo) -> (lambda rest [+ foo . rest])
- (op @1 @2) -> (lambda (arg1 arg2 . rest) [arg1 arg2])
-
(op @1 . @rest) -> (lambda (arg1 . rest) [arg1 . @rest])
(op @1 @rest) -> (lambda (arg1 . rest) [arg1 @rest])
@@ -47002,12 +59533,16 @@ symbols in the program.
.brev
Note that if argument
-.meta @n
+.mono
+.meti >> @ n
+.onom
appears in the syntax, it is not necessary
for arguments
-.meta @1
+.code @1
through
-.meta @n-1
+.mono
+.meti >> @ n-1
+.onom
to appear. The function will have
.code n
arguments:
@@ -47035,7 +59570,10 @@ what is the meaning?
An expression with a single
.code @
-always belongs with the inner-most op or do
+always belongs with the innermost
+.code op
+or
+.code do
operator. So for instance
.code "(op (op @1))"
means that an
@@ -47046,7 +59584,8 @@ within an outer
expression that contains no references to its implicit variables.
The
.code @1
-belongs to the inner op.
+belongs to the inner
+.codn op .
There is a way for an inner
.code op
@@ -47148,6 +59687,60 @@ from a quasiliteral within a nested
(op ... (op ... `@@@1`))
.brev
+Because the
+.code do
+macro may be applied to operators, it is possible to apply it to itself,
+as well as to
+.codn op ,
+as in the following example:
+
+.verb
+ [[[[(do do do op list) 1] 2] 3] 4] -> (1 2 3 4)
+.brev
+
+The chained application associates right-to-left: the rightmost
+.code do
+is applied to
+.codn op ;
+the second rightmost
+.code do
+is applied to the rightmost one and so on. The effect is that partial
+application has been achieved. The value
+.code 1
+is passed to the resulting function, which returns another function
+which takes the next argument. Finally, all these chained argument
+values are passed to
+.codn list .
+
+Each
+.cod3 do / op
+level is processed independently. The following examples show how the list may
+be permuted into several different orders by referring to an implicit argument
+at various levels of nesting, making it the first argument of
+.codn list .
+The unmentioned arguments implicitly follow, in order. This works because
+mentioning the argument explicitly means that its corresponding
+.code do
+operator no longer inserts its argument implicitly into body of the
+function which it generates:
+
+.verb
+ [[[[(do do do op list @1) 1] 2] 3] 4] -> (4 1 2 3)
+ [[[[(do do do op list @@1) 1] 2] 3] 4] ->(3 1 2 4)
+ [[[[(do do do op list @@@1) 1] 2] 3] 4] -> (2 1 3 4)
+ [[[[(do do do op list @@@@1) 1] 2] 3] 4] -> (1 2 3 4))
+.brev
+
+The following example mentions all arguments at every
+.cod3 do / op
+nesting level, thereby explicitly establishing the order
+in which they are passed to
+.codn list :
+
+.verb
+ [[[[(do do do op list @1 @@1 @@@1 @@@@1) 1] 2] 3] 4] -> (4 3 2 1)
+.brev
+
.TP* Examples:
.verb
@@ -47157,6 +59750,7 @@ from a quasiliteral within a nested
(reduce-left (op + (* 10 @1) @2) '(1 2 3)) --> 123
.brev
+
.coNP Macro @ lop
.synb
.mets (lop << form +)
@@ -47187,14 +59781,14 @@ arguments are present, then
.code lop
generates a variadic function which inserts all of its trailing
arguments between the first and second
-.metn form -s.
+.metn form s.
That is to say, trailing arguments coming into the anonymous function
become the left arguments of the function or function-like object
denoted by the first
.meta form
and the remaining
-.metn form -s
+.metn form s
give additional arguments. Hence the name
.codn lop ,
which stands for \(dqleft-inserting
@@ -47285,7 +59879,7 @@ specified by the first form.
--> (c b a)
.brev
-.coNP Macros @, ap @, ip @ ado and @ ido.
+.coNP Macros @, ap @, ip @ ado and @ ido
.synb
.mets (ap << form +)
.mets (ip << form +)
@@ -47310,9 +59904,12 @@ macro. However, instead of returning
.metn f ,
directly, it returns a different function
.metn g ,
-which is a one-argument function which accepts a list,
-and then applies the list as arguments to
-.metn f .
+which is a one-argument function that accepts a list.
+The list specifies arguments to which
+.meta g
+applies
+.metn f ,
+and then returns the resulting value.
In other words, the following equivalence holds:
@@ -47357,8 +59954,8 @@ and
are related to
.codn op .
They produce a one-argument function which works
-as if by applying its arguments to the function generated by do,
-according to the following equivalence:
+as if by applying the function generated by do to its
+its own arguments, according to the following equivalence:
.verb
(ado form ...) <--> (apf (do form ...))
@@ -47381,10 +59978,12 @@ functions.
(mapcar (ap list @2 @1) '((1 2) (a b))) -> ((2 1) (b a))
.brev
-.coNP Macros @ opip and @ oand
+.coNP Macros @, opip @, oand @ lopip and @ loand
.synb
.mets (opip << clause *)
.mets (oand << clause *)
+.mets (lopip << clause *)
+.mets (loand << clause *)
.syne
.desc
The
@@ -47420,16 +60019,44 @@ where the above
notation denotes the following transformation applied to each argument:
.verb
- (function ...) -> (op function ...)
- (operator ...) -> (do operator ...)
- (macro ...) -> (do macro ...)
+ ;; these specific form patterns are left untransformed:
+
(dwim ...) -> (dwim ...)
[...] -> [...]
(qref ...) -> (qref ...)
(uref ...) -> (uref ...)
+ (op ...) -> (op ...)
+ (do ...) -> (do ...)
+ (lop ...) -> (lop ...)
+ (ldo ...) -> (ldo ...)
+ (ap ...) -> (ap ...)
+ (ip ...) -> (ip ...)
+ (ado ...) -> (ado ...)
+ (ido ...) -> (ido ...)
+ (ret ...) -> (ret ...)
+ (aret ...) -> (aret ...)
.slot -> .slot
.(method ...) -> .(method ...)
atom -> atom
+
+ ;; forms headed by let are treated specially
+
+ (let sym) -> ;; described below
+
+ (let (s0 i0)
+ (s1 i1)
+ ....) -> ;; described below
+
+ (let ((s0 i0)
+ (s1 i1)) -> ;; described below
+ body)
+
+
+ ;; other compound forms are transformed like this:
+
+ (function ...) -> (op function ...)
+ (operator ...) -> (do operator ...)
+ (macro ...) -> (do macro ...)
.brev
In other words, compound forms whose leftmost symbol is a macro or operator
@@ -47445,8 +60072,102 @@ denoting struct slot access, either explicitly using
.code uref
or
.code qref
-or the respective dot notations, as well as any atom forms.
+or the respective dot notations, forms which invoke any of the
+.code do
+family of operators, as well as any atom forms.
+
+The
+.code lopip
+and
+.code loand
+operators are similar to, respectively,
+.code opip
+and
+.codn oand ,
+except that they insert the implicit argument as the leftmost
+argument. For these macros, the above specification of what transformations
+are applied to the arguments is modified as follows:
+.verb
+ ;; other compound forms are transformed like this:
+
+ (function ...) -> (lop function ...)
+ (operator ...) -> (ldo operator ...)
+ (macro ...) -> (ldo macro ...)
+.brev
+
+When a
+.code let
+or
+.code let*
+expression occurs in
+.code opip
+syntax, it denotes a special syntax which is treated as follows.
+.RS
+.IP 1.
+The simple form
+.mono
+.meti (let << sym )
+.onom
+where
+.meta sym
+is a symbol is transformed into the
+.mono
+.meti (let >> ( sym @1))
+.onom
+syntax, which is then handled via the following case (2).
+.IP 2.
+The form
+.mono
+.meti (let >> {( sym << init )}+)
+.onom
+specifies an implicit function which binds the specified variables.
+The variables are bound sequentially as if by
+.codn let* ,
+even though the operator is
+.codn let .
+Note also that the bindings are not enclosed in a list. An example
+of the syntax is
+.code "(let (x @1) (y (+ x @2)))"
+which specifies a function of two arguments, inside of which
+.code x
+will be bound to the first argument, and
+.code y
+will be bound to the value of
+.code x
+plus the second argument.
+The remaining elements of the
+.code opip
+are incorporated into the body of this function. The value of
+the first argument,
+.codn @1 ,
+is injected into the
+.code opip
+remaining opip chain, and that chain is processed in a scope
+in which the variables bound by
+.code let
+are visible.
+.IP 3.
+All other
+.code let
+forms not matching the above syntax are treated like all special
+operators. They become a
+.code do
+element of the
+.code opip
+pipeline. For instance
+.code "(let ((x @1)) (+ x 1))"
+denotes a one-argument function which binds
+.code x
+to its first argument, then produces the value
+.code "(+ x 1)"
+which is passed to the next stage of the
+.code opip
+chain. The remaining chain is not evaluated in the scope of the
+.code x
+variable.
+.RE
+.IP
Note: the
.code opip
and
@@ -47454,7 +60175,15 @@ and
macros use their macro environment in determining whether a form is a
macro call, thereby respecting lexical scoping.
-.TP* Example:
+Note: an
+.code opip
+form with no arguments specifies a function which returns
+.codn nil ,
+which follows from a documented property of the
+.code chain
+function.
+
+.TP* Examples:
Take each element from the list
.code "(1 2 3 4)"
and multiply it by three, then add 1.
@@ -47488,6 +60217,199 @@ respectively, whereas
.code "[iff oddp list]"
is passed through untransformed.
+The following demonstrates the single variable
+.codn let :
+
+.mono
+ (let ((pipe (opip (+ 1) (let x)
+ (+ 2) (let y)
+ (+ 3)
+ (list x y))))
+ [pipe 1])
+ -> (2 4 7)
+.onom
+
+The
+.code x
+variable intercepts the value coming from
+.code "(+ 1)"
+and binds
+.code x
+to that value. When the
+.code opip
+function is invoked with the argument
+.codn 1 ,
+that value is
+.codn 2 .
+That value also continues to the
+.code "(+ 2)"
+element which yields
+.codn 4 ,
+which is similarly captured by variable
+.codn y .
+The final
+.code list
+expression lists the values of
+.code x
+and
+.codn y ,
+as well as, implicitly, the value
+.code @1
+coming from the previous element,
+
+.coNP Macros @ opf and @ lopf
+.synb
+.mets (opf < function << clause *)
+.mets (lopf < function << clause *)
+.syne
+.desc
+The
+.code opf
+and
+.code lopf
+function make available the
+.codn opip -style
+functional arguments in conjunction with an arbitrary
+.metn function .
+
+The
+.meta clause
+arguments of
+.code opf
+and
+.code lopf
+are processed exactly like those of
+.code opip
+and
+.codn lopip .
+
+The syntax
+.verb
+ (opf f c1 c2 c3 ...)
+.brev
+is converted into a function call of the form:
+.verb
+ [f {c1} {c2} {c3} ...]
+.brev
+where every argument
+.code {cN}
+is converted to a form denoting a function, in exactly the same manner
+as the arguments of
+.codn opip .
+The same remarks apply to code
+.code lopf
+in relation to
+.codn lopip .
+
+Thus, it is possible to express
+.code opip
+using
+.code opf
+by choosing
+.code chain
+as the
+.meta function
+argument, according to this equivalence:
+
+.verb
+ (opip c1 c2 c3 ...) <--> (opf chain c1 c2 c3 ...)
+.brev
+
+.TP* Example:
+
+.verb
+ ;; Remove values greater than 10 or less than five from list
+ (remove-if (lopf orf (> 10) (< 5)) (range 0 20)) -> (5 6 7 8 9 10))
+
+ ;; Note: could be expressed as
+ (remove-if (orf (lop > 10) (lop < 5)) (range 0 20))
+.brev
+
+As the example shows, the
+.code opf
+and
+.code lopf
+macros provide a way to avoid repeating the
+.code op
+and
+.code lop
+syntax in every argument of a functional combinator of a function.
+
+.coNP Macros @ flow and @ lflow
+.synb
+.mets (flow < form << opip-arg *)
+.mets (lflow < form << lopip-arg *)
+.syne
+.desc
+The
+.code flow
+macro passes the value of
+.meta form
+through the processing stages described by the
+.meta opip-arg
+arguments, yielding the resulting value.
+
+The
+.meta opip-arg
+arguments follow the semantics of the
+.code opip
+macro.
+
+The same requirements apply to
+.codn lflow ,
+except that it is related to the
+.code lopip
+macro which inserts the implicit argument into the
+leftmost position.
+
+
+The following equivalences hold:
+
+.verb
+ (flow x ...) <--> [(opip ...) x]
+ (lflow x ...) <--> [(lopip ...) x]
+.brev
+
+That is to say,
+.code flow
+is equivalent to the application of an
+.codn opip -generated
+function to the value of
+.metn form ,
+and likewise
+.code lflow
+is equivalent to the application of a
+.codn lopip -generated
+function.
+
+Note: if there are no
+.meta opip-arg
+or
+.meta lopip-arg
+arguments, then
+.code flow
+evaluates the
+.code x
+argument and returns
+.codn nil ;
+which follows from the behavior of the
+.code opip
+and
+.code lopip
+macros, when those are invoked with no arguments.
+
+.TP* Examples:
+
+.verb
+ (flow 1 (+ 2) (* 3) (cons 0)) -> (0 . 9)
+
+ (flow "abc" (upcase-str) (regsub #/B/ "ZTE")) -> "AZTEC"
+
+ (flow 1 (- 10)) -> 9
+
+ (lflow 10 (- 1)) -> 9
+.brev
+
.coNP Macro @ ret
.synb
.mets (ret << form )
@@ -47518,7 +60440,7 @@ and
The following equivalence holds:
.verb
- (ret x) <--> (op identity x))
+ (ret x) <--> (op identity* x))
.brev
Thus the expression
@@ -47553,14 +60475,16 @@ and returns the value specified by
can contain
.code ap
meta syntax like
-.meta @n
+.mono
+.meti >> @ n
+.onom
and
.codn @rest .
The following equivalence holds:
.verb
- (aret x) <--> (ap identity x))
+ (aret x) <--> (ap identity* x))
.brev
Thus the expression
@@ -47572,6 +60496,72 @@ and the expression
returns a function similar to
.codn "(lambda (. rest) 42)" .
+.coNP Macro @ tap
+.synb
+.mets (tap << arg +)
+.syne
+.desc
+The
+.code tap
+macro is intended for use in conjunction with
+.codn opip ,
+.code flow
+and other macros in that family. It is a short-hand for writing a pipeline
+element which performs a side-effecting operation, but unconditionally returns
+the original input value.
+
+The exact expansion of
+.code tap
+is unspecified, but the following equivalence indicates a possible
+expansion strategy:
+
+.verb
+ (tap ...) <--> (prog1 @1 (...))
+.brev
+
+Assuming that expansion strategy, the expression
+.code "(tap put-line `foo: @1`)"
+would expand to
+.codn "(prog1 @1 (put-line `foo: @1`))" .
+
+Note:
+.codn tap ,
+in addition to being useful for inserting necessary
+side effects into pipelines, is also
+useful for inserting temporary debug print forms. For that purpose, inserting
+the `prinl` function is often enough:
+
+.verb
+ (flow 10 (+ 2) print (* 4))
+.brev
+
+Here, the pipeline will calculate
+.code "(* 4 (+ 2 10))"
+with the side effect of the value of
+.code "(+ 2 10)"
+being printed. With
+.codn tap ,
+the output can be customized, allowing multiple output
+points to be distinguished.
+
+.verb
+ (flow 10
+ (tap put-line `input: @1`)
+ (+ 2)
+ (tap put-line `+ 2: @1`)
+ (* 4)
+ (tap put-line `* 4: @1`))
+ -> 48
+.brev
+
+Output produced:
+
+.verb
+ input: 10
+ + 2: 12
+ * 4: 48
+.brev
+
.coNP Function @ dup
.synb
.mets (dup << func )
@@ -47613,7 +60603,7 @@ The
.code chain
function accepts zero or more functions as arguments, and returns
a single function, called the chained function, which represents the chained
-application of those functions, in left to right order.
+application of those functions, in left-to-right order.
If
.code chain
@@ -47702,8 +60692,9 @@ function accepts a variable number of arguments which are functions. It
combines these into a single function which, when invoked, passes its arguments
to each of these functions, and collects the results into a list.
-Note: the juxt function can be understood in terms of the following reference
-implementation:
+Note: the
+.code juxt
+function can be understood in terms of the following reference implementation:
.verb
(defun juxt (funcs)
@@ -47757,37 +60748,45 @@ resulting combined function is then callable with that many arguments.
The
.code andf
function returns a function which combines the input functions with
-a short-circuiting logical conjunction. The resulting function passes its
-arguments to the functions successively, in left to right order. As soon as any
-of the functions returns
+a short-circuiting logical conjunction.
+The resulting function passes its arguments to the input functions
+successively,
+in left-to-right order.
+As soon as any of the functions returns
.codn nil ,
-then nil is returned immediately, and the
-remaining functions are not called. Otherwise, if none of the functions return
+then
+.code nil
+is returned and the remaining functions are not called.
+If none of the functions return
.codn nil ,
-then the value returned by the last function is returned. If the list of
-functions is empty, then
+then the value returned by the last function is returned.
+If the list of functions is empty, then
.code t
-is returned. That is,
+is returned.
+That is,
.code (andf)
-returns a function
-which accepts any arguments, and returns
+returns a function which accepts any arguments and returns
.codn t .
The
.code orf
-function combines the input functions with a short-circuiting logical
-disjunction. The function produced by
-.code orf
-passes its arguments down to the
-functions successively, in left to right order. As soon as any function
-returns a
+function returns a function which combines the input functions with
+a short-circuiting logical disjunction.
+The resulting function passes its arguments to the input functions
+successively,
+in left-to-right order.
+As soon as any of the functions returns a
.cod2 non- nil
-value, that value is returned and the remaining functions are
-not called. If all functions return
+value, that value is returned and the remaining functions are not called.
+If all of the functions return
.codn nil ,
then
.code nil
-is returned. The expression
+is returned.
+If the list of functions is empty, then
+.code nil
+is returned.
+That is,
.code (orf)
returns a function which accepts any arguments and returns
.codn nil .
@@ -47806,9 +60805,31 @@ of
The returned function takes a variable number of arguments. When
invoked, it passes all of these arguments to
.meta function
-and then inverts the result as if by application of the
+and then inverts the result as if by application of
.codn not .
+.coNP Functions @ nandf and @ norf
+.synb
+.mets (nandf << func *)
+.mets (norf << func *)
+.syne
+.desc
+The
+.code nandf
+and
+.code norf
+functions are the logical negation of the
+.code andf
+and
+.code orf
+functions.
+They are related according to the following equivalences:
+
+.verb
+ [nandf f0 f1 f2 ...] <--> (notf [andf f0 f1 f2 ...])
+ [norf f0 f1 f2 ...] <--> (notf [orf f0 f1 f2 ...])
+.brev
+
.coNP Functions @ iff and @ iffi
.synb
.mets (iff < condfun >> [ thenfun <> [ elsefun ]])
@@ -47822,7 +60843,7 @@ function is the functional equivalent of the
operator. It accepts
functional arguments and returns a function.
-The resulting function takes its arguments, if any, and applies them to
+The resulting function passes its arguments to
.metn condfun .
If
.meta condfun
@@ -47888,10 +60909,11 @@ with both optional arguments omitted:
[iff a] <---> [iff a identity nilf] <---> a
.brev
-.coNP Functions @ tf and @ nilf
+.coNP Functions @, tf @ nilf and @ ignore
.synb
.mets (tf << arg *)
.mets (nilf << arg *)
+.mets (ignore << arg *)
.syne
.desc
The
@@ -47908,6 +60930,11 @@ and the
function returns
.codn nil .
+The
+.code ignore
+function is a synonym of
+.codn nilf .
+
Note: the following equivalences hold between these functions and the
.code ret
operator, and
@@ -47932,6 +60959,11 @@ and
[mapcar (ret nil) list] <--> [mapcar nilf list]
.brev
+Note: the
+.code ignore
+function can be used for suppressing unused variable
+warnings.
+
.TP* Example:
.verb
@@ -47970,6 +61002,16 @@ is even, then iff passes it into the
function, which ignores the value and returns
.codn nil .
+The following example shows how
+.code ignore
+may be used to suppress compiler warnings about unused parameters
+or other variables:
+
+.verb
+ (defun (x y)
+ (ignore x y))
+.brev
+
.coNP Function @ retf
.synb
.mets (retf << value )
@@ -48005,23 +61047,25 @@ function returns a one-argument function whose argument conventions
are similar to those of the
.code apply
function: it accepts one or more arguments, the last of which should
-be a list. When that function is called, it applies these arguments to
+be a list. When that function is called, it applies
.meta function
-as if by
+to these arguments to as if by
.codn apply .
It then returns whatever
.meta function
returns.
If one or more additional
-.metn arg -s
+.metn arg s
are passed to
.codn apf ,
then these are stored in the function which is returned.
-When the function is invoked, it prepends all of these stored
-arguments to those that it is being given, and the resulting combined
-arguments are applied. Thus the
-.metn arg -s
+When that function is invoked, it prepends all of the stored
+arguments to the passed arguments, and applies the
+.metn function .
+to the resulting combined argument list.
+Thus the
+.metn arg s
become the leftmost arguments of
.metn function .
@@ -48029,11 +61073,10 @@ The
.code ipf
function is similar to
.codn apf ,
-except that the argument conventions of the function returned by
+except that the argument conventions and application semantics of the function
+returned by
.code ipf
are based on
-.codn iapply ,
-and that function applies arguments as if by
.code iapply
rather than
.codn apply .
@@ -48046,7 +61089,7 @@ macro.
.verb
;; Function returned by [apf +] accepts the
- ;; (1 2 3) list and applies it to +, as
+ ;; (1 2 3) list and applies + to it, as
;; if (+ 1 2 3) were called.
(call [apf +] '(1 2 3)) -> 6
@@ -48059,11 +61102,12 @@ macro.
.desc
The
.code callf
-function returns a function which applies its arguments to each
-.metn arg-function ,
-juxtaposing the return values of these calls to form arguments
-which are then passed to
-.metn main-function .
+function returns a function which applies each
+.meta arg-function
+to its arguments, juxtaposing the return values of these calls to form
+arguments to which
+.meta main-function
+is then applied.
The return value of
.meta main-function
is returned.
@@ -48110,7 +61154,7 @@ The
.code mapf
function returns a function which distributes its arguments
into the
-.metn arg-function -s.
+.metn arg-function s.
That is to say, each successive argument of the returned
function is associated with a successive
.metn arg-function .
@@ -48125,10 +61169,10 @@ and the resulting value is returned.
If the returned function is called with fewer arguments than there
are
-.metn arg-function -s,
+.metn arg-function s,
then only that many functions are used. Conversely, if the function is
called with more arguments than there are
-.metn arg-function -s,
+.metn arg-function s,
then those arguments are ignored.
The following equivalence holds:
@@ -48156,7 +61200,7 @@ In general, I/O errors are usually turned into exceptions. When the description
of error reporting is omitted from the description of a function, it can be
assumed that it throws an error.
-.coNP Special variables @, *stdout* @, *stddebug* @, *stdin* @ *stderr* and @ *stdnull*
+.coNP Special Variables @, *stdout* @, *stddebug* @, *stdin* @ *stderr* and @ *stdnull*
.desc
These variables hold predefined stream objects. The
.codn *stdin* ,
@@ -48175,13 +61219,40 @@ debugging output to be separated from normal output.
The
.code *stdnull*
-stream is a special kind of stream called a null stream.
-This stream is not connected to any device or file. It is similar to
+stream is a special kind of stream called a null stream. To read operations,
+the stream appears empty, like a stream open on an empty file. To write
+operations, it appears as a data sink of infinite capacity which consumes data
+and discards it. This stream is similar to
the
.code /dev/null
-device on Unix, but does not involve the operating system.
+device on Unix, and in fact has a relationship to it. If an attempt is made
+to obtain the underlying file descriptor of
+.code *stdnull*
+using the
+.code fileno
+function, then the
+.code /dev/null
+device is open, if the host platform supports it. The resulting file
+descriptor number is returned, and also retained in the
+.code *stdnull*
+device. When
+.code close-stream
+is invoked on
+.codn *stdnull* ,
+that descriptor is closed. This feature of
+.code *stdnull*
+allows it to be useful for establishing redirections around the
+execution of external utilities.
-.coNP Special variables @ *print-flo-format* and @ *pprint-flo-format*
+.TP* Example:
+
+.verb
+ ;; redirect output of ls *.txt command to /dev/null
+ (let ((*stderr* *stdnull*))
+ (sh "ls *.txt"))
+.brev
+
+.coNP Special Variables @ *print-flo-format* and @ *pprint-flo-format*
.desc
The
.code *print-flo-format*
@@ -48221,7 +61292,7 @@ is a valid value for
or
.codn *pprint-flo-format* .
-.coNP Special variable @ *print-flo-precision*
+.coNP Special Variable @ *print-flo-precision*
.desc
The
.code *print-flo-precision*
@@ -48265,7 +61336,7 @@ to the value of the
.code flo-max-dig
variable.
-.coNP Special variable @ *print-flo-digits*
+.coNP Special Variable @ *print-flo-digits*
.desc
The
.code *print-flo-precision*
@@ -48282,7 +61353,7 @@ is specified.
Its default value is
.codn 3 .
-.coNP Special variable @ *print-base*
+.coNP Special Variable @ *print-base*
.desc
The
.code *print-base*
@@ -48314,10 +61385,10 @@ Meaningful values are:
and
.codn 16 .
-When base 16 is selected, hexadecimal digits are printed as upper-case
+When base 16 is selected, hexadecimal digits are printed as uppercase
characters.
-.coNP Special variable @ *print-circle*
+.coNP Special Variable @ *print-circle*
.desc
The
.code *print-circle*
@@ -48358,6 +61429,25 @@ circle notation label. The "ordinary structure that is reachable from the
slots" denotes structure that is directly reachable by traversing conses,
ranges, vectors, hashes and struct slots: all printable aggregate objects.
+.coNP Special Variable @ *read-unknown-structs*
+.desc
+The
+.code *read-unknown-structs*
+variable controls the behavior of the parser upon encountering
+structure literal
+.code #S
+syntax which specifies an unknown structure type.
+
+If this variable's value is
+.code nil
+then such a literal is erroneous; an exception is thrown. Otherwise, such
+a structure is converted not into a structure object, which is impossible,
+but into a list object whose first element is the symbol
+.codn sys:struct-lit .
+The remaining elements are taken from the
+.code #S
+syntax.
+
.coNP Function @ format
.synb
.mets (format < stream-designator < format-string << format-arg *)
@@ -48488,65 +61578,46 @@ character, then it means that
.meta width
is being omitted; there is only a precision field.
-The precision specifier may begin with these optional characters:
+The precision specifier may begin with these optional characters, whose effect
.RS
.coIP 0
-(the "leading zero flag"),
+the "leading zero option": pad with leading zeros;
.coIP +
-(print a sign for positive values")
+print a sign for positive values;
+.coIP -
+print a single leading zero in place of a positive sign; and
.IP space
-(print a space in place of a positive sign).
+print a space in place of a positive sign.
.RE
-The precision specifier itself is either a decimal integer that does not
-begin with a zero digit, or the
-.code *
-character.
+The precision value influences the printing of values of all types.
+The precision options apply only when the value being printed is a
+number; otherwise they are ignored.
-The precision field's components have a meaning which depends on the type of
-object printed and the conversion specifier.
-
-For integer arguments, the precision value specifies the minimum number of digits
-to print. If the precision field has a leading zero flag, then the integer is
-padded with zeros to the required number of digits, otherwise the number is
-padded with spaces instead of zeros. If zero or space padding is present, and
-a leading positive or negative sign must be printed, then it is placed before
-leading zeros, or after leading spaces, as the case may be.
-
-For floating-point values, the meaning of the precision value depends on which
-specific conversion specifier
-.cod1 ( f ,
-.codn e ,
-.code a
-or
-.codn s )
-is used. The details are
-documented in the description of each of these, below. The leading zero flag is
-also taken into account for floating-point values, and treated uniformly by
-these directives. If the flag is present, then the printed value's integer
-part will be padded with leading zeros up to the width of the field such that
-one character of unused space remains in the field, in case a positive or
-negative sign needs also to be rendered.
-
-For integer or floating-point arguments, if the precision specifier has a
-.code +
-sign
-among the special characters, then a
-.code +
-sign is printed for positive numbers. If
-the precision specifier has a leading space instead of a
-.code +
-sign, then the
-.code +
-sign is rendered as a space for positive numbers. If there is no leading space
-or
+If the
.codn + ,
-then a sign character is omitted for positive numbers. Negative
-numbers are unconditionally prefixed with a
.code -
-sign.
+or
+space are multiply specified, the rightmost one takes precedence.
+
+The precision specifier itself follows: it must be either a decimal integer
+or the
+.code *
+character indicating that the precision value comes from an integer argument.
-For all other objects, the precision specifies the maximum number of
+The leading zero option is only active if accompanied by a precision
+value, either coming from additional digits in the formatting directive,
+or from an argument indicated by
+.codn * .
+If no precision specifier is present, then the leading zero option
+is interpreted as a specifier indicating a precision value of zero, rather
+than requesting leading zeros. To request zero padding together with zero
+precision, either two or more zero digits are required, or else the leading
+zero indicator must be given together with the
+.code *
+specifier.
+
+For non-numeric values, the precision specifies the maximum number of
print positions to occupy, taking into account the display width of each
character of the printed representation of the object, as according
to the
@@ -48555,6 +61626,40 @@ function. The object's printed representation is truncated, if necessary, to
the maximum number of characters which will not exceed the specified number of
print positions.
+A numeric argument is formatted into the field in two distinct steps, both of
+which involve the precision value in a different role. The details of the first
+of these steps, and the role payed by precision, depend on which conversion
+directive is used, as well as whether the argument is integer or
+floating-point. That first step prepares the printed representation of a
+number which is then fitted into the field by the second step,
+and also calculates the
+.I "effective precision"
+value, which is based on the original width and precision. The second step
+works with the effective precision rather than the original precision. Its
+description follows.
+
+First, the length of the printed representation of the number, not including
+its sign, is calculated. If this part of the number is shorter than the
+effective precision, then it is padded on the left with spaces or leading zeros
+so that the resulting string is equal to the precision.
+
+Next, if the number is negative, or else if adding a positive sign has been
+requested, then the sign is added. It is added to the left of the padding
+zeros, or else to the right of padding spaces, whichever the case may be.
+
+At this stage, if the number is not yet adorned with a sign, and either the
+.code -
+or space precision option had been given, then the appropriate character,
+the digit
+.code 0
+or a space, is added in the place where the sign would go. This is done
+only if the result will not overflow the field width, but without regard
+for whether the character will overflow the effective precision.
+
+Finally, the resulting number is rendered into the field, using the requested
+left, right or center adjustment, as if it were a character string. If it
+overflows the field, it is reproduced in its entirety without any adjustment
+being performed.
.RE
.TP* "Format directives:"
@@ -48579,16 +61684,28 @@ is not necessarily readable if it is implanted in \*(TX source code.
The field width specifier is honored, including the left-right adjustment
semantics.
-When this specifier is used for floating-point values, the precision specifies
-the maximum number of total significant figures, which do not include any
-digits in the exponent, if one is printed. Numbers are printed in exponential
-notation if their magnitude is small, or else if their exponent exceeds their
-precision. If the precision is not specified, then it is obtained from
-the
+When the
+.code a
+specifier is used for numbers, the formatting is performed in two
+distinct steps: the printed representation of the number is calculated
+first, and then that representation is set into the field. At the same time,
+an effective precision is calculated, based on the precision and width,
+and that effective precision is used in the second step.
+
+In the first step, the rendering of a floating-point number to its printed
+representation, the precision specifies the maximum number of total significant
+figures, which do not include any digits in the exponent, if one is printed.
+Numbers are printed in E notation if their magnitude is small, or
+else if their exponent exceeds their precision. If the precision is not
+specified, then it is obtained from the
.code *print-flo-precision*
special variable, whose default value is the same as that of the
.code flo-dig
-variable.
+variable. The effective precision for the second step is then taken
+from the original precision, or one less than the width, whichever of the
+these two values is smaller, but no lower than zero. If the width is
+unspecified, it is taken as zero.
+
Floating point values which are integers are
printed without a trailing
.code .0
@@ -48597,11 +61714,52 @@ The
.code +
flag in the precision is honored for rendering an explicit
.code +
-sign on non-negative values.
+sign on nonnegative values.
If a leading zero is specified in the precision, and a nonzero width is
specified, then the printed value's integer part will be padded with leading
zeros up to one less than the field width. These zeros are placed before the
-sign.
+sign. A precision value of zero imposed on floating-point values is
+equivalent to a value of one; it is not possible to request zero significant
+figures.
+
+Integers are not affected by the precision value in the conversion to
+text; all of the digits of the integer are taken into the second step.
+In the case of integers, The effective precision for the second step is then
+taken from the original precision, or one less than the width, whichever of the
+these two values is smaller. However, if the width is not specified, or given
+as zero, then the unmodified precision value is taken as the effective
+precision. Thus, in the zero width or missing width case, integers are always
+padded with spaces or leading zeros due to the precision value, even if such
+padding overflows the field width.
+
+Rationale: the purpose of the elaborate rules for calculating the
+effective precision is to both obtain consistency in the printing of integers
+and floating-point values that are integers, as well as to break that
+consistency when the width is omitted or zero. This break in consistency
+has two benefits. The common situation of adding leading spaces or zeros
+to integers can be specified without specifying the width. For instance
+.str "~,8a"
+will format an integer right-justified in an eight-character extent, without
+width having to be used in order to specify a field to accommodate
+that padding. The effective padding amount going into the second step is 8,
+exceeding the zero width, and thus allowing the padding to overflow the field.
+In the case of floating-point, precision alone can express the common
+requirement for limiting the number of digits can be expressed by the
+precision, without causing unwanted padding when there are fewer digits.
+If the above
+.str "~,8a"
+is used to format a floating-point value, it will be limited to 8 digits
+of precision, regardless of its magnitude and the position of its
+decimal point, or whether or not exponential notation is used.
+The effective precision for field placement shall then be zero in
+the second step, so that no padding is generated. However, if a nonzero
+width is used, then formatting becomes consistent between floating-point
+and integer so that, for instance, the format directive
+.str "~8,8a"
+produces the same output for the argument values 42 and 42.0, namely
+an eight-character-wide field in which the digits
+.str 42
+appear right-aligned.
.coIP s
Prints any object in a standard way, as if by the
@@ -48634,16 +61792,18 @@ directive, depending on the value of the variable.
.coIP d
Requires an argument of integer or character type type. The integer
value or character code is printed in decimal.
+Width and precision semantics are as described for the
+.code a
+format directive, for integers.
.coIP x
-Requires an argument of character or integer type. The integer value or
-character code is printed in hexadecimal, using lower-case letters
-for the digits
+Requires an argument of character, integer or buffer type. The integer value,
+character code, or buffer contents are printed in hexadecimal, using lowercase
+letters for the digits
.code a
through
.codn f .
-Width and precision semantics
-are as described for the
+Width and precision semantics are as described for the
.code a
format directive, for integers.
@@ -48654,7 +61814,7 @@ directive, but the hexadecimal digits
.code a
through
.code f
-are rendered in upper case.
+are rendered in uppercase.
.coIP o
Like the
@@ -48677,36 +61837,68 @@ argument. (Unlike
and
.codn o ,
it does not allow an argument of character type).
-The precision specifier gives the number of digits past the decimal point.
-The number is rounded off to the specified precision, if necessary.
-Furthermore, that many digits are always printed, regardless of the actual
-precision of the number or its type. If it is omitted, then the value
+
+The formatting performed by
+.code f
+is performed in two distinct steps: the printed representation of the number is
+calculated first, and then that representation is set into the field. The
+precision parameter coming from the directive is only involved in
+the first step.
+
+In the first step, the precision specifier gives the number of digits past the
+decimal point. The number is rounded off to the specified precision, if
+necessary. Furthermore, that many digits are always printed, regardless of the
+actual precision of the number or its type. If it is omitted, then the value
is obtained from the special variable
.codn *print-flo-digits* ,
whose default value is three: three digits past the decimal point. A precision
-of zero means no digits pas the decimal point, and in this case the decimal
+of zero means no digits past the decimal point, and in this case the decimal
point is suppressed (regardless of whether the numeric argument is
floating-point or integer).
+No limit is placed on the number of significant figures in the number by
+either the precision or width value.
+
+When the resulting textual number passes to the second formatting step, the
+precision value, for the purposes of that step, is calculated by taking one
+less than the field width, or else zero if the field width is zero.
+This value is not related to the precision that had been used to determine
+the number of places past the decimal point.
+
.coIP e
The
.code e
-directive prints numbers in exponential notation. It requires
+directive prints numbers in E notation. It requires
a numeric argument. (Unlike
.codn x ,
.code X
and
.codn o ,
it does not allow an argument of character type).
-The precision specifier gives the number of digits past the decimal point
-printed in the exponential notation, not counting the digits in the exponent.
-Exactly that many digits are printed, regardless of the precision of the
-number. If the precision is omitted, then the number of digits after the
-decimal point is obtained from the value of the special variable
+
+The formatting performed by
+.code e
+is performed in two distinct steps: the printed representation of the number is
+calculated first, and then that representation is set into the field. The
+precision parameter coming from the directive is only involved in
+the first step.
+
+In the first step, the precision specifier gives the number of digits past the
+decimal point printed in the E notation, not counting the digits in
+the exponent. Exactly that many digits are printed, regardless of the
+precision of the number. If the precision is omitted, then the number of
+digits after the decimal point is obtained from the value of the special
+variable
.codn *print-flo-digits* ,
whose default value is three. If the precision is zero, then a decimal portion
is truncated off entirely, including the decimal point.
+When the resulting textual number passes to the second formatting step, the
+precision value, for the purposes of that step, is calculated by taking one
+less than the field width, or else zero if the field width is zero.
+This value is not related to the precision that had been used to determine
+the number of places past the decimal point.
+
.coIP p
The
.code p
@@ -48739,7 +61931,7 @@ function.
The indentation mode and indentation column are automatically restored to their
previous values when
.code format
-function terminates, naturally or via an exception or non-local jump.
+function terminates, naturally or via an exception or nonlocal jump.
The effect of a precision field (even if zero) combined with the
.code !
@@ -48764,6 +61956,372 @@ and
(fmt s arg ...) <--> (format nil s arg ...)
.brev
+.coNP Macro @ pic
+.synb
+.mets (pic < format-string << format-arg *)
+.syne
+.desc
+The
+.code pic
+macro ("picture based formatting") provides a notation for constructing a
+character string under the control of
+.meta format-string
+which indicates the insertion of zero or more
+.meta format-arg
+argument values.
+
+Like the
+.code fmt
+function or quasiliteral syntax, the
+.code pic
+macro returns a character string.
+
+The
+.code pic
+macro's
+.meta format-string
+notation is different from quasiliterals or from
+.codn fmt .
+
+The
+.code pic
+.meta format-string
+argument isn't an evaluated expression, but syntax. It must be either a string
+literal or else a string quasiliteral. No other syntax is permitted.
+
+If
+.meta pic
+is a string, is scanned left to right in search of
+.IR "pic patterns" .
+Any characters not belonging to a pic pattern are copied into the output
+string verbatim. When a pic pattern is found, it is removed from
+.meta format-string
+and applied to the next successive
+.meta format-arg
+to perform a conversion and formatting of that value to text. The resulting
+text is appended to the output string, and the process continues in search of the next pic pattern.
+When the
+.meta format-string
+is exhausted, the constructed string is returned.
+
+If
+.meta format-string
+is a quasiliteral, then all of the text strings embedded within the
+quasiliteral are examined in the same way, in left to right order. Each such
+string is transformed into an expression which produces a character string
+according to the semantics of the pic patterns it contains, and the resulting
+expressions are substituted into the original quasiliteral to produce a
+transformed quasiliteral.
+
+There must be exactly as many
+.meta format-arg
+arguments as there are pic patterns in
+.metn format-string .
+
+The
+.code pic
+macro arranges for the left-to-right evaluation of the
+.meta format-arg
+expressions. If
+.meta format-string
+is a quasiliteral, the evaluation of these expressions is interleaved
+into the quasiliterals expressions and variables, in the order implied
+by the placement of the corresponding pic patterns relative to the
+quasiliteral elements. For instance, if
+.meta format-string
+is
+.code `@(abc)<<<@(xyz)`
+then the function
+.code abc
+is called first, then the
+.meta format-argument
+is evaluated which produces a value for the
+.code <<<
+pic pattern, after which the
+.code xyz
+function is called.
+
+There are two kinds of pic patterns: alignment patterns, numeric patterns and
+escape patterns.
+
+Escape patterns consist of a two-character sequence introduced by the
+.code ~
+(tilde)
+character, which is followed by one of the characters that are special in
+pic pattern syntax:
+
+.verb
+ < > | + - 0 # . ! ~ , ( )
+.brev
+
+An escape pattern produces the second character as its output. For instance
+.code ~~
+encoded a single
+.code ~
+character, and
+.code ~#
+encodes a literal
+.code #
+character that is not part of any pattern.
+
+Alignment patterns are described next.
+.RS
+.coIP <<...<<
+A sequence of one or more
+.code <
+(less than)
+characters specifies that the corresponding argument is rendered left-aligned
+in a field whose width is given by the number of
+.code <
+characters. If the argument's textual representation doesn't fit into the field,
+it overflows.
+.coIP >>...>>
+A sequence of one or more
+.code >
+(greater than)
+characters specifies that the corresponding argument is rendered right-aligned
+in a field whose width is given by the number of
+.code >
+characters. If the argument's textual representation doesn't fit into the field,
+it overflows.
+.coIP ||...||
+A sequence of one or more
+.code |
+(pipe) characters specifies that the corresponding argument is centered
+in a field whose width is given by the number of
+.code |
+characters. If the argument's textual representation doesn't fit into the field,
+it overflows. If the argument cannot be precisely centered, because the
+even-odd parity of its character count is different from the parity of the
+field width, it is centered slightly to the left: one less space appears on its
+left side in respect to its right side.
+.RE
+.IP
+The numeric patterns, by means of their visual pattern and several optional
+prefix codes, specify the parameters for the conversion of a numeric
+argument, which is rendered right-aligned in a fixed-width field. Numeric
+patterns that do not contain any commas conform this simple rule:
+
+.mono
+.mets <> [ sign ] [0] {#}+ >> [ point {#}+ | !]
+.onom
+
+or else if they contain commas, the placement of these commas is governed
+by the more complicated rule:
+
+.mono
+.mets <> [ sign ] [0 [,]] {#}+ {,{#}+}* >> [ point {#}+ {,{#}+}* | !]
+.onom
+
+Commas may be placed anywhere within the pattern of hash characters, except at
+the beginning or end, or adjacent to the decimal point. If the leading zero is
+present, a comma may appear immediately after it, before the first hash.
+
+A second form of both of the above patterns is supported, for specifying
+that negative numbers be shown in parentheses. Instead of the sign, an
+opening parenthesis may appear, which must be matched by a closing parenthesis
+which follows a valid pattern interior:
+
+.mono
+.mets ( [0] {#}+ >> [ point {#}+ | !] )
+.onom
+
+With embedded commas:
+
+.mono
+.mets ( [0 [,]] {#}+ {,{#}+}* >> [ point {#}+ {,{#}+}* | !] )
+.onom
+
+The pattern consists of an optional
+.meta sign
+which is one of the characters
+.code +
+(plus) or
+.code -
+(minus), or else it may optionally begin with an opening parenthesis,
+indicating one of the two alternative forms.
+
+This is followed by an optional leading zero.
+After this comes a sequence of one or more
+.code #
+(hash) characters, which may contain exactly one
+.meta point
+element, which is defined as one of the characters
+.code .
+(period)
+or
+.code !
+(exclamation mark).
+This
+.meta point
+element may appear at most once, and must not be the first or
+last character, unless it is the exclamation mark,
+in which case it may appear last.
+
+Except if ending in the exclamation mark, a numeric pattern specifies a field
+width which is equal to the number of characters occurring in the pattern
+itself.
+For instance, the patterns
+.codn #### ,
+.code +###
+and
+.code 0#.#
+all specify a field width of four. If the numeric pattern ends in an exclamation
+mark, that character is not counted toward the field width that it specifies.
+Thus the pattern
+.code ###!
+specifies a field width of three.
+
+If the leading sign is present, it has the following meanings:
+.RS
+.coIP +
+If the corresponding numeric argument is nonnegative, the
+.code +
+character shall appear before first digit. Otherwise the minus character
+will appear.
+.coIP -
+Like
+.code +
+except that when the numeric argument is nonnegative, instead of a
+.code +
+character, a space appears before the first digit. This space counts
+toward the field width and therefore contributes to overflow.
+.RE
+.IP
+If a leading sign is not present, then no extra character appears before
+the first digit of a positive value, which means that an extra character
+of field width is available for representing nonnegative values.
+
+If the leading zero is present, it specifies that the number is
+padded with zeros on the left. In combination with the
+.code -
+sign, this shall not cause the leading space before a positive value to
+be overwritten with a zero; leading zeros, if any, begin after that space.
+
+The remainder of the pattern specifies the number of digits of the fractional
+part which is indicated by number of
+.code #
+characters after the
+.metn point .
+The number is rounded to that many fractional digits, which are all rendered,
+even if there are trailing zeros.
+If no
+.meta point
+is not specified, then the number of fractional digits is zero. The same is
+true if
+.meta point
+is specified as
+.code !
+as the last character. In both cases, the numeric argument is rounded to
+integer, and rendered without any decimal point or fractional part.
+
+There is a difference between
+.meta point
+being specified using the ordinary decimal point character
+.code .
+versus the
+.code !
+character. The
+.code !
+character specifies that if the conversion of the numeric argument overflows
+the field, then instead of showing any digits, the field is filled with a
+pattern consisting of
+.code #
+(hash) characters, and possibly an embedded decimal point. In contrast, the
+.code .
+character permits the field's width to increase to accommodate overflowing
+output. If overflow takes place and the
+.code !
+character appears other than as the rightmost character of the pattern,
+then the decimal point character
+.code .
+character appears at the position indicated by that
+.code !
+character. If the
+.code !
+character is the rightmost character of the pattern, then, just as
+in the case of normal, non-overflowing output, it doesn't contribute to the
+width of the hash fill, and only hash characters appear.
+
+If commas appear in the numeric pattern according to the more complex syntactic
+rule, they count toward the field width and specify the insertion of
+digit-separating commas at the indicated locations. Digit separators may be
+specified on either side of the decimal point, but not adjacent to it. In the
+output, a digit separating comma shall not appear if it would be immediately
+preceded by a
+.code +
+or
+.code -
+sign or space. In this situations, the sign character or space appears
+in place of the digit separator. A digit separator that appears in a position
+occupied by a space is also suppressed in favor of the space. Digit separators
+are included among leading zeros. It is not logically possible for a digit
+separator to appear as the first character of a pattern's output, because it
+may not be the first character of a pattern. However, if a numeric pattern is
+preceded or followed by a comma, those commas are ordinary characters which are
+copied to the output.
+
+When, due to the presence of
+.codn ! ,
+an overflowing field is handled by the generation of a the hash character fill,
+the hash characters are treated as digits for the purpose of digit separation.
+
+When the pattern uses parentheses to specify that negative numbers are
+to be shown with parentheses, the parentheses count toward the field width.
+The field portion between the parentheses is called the inner field.
+The parentheses appear in the output when the number is negative, and are
+placed immediately outside of the inner field, so that if leading zeros are not
+requested, there may be one or more spaces between the opening parenthesis and
+the first digit. If the number is nonnegative, then each parenthesis is
+replaced by one space, flanking the inner field in the same manner as
+parentheses.
+
+.TP* Examples:
+
+.verb
+ ;; numeric formatting
+ (pic "######" 1234.1) -> " 1234"
+ (pic "######.#" 1234.1) -> " 1234.1"
+ (pic "#######.##" 1234.1) -> " 1234.10"
+ (pic "#######.##" -1234.1) -> " -1234.10"
+ (pic "0######.##" 1234.1) -> "0001234.10"
+ (pic "+######.##" 1234.1) -> " +1234.10"
+ (pic "-######.##" 1234.1) -> " 1234.10"
+ (pic "+0#####.##" 1234.1) -> "+001234.10"
+ (pic "-0#####.##" 1234.1) -> " 001234.10"
+ (pic "#######.##" -1234.1) -> " -1234.10"
+
+ ;; digit separation
+ (pic "0,###,###.##" 1234.1) -> "0,000,123.10"
+ (pic "#,###,###.##" 1234.1) -> " 123.10"
+
+ ;; overflow with !
+ (pic "#!#" 1234) -> "###"
+ (pic "#!#" 123) -> "###"
+ (pic "-##!#" -123) -> "#####"
+ (pic "+##!#" 123) -> "#####"
+ (pic "###!" 1234) -> "###"
+
+ ;; negative parentheses
+ (pic "(#,###.##) 1234.56) -> " 1,234.56 "
+ (pic "(#,###.##) -234.56) -> "( 234.56)"
+
+ ;; alignment, multiple arguments
+ (pic "<<<<<< 0#.# >>>>>>>" "foo" (+ 2 2) "bar")
+ --> "foo 04.0 bar"
+
+ ;; quasiliteral
+ (let ((a 2) (b "###") (c 13.5))
+ (pic `abc@(+ a a)###.##@b>>>>` c "x"))
+ --> "abc4 13.50### x"
+
+ ;; filename generation
+ (mapcar (do pic "foo~-0##.jpg") (rlist 0..5 8 12))
+
+ --> ("foo-000.jpg" "foo-001.jpg" "foo-002.jpg" "foo-003.jpg"
+ "foo-004.jpg" "foo-005.jpg" "foo-008.jpg" "foo-012.jpg")
+.brev
+
.coNP Functions @, print @, pprint @, prinl @, pprinl @ tostring and @ tostringp
.synb
.mets (print < obj >> [ stream <> [ pretty-p ]])
@@ -48849,7 +62407,7 @@ The
.codn print ,
with the
.meta pretty-p
-argument hard-coded true.
+argument hardcoded true.
The
.code prinl
@@ -49074,7 +62632,7 @@ the POSIX function
reports true). This is only supported on platforms that have this function.
The behavior is overridden by the
.code -n
-command line option.
+command-line option.
.coNP Function @ open-file
.synb
@@ -49095,14 +62653,17 @@ conventions as the mode argument of the C language
.code fopen
function, with greater permissiveness, and some extensions.
-The syntax of mode-string is described by the following
-grammar. Note that it permits no whitespace characters:
+The syntax of
+.meta mode-string
+is described by the following grammar.
+Note that it permits no whitespace characters:
.mono
.mets < mode-string := [ < mode ] [ < options ]
.mets < mode := { < selector [ + ] | + }
-.mets < selector := { r | w | a | m }
-.mets < options := { b | l | u | < digit | < redirection }
+.mets < selector := { r | w | a | m | T }
+.mets < options := { b | x | l | u | i | n | < digit |
+.mets \ \ \ \ \ \ \ \ \ \ \ \ \ \ <> z[ digit ] | < redirection }
.mets < digit := { 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 }
.onom
@@ -49161,15 +62722,36 @@ are appended.
The file is opened for reading and writing. If it doesn't exist,
it is created. The read position is at the beginning of the file,
but writes are appended to the end regardless of the position.
+.coIP T
+This selector may be used on operating systems which support the
+.code O_TMPFILE
+mode of the
+.code open
+POSIX C library function. The
+.meta path
+must specify a directory to which the calling process has write permission. An
+anonymous, unlinked file will be created in the filesystem which holds that
+directory, open for reading and writing. See additional notes at the
+end of this section.
.RE
.IP
The meanings of the option characters are:
.RS
.coIP b
-The file is opened in binary mode: no line ending translation takes place.
+The file is opened in binary mode: no line-ending translation takes place.
In the absence of this option, files are opened in text mode, in which newline
characters in the stream are an abstract indication of the end of a line,
translate to a system-specific way of terminating lines in text files.
+.coIP x
+The file is created and opened only if it does not already exist.
+Otherwise, a
+.code file-error
+exception is thrown.
+This option is allowed only with the
+.code w
+and
+.code w+
+modes.
.coIP l
Specifies that the stream will be line buffered. This means that an implicit
flush operation takes place whenever the newline character is output.
@@ -49190,8 +62772,10 @@ In addition, for a stream opened for writing or reading and writing, the
mode letter specifies that the stream will be line buffered, unless
specified as unbuffered with
.codn u .
+.coIP n
+Specifies that the operation shall not block.
.meIP digit
-A decimal digit specifies the the stream buffer size
+A decimal digit specifies the stream buffer size
as binary exponential buffer size order, such that
.code 0
specifies 1024 bytes,
@@ -49202,6 +62786,48 @@ specifying 524288 bytes. If no such digit is specified, then the
stream uses a default buffer size. It is erroneous for the
size order digit to be present together with the option
.codn u .
+.coIP z
+This option specifies
+.code gzip
+compression. A
+.code gzip-stream
+is opened for the file rather than an ordinary
+.codn stdio-stream ,
+which performs compression when writing and decompression when reading.
+The compression uses the Deflate algorithm, and a file format compatible
+with the
+.code gzip
+utility. If
+.code z
+is immediately followed by a digit, then that specifies the compression level.
+The default level is 6. A value of zero is an invalid level, silently accepted
+and treated as the default.
+When
+.code z
+is specified, special restrictions apply to the
+.metn mode-string .
+If these are violated, an exception is thrown.
+A
+.code gzip-stream
+does not support an update mode; it may not be open simultaneously for
+reading and writing as, for example, requested by the
+.str r+
+mode. The options
+.codn l ,
+.code u
+and
+.code i
+are inapplicable. The digit option specifying the buffer size
+order also may not be used with
+.codn z .
+The
+.code seek-stream
+function may only be used in the forward direction on
+.code gzip
+streams open for writing, and has the semantics of writing a region
+of zero bytes. Arbitrary seeking is supported in read mode, but
+via a costly emulation which decompresses data from the beginning
+of the file to the desired seek point.
.meIP redirection
This option refers to a special syntax that only has an effect
in mode strings that are passed to the
@@ -49210,6 +62836,47 @@ function; the syntax performs I/O redirections in the child process
created by that function, and is described in that function's
documentation.
.RE
+.IP
+The
+.code O_TMPFILE
+flag on which the
+.str T
+mode selector depends was introduced by the Linux kernel, and is likely only
+supported on Linux systems. It is not supported on all filesystem types.
+
+The
+.code T
+mode offers a way to create temporary files in a robust way in any file system
+which supports the mechanism. There is no concern about choosing a unique
+file name, since the file doesn't have one.
+The file is guaranteed to disappear if the process is terminated in any manner.
+In contrast, traditional temporary files which are initially named a name and
+then unlinked may remain if the process is abruptly terminated before it is
+able to call
+.codn unlink .
+
+On Linux, it is possible to link a file created with
+.str T
+into the filesystem, according to the following pattern:
+
+.verb
+ ;; atomically create file called "name" with content "hello"
+
+ (let* ((stream (open-file "." "T"))
+ (fd (fileno stream)))
+ (put-string "hello\en" stream)
+ (flush-stream stream)
+ (rlink `/proc/self/fd/@fd` "name"))
+.brev
+
+The atomic creation of a file can be simulated by the familiar pattern of
+writing to a visible temporary file and then renaming. However, the above
+pattern eliminates the risk that a temporary file will be left behind if the
+procedure is interrupted for any reason before reaching the
+.code rlink
+call. Any reason includes process termination that
+cannot be intercepted and handled, and operating
+system failure or power loss.
.coNP Function @ open-tail
.synb
@@ -49258,11 +62925,11 @@ this change: it automatically opens the smaller file and starts reading from
the beginning (the
.meta seek-to-end-p
flag only applies to the initial open).
-In this manner, a tail stream can dynamically growing rotating log files.
+In this manner, a tail stream can dynamically grow rotating log files.
-Caveat: since a tail stream can re-open a new file which has the same
+Caveat: since a tail stream can reopen a new file which has the same
name as the original file, it behave incorrectly if the program
-changes the current working directory, and the path name is relative.
+changes the current working directory, and the pathname is relative.
.coNP Function @ open-directory
.synb
@@ -49278,7 +62945,9 @@ If a filesystem object exists
under the path, is accessible, and is a directory, then the function
returns a stream. Otherwise, a file error exception is thrown.
-The resulting stream supports the get-line operation. Each call to the
+The resulting stream supports the
+.code get-line
+operation. Each call to the
.code get-line
operation retrieves a string representing the next directory
entry. The value
@@ -49290,6 +62959,40 @@ and
.code ..
entries in Unix filesystems are not skipped.
+.coNP Function @ tmpfile
+.synb
+.mets (tmpfile)
+.syne
+.desc
+The
+.code tmpfile
+function creates a new temporary binary file which is different from any
+existing file. It opens a stream for that file and returns the stream. The
+stream is created with the
+.code open-file
+mode
+.strn w+b .
+When the stream is closed, or the \*(TX image terminates, the file is deleted.
+
+Note: the
+.code tmpfile
+function is implemented using the same-named ISO C and POSIX library function.
+On POSIX systems of sufficient quality,
+.code tmpfile
+deletes the file before returning the open stream, such that the file object
+continues to exist while the stream is open, but is not known by any name
+in the file system. POSIX (IEEE Std 1003.1-2017) notes that in some
+implementations, "a permanent file may be left behind if the process calling
+tmpfile() is killed while it is processing a call to tmpfile".
+
+Notes: if a unique file is required which exists in the file system under a
+known name until explicitly deleted, the
+.code mkstemp
+function may be used. If a unique directory needs to be created, the
+.code mkdtemp
+function may be used. These two functions are described in the Unix Filesystem
+Complex Operations section of the manual.
+
.coNP Function @ make-string-input-stream
.synb
.mets (make-string-input-stream << string )
@@ -49336,7 +63039,7 @@ The
.code make-string-output-stream
function, which takes no arguments, creates a string output stream.
Data sent to this stream is accumulated into a string object.
-String output streams supports both character and byte output operations.
+String output streams support both character and byte output operations.
Bytes are assumed to represent a UTF-8 encoding, and are decoded in order
to form characters which are stored into the string.
@@ -49350,7 +63053,7 @@ The
function is used to retrieve the accumulated string.
If the null character is written to a string output stream, the behavior
-is unspecified. \*(TX strings cannot contain null bytes. A the pseudo-null
+is unspecified. \*(TX strings cannot contain null bytes. The pseudo-null
character
.codn #\exDC00 ,
also notated
@@ -49424,7 +63127,7 @@ as if by the
expression.
Then it evaluates the
-.metn body-form -s
+.metn body-form s
in the scope of the variable.
The value of the last
@@ -49466,7 +63169,7 @@ as if by the
expression.
Then it evaluates the
-.metn body-form -s
+.metn body-form s
in the scope of the variable.
The value of the last
@@ -49497,7 +63200,7 @@ stream is created as if by the
function.
Then it evaluates
-.metn body-form -s
+.metn body-form s
in the scope of that variable.
After these forms are evaluated, the string is extracted
@@ -49523,7 +63226,7 @@ stream is created as if by the
function.
Then it evaluates
-.metn body-form -s
+.metn body-form s
in the scope of that variable.
After these forms are evaluated, the string list is extracted
@@ -49586,9 +63289,13 @@ errors, otherwise
For most streams, "without errors" means that any buffered output data is
flushed successfully.
-For command and process pipes (see open-command and open-process), success also
+For command and process pipes (see
+.code open-command
+and
+.codn open-process ),
+success also
means that the process terminates normally, with a successful error code, or an
-unsuccessful one. An abnormal termination is considered an error, as
+unsuccessful one. An abnormal termination is considered an error,
as is the inability to retrieve the termination status, as well as the situation
that the process continues running in spite of the close attempt.
Detecting these situations is platform specific.
@@ -49602,6 +63309,43 @@ function throws an exception if an error occurs during the close operation
instead of returning
.codn nil .
+If
+.code close-stream
+is called in such a way that it returns a value, without throwing an exception,
+and that value isn't
+.codn nil ,
+that value is retained. Additional calls to the function with the same
+.meta stream
+object return that same value without having any effect on the stream.
+These additional calls ignore the
+.meta throw-on-error-p
+argument.
+
+The
+.meta stream
+may be associated with a process, in one of several ways: implicitly,
+by the functions
+.code open-process
+and
+.code open-command
+and related functions, or explicitly by the
+.code open-fileno
+function, if a
+.meta pid
+argument is specified.
+In this situation,
+.code close-stream
+waits for the termination of that process, after closing the underlying file descriptor.
+If the process terminates normally, then
+.code close-stream
+returns its termination status, which is zero if the termination is successful.
+If the status of the process cannot be obtained, or is an abnormal termination, then
+the return value is
+.codn nil .
+In that situation, if
+.meta throw-on-error-p
+is true, an exception is thrown instead.
+
.coNP Macro @ with-stream
.synb
.mets (with-stream >> ( stream-var << init-form )
@@ -49610,10 +63354,10 @@ instead of returning
.desc
The
.code with-stream
-binds the variable whose name is given by the
+macro binds the variable whose name is given by the
.meta stream-var
argument, and macro arranges for the evaluation of
-.metn body-form -s
+.metn body-form s
in the scope of that variable.
The variable is initialized with the value produced
@@ -49637,7 +63381,7 @@ or else
if these forms are absent.
If the evaluation of the
-.metn body-form -s
+.metn body-form s
is abandoned, the stream is still closed. That is to say,
the closure of the stream is a protected action, as if by
the
@@ -49700,7 +63444,7 @@ The
.code clear-error
function removes the error situation from a stream. On some streams, it does
nothing. If an error has occurred on a stream, this function should be called
-prior to re-trying any I/O or positioning operations.
+prior to retrying any I/O or positioning operations.
The return value is the previous error code, or
.code nil
if there was no error, or the operation is not supported on the stream.
@@ -49730,7 +63474,8 @@ newline character and returns it as a string. (The newline character does not
appear in the string which is returned).
Character input from streams based on bytes requires UTF-8 decoding, so that
-get-char actually may read several bytes from the underlying low level
+.code get-char
+may actually read several bytes from the underlying low-level
operating system stream.
The
@@ -49862,13 +63607,17 @@ to a stream. If the
stream is based on bytes, then the character is encoded into UTF-8 and multiple
bytes are written. Streams which support
.code put-char
-also support put-line, and
+also support
+.code put-line
+and
.codn put-string .
The
.code put-string
function writes the characters of a string out to
-the stream as if by multiple calls to put-char. The
+the stream as if by multiple calls to
+.codn put-char .
+The
.meta string
argument
may be a symbol, in which case its name is used as the string.
@@ -49985,8 +63734,12 @@ to and from UTF-8.
The
.meta whence
-argument is one of three keywords: :from-start, :from-current
-and :from-end. These denote the start of the file, the current position
+argument is one of three keywords:
+.codn :from-start ,
+.code :from-current
+and
+.codn :from-end .
+These denote the start of the file, the current position in the file
and the end of the file.
If
@@ -50248,7 +64001,7 @@ argument specified, it overrides this default. In that situation,
the specified mode should permit reading.
These streams are turned
-into a catenated stream as if applied as arguments to
+into a catenated stream as if they were the arguments of a call to
.codn make-catenated-stream .
The effect is that multiple files appear to be catenated together into a single
@@ -50288,14 +64041,85 @@ there are no files, then read from standard input:
@(end)
.brev
-.coNP Function @ abs-path-p
+.coNP Function @ path-equal
+.synb
+.mets (path-equal < left-path << right-path )
+.syne
+.desc
+The
+.code path-equal
+function determines whether the two paths
+.meta left-path
+and
+.meta right-path
+are equal under a certain definition of equivalence, whose requirements are given below.
+The function returns
+.code t
+if the paths are equal, otherwise
+.codn nil .
+
+If
+.meta left-path
+and
+.meta right-path
+are strings which are identical under the
+.code equal
+function, then they are considered equal paths.
+
+Otherwise, the two paths are equal if the relative path from
+.meta left-path
+to
+.meta right-path
+is
+.str .
+(dot), as would be determined by the
+.code path-rel
+function, if it were applied to
+.meta left-path
+and
+.meta right-path
+as its arguments. If
+.code path-rel
+would return the dot path, then the two paths are equal. If
+.code path-rel
+would return any other value, or throw an exception, then the paths are unequal.
+
+.TP* Examples:
+
+.verb
+ ;; simple case
+ (path-equal "a" "a") -> t
+ (path-equal "a" "b") -> nil
+
+ ;; trailing slashes don't matter
+ (path-equal "a" "a/") -> t
+ (path-equal "a/" "a/") -> t
+
+ ;; .. components resolved:
+ (path-equal "a/b/../c" "a/c") -> t
+
+ ;; . components resolved:
+ (path-equal "a" "a/././.") -> t
+ (path-equal "a/." "a/././.") -> t
+
+ ;; (On Microsoft Windows)
+ ;; different drive:
+ (path-equal "c:/a" "d:/b/../a") -> nil
+ ;; same drive:
+ (path-equal "c:/a" "c:/b/../a") -> t
+.brev
+
+.coNP Functions @ abs-path-p and @ portable-abs-path-p
.synb
.mets (abs-path-p << path )
+.mets (portable-abs-path-p << path )
.syne
.desc
The
-.code abs-path-function
-tests whether the argument
+.code abs-path-p
+and
+.code portable-abs-path-p
+functions test whether the argument
.meta path
is an absolute path, returning a
.code t
@@ -50303,7 +64127,9 @@ or
.code nil
indication.
-The function behaves in the same manner on all platforms, implementing
+The
+.code portable-abs-path-p
+function behaves in the same manner on all platforms, implementing
a platform-agnostic definition of
.IR "absolute path" ,
as follows.
@@ -50314,7 +64140,8 @@ followed by a slash or backslash.
The empty string isn't an absolute path.
-Examples of absolute paths:
+Examples of absolute paths under
+.codn portable-abs-path-p :
.verb
/etc
@@ -50326,13 +64153,27 @@ Examples of absolute paths:
Examples of strings which are not absolute paths:
-.mono
-.mets >> ( the < empty << string )
+.verb
.
abc
foo:bar/x
$:\eabc
-.onom
+.brev
+
+The
+.code abs-path-p
+is similar to
+.code portable-abs-path-p
+except that it reports false for paths which are not absolute paths
+according to the host platform. The following paths are not absolute
+on POSIX platforms:
+
+.verb
+ c:/tmp
+ ftp://user@server
+ disk0:/home
+ Z:\eUsers
+.brev
.coNP Function @ pure-rel-path-p
.synb
@@ -50351,7 +64192,7 @@ which isn't the string
.str .
(single period),
which doesn't begin with a period followed by a slash or backslash,
-and which doesn't begin with alphanumeric word
+and which doesn't begin with an alphanumeric word
terminated by a colon.
The empty string is a pure relative path.
@@ -50389,7 +64230,7 @@ The
and
.code base-name
functions calculate, respective, the directory part and
-base name part of a path name.
+base name part of a pathname.
The calculation is performed in a platform-dependent way, using the
characters in the variable
@@ -50409,7 +64250,7 @@ is reduced to
.strn "/" .
The resulting trimmed path is the
-.I "effective path" .
+.IR "effective path" .
If the effective path is an empty string, then
.code dir-name
@@ -50451,28 +64292,325 @@ If the
.meta suffix
argument is given to
.codn base-name ,
-then the returned base name is adjusted as follows. If the base
-name ends in
+it specifies a proper suffix to be removed from the returned base name.
+First, the base name is calculated according to the foregoing rules.
+Then, if
+.meta suffix
+matches a trailing portion of the base name, but not the entire base name,
+it is removed from the base name.
+
+The
+.meta suffix
+parameter may be given a
+.codn nil ,
+argument, which is treated exactly as if it were absent.
+Note: this requirement allows for the following idiom
+to work correctly even in cases when
+.code p
+has no suffix:
+
+.verb
+ ;; calculate base name of p with short suffix removed
+ (base-name p (short-suffix p))
+
+ ;; calculate base name of p with long suffix removed
+ (base-name p (long-suffix p))
+.brev
+
+.TP* Examples:
+
+.verb
+ (base-name "") -> ""
+ (base-name "/") -> "/"
+ (base-name ".") -> "."
+ (base-name "./") -> "."
+ (base-name "a") -> "a"
+ (base-name "/a") -> "a"
+ (base-name "/a/") -> "a"
+ (base-name "/a/b") -> "b"
+ (base-name "/a/b/") -> "b"
+ (base-name "/a/b///") -> "b"
+
+ ;; with suffix
+ (base-name "" "") -> ""
+ (base-name "/" "/") -> "/"
+ (base-name "/" "") -> "/"
+ (base-name "." ".") -> "."
+ (base-name "." "") -> "."
+ (base-name "./" "/") -> "."
+ (base-name "a" "a") -> "a"
+ (base-name "a" "") -> "a"
+ (base-name "a.b" ".b") -> "a"
+ (base-name "a.b/" ".b") -> "a"
+ (base-name "a.b/" ".b/") -> "a.b"
+ (base-name "a.b/" "a.b") -> "a.b"
+.brev
+
+.coNP Functions @ long-suffix and @ short-suffix
+.synb
+.mets (long-suffix < path <> [ alt ])
+.mets (short-suffix < path <> [ alt ])
+.syne
+.desc
+The
+.code long-suffix
+and
+.code short-suffix
+functions calculate the
+.I "long suffix"
+and
+.I "short suffix"
+of
+.metn path ,
+which must be a string.
+
+If
+.meta path
+does not contain any occurrences of the character
+.code .
+(period) in the role of a suffix delimiter, then
+.meta path
+does not have a suffix. In this situation, both
+functions return the
+.meta alt
+argument, which defaults to
+.code nil
+if it is omitted.
+
+What it means for
+.meta path
+to have a suffix delimiter is that the
+.code .
+character occurs somewhere in the last component of
+.metn path ,
+other than as the first character of that component.
+What constitutes the last component is specified
+in more detail below.
+
+If a suffix delimiter is present, then the long or short suffix is the
+substring of
+.meta path
+which includes the delimiting period and all characters which follow,
+except that if
+.meta path
+ends in a sequence of one or more path separator characters,
+those characters are omitted from the returned suffix.
+
+If multiple periods occur in the last component of the path,
+the delimiter for the long suffix is the leftmost period and
+the delimiter for the short suffix is the rightmost period.
+
+If the delimiting period is the rightmost character of
+.metn path ,
+or occurs immediately before a trailing path separator,
+then the suffix delimited by that period is the period itself.
+
+If
+.meta path
+contains only one suffix delimiter, then its long and short suffix coincide.
+
+For the purpose of identifying the last component of
+.metn path ,
+if
+.meta path
+ends a sequence of one or more path-separator characters, then those
+characters are removed from consideration.
+If the remaining string contains path-separator characters, then
+the last component consists of that portion of it which follows
+the rightmost path-separator character. Otherwise, the last component
+is the entire string. The suffix, if present, is identified and
+extracted from this last component.
+
+.TP* Examples:
+
+.verb
+ (short-suffix "") -> nil
+ (short-suffix ".") -> nil
+ (short-suffix "abc") -> nil
+ (short-suffix ".abc") -> nil
+ (short-suffix "/.abc") -> nil
+ (short-suffix "abc" "") -> ""
+ (short-suffix "abc.") -> "."
+ (short-suffix "abc.tar") -> ".tar"
+ (short-suffix "abc.tar///") -> ".tar"
+ (short-suffix "abc.tar.gz") -> ".gz"
+ (short-suffix "abc.tar.gz/") -> ".gz"
+ (short-suffix "x.y.z/abc.tar.gz/") -> ".gz"
+ (short-suffix "x.y.z/abc.tar.gz//") -> nil
+
+ (long-suffix "") -> nil
+ (long-suffix ".") -> nil
+ (long-suffix "abc") -> nil
+ (long-suffix ".abc") -> nil
+ (long-suffix "/.abc") -> nil
+ (long-suffix "abc.") -> "."
+ (long-suffix "abc.tar") -> ".tar"
+ (long-suffix "abc.tar///") -> ".tar"
+ (long-suffix "abc.tar.gz") -> ".tar.gz"
+ (long-suffix "abc.tar.gz/") -> ".tar.gz"
+ (long-suffix "x.y.z/abc.tar.gz/") -> ".tar.gz"
+.brev
+
+.coNP Functions @ trim-long-suffix and @ trim-short-suffix
+.synb
+.mets (trim-long-suffix << path )
+.mets (trim-short-suffix << path )
+.syne
+.desc
+The
+.code trim-long-suffix
+and
+.code trim-short-suffix
+functions calculate the portion of
+.meta path
+.I "long suffix"
+and
+.I "short suffix"
+of the string argument
+.metn path ,
+and return a path with the suffix removed.
+
+Respectively,
+.code trim-long-suffix
+and
+.code trim-short-suffix
+calculate the suffix in exactly the same manner as
+.code long-suffix
+and
+.codn short-suffix .
+
+If
+.meta path
+is found not to contain a suffix, then it is returned.
+
+If
+.meta path
+contains a suffix, then a new string is returned from which
+the suffix is deleted. If the suffix is followed by one or more path separator
+characters, these are preserved in the return value.
+
+.TP* Examples:
+
+.verb
+ (trim-short-suffix "") -> ""
+ (trim-short-suffix "a") -> "a"
+ (trim-short-suffix ".") -> "."
+ (trim-short-suffix ".a") -> ".a"
+
+ (trim-short-suffix "a.") -> "a"
+ (trim-short-suffix "a.b") -> "a"
+ (trim-short-suffix "a.b.c") -> "a.b"
+
+ (trim-short-suffix "a./") -> "a/"
+ (trim-short-suffix "a.b/") -> "a/"
+ (trim-short-suffix "a.b.c/") -> "a.b/"
+
+ (trim-long-suffix "a.b.c") -> "a"
+ (trim-long-suffix "a.b.c/") -> "a/"
+ (trim-long-suffix "a.b.c///") -> "a///"
+.brev
+
+.coNP Function @ add-suffix
+.synb
+.mets (add-suffix < path << suffix )
+.syne
+.desc
+The
+.code add-suffix
+function combines the string arguments
+.meta path
+and
.meta suffix
-then a trimmed version of the base name is returned instead, with that suffix
-removed. This adjustment isn't performed if it would result in an empty
-string being returned.
+in a way which harmonizes with the
+.code long-suffix
+and
+.code short-suffix
+functions.
+
+If
+.meta path
+does not end in a path separator character, that category being defined by the
+.code path-sep-chars
+variable, then
+.code add-suffix
+returns the trivial string catenation of
+.meta path
+and
+.metn suffix .
+
+Otherwise,
+.code add-suffix
+returns a string formed by inserting
+.meta suffix
+into
+.meta path
+just prior to the sequence of trailing path separator characters.
+The returned string is a catenation of that portion of
+.meta path
+which excludes the sequence of trailing path separators,
+followed by
+.metn suffix ,
+followed by the sequence of trailing path separators.
+
+A path separator which occurs as a part of syntax that indicates an absolute
+pathname is not considered a trailing separator. A path which begins with a
+separator is absolute. Other platform-specific path patterns may constitute
+an absolute pathname.
+
+Note: in cases when
+.meta suffix
+does not begin with a period, or is inserted in such a way
+that it is the start of a path component, then the functions
+.code long-suffix
+and
+.code short-suffix
+will not recognize
+.meta suffix
+in the resulting path.
+
+.TP* Examples:
+
+.verb
+ (add-suffix "" "") -> ""
+ (add-suffix "" "a") -> "a"
+ (add-suffix "." "a") -> ".a"
+ (add-suffix "." ".a") -> "..a"
+ (add-suffix "/" ".b") -> "/.b"
+ (add-suffix "//" ".b") -> "/.b/"
+ (add-suffix "//" "b") -> "/b/"
+ (add-suffix "a" "") -> "a"
+ (add-suffix "a" ".b") -> "a.b"
+ (add-suffix "a/" ".b") -> "a.b/"
+ (add-suffix "a//" ".b") -> "a.b//"
+
+ ;; On MS Windows
+ (add-suffix "c://" "x") -> "c:/x/"
+ (add-suffix "host://" "x") -> "host://x"
+ (add-suffix "host:///" "x") -> "host://x/"
+
+.brev
.coNP Function @ path-cat
.synb
-.mets (path-cat < dir-path << rel-path )
+.mets (path-cat >> [ dir-path <> { rel-path }*])
.syne
.desc
The
.code path-cat
-function joins the directory path name given by the character
-string argument
+function joins together zero or more paths, returning the combined path.
+All arguments are strings.
+
+The following description defines the behavior when
+.code path-cat
+is given exactly two arguments, which are interpreted as
.meta dir-path
-with the relative path name given by
-.metn rel-path ,
-returning the joined path.
+and
+.metn rel-path .
+A description of the variable-argument semantics follows.
-The function is related to the functions
+Firstly, the two-argument
+.code path-cat
+is related to the functions
.code dir-name
and
.code base-name
@@ -50491,7 +64629,7 @@ might not be equivalent strings.
The
.code path-cat
function ensures that paths are joined without superfluous
-path separator characters, regardless of whether
+path-separator characters, regardless of whether
.meta dir-path
ends in a separator.
@@ -50509,7 +64647,7 @@ function eliminates trivial occurrences of the
(dot) path component. It preserves trailing separators in the following
way: if
.meta rel-path
-ends in a path separator character, then the returned string shall
+ends in a path-separator character, then the returned string shall
end in that character; and if
.meta rel-path
vanishes entirely because it is equivalent to the dot, then the returned
@@ -50517,13 +64655,46 @@ string is
.meta dir-name
itself.
+If
+.meta dir-path
+is an empty string, then
+.code rel-path
+is returned, and vice versa.
+
+The variadic semantics of
+.code path-cat
+are as follows.
+
+If
+.code path-cat
+is called with no arguments at all, it returns the path
+.str .
+(period) denoting the relative path of the current directory.
+
+If
+.code path-cat
+is called with one argument, that argument is returned.
+
+If
+.code path-cat
+is called with three or more arguments, a left-associative reduction
+takes place using the two-argument semantics. The first two arguments
+are catenated into a single path, which is then catenated
+with the third argument, and so on.
+
+The above semantics imply that the following equivalence holds:
+
+.verb
+ [reduce-left path-cat list] <--> [apply path-cat list]
+.brev
+
.TP* Examples:
.verb
(path-cat "" "") --> ""
- (path-cat "" ".") --> ""
- (path-cat "." "") --> ""
- (path-cat "." ".") --> ""
+ (path-cat "" ".") --> "."
+ (path-cat "." "") --> "."
+ (path-cat "." ".") --> "."
(path-cat "abc" ".") --> "abc"
(path-cat "." "abc") --> "abc"
@@ -50539,15 +64710,275 @@ itself.
(path-cat "/" "abc") --> "/abc"
(path-cat "ab/cd" "ef") --> "ab/cd/ef"
+
+ (path-cat "a" "b" "c") --> "a/b/c"
+
+ (path-cat "a" "b" "" "c" "/") --> "a/b/c/"
+.brev
+
+.coNP Function @ trim-path-seps
+.synb
+.mets (trim-path-seps << path )
+.syne
+.desc
+The
+.code trim-path-seps
+function removes a consecutive run of one or more trailing separators from the
+end of the input string
+.metn path .
+
+The function treats the
+.mets path
+in a system-independent way: both the backslash and forward slash
+are considered a trailing separator.
+
+The function preserves any necessary trailing separators, such as that of
+the absolute path
+.str /
+or the trailing slashes in volume absolute paths such as
+.strn c:/ .
+
+.TP* Examples:
+
+.verb
+ (trim-path-seps "") -> ""
+ (trim-path-seps "/") -> "/"
+ (trim-path-seps "//") -> "/"
+ (trim-path-seps "a///") -> "a"
+ (trim-path-seps "/a///") -> "/a")
+
+ (trim-path-seps "\e\e") -> "\e\e"
+ (trim-path-seps "\e\e\e\e") -> "\e\e"
+ (trim-path-seps "\e\ea\e\e\e\e\e\e") -> "\e\ea")
+
+ (trim-path-seps "c:/") -> "c:/"
+ (trim-path-seps "c://") -> "c:/"
+ (trim-path-seps "c:///") -> "c:/"
+ (trim-path-seps "c:a///") -> "c:a"
+
+ ;; not a volume prefix:
+ (trim-path-seps "/c:/a///") -> "/c:/a"
+ (trim-path-seps "/c://///") -> "/c:")
+
+ (trim-path-seps "c:\e\e") -> "c:\e\e"
+ (trim-path-seps "c:\e\e\e\e") -> "c:\e\e"
+ (trim-path-seps "c:a\e\e\e\e\e\e") -> "c:a"
+
+ ;; mixtures
+ (trim-path-seps "c:/\e\e/\e\e/") -> "c:/"
+.brev
+
+.coNP Function @ rel-path
+.synb
+.mets (rel-path < from-path << to-path )
+.syne
+.desc
+The
+.code rel-path
+function calculates the relative path between two file system locations
+indicated by string arguments
+.meta from-path
+and
+.metn to-path .
+The
+.meta from-path
+is assumed to be a directory. The return value is a relative path
+which could be used to access an object named by
+.meta to-path
+if
+.meta from-path
+were the current working directory.
+
+The calculation performed by
+.code rel-path
+is a pure calculation; it has no interaction with the host operating system.
+No component of either input path has to exist. Symbolic links are not
+resolved. This can lead to incorrect results, as noted below.
+
+Either both the inputs must be absolute paths, or must both be relative,
+otherwise an error exception is thrown.
+
+On the MS Windows platform, if one input specifies a drive letter prefix, the
+other input must specify the same prefix, or else an error exception is thrown;
+there is no relative path between locations on different drives.
+The behavior is unspecified if the arguments are two UNC paths indicating
+different hosts.
+
+The
+.code rel-path
+function first splits both paths into components according to the
+platform-specific pathname separators indicated by the
+.code path-sep-chars
+variable.
+
+Next, it eliminates all empty components,
+.code .
+(dot) components and
+.code ..
+(dotdot)
+components from both separated paths. All dot components are removed,
+and any component which is neither dot nor dotdot is removed if it is
+followed by dotdot.
+
+Then, a common prefix is determined between the two component sequences,
+and a relative component sequence is calculated from them as follows:
+
+If the component sequence corresponding to
+.meta from-path
+is longer than the common prefix, then the excess part of that
+sequence after the common prefix must not contain any
+.code ..
+(dotdot) components, or else an error exception is thrown.
+Otherwise, every component in this excess part of the
+.meta from-path
+component sequence is converted to
+.code ..
+in order to express the relative navigation from
+.meta from-path
+up to the directory indicated by the common prefix.
+
+Next, if the component sequence corresponding to
+.meta to-path
+has any components in excess of the common prefix, those excess components are
+appended to this possibly empty sequence of dotdot components, in
+order to express navigation from the common prefix down to the
+.meta to-path
+object. This excess sequence coming from
+.meta to-path
+may include
+.code ..
+components.
+
+Finally, if the resulting sequence is nonempty, it is joined together using the leftmost
+path separator character indicated in
+.code path-sep-chars
+and returned. If it is empty, then the string
+.str .
+is returned.
+
+Note: because the function doesn't access the file system and in particular
+does not resolve symbolic links or other indirection devices, the result
+may be incorrect. For example, suppose that the current working directory
+contains a symbolic link called
+.code up
+which expands to
+.code ..
+(dotdot). The expression
+.code "(rel-path \(dqup/a\(dq \(dq../a\(dq)"
+is oblivious to this, and calculates
+.strn ../../../a .
+The correct result in light of
+.code up
+being an alias for
+.code ..
+calls for a return value of
+.strn . .
+The exact problem is that any symbolic links in the excess part of
+.meta from-path
+after the common prefix are assumed by
+.code rel-path
+to be simple subdirectory names, which can be navigated in reverse
+using a
+.code ..
+link. This reverse navigation assumption is false for any symbolic link which
+which does not act as an alias for a subdirectory in the same location.
+
+In situations where this possibility exists, it is recommended to use
+.code realpath
+function to canonicalize the input paths.
+
+The following is an example of the algorithm being applied to arguments
+.str a/d/../b/x/y/
+and
+.strn a/b/w ,
+where the assumption is that this is on a POSIX platform where the leftmost
+character in
+.code path-sep-chars
+is
+.codn / :
+
+Firstly, both inputs are converted to component sequences, those respectively being:
+
+.verb
+ ("a" "d" ".." "b" "x" "y" "")
+ ("a" "b" "w")
+.brev
+
+Next the
+.code ..
+and empty components are removed:
+
+.verb
+ ("a" "b" "x" "y")
+ ("a" "b" "w")
.brev
+At this point, the common prefix is identified:
+
+.verb
+ ("a" "b")
+.brev
+
+The
+.meta from-path
+has two components in excess of the prefix:
+
+.verb
+ ("x" "y")
+.brev
+
+which are each replaced by
+.strn .. .
+
+The
+.meta to-path
+has one component in excess of the common prefix,
+.strn w .
+
+These two sequences are appended together:
+
+.verb
+ (".." ".." "w")
+.brev
+
+The resulting path is then formed by joining these with the separator
+character, resulting in the relative path
+.strn "../../w" .
+
+.TP* Examples:
+
+.verb
+ ;; mixtures of relative and absolute
+ (rel-path "/abc" "abc") -> ;; error
+ (rel-path "abc" "/abc") -> ;; error
+
+ ;; dotdot in excess part of from path:
+ (rel-path "../../x" "y") -> ;; error
+
+ (rel-path "." ".") -> "."
+ (rel-path "./abc" "abc") -> "."
+ (rel-path "abc" "./abc") -> "."
+ (rel-path "./abc" "./abc") -> "."
+ (rel-path "abc" "abc") -> "."
+ (rel-path "." "abc") -> "abc"
+ (rel-path "abc/def" "abc/ghi") -> "../ghi"
+ (rel-path "xyz/../abc/def" "abc/ghi") -> "../ghi"
+ (rel-path "abc" "d/e/f/g/h") -> "../d/e/f/g/h"
+ (rel-path "abc" "d/e/../g/h") -> "../d/g/h"
+ (rel-path "d/e/../g/h" ".") -> "../../.."
+ (rel-path "d/e/../g/h" "a/b") -> "../../../a/b"
+ (rel-path "x" "../../../y") -> "../../../../y"
+ (rel-path "x///" "x") -> "."
+ (rel-path "x" "x///") -> "."
+ (rel-path "///x" "/x") -> "."
+.brev
.coNP Variable @ path-sep-chars
.desc
The
.code path-sep-chars
variable holds a string consisting of the characters which the underlying
-operating system recognizes as path name separators.
+operating system recognizes as pathname separators.
If a particular of these characters is considered preferred on
the host platform, that character is placed in the first position of
@@ -50558,8 +64989,10 @@ function.
.coNP Functions @ read and @ iread
.synb
-.mets (read >> [ source >> [ error-stream >> [ error-retval <> [ name ]]]])
-.mets (iread >> [ source >> [ error-stream >> [ error-retval <> [ name ]]]])
+.mets (read >> [ source
+.mets \ \ \ \ \ \ >> [ err-stream >> [ err-retval >> [ name <> [ lineno ]]]]])
+.mets (iread >> [ source
+.mets \ \ \ \ \ \ \ >> [ err-stream >> [ err-retval >> [ name <> [ lineno ]]]]])
.syne
.desc
The
@@ -50572,16 +65005,35 @@ string, or a stream. If it is omitted, then
.code *stdin*
is used as the stream.
-The source must provide the text representation of one complete \*(TL object.
+The
+.meta source
+must provide the text representation of one complete \*(TL object.
+If
+.meta source
+and the function being applied is
+.codn read ,
+then if the object is followed by any non-whitespace material, the
+situation is treated as a syntax error, even if that material is
+a syntactically valid additional object.
+The
+.code iread
+function ignores this situation. Other differences between
+.code read
+and
+.code iread
+are given below.
-Multiple calls to read on the same stream will extract successive objects
-from the stream. To parse successive objects from a string, it is necessary
+Multiple calls to
+.code read
+on the same stream will extract successive objects from the stream.
+To parse successive objects from a string, it is necessary
to convert it to a string stream.
The optional
-.meta error-stream
+.meta err-stream
argument can be used to specify a stream to which
-parse errors diagnostics are sent. If absent, the diagnostics are suppressed.
+diagnostics of parse errors are sent.
+If absent, the diagnostics are suppressed.
The optional
.meta name
@@ -50595,12 +65047,19 @@ is used as the name if
.meta source
is a string.
+The optional
+.code lineno
+argument, defaulting to 1, specifies the starting line number. This,
+like the
+.meta name
+argument, is used for reporting errors.
+
If there are no parse errors, the function returns the parsed data
structure. If there are parse errors, and the
-.meta error-retval
+.meta err-retval
parameter is
present, its value is returned. If the
-.meta error-retval
+.meta err-retval
parameter
is not present, then an exception of type
.code syntax-error
@@ -50645,6 +65104,70 @@ it may be useful to set
true in order to obtain better diagnostics. However, source location recording
incurs a performance and storage penalty.
+.coNP Function @ read-objects
+.synb
+.mets (read-objects >> [ source
+.mets \ \ \ \ \ \ \ \ \ \ \ \ \ \ >> [ err-stream
+.mets \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ >> [ err-retval >> [ name <> [ lineno ]]]]])
+.syne
+.desc
+The
+.code read-objects
+function has the same argument syntax and semantics as the
+.code read
+function, except that rather than reading one object, it reads all
+the Lisp objects from the source, and returns a list of these objects.
+
+If the stream is empty, then
+.code read-objects
+returns the empty list
+.codn nil ,
+whereas the
+.code read
+function treats the situation as an error.
+
+.coNP Function @ parse-errors
+.synb
+.mets (parse-errors << stream )
+.syne
+.desc
+The
+.code parse-errors
+function retrieves information, from a
+.metn stream ,
+pertaining to the status of the most recent parsing operation performed
+on that stream: namely, a previous call to
+.codn read ,
+.code iread
+or
+.codn get-json .
+
+If the
+.meta stream
+object has not been used for parsing, or else the most recent
+parsing operation did not encounter errors, then
+.code parse-errors
+returns
+.codn nil .
+
+If the most recent parsing operation on
+.meta stream
+encountered errors, then
+.code parse-errors
+function returns a positive integer value indicating the error count.
+Otherwise it returns
+.codn nil .
+
+If a parse error operation encounters a syntax error before obtaining any token
+from the stream, then the error count is zero and
+.code parse-errors
+returns
+.codn nil .
+Consequently,
+.code parse-errors
+may be used after a failed parse operation to distinguish a true
+syntax error from an end-of-stream condition.
+
.coNP Function @ record-adapter
.synb
.mets (record-adapter < regex >> [ stream <> [ include-match ]])
@@ -50738,7 +65261,7 @@ to break up long lines.
The
.code indent-off
and
-.code intent-foff
+.code indent-foff
modes are also treated the same way by lower level stream output,
indicating "indentation turned off". The modes are distinguished
by
@@ -50804,8 +65327,7 @@ function sets the indent mode of
.meta stream
to
.meta new-mode
-if, and only if,
-its current mode is equal to
+if and only if its current mode is equal to
.metn compare-mode .
Whether or not it changes the mode, it returns the previous mode.
@@ -50815,17 +65337,17 @@ only differs in that it sets
.meta stream
to
.meta new-mode
-if, and only if,
-the current mode is
+if and only if the current mode is
.B not
equal to
.metn compare-mode .
-.coNP Functions @, get-indent @ set-indent and @ inc-indent
+.coNP Functions @, get-indent @, set-indent @ inc-indent and @ inc-indent-abs
.synb
.mets (get-indent << stream )
.mets (set-indent < stream << new-indent )
.mets (inc-indent < stream << indent-delta )
+.mets (inc-indent-abs < stream << indent-delta )
.syne
.desc
These functions manipulate the indentation value of the stream.
@@ -50856,6 +65378,16 @@ The indentation is calculated by adding
to the current column position.
If a negative indentation results, it is clamped to zero.
+The
+.code inc-indent-abs
+function sets
+.metn stream 's
+indentation relative to the current indentation value.
+The indentation is calculated by adding
+.meta indent-delta
+to the current indentation amount.
+If a negative indentation results, it is clamped to zero.
+
.coNP Function @ width-check
.synb
.mets (width-check < stream << alt-char )
@@ -50963,12 +65495,12 @@ methods defined on structure objects can take advantage of
.code width-check
and
.code force-break
-in the same way so that application-defined output integrates
+in the same way so that user-defined output integrates
with the formatting algorithm.
.SS* Stream Output Limiting
-Streams have two properties which are used by the The \*(TL object printer to
+Streams have two properties which are used by the \*(TL object printer to
optionally truncate the output generated by aggregate objects.
A stream can specify a maximum length for aggregate objects via the
@@ -51013,7 +65545,7 @@ as well as quasiliterals and quasiword list literals (QLLs).
The default value is 0 and this value means that no limit is imposed.
Otherwise, the value must be a positive integer.
-When the list, vector or hash table object being printed has more
+When the list, vector or hash-table object being printed has more
elements than the maximum length, then elements are printed only up to
the maximum count, and then the remaining elements are summarized by
printing the
@@ -51021,12 +65553,14 @@ printing the
(three dots) character sequence as if it were an additional element.
This sequence is an invalid token; it cannot be read as input.
-When a character string is printed, any positive value of
-the maximum length which is less than 15 is considered to be 15.
-The maximum length specifies the number of characters of the
-a string which are output.
+When a character string is printed, and the maximum length parameter
+is nonzero, a maximum character count is determined as follows.
+Firstly, if the maximum length value is less than 3, it is taken
+to be 3. Then it is multiplied by 8. Thus, a maximum length
+of 10 allows 80 characters, whereas a maximum length of 1
+allows 24 characters.
-If a string which exceeds the maximum length is being printed
+If a string which exceeds the maximum number of characters is being printed
with read-print consistency, as by the
.code print
function, then only a prefix of the string is printed, limited
@@ -51038,7 +65572,7 @@ whose leading invalid escape sequence
.code \e.
(backslash, dot) ensures that the truncated object is not readable.
-If a string which exceeds the maximum length is being printed
+If a string which exceeds the maximum number of characters is being printed
without read-print consistency, as by the
.code pprint
function, then only a prefix of the string is printed, limited
@@ -51051,17 +65585,16 @@ Quasiliterals are treated using a combination of behaviors. Elements of a
quasiliteral are literal sequence of text, and embedded variables and
expressions. The maximum length specifies both the maximum number of elements
in the quasiliteral, and the maximum number of characters in any element which
-is a sequence of text. When either limit is exceeded, the quasiliteral
-is immediately terminated with the sequence
+is a sequence of text. When either limit is exceeded, the
+quasiliteral is immediately terminated with the sequence
.code \e...`
-(escaped dot, dot, dot, backtick). The maximum limit is applied to
+(escaped dot, dot, dot, backtick). The maximum character limit is applied to
the units of text cumulatively, rather than individually. As in the case of
-string literals, smaller limit values than 15 are treated as 15,
-but only for the cumulative text length limit. For limiting the number of
-elements, the count is used as-is.
+string literals, the limit is determined by multiplying the length by 8, and
+clamping at a minimum value of 24.
When a QLL is printed, the space-separated elements
-of the literal are individually subject to the maximum length limit as if
+of the literal are individually subject to the maximum character limit as if
they were independent quasiliterals. Furthermore, the sequence of these
elements is subject to the maximum length. If there are more elements in the
QLL, then the sequence
@@ -51121,7 +65654,7 @@ The
function returns the previous value.
.SS* Coprocesses
-.coNP Functions @ open-command and @ open-process
+.coNP Functions @, open-command @ open-process and @ open-subprocess
.synb
.mets (open-command < system-command <> [ mode-string ])
.mets (open-process < program < mode-string <> [ argument-list ])
@@ -51130,7 +65663,7 @@ function returns the previous value.
.syne
.desc
These functions spawn external programs which execute concurrently
-with the \*(TX program. Both functions return a unidirectional stream for
+with the \*(TX program. They all return a unidirectional stream for
communicating with these programs: either an output stream, or an input
stream, depending on the contents of
.metn mode-string .
@@ -51171,7 +65704,8 @@ function specifies a program to invoke via the
argument. This is subject to the operating system's search strategy.
On POSIX systems, if it is an absolute or relative path, it is treated as
such, but if it is a simple base name, then it is subject to searching
-via the components of the PATH environment variable. If open-process
+via the components of the PATH environment variable. If
+.code open-process
is not able to find
.metn program ,
or is otherwise unable to execute
@@ -51183,14 +65717,14 @@ as its exit status. This value can be retrieved via
The
.meta argument-list
argument is a list of strings which specifies additional
-optional arguments to be passed passed to the program. The
+optional arguments to be passed to the program. The
.meta program
argument
becomes the first argument, and
-.meta argument-string
-become the second and
+.meta argument-list
+becomes the second and
subsequent arguments. If
-.meta argument-strings
+.meta argument-list
is omitted, it defaults to empty.
If a coprocess is open for writing
@@ -51228,7 +65762,7 @@ and
special variables. These variables must contain streams on which the
.code fileno
function is meaningful, otherwise the operation will fail.
-What this functionality means is that re-binding the special variables
+What this functionality means is that rebinding the special variables
for standard streams has the effect of redirection. For example,
the following two expressions achieve the same effect of creating
a stream which reads the output of the
@@ -51266,7 +65800,7 @@ previous output to
.code *stdout*
or
.code *stderr*
-is flushed, so that the output of the coprocess isn't re-ordered
+is flushed, so that the output of the coprocess isn't reordered
with regard to output produced by the program. Similarly,
input buffered in
.code *stdin*
@@ -51276,9 +65810,7 @@ situation also.
If a coprocess terminates abnormally or unsuccessfully, an exception is raised.
-On platforms which have the
-.code fork
-function, the
+The
.meta mode-string
argument of
.code open-process
@@ -51334,8 +65866,8 @@ which is immediately followed by an open parenthesis
.codn ( .
The parenthesis is immediately followed by one or more digits which
give the to-be-redirected file descriptor. This is followed by
-one or more whitespace characters, and then either another multi-digit decimal file descriptor
-or one of the two letters
+one or more whitespace characters, and then either another multi-digit
+decimal file descriptor or one of the two letters
.code n
or
.codn x .
@@ -51361,22 +65893,11 @@ output of the process. In that process, standard error is redirected
to standard output, standard input is connected to the null device,
and descriptor 27 is redirected to descriptor 31.
-Note: on platforms which don't have a
-.code fork
-function, the implementation of
-.code open-process
-is simulated via
-.code open-command
-and therefore does not support the redirection syntax; it is parsed
-and ignored.
-
The
.code open-subprocess
function is a variant of
-.code open-process
-that is available on platforms which have a
-.code fork
-function. This function has all the same argument conventions and semantics as
+.codn open-process .
+This function has all the same argument conventions and semantics as
.codn open-process ,
adding the
.meta function
@@ -51410,11 +65931,40 @@ Several other functions in this category exist, which operate with buffers.
They are documented in the Buffer Functions subsection under the
FOREIGN FUNCTION INTERFACE section.
+Many of the functions described in this section take an optional
+.meta mode-opts
+argument. If this is specified, it must be a string which follows the
+.meta options
+portion of the
+.meta mode-string
+syntax described for the
+.code open-file
+function. This string must not specify the
+.code mode
+part. If specified, the
+.meta mode-opts
+must be compatible with the implied
+.metn mode .
+Functions that write a file have an implied mode of
+.strn "w" ,
+those which append have an implied mode of
+.strn "a" ,
+and those which read have an implied mode of
+.strn "r" .
+For instance, a
+.meta mode-opts
+value of
+.str "x"
+is useful with
+.code file-put-string
+but not
+.codn file-get-string ,
+
.coNP Functions @, file-get @ file-get-string and @ file-get-lines
.synb
-.mets (file-get << name )
-.mets (file-get-string << name )
-.mets (file-get-lines << name )
+.mets (file-get < name <> [ mode-opts ])
+.mets (file-get-string < name <> [ mode-opts ])
+.mets (file-get-lines < name <> [ mode-opts ])
.syne
.desc
The
@@ -51444,9 +65994,9 @@ list is consumed to the end, as indicated in the description of
.coNP Functions @, file-put @ file-put-string and @ file-put-lines
.synb
-.mets (file-put < name << obj )
-.mets (file-put-string < name << string )
-.mets (file-put-lines < name << list )
+.mets (file-put < name < obj <> [ mode-opts ])
+.mets (file-put-string < name < string <> [ mode-opts ])
+.mets (file-put-lines < name < list <> [ mode-opts ])
.syne
.desc
The
@@ -51491,9 +66041,9 @@ function. The return value is that of
.coNP Functions @, file-append @ file-append-string and @ file-append-lines
.synb
-.mets (file-append < name << obj )
-.mets (file-append-string < name << string )
-.mets (file-append-lines < name << list )
+.mets (file-append < name < obj <> [ mode-opts ])
+.mets (file-append-string < name < string <> [ mode-opts ])
+.mets (file-append-lines < name < list <> [ mode-opts ])
.syne
.desc
The
@@ -51508,19 +66058,68 @@ and then close the stream.
These functions are close counterparts of, respectively,
.codn file-get ,
-.code file-append-string
+.code file-get-string
and
-.codn file-append-lines .
+.codn file-get-lines .
These functions behave differently when the indicated file
already exists. Rather than being truncated and overwritten,
the file is extended by appending the new data to its end.
+.coNP Function @ file-get-objects
+.synb
+.mets (file-get-objects < name < [ mode-opts <> [ error-stream ]])
+.syne
+.desc
+The
+.code file-get-objects
+function opens an input text stream over the file indicated by the
+.meta name
+argument, which is a string.
+
+All Lisp objects are read from the stream. Parse errors are
+reported to
+.meta error-stream
+which defaults to
+.code *stdnull*
+(error output is discarded).
+
+If there is a parse error, the function throws an exception,
+otherwise the list of parsed objects is returned.
+
+.coNP Functions @ file-put-objects and @ file-append-objects
+.synb
+.mets (file-put-objects < name < seq <> [ mode-opts ])
+.syne
+.desc
+The functions
+.code file-put-objects
+and
+.code file-append-objects
+open a text stream over the file indicated by the string argument
+.metn name ,
+and write each of the objects contained in sequence
+.meta seq
+into the stream as if using the
+.code prinl
+function on each individual element of
+.metn seq .
+
+The
+.code file-put-objects
+function opens the file using the
+.str w
+mode, which overwrites the file if it exists, whereas
+.code file-append-objects
+uses
+.strn a ,
+which appends to the file.
+
.coNP Functions @, command-get @ command-get-string and @ command-get-lines
.synb
-.mets (command-get << cmd )
-.mets (command-get-string << cmd )
-.mets (command-get-lines << cmd )
+.mets (command-get < cmd <> [ mode-opts ])
+.mets (command-get-string < cmd <> [ mode-opts ])
+.mets (command-get-lines < cmd <> [ mode-opts ])
.syne
.desc
The
@@ -51554,9 +66153,9 @@ list is consumed to the end, as indicated in the description of
.coNP Functions @, command-put @ command-put-string and @ command-put-lines
.synb
-.mets (command-put < cmd << obj )
-.mets (command-put-string < cmd << string )
-.mets (command-put-lines < cmd << list )
+.mets (command-put < cmd < obj <> [ mode-opts ])
+.mets (command-put-string < cmd < string <> [ mode-opts ])
+.mets (command-put-lines < cmd < list <> [ mode-opts ])
.syne
.desc
The
@@ -51617,7 +66216,7 @@ referencing the storage belonging to another object
(such as the buffer object produced by the
.code buf-d
FFI type's get semantics) the stream operations can change the buffer's size.
-Seeking beyond the end of the buffer an then writing one or more bytes
+Seeking beyond the end of the buffer and then writing one or more bytes
extends the buffer's length, filling the newly allocated area with zero bytes.
The
.code truncate-stream
@@ -51675,7 +66274,7 @@ and
macros both bind variable
.meta var
to an implicitly created buffer stream, and evaluate zero or more
-.metn body-form -s
+.metn body-form s
in the environment where the variable is visible.
The
@@ -51720,11 +66319,14 @@ if no forms are specified.
-> #b'48656c6c6f2c2077 6f726c6421'
.brev
-.coSS The @ cptr type
+.SS* Foreign Pointers
+
+.coNP The @ cptr type
Objects of type
.code cptr
-are Lisp values which contain a C pointer. This data type is used by the
+are Lisp values which contain a foreign pointer ("C pointer"). This data type
+is used by the
.code dlopen
function and is generally useful in conjunction with the Foreign Function
Interface (FFI). An arbitrary pointer emanating from a foreign function
@@ -51753,6 +66355,19 @@ object under control of the FFI
.code cptr
type, the object inherits the type tag from the FFI type.
+Although
+.code cptr
+objects are conceptually non-aggregate values, corresponding to pointers,
+they are de facto aggregates
+due to their implementation as references to heap objects.
+When a
+.code cptr
+object is passed to a foreign function by pointer, for
+instance using a parameter of type
+.codn "(ptr cptr)" ,
+its internal pointer is potentially updated to the new value coming from the
+function.
+
.coNP Function @ cptr-int
.synb
.mets (cptr-int < integer <> [ type-symbol ])
@@ -51770,13 +66385,26 @@ object.
The
.meta integer
-parameter must be an integer which is in range for a pointer value.
+argument must be an integer which is in range for a pointer value.
Note: this range is wider than the
.code fixnum
range; a portion of the range of
.code bignum
integers can denote pointers.
+An extended range of values is accepted. The entire addressable space may be
+expressed by non-negative values. A range of negative values also expresses a
+portion of the address space, in accordance with the platform's concept of a
+signed integer.
+
+For instance, on a system with 32-bit addresses, the values 0 to 4294967295
+express all of the addresses as a pure binary value. Furthermore, the values
+-2147483648 to -1 also express the upper part of this range, corresponding,
+respectively, to the addresses 2147483648 to 4294967295. On that platform,
+values of
+.meta integer
+outside of the range -2147483648 to 4294967295 are invalid.
+
The
.meta type-symbol
argument should be a symbol. If omitted, it defaults to
@@ -51851,12 +66479,12 @@ reproduces
.coNP Function @ cptr-buf
.synb
-.mets (cptr-obj < buf <> [ type-symbol ])
+.mets (cptr-buf < buf <> [ type-symbol ])
.syne
.desc
The
.code cptr-buf
-returns a
+function returns a
.code cptr
object which holds a pointer to a buffer object's storage
area. The
@@ -51906,6 +66534,20 @@ circumvents the safety mechanism which
.code cptr
type tagging provides.
+.coNP Function @ copy-cptr
+.synb
+.mets (cptr-copy << cptr )
+.syne
+.desc
+The
+.code copy-cptr
+function creates a new
+.code cptr
+object similar to
+.metn cptr ,
+which has the same address and type symbol as
+.metn cptr .
+
.coNP Function @ cptr-zap
.synb
.mets (cptr-zap << cptr )
@@ -51993,6 +66635,137 @@ function retrieves the
.meta cptr
object's type tag.
+.coNP Function @ cptr-get
+.synb
+.mets (cptr-get < cptr <> [ type ])
+.syne
+.desc
+The
+.code cptr-get
+function extracts a Lisp value by converting a C object
+at the memory location denoted by
+.metn cptr ,
+according to the FFI type
+.metn type .
+The external representation at the specified memory location is
+is scanned according to the
+.meta type
+and converted to a Lisp value which is returned.
+
+If the
+.meta type
+argument is specified, it must be a FFI type object.
+If omitted, then the
+.code cptr
+object's type tag is interpreted as a FFI type symbol and resolved to
+a type; the resulting type, if one is found is substituted for
+.metn type .
+If the lookup fails an error exception is thrown.
+
+The
+.meta cptr
+object must be of type
+.code cptr
+and point to a memory area suitably aligned for, and large
+enough to hold a foreign representation of
+.metn type ,
+at the byte offset indicated by the
+.meta offset
+argument.
+
+If
+.meta cptr
+is a null pointer, an exception is thrown.
+
+The
+.code cptr-get
+operation is similar to the "get semantics" performed by FFI
+in order to extract the return value of foreign function
+calls, and by the FFI callback mechanism to extract the
+arguments coming into a callback.
+
+The
+.meta type
+argument may not be a variable length type, such as an array of
+unspecified size.
+
+Note: the functions
+.code cptr-get
+and
+.code cptr-out
+are useful in simplifying the interaction with "semi-opaque" foreign objects:
+objects which serve as API handles that are treated as opaque pointers in API
+argument calls, but which expose some internal members that the application
+must access directly. The
+.code cptr
+objects pass through the foreign API without undergoing conversion,
+as usual. The application uses these two functions to perform conversion as
+necessary. Under this technique, the description of the foreign object need not
+be complete. Structure members which occur after the last member that the
+application is interested in need not be described in the FFI type.
+
+.coNP Function @ cptr-out
+.synb
+.mets (cptr-out < cptr < obj <> [ type ])
+.syne
+.desc
+The
+.code cptr-out
+function converts a Lisp value into a C representation,
+which is stored at the memory location denoted by
+.metn cptr ,
+according to the FFI type
+.metn type .
+The function's return value is
+.metn obj .
+
+If the
+.meta type
+argument is specified, it must be a FFI type object.
+If omitted, then the
+.code cptr
+object's type tag is interpreted as a FFI type symbol and resolved to
+a type; the resulting type, if one is found is substituted for
+.metn type .
+If the lookup fails an error exception is thrown.
+
+The
+.meta obj
+argument must be an object compatible with the conversions
+implied by
+.metn type .
+
+The
+.meta cptr
+object must be of type
+.code cptr
+and point to a memory area suitably aligned for, and large
+enough to hold a foreign representation of
+.metn type ,
+at the byte offset indicated by the
+.meta offset
+argument.
+
+If
+.meta cptr
+is a null pointer, an exception is thrown.
+
+It is assumed that
+.meta obj
+is an object which was returned by an earlier call to
+.codn cptr-get ,
+and that the
+.meta cptr
+and
+.meta type
+arguments are the same objects that were used in that call.
+
+The
+.code cptr-out
+function performs the "out semantics" encoding action, similar
+to the treatment applied to the arguments of a callback prior to
+returning to foreign code.
+
.coNP Variable @ cptr-null
.desc
The
@@ -52131,7 +66904,7 @@ stream operations on the object.
.coNP Method @ put-string
.synb
-.mets << stream .(put-string str)
+.mets << stream .(put-string << str )
.syne
.desc
The
@@ -52144,7 +66917,7 @@ stream I/O function.
.coNP Method @ put-char
.synb
-.mets << stream .(put-char chr)
+.mets << stream .(put-char << chr )
.syne
.desc
The
@@ -52157,7 +66930,7 @@ stream I/O function.
.coNP Method @ put-byte
.synb
-.mets << stream .(put-byte byte)
+.mets << stream .(put-byte << byte )
.syne
.desc
The
@@ -52209,7 +66982,7 @@ stream I/O function.
.coNP Method @ unget-char
.synb
-.mets << stream .(unget-char chr)
+.mets << stream .(unget-char << chr )
.syne
.desc
The
@@ -52222,7 +66995,7 @@ stream I/O function.
.coNP Method @ unget-byte
.synb
-.mets << stream .(unget-byte byte)
+.mets << stream .(unget-byte << byte )
.syne
.desc
The
@@ -52235,7 +67008,7 @@ stream I/O function.
.coNP Method @ put-buf
.synb
-.mets << stream .(put-buf buf pos)
+.mets << stream .(put-buf < buf << pos )
.syne
.desc
The
@@ -52246,9 +67019,21 @@ description of the
.code put-buf
stream I/O function.
+Note: there is a severe restriction on the use of the
+.meta buf
+argument. The buffer object denoted by the
+.meta buf
+argument may be specially allocated and have a lifetime
+which is scoped to the method invocation. The
+.code put-buf
+method shall not permit the
+.meta buf
+object to be used beyond the duration of the method
+invocation.
+
.coNP Method @ fill-buf
.synb
-.mets << stream .(fill-buf buf pos)
+.mets << stream .(fill-buf < buf << pos )
.syne
.desc
The
@@ -52259,9 +67044,21 @@ description of the
.code fill-buf
stream I/O function.
+Note: there is a severe restriction on the use of the
+.meta buf
+argument. The buffer object denoted by the
+.meta buf
+argument may be specially allocated and have a lifetime
+which is scoped to the method invocation. The
+.code fill-buf
+method shall not permit the
+.meta buf
+object to be used beyond the duration of the method
+invocation.
+
.coNP Method @ close
.synb
-.mets << stream .(close offs whence)
+.mets << stream .(close << throw-on-error-p )
.syne
.desc
The
@@ -52272,9 +67069,45 @@ description of the
.code close-stream
stream I/O function.
+With two exceptions, the value returned from
+.code close
+is retained by close-stream, such that repeated calls to
+.code close-stream
+then return that value without calling the
+.code close
+method.
+The exceptions are the values
+.code nil
+and
+.code :
+(the colon symbol).
+If either of these values is returned, and
+.code close-stream
+is invoked again on the same stream object, the
+.code close
+method will be called again.
+
+Furthermore, if the
+.code :
+symbol is returned by the
+.code close
+method, this indicates a successful close, and the
+.code close-stream
+function returns the
+.code t
+symbol rather than the
+.code :
+symbol.
+
+The rationale for this mechanism is that it supports reference-counted
+closing. A struct delegate stream may be written which is shared by
+several owners, which must each call
+.code close-stream
+before the underlying real stream is closed.
+
.coNP Method @ flush
.synb
-.mets << stream .(flush offs whence)
+.mets << stream .(flush < offs << whence )
.syne
.desc
The
@@ -52287,7 +67120,7 @@ stream I/O function.
.coNP Method @ seek
.synb
-.mets << stream .(seek offs whence)
+.mets << stream .(seek < offs << whence )
.syne
.desc
The
@@ -52300,7 +67133,7 @@ stream I/O function.
.coNP Method @ truncate
.synb
-.mets << stream .(truncate len)
+.mets << stream .(truncate << len )
.syne
.desc
The
@@ -52313,7 +67146,7 @@ stream I/O function.
.coNP Method @ get-prop
.synb
-.mets << stream .(get-prop sym)
+.mets << stream .(get-prop << sym )
.syne
.desc
The
@@ -52326,7 +67159,7 @@ stream I/O function.
.coNP Method @ set-prop
.synb
-.mets << stream .(set-prop sym nval)
+.mets << stream .(set-prop < sym << nval )
.syne
.desc
The
@@ -52413,8 +67246,8 @@ stream I/O function.
.mets \ \ \ \ (put-buf buf pos me.stream))
.mets \ \ (:method fill-buf (me buf pos)
.mets \ \ \ \ (fill-buf buf pos me.stream))
-.mets \ \ (:method close (me)
-.mets \ \ \ \ (close-stream me.stream))
+.mets \ \ (:method close (me throw-on-error)
+.mets \ \ \ \ (close-stream me.stream throw-on-error))
.mets \ \ (:method flush (me)
.mets \ \ \ \ (flush-stream me.stream))
.mets \ \ (:method seek (me offs whence)
@@ -52537,9 +67370,9 @@ When a package is deleted with
.codn delete-package ,
its symbols are uninterned from all other packages.
-An existing symbol can be brought into a package via the
+A symbol existing in one package can be brought into another package via the
.code use-sym
-function, causing it to be interned in that package. A symbol which thus exists
+function, causing it to be interned in the target package. A symbol which thus exists
inside a package which is not its home package is called a
.IR "foreign symbol" ,
relative to that package.
@@ -52551,6 +67384,13 @@ which refers to a symbol, relative to a package, which is interned in that
package and that package is also its home. Every symbol interned in
a package is either foreign or local.
+An existing symbol can also be brought into a package under a different
+name using the
+.code use-sym-as
+function, causing it to be interned under an alternative name.
+This has the effect of creating a local alias for a foreign symbol,
+and is intended as a renaming mechanism for resolving name clashes.
+
If a foreign symbol is introduced into a package, and has the same name
as an existing local symbol, the local symbol continues to exist, but
is hidden: it is not accessible via a name lookup on that package.
@@ -52561,7 +67401,7 @@ on whether that symbol is interned in other packages.
When a foreign symbol is removed from a package via
.codn unuse-sym ,
then if a hidden symbol exists in that package of the same name,
-that hidden symbol is re-interned in that package and re-acquires
+that hidden symbol is reinterned in that package and reacquires
that package as its home package, becoming an interned symbol again.
Finally, packages have a
@@ -52599,10 +67439,10 @@ recursion takes place.
The printer situation involving the fallback list is as follows.
If a symbol is being printed in a machine-readable way (not "pretty"),
has a home package and is not a keyword symbol, then a search takes place
-through the current package and its fallback list. If the symbol is found
-in any of those places, and if those places are devoid of any symbols
-which have the same name, thus causing ambiguity, then the symbol is printed
-without a package prefix.
+through the current package first and then its fallback list. If the symbol is
+found anywhere in that sequence of locations, and is not occluded by a
+same-named symbol occurring earlier in that sequence, then the symbol is
+printed without a package prefix.
The listener situation involving the fallback list is a follows.
When tab completion is used on a symbol without a package
@@ -52660,6 +67500,73 @@ as the current package in the
variable. It then allows unqualified symbol references to refer across
the fallback list.
+The \*(TL package system does not feature package nicknames,
+which have been found to be a source of clashes in large Common Lisp
+software collections, leading to the development of a feature
+called package local nicknames that is not part of ANSI CL, but
+supported by a number of implementations. In \*(TL,
+packages have only one name, accessible via
+.codn package-name .
+\*(TL packages are held in an association list called
+.codn *package-alist* ,
+which is public, which associates string names with packages.
+The function
+.code find-package
+which is used by the parser when looking up the package prefix
+of a qualified symbol, only uses the names which appears as keys
+in this association list. Usually those names are the same as
+the names of the package objects. However, it's possible to manipulate
+this association list to create alias names for packages.
+Thus, it is possible for
+.code "(find-package \(dqfoo\(dq)"
+to return
+.code "#<package: bar>"
+if the name
+.str foo
+is associated, in
+.code *package-alist*
+with a package object named
+.strn bar .
+
+The \*(TL package system doesn't feature package local nicknames.
+There are three reasons for this. One is that it doesn't have global package
+nicknames. The second is that the mechanism would be cumbersome,
+and add delay to the resolution of qualified symbols, requiring
+nicknames in the
+.code *package*
+to be searched for a package name, in addition to the dynamic
+.codn *package-alist* .
+The third reason is that package local nicknames do not actually solve the
+problem of clashing symbols, when an application uses multiple packages
+that each define a symbol by the same name. Package nicknames only
+shorten the qualified names required to refer to the symbols,
+Instead, \*(TL allows a foreign symbol to be interned in a
+package under a name which is different from its
+.codn symbol-name .
+Thus, rather than creating aliases for package names,
+\*(TL packages can locally rename the actual clashing symbols,
+which can then be referenced by unqualified names.
+
+By manipulating
+.codn *package-alist* ,
+a \*(TL source file can nevertheless achieve the creation of a
+de facto package nickname, which is local to a loaded file,
+by following the following example:
+
+.verb
+ ;; make sure that when this file finishes loading,
+ ;; or the loading is interrupted by an exception,
+ ;; the "u" package alias is deleted from *package-alist*
+ (push-after-load
+ (set *package-alist* [remqual "u" *package-alist* car]))
+
+ ;; push an alias named u for the usr package.
+ (push (cons "u" (find-package "usr")) *package-alist*)
+
+ ;; u: can now be used, until the end of this file
+ (u:prinl (u:list 1 2 3))
+.brev
+
.NP* Package Examples
The following example illustrates a simple scenario of a module
whose identifies are in a package, and which also has private identifiers
@@ -52770,7 +67677,7 @@ all "punctuation" directives like
.code "@(and)"
or
.code "@(end)"
-and all sub-phrase indicators like
+and all subphrase indicators like
.code "@(last)"
or
.codn "@(elif)" .
@@ -52840,7 +67747,7 @@ user-defined pattern function called
.code mypackage:end
it may not be invoked using the syntax
.codn "@(mypackage:end)" ,
-which is erroneous; though it is invokable indirectly via the
+which is erroneous; though it is invocable indirectly via the
.code "@(call)"
directive.
@@ -52900,7 +67807,7 @@ The names of these packages, respectively, are
and
.strn keyword .
-.coNP Special variable @ *package*
+.coNP Special Variable @ *package*
.desc
This variable holds the current package. The global value of this variable
is initialized to a package called
@@ -52957,12 +67864,12 @@ function.
.desc
The
.code gensym
-function is similar to make-sym. It creates and returns a new
-symbol object. If the
+function is similar to
+.codn make-sym .
+It creates and returns a new symbol object. If the
.meta prefix
argument is omitted, it defaults to
.strn g .
-Otherwise it must be a string.
The difference between
.code gensym
@@ -52970,25 +67877,28 @@ and
.code make-sym
is that
.code gensym
-creates the name
-by combining the prefix with a numeric suffix.
-
-The numeric suffix is a decimal digit string, taken from the value of
-the variable
-.codn *gensym-counter* ,
-after incrementing it.
+creates the symbol's name
+by combining the
+.meta prefix
+with a numeric suffix. The suffix is obtained by incrementing the
+.code *gensym-counter*
+and taking the new value.
+The name string then calculated from the prefix and the counter value
+as if by evaluating a form similar to
+.codn "(fmt \(dq~a~,04d\(dq prefix counter)" .
+From this it can be inferred that
+.meta prefix
+can be an object of any kind.
-Note: the variation in name is not the basis of the uniqueness assurance
-offered by
-.code make-sym
-and
-.codn gensym ;
-the basis is that the returned symbol is a freshly instantiated object.
+Note: the generated symbol's name, though varying thanks to the incrementing
+counter, is not the basis of its uniqueness. The basis of the symbol's
+uniqueness is that it is a freshly created object, distinct from any other
+object. The related function
.code make-sym
still returns unique symbols even if repeatedly called with the same
-string.
+string argument.
-.coNP Special variable @ *gensym-counter*
+.coNP Special Variable @ *gensym-counter*
.desc
This variable is initialized to 0. Each time the
.code gensym
@@ -53000,7 +67910,7 @@ uses to form the name of the new symbol.
.coNP Function @ make-package
.synb
-.mets (make-package << name )
+.mets (make-package < name <> [ weak ])
.syne
.desc
The
@@ -53016,6 +67926,24 @@ should be performed with the
macro rather than by direct use of
.codn make-package .
+If the
+.meta weak
+parameter is given an argument which is a Boolean true, then the resulting
+package holds symbols weakly, from a garbage collection point of view. If the
+only reference to a symbol is that which occurs inside the weak package, then
+that symbol may be removed from the package and reclaimed by the garbage
+collector.
+
+Note: weak packages address the following problem. The application creates a
+package for the purpose of reading Lisp data. Symbols occurring in that data
+therefore are interned into the package. Subsequently, the application retains
+references to some of the symbols, discarding the others. If the package isn't
+weak, then because the application is retaining some of the symbols, and those
+symbols hold a reference to the package, and the package holds a reference to
+all symbols that were interned in it, all of the symbols are retained. If a
+weak package is used, then the discarded symbols are eligible for garbage
+collection.
+
.coNP Function @ delete-package
.synb
.mets (delete-package << package )
@@ -53037,7 +67965,7 @@ iterates over all remaining packages. For each remaining package
.metn p ,
it performs the semantic action of the
.mono
-.meti (unuse-package < package << p)
+.meti (unuse-package < package << p )
.onom
expression. That is to say, all of the remaining packages
are scrubbed of any foreign symbols which are the local symbols
@@ -53095,7 +68023,7 @@ then it is returned. Otherwise
.code nil
is returned.
-.coNP Special variable @ *package-alist*
+.coNP Special Variable @ *package-alist*
.desc
The
.code *package-alist*
@@ -53110,7 +68038,7 @@ field is the name of a package and whose
.code cdr
is a package object.
-Note: the \*(TL application can overwrite or re-bind this
+Note: the \*(TL application can overwrite or rebind this
variable to manipulate the active package list. This is
useful for
.IR sandboxing :
@@ -53246,6 +68174,7 @@ resolve to existing packages. Symbols are reduced to strings via
.coNP Functions @ intern and @ intern-fb
.synb
.mets (intern < name <> [ package ])
+.mets (intern-fb < name <> [ package ])
.syne
.desc
The argument
@@ -53335,7 +68264,7 @@ returns the hidden symbol that was removed from the hidden store.
If
.meta symbol
is a foreign symbol, then it is removed from the package. If the package
-has a hidden symbol of the same name, that hidden symbol is re-interned
+has a hidden symbol of the same name, that hidden symbol is reinterned
in the package, and the package once again becomes its home package.
In this case,
.meta symbol
@@ -53539,55 +68468,95 @@ special symbols
and
.codn nil .
-.coNP Function @ use-sym
+.coNP Functions @ use-sym and @ use-sym-as
.synb
.mets (use-sym < symbol <> [ package ])
+.mets (use-sym-as < symbol < name <> [ package ])
.syne
.desc
The
.code use-sym
function brings an existing
-.code symbol
+.meta symbol
into
.metn package .
-In all cases, the function returns
+The
+.code use-sym-as
+is similar, but allows an alternative
+.meta name
+to be specified. The
+.meta symbol
+will be interned under that name, rather than under its symbol name.
+
+In all cases, both function return
.codn symbol .
-If
+The following equivalence holds:
+
+.verb
+ (use-sym s p) <--> (use-sym-as s (symbol-name s) p)
+.brev
+
+Thus, in the following descriptions, when the remarks are interpreted
+as applying to
+.codn use-sym ,
+the
+.meta name
+argument is understood as referring to the
+.code symbol-name
+of the
.meta symbol
-is already interned in
-.metn package ,
+argument.
+
+If
+.meta package
+is the home package of
+.metn symbol ,
then the function has no effect.
Otherwise
.meta symbol
is interned in
-.metn package .
+.meta package
+under
+.metn name .
-If a symbol having the same name as
-.meta symbol
-already exists in
-.metn package ,
-then it is replaced.
+If a symbol is already interned in
+.meta package
+under
+.metn name ,
+then that symbol is is replaced.
If that replaced symbol is a local symbol of
.metn package ,
-then the replaced symbol turns into a hidden symbol associated
+meaning that
+.meta package
+is its home package,
+then that replaced symbol turns into a hidden symbol associated
with the package. It is placed into a special hidden symbol store
associated with
.meta package
and is stripped of its home package, becoming quasi-interned or uninterned.
-An odd case is possible whereby
-.meta symbol
-is already a hidden symbol of
-.metn package .
-In this case, the hidden symbol replaces some foreign symbol and
-is interned in
-.metn package .
-Thus it simultaneously exists as both an interned
-foreign symbol and as a hidden symbol of
-.metn package .
+Note:
+.code use-sym
+and
+.code use-sym-as
+are the basis for the
+.code defpackage
+clauses
+.code :use-syms
+and
+.codn :use-syms-as .
+
+Note:
+if
+.code use-sym-as
+is used to introduce a foreign symbol into a package under a different
+name, that symbol cannot be removed with
+.codn unintern .
+It can only be removed using
+.codn unuse-sym .
.coNP Function @ unuse-sym
.synb
@@ -53625,7 +68594,7 @@ and is removed.
If the package has a hidden symbol of the same name as
.metn symbol ,
-that symbol is re-interned into
+that symbol is reinterned into
.meta package
as a local symbol. In this case, that previously hidden symbol is
returned.
@@ -53636,6 +68605,39 @@ then
.meta symbol
itself is returned.
+There are close similarities between the function
+.code unintern
+and
+.codn unuse-sym ,
+but the two are significantly different.
+
+Firstly,
+.code unuse-sym
+cannot be used to remove a symbol from its home package. As noted
+above, this requires
+.codn unintern .
+
+Secondly,
+.code unuse-sym
+can be used to undo the effect of
+.code use-sym-as
+whereby a foreign symbol is introduced into a package under a
+different name. If
+.meta symbol
+is not found under its name,
+.code unuse-sym
+will search the package for that symbol to discover whether it is
+present under a different name, and proceed with the removal
+using that name. The
+.code unintern
+function performs no such secondary check; if
+.meta symbol
+is not found in the package under its own name, the operation fails,
+and so
+.code unintern
+cannot be used for undoing the effect of
+.codn use-sym-as .
+
.coNP Functions @ use-package and @ unuse-package
.synb
.mets (use-package < package-list <> [ package ])
@@ -53718,14 +68720,14 @@ The
.code :fallback
clause specifies the packages to comprise the fallback list of
the present package. If this clause is omitted, or if it is present
-with not
+with no
.meta package-name
arguments, then the present package has an empty fallback list.
Each
.meta package-name
may be a string or symbol naming an existing package. It is permitted
for the present package itself to appear in its own fallback list.
-This is useful for creating a package with a non-empty fallback list
+This is useful for creating a package with a nonempty fallback list
which doesn't actually provide access to any other package.
.meIP (:use << package-name *)
The
@@ -53739,8 +68741,25 @@ The list of package names is processed as if by a call to
.meIP (:use-syms << symbol *)
The
.code :use-syms
-clause specifies individual symbols to be interned in the present package.
-The arguments are symbols.
+clause specifies individual symbols to be brought into the present
+package, as if by the
+.code use-sym
+function. The arguments are symbols.
+.meIP (:use-syms-as >> { symbol << name }*)
+The
+.code :use-syms-as
+clause specifies individual symbols to be brought into the present
+package, as if by the
+.code use-sym-as
+function. The arguments constitute a property list consisting of interleaved
+symbols and names. Each
+.meta symbol
+argument is a symbol, and each
+.meta name
+is either a symbol or a string. If it is a symbol, then its name
+is retrieved via
+.code symbol-name
+and used in its place.
.meIP (:use-from < package-name << symbol-name *)
The
.code :use-from
@@ -53756,7 +68775,7 @@ is interned in the package identified by
which may have the effect of creating that symbol.
This symbol is expected to be a local symbol of that package. If
that is so, the symbol is brought into the present package via
-.codn use-symbol .
+.codn use-sym .
Otherwise if the symbol is foreign to package identified by
.metn package-name ,
then an error exception is thrown.
@@ -53801,13 +68820,13 @@ The code generated by the macro performs a search for the
package. If the package is not found at the time when
the macro's expansion is evaluated, an error is thrown.
-.SS* Pseudo-random Numbers
-.coNP Special variable @ *random-state*
+.SS* Pseudorandom Numbers
+.coNP Special Variable @ *random-state*
.desc
The
.code *random-state*
variable holds an object which encapsulates the state
-of a pseudo-random number generator. This variable is the default argument
+of a pseudorandom number generator. This variable is the default argument
value for the
.code random-fixnum
and
@@ -53816,7 +68835,7 @@ for the convenience of writing programs which are not concerned about the
management of random state.
On the other hand, programs can create and manage random states, making it
-possible to obtain repeatable sequences of pseudo-random numbers which do not
+possible to obtain repeatable sequences of pseudorandom numbers which do not
interfere with each other. For instance objects or modules in a program can
have their own independent streams of random numbers which are repeatable,
independently of other modules making calls to the random number functions.
@@ -53828,7 +68847,7 @@ a newly created random state object, which is produced as if by
the call
.codn "(make-random-state 42)" .
-.coNP Special variable @ *random-warmup*
+.coNP Special Variable @ *random-warmup*
.desc
The
.code *random-warmup*
@@ -53838,12 +68857,12 @@ in place of a missing
.meta warmup-period
argument.
-To "warm up" a pseudo-random number generator (PRNG) means to obtain some
+To "warm up" a pseudorandom number generator (PRNG) means to obtain some
values from it which are discarded, prior to use. The number of values
discarded is the
.IR "warm-up period" .
-The WELL PRNG used in \*(TX produces 32-bit values, natively. Thus each
+The WELL512a PRNG used in \*(TX produces 32-bit values, natively. Thus each
warm-up iteration retrieves and discards a 32-bit value. The PRNG has
a state space consisting of a vector of sixteen 32-bit words, making
the state space 4096 bits wide.
@@ -53871,12 +68890,12 @@ distribution of values.
Applications which critically depend on good PRNG behavior should choose
large warm-up periods into the hundreds or thousands of iterations.
If a small warm-up period is used, it is recommended to use larger seeds
-which initialize more of the 4096 bit state space.
+which initialize more of the 4096-bit state space.
-\*(TX's PRNG implementation addresses "problem 1" first problem by padding the
+\*(TX's PRNG implementation addresses "problem 1" by padding the
unseeded portions of the state space with random values (from a static table
that doesn't change). For instance, if the integer 1 is used to seed the space,
-then one 32 bit word of the space is set to the value 1. The remaining 15 are
+then one 32-bit word of the space is set to the value 1. The remaining 15 are
populated from the random table. This helps to ensure that a good PRNG sequence
is obtained immediately. However, it doesn't address "problem 2": that
similar seed values generate similar sequences, when the warm-up period is
@@ -53896,9 +68915,9 @@ an object of the same kind as what is stored in the
.code *random-state*
variable.
-The seed, if specified, must be either an integer value, an
-existing random state object, or a vector returned from a call
-to the function
+The seed, if specified, must be an integer value, a buffer,
+an existing random state object, or else a vector returned from a call to the
+function
.codn random-state-get-vec .
Note that the sign of the seed is ignored, so that negative seed
@@ -53909,20 +68928,21 @@ If seed is not specified, then
produces a seed based
on some information in the process environment, such as current
time of day. It is not guaranteed that two calls to
-.code (make-random-state)
+.code make-random-state
that are separated by less than some minimum increment of real time produce
different seeds. The minimum time increment depends on the platform.
On a platform with a millisecond-resolution real-time clock, the minimum
-time increment is a millisecond. Calls to make-random-state less than
-a millisecond apart may predictably produce the same seed.
+time increment is a millisecond. Calls to
+.code make-random-state
+less than a millisecond apart may predictably produce the same seed.
-If an integer seed is specified, then the integer value is mapped to a
-pseudo-random sequence, in a platform-independent way.
+If an integer or buffer seed is specified, then the integer value is mapped to
+a pseudorandom sequence, in a platform-independent way.
If an existing random state is specified as a seed, then it is duplicated. The
returned random state object is a distinct object which is in the same
-state as the input object. It will produce the same remaining pseudo-random
+state as the input object. It will produce the same remaining pseudorandom
number sequence, as will the input object.
If a vector is specified as a seed, then a random state is constructed
@@ -53934,15 +68954,22 @@ function.
The
.meta warm-up-period
argument specifies the number of values which are immediately obtained and
-discarded from the newly-seeded generator before it is returned.
-Warm-up is not performed when
+discarded from the newly-seeded generator before it is returned. This
+procedure is referred to as PRNG
+.IR warm-up .
+
+Warm-up is not performed if
.meta seed
-is an existing random state object, and this argument is ignored in that
-case. If the parameter is required, but the argument is missing, then
-the value of the
+is a vector or random state object. In this situation, if the
+.meta warm-up-period
+is present, it may still be required to be an integer, even though it is ignored.
+
+If warm-up is performed, but the
+.meta warm-up-period
+argument is missing, then the value of the
.code *random-warmup*
-special variable is used. This variable has a default value which may be too
-small for serious applications of pseudo-random numbers; see the Notes under
+special variable is used. Note: this variable has a default value which may be too
+small for some applications of pseudorandom numbers; see the Notes under
.codn *random-warmup* .
.coNP Function @ random-state-p
@@ -53982,9 +69009,9 @@ is used.
.mets (rand < modulus <> [ random-state ])
.syne
.desc
-All three functions produce pseudo-random numbers, which are positive integers.
+All three functions produce pseudorandom numbers, which are positive integers.
-The numbers are obtained from a WELL 512 PRNG, whose state is stored in the
+The numbers are obtained from a WELL512a PRNG, whose state is stored in the
random state object.
The
@@ -54010,28 +69037,114 @@ The
argument must be a positive integer. If
.meta modulus
is 1, then the function returns zero without altering the state of the
-pseudo-random number generator.
+pseudorandom number generator.
-.coNP Function @ random-float
+.coNP Functions @ random-float and @ random-float-incl
.synb
.mets (random-float <> [ random-state ])
+.mets (random-float-incl <> [ random-state ])l
.syne
.desc
The
.code random-float
-function produces a pseudo-random floating-point value in the range [0.0, 1.0).
+function produces a pseudorandom floating-point value in the range [0.0, 1.0).
-The numbers are obtained from a WELL 512 PRNG, whose state is stored in the
+The
+.code random-float-incl
+produces a pseudorandom floating-point value in the range [0.0, 1.0], thus
+differing from
+.code random-float
+by including the 1.0 limit value.
+
+The numbers are obtained from a WELL512a PRNG, whose state is stored in the
random state object given by the argument to the optional
.meta random-state
parameter, which defaults to the value of
.codn *random-state* .
+Because the floating-point type does not provide a representation of every real
+value in the range 0.0 to 1.0, it is not possible to impose the requirement
+that every value shall occur with equal likelihood.
+
+Rather, these functions are intended to produce an a uniform distribution of
+values according to the following pragmatic requirements. A subset
+.I S
+of the real values in the
+specified range, [0.0, 1.0) or [0.0, 1.0] is identified whose elements are representable
+in the floating-point type and which are uniformly spaced along the interval. Then,
+a random element is chosen from
+.I S
+and returned, such that every element is equally likely to be selected.
+
+Note that these requirements do not correspond to the more mathematically ideal
+concept of uniformly choosing actual real numbers in the [0, 1] interval of the
+real number line, and then finding the closest floating-point representation.
+Such a requirement would mean that the boundary values 0.0 and 1.0 appear in
+the output half as frequently as all the interior values, because each of these
+two floating-point values is a representations of a range of numbers, half of
+which lies outside of the [0, 1] interval.
+
+.coNP Function @ random-buf
+.synb
+.mets (random-buf < size <> [ random-state ])
+.syne
+.desc
+The
+.code random-buf
+function creates a
+.code buf
+object of the specified
+.meta size
+fills it with pseudorandom bytes, and returns it.
+
+The bytes are obtained from the random state object given by the optional
+.meta random-state
+parameter, which defaults to the value of
+.codn *random-state* .
+
+See the section
+.B Buffers
+for a description of
+.code buf
+objects.
+
+.coNP Function @ random-sample
+.synb
+.mets (random-sample < size < seq <> [ random-state ])
+.syne
+.desc
+The
+.code random-sample
+function returns a vector of
+.meta size
+randomly selected elements from the sequence
+.metn seq ,
+using reservoir sampling.
+
+If the number of elements in
+.meta seq
+is equal to or smaller than
+.metn size ,
+then the function returns a vector of all the elements of
+.meta seq
+in their original order.
+
+In other cases, the selected elements are not required to appear
+in their original order.
+
+No element of sequence
+.meta seq
+is selected more than once; duplicate values can appear
+in the output only if
+.meta seq
+itself contains duplicates.
+
.SS* Time
-.coNP Functions @ time and @ time-usec
+.coNP Functions @, time @ time-usec and @ time-nsec
.synb
.mets (time)
.mets (time-usec)
+.mets (time-nsec)
.syne
.desc
The
@@ -54050,6 +69163,20 @@ field holds the seconds measured in the same way, and whose
field extends the precision by giving
number of microseconds as an integer value between 0 and 999999.
+The
+.code time-nsec
+function is similar to
+.code time-usec
+except that the returned cons cell's
+.code cdr
+field gives a number of nanoseconds as an integer value
+between 0 and 999999999.
+
+Note: on hosts where obtaining nanosecond precision is not available, the
+.code time-nsec
+function obtains a microseconds value instead, and multiplies
+it by 1000.
+
.coNP Functions @ time-string-local and @ time-string-utc
.synb
.mets (time-string-local < time << format )
@@ -54085,20 +69212,49 @@ field of the cons returned by the
.code time-usec
function.
+.coNP Functions @ time-str-local and @ time-str-utc
+.synb
+.mets (time-str-local < format <> [ time ])
+.mets (time-str-utc < format <> [ time ])
+.syne
+.desc
+The functions
+.code time-str-local
+and
+.code time-str-utc
+are equivalent, respectively, to
+.code time-string-local
+and
+.code time-string-utc
+with the arguments reversed. Thus the following
+equivalences hold:
+
+.verb
+ (time-str-local F T) <--> (time-string-local T F)
+ (time-str-utc F T) <--> (time-string-utc T F)
+.brev
+
+Additionally, if no argument is supplied to the
+.code time
+parameter, its value is obtained by invoking the
+.code time
+function.
+
.coNP Functions @ time-fields-local and @ time-fields-utc
.synb
-.mets (time-fields-local << time )
-.mets (time-fields-utc << time )
+.mets (time-fields-local <> [ time ])
+.mets (time-fields-utc <> [ time ])
.syne
.desc
-These functions take the numeric time returned by the time function,
-and convert it to a list of seven fields.
+These functions take numeric time in the format returned by the
+.code time
+function and convert it to a list of seven fields.
The
-.code time-string-local
+.code time-fields-local
function converts the time to the local timezone of
-the host system. The
-.code time-string-utc
+the host system, whereas the
+.code time-fields-utc
function produces time in UTC.
The fields returned as a list consist of six integers, and a Boolean value.
@@ -54111,17 +69267,18 @@ in the case of
The
.meta time
-argument is an integer representing seconds obtained from the
+parameter is an integer representing seconds obtained from the
.code time
-function or from the
-.code time-usec
-function.
+function. If the argument is absent, the value is obtained by
+calling
+.codn time .
.coNP Structure @ time
.synb
.mets (defstruct time nil
-.mets \ \ year month day hour min sec dst
-.mets \ \ gmtoff zone)
+.mets \ \ year month day hour min sec
+.mets \ \ wday yday
+.mets \ \ dst gmtoff zone)
.syne
.desc
The
@@ -54149,20 +69306,24 @@ uses a zero-based month. The
slot is a \*(TL Boolean value. The slots
.codn hour ,
.codn min ,
+.codn sec ,
+.code wday
and
-.code sec
+.code yday
correspond directly to
.codn tm_hour ,
.codn tm_min ,
+.codn tm_sec ,
+.code tm_wday
and
-.codn tm_sec .
+.codn tm_yday .
The slot
.code gmtoff
represents the number of seconds east of UTC, and
.code zone
holds a string giving the abbreviated time zone name.
-On platform where the C type
+On platforms where the C type
.code "struct tm"
has fields corresponding to these slots, values for
these slots are calculated and stored into them by the
@@ -54173,7 +69334,7 @@ functions, and also the related
.code time-local
and
.code time-utc
-methods. On platform where the corresponding fields are not
+methods. On platforms where the corresponding fields are not
present in the C language
.codn "struct tm" ,
these slots are unaffected by those functions,
@@ -54190,29 +69351,30 @@ structure as a source of input values.
.coNP Functions @ time-struct-local and @ time-struct-utc
.synb
-.mets (time-struct-local << time )
-.mets (time-struct-utc << time )
+.mets (time-struct-local <> [ time ])
+.mets (time-struct-utc <> [ time ])
.syne
.desc
-These functions take the numeric time returned by the time function,
-and convert it to an instance of the
+These functions take numeric time in the format returned by the
+.code time
+function and convert it to an instance of the
.code time
structure.
The
.code time-struct-local
function converts the time to the local timezone of
-the host system. The
+the host system, whereas
.code time-struct-utc
function produces time in UTC.
The
.meta time
-argument is an integer representing seconds obtained from the
+parameter is an integer representing seconds obtained from the
.code time
-function or from the
-.code time-usec
-function.
+function. If the argument is absent, the value is obtained by
+calling
+.codn time .
.coNP Functions @, time-parse @ time-parse-local and @ time-parse-utc
.synb
@@ -54272,6 +69434,22 @@ Note: the availability of these three functions
depends on the availability of
.codn strptime .
+Note: on some platforms, like the GNU C Library, the
+.code strptime
+function supports the parsing of numeric and symbolic time zones. The
+.code gmtoff
+slot of the structure ends up being set accordingly.
+The
+.code time-local
+and
+.code time-utc
+functions take the
+.code gmtoff
+field into account, adjusting the returned time accordingly.
+
+
+If these are specified.
+
.coNP Methods @ time-local and @ time-utc
.synb
.mets << time-struct .(time-local)
@@ -54302,10 +69480,17 @@ the slots of
to be in the UTC time zone.
Note: these functions work by converting the slots into arguments
-which are applied to
+to which
.code make-time
or
-.codn make-time-utc .
+.code make-time-utc
+is applied.
+
+Note: if the
+.code gmtoff
+slot is not
+.codn nil ,
+its value is subtracted from the returned result.
.coNP Method @ time-string
.synb
@@ -54454,7 +69639,7 @@ savings time).
.coNP Function @ crc32-stream
.synb
-.mets (crc32-stream < stream <> [ nbytes ])
+.mets (crc32-stream < stream >> [ nbytes <> [ crc-prev ]])
.syne
.desc
The
@@ -54470,11 +69655,19 @@ integer. It gives the number of bytes which should be read
and included in the sum. If the argument is omitted, then bytes are read
until the end of the stream.
-The CRC-32 is returned as a non-negative integer.
+The optional
+.meta crc-prev
+argument defaults to zero. It is fully documented under the
+.code crc32
+function.
+
+The
+.code crc32-stream
+functions returns the calculated CRC-32 as a nonnegative integer.
.coNP Function @ crc32
.synb
-.mets (crc32 << obj )
+.mets (crc32 < obj <> [ crc-prev ])
.syne
.desc
The
@@ -54493,17 +69686,52 @@ If
is a character string, then the sum is calculated over the bytes
which constitute its UTF-8 representation.
-The CRC-32 is returned as a non-negative integer.
+The optional
+.meta crc-prev
+argument defaults to zero. If specified, it should be a nonnegative integer in
+the 32-bit range. This argument is useful when a single CRC-32 must be
+calculated in multiple operations over several objects. The first call should
+specify a value of zero, or omit the argument. To continue the checksum,
+each subsequent call to the function should pass as the
+.meta crc-prev
+argument the CRC-32 obtained from the previous call.
+
+The
+.code crc32
+function returns the calculated CRC-32 as a nonnegative integer.
+
+The parameters of the algorithm are as follows. The polynomial is
+.codn #x04C11DB7 ;
+the input and result are reflected; the initial value is
+.codn #xFFFFFFFF ;
+and the final value is bitwise
+.IR xor -ed
+with
+.codn #xFFFFFFFF .
+
+.TP* Examples:
+
+.mono
+ ;; Single operation
+ (crc32 "ABCD") --> 3675725989
+
+ ;; In two steps, demonstrating crc-prev argument:
+ (crc32 "CD" (crc32 "AB")) -> 3675725989
+.onom
-.coNP Functions @ sha256-stream and @ md5-stream
+.coNP Functions @, sha1-stream @ sha256-stream and @ md5-stream
.synb
+.mets (sha1-stream < stream >> [ nbytes <> [ buf ]])
.mets (sha256-stream < stream >> [ nbytes <> [ buf ]])
.mets (md5-stream < stream >> [ nbytes <> [ buf ]])
.syne
.desc
The
+.code sha1-stream
+and
.code sha256-stream
-calculates the NIST SHA-256 digest over the bytes read from
+functions calculate, respectively, the NIST SHA-1 and SHA-256 digests over the
+bytes read from
.metn stream ,
starting at the stream's current position.
@@ -54531,15 +69759,18 @@ argument is specified, it must be a buffer that is at least 16 bytes long
in the case of MD5, and at least 32 bytes long in the case of SHA-256.
The hash is placed into that buffer, which is then returned.
-.coNP Functions @ sha256 and @ md5
+.coNP Functions @, sha1 @ sha256 and @ md5
.synb
+.mets (sha1 < obj <> [ buf ])
.mets (sha256 < obj <> [ buf ])
.mets (md5 < obj <> [ buf ])
.syne
.desc
The
+.code sha1
+and
.code sha256
-function calculates the NIST SHA-256 digest over
+function calculate, respectively, the NIST SHA-1 and SHA-256 digests over
.metn obj ,
which may be a character string or a buffer.
@@ -54571,6 +69802,63 @@ argument is specified, it must be a buffer that is at least 16 bytes long
in the case of MD5, and at least 32 bytes long in the case of SHA-256.
The hash is placed into that buffer, which is then returned.
+.coNP Functions @, sha1-begin @ sha1-hash and @ sha1-end
+.synb
+.mets (sha1-begin)
+.mets (sha1-hash < ctx << obj )
+.mets (sha1-end < ctx <> [ buf ])
+.syne
+.desc
+The three functions
+.codn sha1-begin ,
+.code sha1-hash
+and
+.code sha1-end
+implement a stateful computation of SHA-1 digest which allows multiple input
+sources to contribute to the result. Furthermore, the context object may be
+serially reused for calculating multiple digests.
+
+The
+.code sha1-begin
+function, which takes no arguments, returns a new SHA-1 digest-producing
+context object.
+
+The
+.code sha1-hash
+updates the state of the SHA-1 digest object
+.meta ctx
+by including
+.meta obj
+into the digest calculation. The
+.meta obj
+argument may be: a character or character string, whose UTF-8 representation is
+digested; a buffer object, whose contents are digested; or an integer,
+representing a byte value in the range 0 to 255 included in the digest.
+The
+.code sha1-hash
+function may be called multiple times to include any mixture of
+strings and buffers into the digest calculation.
+
+The
+.code sha1-end
+function finalizes the digest calculation and returns the digest in
+a buffer. If the
+.meta buf
+argument is omitted, then a new 20-byte buffer is created for this
+purpose. Otherwise,
+.meta buf
+must specify a
+.code buf
+object that is at least 20 bytes long. The digest is stored into this
+buffer and that the buffer is returned.
+
+The
+.code sha1-end
+function additionally resets the
+.meta ctx
+object into the initial state of a newly created context object, so
+that it may be used for another digest session.
+
.coNP Functions @, sha256-begin @ sha256-hash and @ sha256-end
.synb
.mets (sha256-begin)
@@ -54583,18 +69871,18 @@ The three functions
.code sha256-hash
and
.code sha256-end
-implement a stateful computation of SHA256 digest which allows multiple input
+implement a stateful computation of SHA-256 digest which allows multiple input
sources to contribute to the result. Furthermore, the context object may be
-serially re-used for calculating multiple digests.
+serially reused for calculating multiple digests.
The
.code sha256-begin
-function, which takes no arguments, returns a new SHA256 digest-producing
+function, which takes no arguments, returns a new SHA-256 digest-producing
context object.
The
.code sha256-hash
-updates the state of the SHA256 digest object
+updates the state of the SHA-256 digest object
.meta ctx
by including
.meta obj
@@ -54642,7 +69930,7 @@ and
.code md5-end
implement a stateful computation of MD5 digest which allows multiple input
sources to contribute to the result. Furthermore, the context object may be
-serially re-used for calculating multiple digests.
+serially reused for calculating multiple digests.
The
.code md5-begin
@@ -54691,7 +69979,7 @@ The \*(TL library provides a macro called
.code awk
which is inspired by the Unix utility Awk. The macro implements
a processing paradigm similar to that of the utility: it scans
-one or more input streams, which are divided into records or fields,
+one or more input streams, which are divided into records and fields,
under the control of user-settable regular-expression-based delimiters.
The records and fields are matched against a sequence of programmer-defined
conditions (called "patterns" in the original Awk), which have associated
@@ -54709,7 +69997,7 @@ The
.code awk
macro implements some of the most important Awk
conventions and semantics, in Lisp syntax, while eschewing others.
-It does not implement implement the Awk convention that
+It does not implement the Awk convention that
variables become defined upon first mention; variables must be
defined to be used. It doesn't implement Awk's weak type system.
A character string which looks like a number isn't a number,
@@ -54746,7 +70034,7 @@ is broken into fields. For each record, the sequence of condition-action
clauses (except for certain special clauses) is processed. Every
.meta condition
is evaluated, and if it yields true, the corresponding
-.metn action -s
+.metn action s
are evaluated.
The
@@ -54794,7 +70082,9 @@ forms, the
.code awk
macro substitutes the single action equivalent to the form
.codn "(prn)" :
-a call to the local awk function
+a call to the local
+.code awk
+function
.codn prn .
The behavior of this macro, when called with no arguments, as above,
is to print the current
@@ -54816,17 +70106,20 @@ and
The following is a description of the special clauses:
.RS
-.meIP (:name << sym )
+.meIP (:name << obj )
The
.code :name
clause establishes the name of the implicit block contained
within the expansion of the
.code awk
-macro. Forms enclosed in the macro can use
+macro to be the object
+.metn obj ,
+usually a symbol.
+Forms enclosed in the macro can use
.code return-from
to abandon the
.code awk
-form, specifying this symbol as the argument.
+form, specifying the same object as the argument.
If the
.code :name
@@ -54837,10 +70130,10 @@ It is an error for two or more
.code :name
forms to appear.
-The
+Note: in \*(TX 255 and older, the
.code :name
-clause must have an argument which is a symbol;
-the symbol
+clause must have an argument which is a symbol.
+The symbol
.code nil
is not permitted.
@@ -54898,7 +70191,32 @@ and ordinary clauses, it will be shadowed by the
.code awk
variable
.codn fs ,
-which holds the field separator regular expression or string.
+which holds the field-separator regular expression or string.
+
+.meIP (:fun >> {( name < param-list << function-body-form *)}*)
+The
+.code :fun
+clause introduces named functions which are visible inside the
+.code awk
+form, as if bound by a
+.code labels
+operator. Variables defined by
+.code :let
+are visible to these named functions. The reverse is not true: the
+functions are not visible to the
+.metn init-form s
+of the
+.code :let
+clause. This is regardless of the order of appearance of the
+.code :let
+and
+.code :fun
+clauses in the
+.code awk
+macro. Furthermore, functions defined by
+.code :fun
+may refer to awk macros, functions and variables.
+
.meIP (:inputs << source-form *)
The
.code :inputs
@@ -54921,7 +70239,7 @@ will convert to an input stream as if by the
.code make-strlist-input-stream
function.
Or else it must be a character
-string, which denotes a filesystem path name which
+string, which denotes a filesystem pathname which
.code awk
will open for reading.
@@ -54948,7 +70266,7 @@ This is done in order that if
.code awk
is used from the \*(TX command line, for example using the
.code -e
-command line option, after
+command-line option, after
.code awk
terminates, \*(TX will not try to open the next argument
as a script file or treat it as an option.
@@ -54997,7 +70315,7 @@ in a scope which is nested within the scope established
by
.codn :output .
Therefore,
-.metn init-form -s
+.metn init-form s
in the
.code :let
may refer to the new value of
@@ -55024,7 +70342,7 @@ redirection macros in the same
.code awk
macro invocation. In brief, the implication is that if
.code :output
-creates a stream for the file path name
+creates a stream for the file pathname
.str "out.txt"
and somewhere in the same
.code awk
@@ -55050,8 +70368,9 @@ clauses are processed in the order in which they appear, before
input processing begins.
Each
.code form
-is evaluated. These forms have in their scope the awk local variables
-and macros.
+is evaluated. These forms have in their scope the local
+.code awk
+variables and macros.
.meIP (:set >> { place << new-value }*)
The
.code :set
@@ -55067,7 +70386,7 @@ when the input processing loop terminates.
This termination occurs when all records
from all input sources are either processed or skipped, or else
by an explicit termination such
-as a dynamic non-local transfer, such as
+as a dynamic nonlocal transfer, such as
.codn return-from ,
or the throwing of an exception.
@@ -55102,7 +70421,7 @@ clause, then end
clauses are not processed.
If an
.code :end
-clause performs a non-local transfer, the remaining
+clause performs a nonlocal transfer, the remaining
.code :end
forms in that clause and
.code :end
@@ -55147,26 +70466,98 @@ clauses are processed first, then the
clauses.
The
-:end-file
+.code :end-file
clauses are processed unconditionally, no matter how
the processing of an input source terminates, whether terminated
naturally by running out of records, prematurely by invocation of the
.code next-file
-macro, or via a dynamic non-local control transfer such as a block
+macro, or via a dynamic nonlocal control transfer such as a block
return or exception throw.
If a
.code :begin-file
-clause performs a non-local transfer,
+clause performs a nonlocal transfer,
.code :end-file
processing is not triggered, because the processing of the input
source is deemed not to have taken place.
+
+.meIP (:fields >> { sym | >> ( sym <> [ fun ]) | -}*)
+The
+.code :fields
+clause may be specified in order to give symbolic names to fields,
+and optionally specify conversions for them.
+Every argument must be one of three expressions. It may be
+a bindable symbol other than
+.code -
+(minus). It may be a list whose first element is
+a symbol other than
+.code -
+optionally followed the name of a function.
+Or else it may be the
+.code -
+symbol, which has a special meaning.
+Symbols other than
+.code -
+may not be repeated, and the
+.code :fields
+clause may appear at most once in a given instance of the
+.code awk
+macro.
+Each argument is understood to correspond to a field expression for a successive field,
+starting with the leftmost
+.meta sym
+corresponding with the first field,
+.codn "[f 0]" .
+Each
+.meta sym
+other than
+.code -
+becomes the name of a symbol macro which denotes its corresponding
+field expression, expanded over the scope of the
+.code awk
+macro. The
+.code -
+symbol is a placeholder which doesn't bind a symbol macro to the
+corresponding field.
+Additionally, every two-element entry which associates the field symbol
+.meta sym
+with a function name
+.meta fun
+specifies a field conversion. After each record is read and divided into
+fields, those fields for which
+.meta fun
+is specified are updated by passing their value to this function
+and replacing them by the returned value.
+The
+.meta fun
+symbol may also be one of the short-hand symbols available in the
+.code fconv
+macro, such as
+.codn i ,
+.code x
+and others.
+If at least one such conversion is specified in a
+.code :fields
+clause, then the value of
+.code rec
+is updated from the converted fields in the usual manner, as if
+the fields had been assigned.
+Furthermore, it is ensured that every field for which a
+.code :fields
+clause specifies a conversion exists. Fields with an empty string
+value are automatically added so that a field exists for the
+rightmost conversion, and the value of
+.code nf
+is updated to include these fields.
+
.meIP >> ( condition << action *)
Clauses which do not have one of the specially recognized keywords
in the first position are ordinary condition-action clauses. After
processing the
.code :begin
-clauses, the awk enters a loop in which it extracts successive records
+clauses,
+.code awk
+enters a loop in which it extracts successive records
from the input sources according to the
.code rs
(record separator) variable. Each record is divided into fields according
@@ -55190,14 +70581,22 @@ is other than a function or regular expression, it is taken directly
to be the truth value.
If the condition is true, then its associated
.meta action
-forms are evaluated. Either way, processing passes to the next condition
-clause (unless an explicit step is taken in one of the
-.metn action -s
-to prevent this, for instance by invoking the
+forms are evaluated. These forms have access to the truth value via the
+.code res
+variable, which is freshly bound for each execution of the
+.meta action
+forms of that specific clause.
+For each input record, all condition-action clauses are processed in the order
+they appear, regardless of which of them have a true action,
+except in cases when some
+.meta action
+invokes the
.code next
-and
+or
.code next-file
-macros).
+macro, or abandons the execution of the
+.code awk
+macro entirely via a non-local exit.
When an input source runs out of records,
.code awk
switches to the next input source. When there are no more input sources,
@@ -55206,10 +70605,12 @@ the macro terminates.
.coNP Variables @ rec and @ orec
.desc
-The awk variable
+The
+.code awk
+variable
.code rec
holds the current record. It is automatically updated prior to the
-processing of the condition-pattern clauses. Prior to the extraction
+processing of the condition-action clauses. Prior to the extraction
of the first record, its value is
.codn nil .
@@ -55219,7 +70620,8 @@ The value assigned to
.code rec
must be a character string. Immediately upon the assignment, the character
string is delimited into fields according to the field separator
-awk variable
+.code awk
+variable
.codn fs ,
and these fields are assigned to the field list
.codn f .
@@ -55237,7 +70639,7 @@ separated by copies of the output field separator
The
.code orec
variable ("original record") also holds the current record. It is automatically
-updated prior to the processing of the condition-clauses at the same time as
+updated prior to the processing of the condition-action clauses at the same time as
.code rec
with the same contents. Like
.codn rec ,
@@ -55256,7 +70658,9 @@ variable.
.coNP Variable @ f
.desc
-The awk variable
+The
+.code awk
+variable
.code f
holds the list of fields. Prior to the first record being read,
its value is
@@ -55279,7 +70683,8 @@ variable is updated by catenating a string representation of the
elements of this sequence, separated by the contents of the
.code ofs
(output field separator)
-awk variable.
+.code awk
+variable.
Note that assigning to a DWIM bracket form which indexes
.codn f ,
@@ -55307,7 +70712,9 @@ is erroneous.
.coNP Variable @ nf
.desc
-The awk variable
+The
+.code awk
+variable
.code nf
holds the current number of fields in the sequence
.codn f .
@@ -55339,7 +70746,9 @@ variable.
.coNP Variable @ nr
.desc
-The awk variable
+The
+.code awk
+variable
.code nr
holds the current absolute record number. Record numbers start at 1.
Absolute means that this value does not reset to 1 when
@@ -55355,7 +70764,9 @@ is zero.
.coNP Variable @ fnr
.desc
-The awk variable
+The
+.code awk
+variable
.code fnr
holds the current record number within the file. The first record is 1.
@@ -55368,7 +70779,9 @@ source.
.coNP Variable @ arg
.desc
-The awk variable
+The
+.code awk
+variable
.code arg
is an integer which indicates what input source is being processed.
Prior to input processing, it holds the value zero. When the first
@@ -55379,15 +70792,17 @@ switches to a new input source.
.coNP Variable @ fname
.desc
-The awk variable
+The
+.code awk
+variable
.code fname
provides access to a character string which, if the current input is
a file stream, is the name of the underlying file. Assigning to this
variable changes its value, but has no effect on the input stream.
Whenever a new input source is used by
-.code awk
-it sets this variable either from the file name on which it is opening
-a stream.. When using an existing stream rather than opening a file,
+.codn awk ,
+this variable is set from the file name on which it is opening
+a stream. When using an existing stream rather than opening a file,
.code awk
sets this variable from the
.code :name
@@ -55403,7 +70818,9 @@ retains its value.
.coNP Variable @ rs
.desc
-The awk variable
+The
+.code awk
+variable
.code rs
specifies a string or regular expression which is used for
delimiting characters read from the inputs into pieces called records.
@@ -55413,14 +70830,14 @@ instantiated by the
.code record-adapter
function.
-The regular expression pattern stored in
+The regular-expression pattern stored in
.code rs
is used to matches substrings in the input which separate or terminate records.
Unless the
.code krs
variable is set true, the substrings which match
.code rs
-are discarded and the records consist of the non-matching extents between
+are discarded and the records consist of the nonmatching extents between
them.
The initial value of
@@ -55471,7 +70888,9 @@ matches a newline.
.coNP Variable @ krs
.desc
-The awk variable
+The
+.code awk
+variable
.code krs
stands for "keep record separator". It is a Boolean variable, initialized to
.codn nil .
@@ -55489,7 +70908,9 @@ read record.
.coNP Variables @ fs and @ ft
.desc
-The awk variable
+The
+.code awk
+variable
.code fs
and
.code ft
@@ -55533,7 +70954,7 @@ is ignored, and no fields are produced: the field list
.code f
is the empty list, and
.code nf
-is zero. A non-empty record is split by searching it for matches for the
+is zero. A nonempty record is split by searching it for matches for the
.code fs
pattern. If a match does not occur, then the entire record is a field.
If one match occurs, then the record is split into two fields, either of which,
@@ -55577,7 +70998,9 @@ is customized.
.coNP Variable @ kfs
.desc
-The awk variable
+The
+.code awk
+variable
.code kfs
is a Boolean flag which is initialized to
.codn nil .
@@ -55596,11 +71019,11 @@ being set, there is always at least one field, even if the record is empty.
If the record doesn't match the tokenizing regular expression in
.code ft
then a single field is generated, then the entire record is
-taken as one field, denoting the non-matching space, even
+taken as one field, denoting the nonmatching space, even
if the record is the empty string.
If the record matches one or more tokens, then the first and
-last field will always contain the non-matching material before
+last field will always contain the nonmatching material before
the first and last token, respectively. This is true even if
the material is empty. Thus
.code "[f 0]"
@@ -55657,7 +71080,9 @@ function.
.coNP Variable @ fw
.desc
-The awk variable
+The
+.code awk
+variable
.code fw
controls the fixed-width-based delimiting of records into fields.
@@ -55705,7 +71130,7 @@ If
.code fw
holds a value other than
.code nil
-or else a list of non-negative integers, the behavior is unspecified.
+or else a list of nonnegative integers, the behavior is unspecified.
.TP* Examples
@@ -55733,7 +71158,9 @@ give rise to field values
.coNP Variable @ ofs
.desc
-The awk variable
+The
+.code awk
+variable
.code ofs
hold the output field separator. Its initial value is a string
consisting of a single space character.
@@ -55757,7 +71184,9 @@ is used to separate the fields, as they appear in
.coNP Variable @ ors
.desc
-The awk variable
+The
+.code awk
+variable
.codn ors ,
though it stands for "output record separator" holds what
is in fact the output record terminator. It is named after the
@@ -55776,12 +71205,59 @@ and so the
.code prn
function prints lines.
+.coNP Variable @ res
+.desc
+The
+.code awk
+variable
+.code res
+is implicitly bound over the scope of the action forms of every
+condition-action clause. It holds the result of the condition form.
+
+Because the action forms execute only if the condition yields true,
+it follows that
+.code res
+is never observed with a value of
+.code nil
+unless the program explicitly assigns that value.
+
+Note: this is an original feature in the \*(TL
+.code awk
+macro, which has no counterpart in POSIX or GNU Awk.
+
+.TP* Example:
+
+.verb
+ (awk
+ (:inputs '("carpet"))
+ (#/a.*p/ (prn res)))
+
+ Output:
+
+ arp
+.brev
+
+In this example, the result of the
+.code "#/a.*p/"
+regular expression being applied to the input
+.code carpet
+is the string
+.str arp
+and so over that clause,
+.code prn
+takes on that string as its value. Thus,
+thanks to
+.codn prn ,
+the action has access to the matching part of the record.
+
.coNP Function @ prn
.synb
.mets (prn << form *)
.syne
.desc
-The awk function
+The
+.code awk
+function
.code prn
performs output into the
.code *stdout*
@@ -55821,12 +71297,19 @@ Thus if the value is
the output for that argument is an empty string, rather than the text
.strn nil .
+The
+.code prn
+function returns
+.codn nil .
+
.coNP Macro @ next
.synb
.mets (next)
.syne
.desc
-The awk macro
+The
+.code awk
+macro
.code next
may be invoked in a condition-pattern clause. It terminates
the processing of that clause, and all subsequent clauses,
@@ -55842,12 +71325,16 @@ terminates.
.mets (again)
.syne
.desc
-The awk macro
+The
+.code awk
+macro
.code again
may be invoked in a condition-pattern clause. It terminates the
processing of that clause, and all subsequent clauses.
Then, the current value of the record, namely the datum stored
-in the Awk variable
+in the
+.code awk
+variable
.codn rec ,
is delimited into fields, and all of the condition-pattern clauses
are processed again.
@@ -55867,16 +71354,20 @@ macro, which has no counterpart in POSIX or GNU Awk.
.mets (next-file)
.syne
.desc
-The awk macro
+The
+.code awk
+macro
.code next-file
may be invoked in a condition-pattern clause. It terminates
-the processing of that clause, and all subsequent clauses.
-Awk then abandons the current input source, and moves to the
-next one. If there is no next input source,
+the processing of that clause and all subsequent clauses.
+Then
+.code awk
+abandons the current input source and moves to the next one.
+If there is no next input source,
.code awk
terminates.
-.coNP Macros @, rng @, -rng @ rng- @, -rng- @, --rng @, --rng- @, rng+ @ -rng+ and @ --rng+
+.coNP Macros @, rng @, -rng @, rng- @, -rng- @, --rng @, --rng- @, rng+ @ -rng+ and @ --rng+
.synb
.mets (rng < from-condition << to-condition )
.mets (-rng < from-condition << to-condition )
@@ -55889,7 +71380,9 @@ terminates.
.mets (--rng+ < from-condition << to-condition )
.syne
.desc
-The nine awk macros in the
+The nine
+.code awk
+macros in the
.code rng
family may be used anywhere within an ordinary condition-pattern
.code awk
@@ -55913,11 +71406,16 @@ expression yields a Boolean true value when it is evaluated in the context
of processing any of the records which are included in the range.
The table below summarizes the semantic variations of these nine
-range macro operators. The leftmost column represents the file of records
-being processed. The remaining columns indicate, using the character
+range macro operators. The leftmost column labeled
+.code DATA
+represents the stream of records being processed. Each entry in this column gives
+the literal piece of text which comprises the content of one record in the stream.
+The remaining nine columns, labeled with the nine range operators, inform about
+the behavior of these operators with respect to these records. In each of these
+columns the letter
.code X
-those rows for each of the nine range operators yield true. Each operator
-is assumed to be invoked with the arguments
+marks those records for which the column's range operator yields true,
+if it is invoked with the arguments
.code #/H/
and
.code #/T/
@@ -55925,10 +71423,16 @@ as its
.meta from-condition
and
.metn to-condition ,
-respectively: for example,
+respectively.
+For example, the
+.code rng
+column shows the values of the
.code "(rng #/H/ #/T/)"
-in the case of
-.codn rng :
+expression, indicating that the expression starts being true when the
+.code H1
+record is seen, stays true for the
+.code T1
+record, and then reverts to false:
.verb
DATA rng -rng rng- -rng- --rng --rng- rng+ -rng+ --rng+
@@ -55945,7 +71449,8 @@ in the case of
EPILOG
.brev
-The prefix or suffix characters are mnemonic. A single
+The prefix and suffix characters of the operator names are intended
+to be mnemonic. A single
.code -
(dash) indicates the exclusion of one record. A double
.code --
@@ -55982,8 +71487,8 @@ are ordinary expressions which are evaluated. However, their
evaluation is unusual in two ways.
Firstly, if either expression
-produces, as its result, a function or regular expression object,
-then that function or regular expression object is applied to
+produces, as its result, a function or regular-expression object,
+then that function or regular-expression object is applied to
the current record (value of the
.code rec
variable), and the result of that application is then taken
@@ -56039,12 +71544,14 @@ expression merely fetches a previously computed Boolean value which indicates
whether the range is active for this record.
Also, the behavior is unspecified if range expressions attempt to modify
-the awk-special variables.
+any of the special
+.code awk
+variables
.codn rec ,
.codn f ,
.codn fs ,
.code ft
-or
+and
.codn kfs .
It is not recommended to place any side effects into range expressions.
@@ -56175,7 +71682,9 @@ expression is true.
.mets (ff < opip-arg *)
.syne
.desc
-The awk macro
+The
+.code awk
+macro
.code ff
(filter fields)
provides a shorthand for filtering the field list
@@ -56186,8 +71695,10 @@ argument syntax.
The following equivalence holds, except that
.code f
-refers to the awk variable even if the
-.code mf
+refers to the
+.code awk
+variable even if the
+.code ff
invocation occurs in code which establishes
a binding which shadows
.codn f .
@@ -56207,7 +71718,9 @@ a binding which shadows
.mets (mf < opip-arg *)
.syne
.desc
-The awk macro
+The
+.code awk
+macro
.code mf
(map fields)
provides a shorthand for mapping each field
@@ -56217,7 +71730,9 @@ argument syntax.
The following equivalence holds, except that
.code f
-refers to the awk variable even if the
+refers to the
+.code awk
+variable even if the
.code mf
invocation occurs in code which establishes
a binding which shadows
@@ -56238,7 +71753,9 @@ a binding which shadows
.mets (fconv >> { clause | : | - }*)
.syne
.desc
-The awk macro
+The
+.code awk
+macro
.code fconv
provides a succinct way to request conversions of the textual fields.
Conversions are expressed by clauses which correspond with fields.
@@ -56254,7 +71771,7 @@ specified simply by using their name as a
Furthermore, several local functions exist in the scope of each
.metn clause ,
-providing a short-hand notation. These are described below.
+providing a shorthand notation. These are described below.
Conversion proceeds by applying the function produced by
a clause to the field to which that clause corresponds, positionally.
@@ -56271,7 +71788,7 @@ on its field.
The
.code :
(colon)
-symbol isn't a clause and does not correspond to a field position.
+keyword symbol isn't a clause and does not correspond to a field position.
Rather, it acts as a separator among clauses. It need not appear at
all. If it appears, it may appear at most twice. Thus, the
clauses may be separated into up to three sequences.
@@ -56281,8 +71798,7 @@ If the colon does not appear, then all the clauses are
Prefix clauses line up with fields from left to right. If there are fewer
fields than prefix clauses, the values of the excess clauses are evaluated, but
ignored.
-.IR "Vice versa" ,
-if there are fewer prefix clauses than fields, then the excess
+Vice versa, if there are fewer prefix clauses than fields, then the excess
fields are not subject to conversions.
If the colon appears once, then the clauses before the colon, if any, are
@@ -56293,11 +71809,11 @@ Interior clauses apply to any fields which are left unconverted by the prefix
clauses. All interior clauses are evaluated. If there are fewer fields than
interior clauses, then the values of the excess interior clauses are ignored.
If there are more fields than clauses, then the clause values are cycled:
-re-used from the beginning against the excess fields, enough times to convert
+reused from the beginning against the excess fields, enough times to convert
all the fields.
If the colon appears twice, then the clauses before the first colon, if any,
-are prefix clauses, the clauses between the two clause are interior clauses,
+are prefix clauses, the clauses between the two colons are interior clauses,
and those after the second colon are
.IR "suffix clauses" .
The presence of suffix clauses change the behavior relative to the one-colon
@@ -56314,30 +71830,34 @@ Finally, the previously reserved rightmost fields are processed using
the suffix clauses.
The following special convenience functions are in scope of the clauses,
-effectively providing a short-hand for commonly-needed conversions:
+effectively providing a shorthand for commonly-needed conversions:
.RS
.coIP i
Provides conversion to integer. It is identical to the
.code toint
-function.
+function, with the default radix.
.coIP o
Converts a string value holding an octal representation
-to the integer which it denotes. The expression
-.code "(o str)"
-is equivalent to
-.codn "(toint str 8)" .
+to the integer which it denotes. It is equivalent to
+.code toint
+with a
+.meta radix
+argument of 8.
.coIP x
Converts a string value holding a hexadecimal representation
-to the integer which it denotes. The expression
-.code "(x str)"
+to the integer which it denotes. It is equivalent to
+.code toint
is equivalent to
-.codn "(toint str 16)" .
+with a
+.meta radix
+argument of 16.
.coIP b
Converts a string value holding a binary (base two) representation
-to the integer which it denotes. The expression
-.code "(b str)"
-is equivalent to
-.codn "(toint str 2)" .
+to the integer which it denotes. It is equivalent to
+.code toint
+with a
+.meta radix
+argument of 2.
.coIP c
Converts a string value holding a C-language-style representation
to the integer which it denotes, meaning that the
@@ -56348,16 +71868,18 @@ decimal. These prefixes follow the
or
.code -
sign, if present.
-The expression
-.code "(c str)"
-is equivalent to
-.codn "(toint str #\ec)" .
+The
+.code c
+function is equivalent to
+.code toint
+invoked with a
+.meta radix
+argument of
+.codn #\ec .
.coIP r
Converts a string holding a floating-point representation to
-the floating-point value which it denotes. The expression
-.code "(r str)"
-is equivalent to
-.codn "(tofloat str)" .
+the floating-point value which it denotes. It is equivalent to
+.codn tofloat .
.ccIP @, iz @, oz @, xz @, bz @ cz and @ rz
Conversion similar to
.codn i ,
@@ -56367,7 +71889,7 @@ Conversion similar to
.code c
and
.codn r ,
-but using
+but equivalent to using the functions
.code tointz
and
.codn tofloatz .
@@ -56375,6 +71897,8 @@ Thus fields which are non-numeric strings or the object
.code nil
get converted to 0, or 0.0 in the case of
.codn rz .
+.coIP -
+Performs no conversion: the corresponding field is taken as-is.
.RE
.IP
Because
@@ -56391,6 +71915,44 @@ The return value of
is
.codn f .
+Note: because
+.code f
+is
+.code nil
+when no fields have been extracted, a
+.code fconv
+expression can be used as the condition in an
+.code awk
+clause which triggers the action if one or more fields have been
+extracted, and performs conversions on them.
+
+Note: although
+.code fconv
+is intended for converting textual fields, and the semantic descriptions below
+consequently make references to string inputs, the behavior of
+.code fconv
+with respect to non-string fields can be inferred. For instance if a field
+actually holds the floating-point value 3.14, and the
+.code i
+conversion is applied to it, it will produce 3, because it works by
+means of the
+.code toint
+function.
+
+Note: a somewhat less flexible mechanism for converting fields, related to
+.codn fconv ,
+is present in the
+.code :fields
+clause of the
+.code awk
+macro, which can specify names for the positional fields, along with
+conversion functions. The
+.code :fields
+clause has different syntax, and doesn't support the
+.code :
+(colon) separator, instead assuming a fixed number of fields
+enumerated from the left.
+
.TP* Examples:
.verb
@@ -56425,7 +71987,9 @@ is
.mets (<! < command << form *)
.syne
.desc
-These awk macros provide convenient redirection of output and input to and from
+These
+.code awk
+macros provide convenient redirection of output and input to and from
files and commands.
When at least one
@@ -56452,7 +72016,7 @@ evaluate each
.meta form
in a dynamic environment in which
.code *stdin*
-is bound to to a file input stream or input command pipe, respectively.
+is bound to a file input stream or input command pipe, respectively.
The
.meta path
@@ -56478,6 +72042,14 @@ or
string, direction and type, a new stream is not opened; rather, the
previously associated stream is used.
+The scope of these macros is the entire containing
+.code awk
+form; they may be used in the
+.code :let
+and
+.code :fun
+clauses.
+
The
.code ->
macro indicates that the file named
@@ -56524,7 +72096,7 @@ If the last
.meta form
yields the
.code :close
-keyword symbol, the the association between the
+keyword symbol, the association between the
.meta path
or
.metn command ,
@@ -56550,7 +72122,7 @@ The association between the
.meta pipe
or
.meta command
-strings, direction and type is scoped to the inner-most enclosing
+strings, direction and type is scoped to the innermost enclosing
.code awk
macro. An inner
.code awk
@@ -56561,9 +72133,9 @@ macro. An outer
macro can obtain an association's stream object and communicate
that stream to the nested macro where it can be used.
-When the
-.meta awk
-surrounding macro terminates, all of the streams opened by these
+When the surrounding
+.code awk
+macro terminates, all of the streams opened by these
redirection macros are closed, without breaking those associations.
If lexical closures are captured inside the macro, and then invoked after the
macro has terminated, and inside those closures the redirection macros are
@@ -56753,7 +72325,7 @@ completes:
(awk (:begin (prn `@{*args* " "}`) (exit 0)))
.brev
.IP 18.
-Pint the components of the
+Print the components of the
.code PATH
environment variable, one per line:
@@ -56793,11 +72365,11 @@ prints the file, filling in page numbers starting at 5.
.SS* Environment Variables and Command Line
-Note that environment variable names, their values, and command line
+Note that environment variable names, their values, and command-line
arguments are all regarded as being externally encoded in UTF-8. \*(TX performs
the encoding and decoding automatically.
-.coNP Special variables @, *args-full* @ *args-eff* and @ *args*
+.coNP Special Variables @, *args-full* @ *args-eff* and @ *args*
.desc
The
.code *args-full*
@@ -56805,12 +72377,12 @@ variable holds the original, complete list of arguments passed
from the operating system, including the program executable
name.
-During command line option processing, \*(TX may transform the
-argument list. The hash bang mechanism, and the
+During command-line-option processing, \*(TX may transform the
+argument list. The hash-bang mechanism, and the
.code --args
and
.code --eargs
-options can inject new command line arguments, as can code
+options can inject new command-line arguments, as can code
which is executed during argument processing via the
.code -e
options and others.
@@ -56818,12 +72390,12 @@ options and others.
The
.code *args-eff*
variable holds the list of
-.I "effective arguments" ,
+.IR "effective arguments" ,
which is the argument list after these transformations are applied.
This variable is established and set to the same value as
.code *args-full*
-prior to command line processing, but is not updated with its final
-value until after command line processing.
+prior to command-line processing, but is not updated with its final
+value until after command-line processing.
The
.code *args*
@@ -56838,7 +72410,7 @@ can be calculated using the expression
The
.code *args*
-variable is available to to \*(TL expressions invoked from the
+variable is available to \*(TL expressions invoked from the
command line via the
.codn -p ,
.code -e
@@ -56867,6 +72439,14 @@ contains an
(equal) character somewhere, separating the variable name
from its value.
+Multiple calls to
+.code env
+may return the same list, or lists which share structure.
+
+If a list returned by
+.code env
+is modified, the behavior is unspecified.
+
See also: the
.code env-hash
function.
@@ -56878,10 +72458,28 @@ function.
.desc
The
.code env-hash
-function constructs and returns an
+function returns an
.code :equal-based
-hash. The hash is
-populated with the environment variables, represented as key-value pairs.
+hash whose keys and values are strings. The hash table is populated
+with the environment variables, represented as key-value character string
+pairs.
+
+The
+.code env-hash
+function allocates the hash table when it is first invoked; thereafter,
+it returns the same hash table.
+
+The hash table is updated by the functions
+.codn setenv ,
+.code unsetenv
+and
+.codn getenv .
+
+Note: calls to the underlying C library functions
+.code setenv
+and
+.codn getenv ,
+and other direct manipulations of the environment, will not update the hash table.
.coNP Functions @, getenv @ setenv and @ unsetenv
.synb
@@ -56938,7 +72536,7 @@ then the variable is overwritten if it already exists.
If the argument is false, then the variable is not modified if it
already exists. If the argument is not specified, it defaults
to the value
-.metn t ,
+.codn t ,
effectively giving rise to a two-argument form of
.code setenv
which creates or overwrites environment variables.
@@ -56988,7 +72586,128 @@ is restored by the
.code unwind-protect
cleanup form.
-.SS* Command Line Option Processing
+These functions interact with the list returned by the
+.code env
+function and with the hash table returned by the
+.code env-hash
+function as follows.
+
+A previously returned list returned by
+.code env
+is not modified. The
+.code setenv
+and
+.code unsetenv
+functions may cause a subsequent call to
+.code env
+to return a different list. The
+.code getenv
+function has no effect on the list.
+
+The hash table previously returned by
+.code env-hash
+is modified by
+.code setenv
+in the manner consistent with its semantics. A new entry is created in the table,
+if required, and an existing entry is overwritten only if the
+.code overwrite-p
+flag is specified. Likewise, if
+.code setenv
+is invoked in a way that causes the environment variable to be deleted, it
+is removed from the hash also.
+The
+.code unsetenv
+function causes the variable to be removed from the hash table also.
+The
+.code getenv
+function accesses the underlying environment and updates the hash
+table with the name-value pair which is retrieved.
+
+.coNP Function @ replace-env
+.synb
+.mets (replace-env << env-list )
+.syne
+.desc
+The
+.code replace-env
+function replaces the environment with the environment variables specified in
+.metn env-list .
+The argument is a list of character strings, in the same format
+as the list returned by the
+.code env
+function: each element of the list describes an environment variable
+as a single character string in which the name is separated by the
+value by the
+.code =
+character. As a special concession, if this character is missing, the
+.code replace-env
+function treats that entry as being a name with an empty value.
+
+The
+.code replace-env
+first empties the existing environment, rendering it devoid of environment
+variables. Then it installs the entries specified in
+.metn env-list .
+
+The return value is
+.metn env-list .
+
+Note:
+.code replace-env
+may be used to specify an exact environment to child programs executed
+by functions like
+.codn open-process ,
+.code sh
+or
+.codn run .
+
+Note: the previous environment may be saved by calling
+.code env
+and retaining the returned list. Then after modifying the environment,
+the original environment can be restored by passing that retained
+list to
+.codn replace-env .
+
+.coNP Special Variable @ *child-env*
+.desc
+The
+.code *child-env*
+variable specifies the list of command-line variables established for programs
+executed via the functions
+.codn exec ,
+.codn run ,
+.codn sh ,
+.code open-command
+and
+.codn open-process .
+
+The initial top-level value of this variable is the symbol
+.code t
+which indicates that
+.code *child-env*
+is to be ignored, such that the executed program
+inherits the current set of environment variables.
+
+If
+.code *child-env*
+has any other value, it must be a possibly empty list of environment
+variables, in the same format as what is returned by
+.code env
+function and accepted by
+.codn replace-env .
+That value completely specifies the environment that executed programs
+shall receive.
+
+.TP* Example:
+
+.verb
+ (let ((*child-env* '("a=b")))
+ ;; /usr/bin/env sees only "a" environment variable
+ (get-lines (open-process "/usr/bin/env" "r")))
+ -> ("a=b")
+.brev
+
+.SS* Command-Line-Option Processing
\*(TL provides a support for recognizing, extracting and validating
the POSIX-style options from a list of command-line arguments.
@@ -57015,7 +72734,18 @@ function takes a list of option descriptors and an output stream,
and generates help text on that stream. A program supporting a
.code --help
option can use this to generate that portion of its help text which
-describes the available options, as well as the conventions that they use.
+describes the available options. Also provided are functions
+.code opthelp-conventions
+and
+.codn opthelp-types ,
+which have the same interface as
+.code opthelp
+and print additional information. These may be used together with
+.code opthelp
+to provide more detailed help under a single
+.code --help
+option, or under separate options like
+.codn --extra-help .
The
.code define-option-struct
@@ -57024,10 +72754,10 @@ same facility. The options are declared in a more condensed way, and
using symbols instead of strings. Furthermore, the parsed option values
become slot values of an object, named by the same symbols.
-.NP* Command Line Option Conventions
+.NP* Command-Line-Option Conventions
-A command line option can have a short or long name. A short name is always
-one-character long, and treated specially in the command line syntax. Long
+A command-line option can have a short or long name. A short name is always
+one character long, and treated specially in the command-line syntax. Long
options have names two or more characters long. An option can have both a long
and short name. Options may not begin with the
.code -
@@ -57055,7 +72785,7 @@ immediately followed by the name. When a long option takes an argument,
it is mandatory. It must be specified in the same argument, separated
from the name by the
.code =
-character. If that is omitted, then the next command line argument
+character. If that is omitted, then the next command-line argument
is taken as the argument. That argument is removed, and not recognized as
an option, even if it looks like one.
@@ -57075,20 +72805,20 @@ of
to explicitly specify false for a Boolean option.
If a short option takes an argument, it may not clump with other
-short option. The following command line argument is taken as the
+short option. The following command-line argument is taken as the
options argument. That argument is removed and is not recognized as
an option even if it looks like one.
-If the command line argument
+If the command-line argument
.code --
occurs in the command line where an option would otherwise be recognized,
it signifies the end of the options. The subsequent arguments are the
non-option arguments, even if they resemble options.
-.NP* Command Line Processing Examples
+.NP* Command-Line Processing Examples
The following example illustrates a complete \*(TL program which
-parses command line options:
+parses command-line options:
.verb
(defvarl options
@@ -57110,7 +72840,7 @@ parses command line options:
(opt "l" "lit" :str
"A character string given in TXR Lisp notation.")
(opt "c" nil 'upcase-str
- "Custom treatment: ARG is converted to upper case.")
+ "Custom treatment: ARG is converted to uppercase.")
(opt "b" "bool" :bool
"A flag you can flip true.")))
@@ -57135,6 +72865,9 @@ macro:
"Verbosity level. Higher values produce more chatter.")
(nil help :bool
"List this help text.")
+ (nil extra-help
+ :bool
+ "List help text with more detailed information.")
(x nil :hex
"The X factor: a number with a mysterious\e \e
interpretation, affecting the program\e \e
@@ -57150,18 +72883,21 @@ macro:
(l lit :str
"A character string given in TXR Lisp notation.")
(c nil upcase-str
- "Custom treatment: ARG is converted to upper case.")
+ "Custom treatment: ARG is converted to uppercase.")
(b bool :bool
- "A flag you can flip true."))
+ "A flag you can flip true."))
(defvarl prog-name *load-path*)
(let ((o (new prog-opts)))
o.(getopts *args*)
- (when o.help
+ (when (or o.help o.extra-help)
(put-line "Usage:\en")
(put-line ` @{prog-name} [options] arg*`)
o.(opthelp)
+ (when o.extra-help
+ o.(opthelp-types)
+ o.(opthelp-conventions))
(exit -1))
(put-line `args after opts are: @{o.out-args ", "}`))
.brev
@@ -57175,7 +72911,7 @@ macro:
.desc
The
.code opt-desc
-structure describes a single command line option.
+structure describes a single command-line option.
The
.code short
@@ -57265,7 +73001,7 @@ successfully yield a string object, otherwise the argument is ill-formed.
.meIP (list << type )
If the type is specified as a compound form headed by the
.code list
-symbol, it indicates that the command line option's argument is a list
+symbol, it indicates that the command-line option's argument is a list
of elements. The argument appears on the command line as a single string
contained within one argument. It may contain commas, and is split into pieces
using the comma character as a separator. The pieces are then individually
@@ -57275,7 +73011,12 @@ and converted accordingly. The option's argument is then a list object
whose elements are the converted pieces. For instance
.code "(list :dec)"
will convert a list of comma-separated decimal integer tokens into
-a list of integer objects. The
+a list of integer objects.
+The
+.meta type
+argument must be a basic type other than
+.codn :bool .
+The
.code list
option type does not nest.
.meIP (cumul << type )
@@ -57285,14 +73026,17 @@ symbol, it indicates that if the option is specified multiple times,
the values coming from the multiple occurrences are accumulated into a list.
The
.meta type
-argument may be a
+argument must be a
.code list
-type, exemplified by
+type or a basic type other than
+.codn :bool ,
+for example
.code "(cumul (list :dec))"
-or a basic type, such as
+and
.codn "(cumul :str)" .
-However, this type specifier does not nest. Combinations such as
-.code "(cumul (cumul ...)"
+This type specifier does not nest:
+combinations such as
+.code "(cumul (cumul ...))"
and
.code "(list (cumul ...))"
are invalid.
@@ -57354,7 +73098,7 @@ corresponds to the same-named slot and defaults to
The optional parameter
.meta helptext
-corresponds to the same-named slot, and defaults to
+corresponds to the same-named slot and defaults to
.code nil
(no help text provided for the option).
@@ -57377,7 +73121,7 @@ function follows this equivalence:
The
.code opts
structure represents a parsed command line, containing decoded
-information obtained from the options, and an indication where
+information obtained from the options and an indication of where
the non-option arguments start.
The
@@ -57480,7 +73224,7 @@ function takes a list of
.code opt-desc
structures and a list of strings
.meta arg-list
-representing command line arguments.
+representing command-line arguments.
The
.meta arg-list
@@ -57499,12 +73243,14 @@ If the parse is successful,
.code getopts
returns an instance of the
.code opts
-structure describing the parsed opts, and listing the non-option
+structure describing the parsed options and listing the non-option
arguments.
-.coNP Function @ opthelp
+.coNP Functions @, opthelp @ opthelp-types and @ opthelp-conventions
.synb
.mets (opthelp < opt-desc-list <> [ stream ])
+.mets (opthelp-types < opt-desc-list <> [ stream ])
+.mets (opthelp-conventions < opt-desc-list <> [ stream ])
.syne
.desc
The
@@ -57513,10 +73259,10 @@ function processes the list of
.code opt-desc
structures
.meta opt-desc-list
-and compiles a customized body of help text describing all of the
-options, as well as general description of the command line option
-conventions to guide the user in in the correct use of command
-line options.
+and compiles a customized body of help describing all of the
+options which have help text. These are presented in alphabetical
+order. Options which do not have help text, if any, are simply
+listed together under a heading which indicates their undocumented status.
The text is formatted to fit within 79 columns, and begins and ends with a
blank line. Its format consists of headings which begin in the first column,
@@ -57535,6 +73281,24 @@ itself, then an exception of type
.code error
is thrown.
+The
+.code opthelp-types
+supplementary help function processes the
+.metn opt-desc-list ,
+considering only those options which are documented. If any of them have typed
+arguments, then a legend is printed explaining the types. The legend includes
+only information about those option argument types which appear in
+.metn opt-desc-list .
+
+The
+.code opthelp-conventions
+supplementary help function processes
+.metn opt-desc-list ,
+considering only those options which are documented. It prints a guide
+to the use of options, which includes information only about the kinds
+of options actually present in
+.metn opt-desc-list .
+
.coNP Macro @ define-option-struct
.synb
.mets (define-option-struct < name < super << opt-specifier *)
@@ -57542,7 +73306,7 @@ is thrown.
.desc
The
.code define-option-struct
-macro defines a struct type instances of which provides command line option
+macro defines a struct type, instances of which provide command-line option
parsing.
The
@@ -57556,7 +73320,9 @@ semantics as the same-named parameters of
The
.meta opt-specifier
arguments are lists of between two and four elements:
+.mono
.meti >> ( short-symbol < long-symbol >> [ type <> [ help-text ]]).
+.onom
The
.meta short-symbol
and
@@ -57578,10 +73344,12 @@ shall exist in the structure.
The struct type defined by
.code define-option-struct
-has two methods:
-.code getopts
+has four methods:
+.codn getopts ,
+.codn opthelp ,
+.code opthelp-types
and
-.codn opthelp .
+.codn opthelp-conventions .
It also has two slots:
.code in-args
and
@@ -57597,8 +73365,11 @@ method takes a single argument: the argument list to be processed.
When the argument list is successfully processed.
The
-.code opthelp
-method takes an optional stream argument.
+.codn opthelp ,
+.code opthelp-types
+and
+.code opthelp-conventions
+methods take an optional stream argument.
Note: to encode the option names
.str "t"
@@ -57608,7 +73379,7 @@ or option names which clash with the slot names
.code in-args
and
.code out-args
-or the methods
+or the method names such as
.code getopts
or
.codn opthelp ,
@@ -57640,30 +73411,49 @@ The place form of
.code errno
does not take an argument.
+.coNP Function @ strerror
+.synb
+.mets (strerror << errno-value )
+.syne
+.desc
+The
+.code strerror
+returns a character string which provides the host platform's description
+of the integer
+.meta errno-value
+obtained from the
+.code errno
+function.
+
+If the host platform fails to provide a description, the function returns
+.codn nil .
+
.coNP Function @ exit
.synb
-.mets (exit << status )
+.mets (exit <> [ status ])
.syne
.desc
The
.code exit
function terminates the entire process (running \*(TX image), specifying
-the termination status to the operating system. Values of
+the termination status to the operating system. Values of the optional
.meta status
-may be
+parameter may be
.codn nil ,
.codn t ,
or an integer value. The value
.code nil
-corresponds to the C constant
-.codn EXIT_FAILURE ,
-and
+indicates an unsuccessful termination status, whereas
.code t
-corresponds to
-.codn EXIT_SUCCESS .
-These are platform-independent
-indicators of failed or successful termination. The numeric value 0 also
-indicates success.
+indicates a successful termination status.
+An absence of the
+.meta status
+argument also specifies a successful termination status.
+If
+.meta status
+is an integer value, it specifies a successful termination if it is
+.codn 0 ,
+otherwise the interpretation of the value is platform-specific.
.coNP Variables @, e2big @, eacces @, eaddrinuse @, eaddrnotavail @, eafnosupport @, eagain @, ealready @, ebadf @, ebadmsg @, ebusy @, ecanceled @, echild @, econnaborted @, econnrefused @, econnreset @, edeadlk @, edestaddrreq @, edom @, edquot @, eexist @, efault @, efbig @, ehostunreach @, eidrm @, eilseq @, einprogress @, eintr @, einval @, eio @, eisconn @, eisdir @, eloop @, emfile @, emlink @, emsgsize @, emultihop @, enametoolong @, enetdown @, enetreset @, enetunreach @, enfile @, enobufs @, enodata @, enodev @, enoent @, enoexec @, enolck @, enolink @, enomem @, enomsg @, enoprotoopt @, enospc @, enosr @, enostr @, enosys @, enotconn @, enotdir @, enotempty @, enotrecoverable @, enotsock @, enotsup @, enotty @, enxio @, eopnotsupp @, eoverflow @, eownerdead @, eperm @, epipe @, eproto @, eprotonosupport @, eprototype @, erange @, erofs @, espipe @, esrch @, estale @, etime @, etimedout @, etxtbsy @ ewouldblock and @ exdev
.desc
@@ -57809,17 +73599,30 @@ instead of
.coNP Function @ chdir
.synb
-.mets (chdir << path )
+.mets (chdir >> { path | < stream | << fd })
.syne
.desc
.code chdir
-changes the current working directory to
-.metn path ,
-and returns
-.metn t ,
+changes the current working directory to the object specified
+by the argument, and returns
+.codn t ,
or else throws an exception of type
.codn file-error .
+If the argument is a string, it is interpreted as a
+.metn path ,
+in which case the POSIX
+.code chdir
+function is used. If the argument is a
+.meta stream
+then an integer file descriptor is retrieved from that stream using the
+.code fileno
+function. That descriptor can be specified directly as a
+.meta fd
+argument. In the case of these these two argument types, the
+.code fchdir
+function is used.
+
.coNP Function @ pwd
.synb
.mets (pwd)
@@ -57846,7 +73649,7 @@ The
function removes the directory named by
.codn path .
If successful, it returns
-.metn t ,
+.codn t ,
otherwise it throws an exception of type
.codn file-error .
@@ -57972,7 +73775,7 @@ support a pair of arguments
.meti -c < command
.onom
to specify the command to be executed. On MS Windows, the interpreter
-is assumed to be the relative path name
+is assumed to be the relative pathname
.code cmd.exe
and expected to support
.mono
@@ -57980,6 +73783,100 @@ and expected to support
.onom
as a way of specifying a command to execute.
+.coNP Functions @, sh-esc @, sh-esc-all @ sh-esc-dq and @ sh-esc-sq
+.synb
+.mets (sh-esc << str )
+.mets (sh-esc-all << str )
+.mets (sh-esc-dq << str )
+.mets (sh-esc-sq << str )
+.syne
+.desc
+The functions
+.codn sh-esc ,
+.codn sh-esc-all ,
+.code sh-esc-dq
+and
+.code sh-esc-sq
+transform the argument string
+.code str
+for safe insertion into commands. These functions are intended
+for use on POSIX systems, where the
+command interpreter used by the functions
+.code sh
+and
+.code open-command
+and related functions is the POSIX Shell Command Language.
+
+The
+.code sh-esc
+function adds quoting and escaping into its argument in such a way that the
+resulting string may be inserted as an argument into a command.
+
+The
+.code sh-esc-all
+function performs a stricter escaping and quoting, such that the transformed
+string may be inserted into any syntactic context where a textual operand is
+required for any reason, such as the
+.meta pattern
+in the
+.mono
+.meti <2> ${ var % pattern }
+.onom
+construct.
+
+The
+.code sh-esc-dq
+function escapes its argument for insertion into a double-quoted field in a
+shell command line. It does not add the double quotes themselves.
+
+The
+.code sh-esc-dq
+function escapes its argument for insertion into a single-quoted field in a
+shell command line. It does not add the single quotes themselves.
+
+The precise set of characters which, according to the
+.code sh-esc
+function, require escaping or quoting, is the following:
+
+.verb
+ | & ; < > ( ) $ ` \e " ' tab newline space * ? [ # ~
+.brev
+
+If none of these characters occur in
+.metn str ,
+then
+.code sh-esc
+returns
+.metn str .
+
+The
+.code sh-esc-all
+function considers all the above characters, and also these:
+
+.verb
+ = %
+.brev
+
+The
+.code sh-esc-dq
+function escapes the following characters by preceding them with
+the \e (backslash) character:
+
+.verb
+ $ ` \e "
+.brev
+
+The
+.code sh-esc-sq
+function replaces every occurrence of the
+.code '
+character (single quote, apostrophe) with the sequence
+.code '\e''
+(single quote, backslash, single quotes, single quote).
+This sequence has the effect of terminating the enclosing single-quoted
+field, then producing a single quote via a backslash escape,
+and then opening a single-quoted field.
+
.SS* Unix Filesystem Manipulation
.coNP Structure @ stat
@@ -58040,9 +73937,9 @@ fields take on values of zero.
.coNP Functions @, stat @ lstat and @ fstat
.synb
-.mets (stat > { path | < stream | << fd })
+.mets (stat >> { path | < stream | << fd } <> [ struct ])
.mets (lstat << path )
-.mets (fstat > { path | stream | << fd })
+.mets (fstat >> { path | < stream | << fd } <> [ struct ])
.syne
.desc
The
@@ -58065,9 +73962,22 @@ is thrown.
If the object is not found or cannot be
accessed, an exception is thrown.
-Otherwise, information is retrieved and returned, in the form
-of a structure of type
+
+Otherwise, if the
+.meta struct
+argument is missing, information is retrieved and returned, in the form of a
+new structure of type
.codn stat .
+If the
+.meta struct
+argument is present, it must be either: an instance of the
+.code struct
+structure type, or of a type derived from that type by inheritance, or
+else structure type which has all the same slots as the
+.code struct
+type. The retrieved information is stored into
+.meta struct
+and that object is returned rather than a new object.
If
.meta path
@@ -58118,7 +74028,7 @@ or
.meta fd
arguments.
-.coNP Variables @, s-ifmt @, s-iflnk @, s-ifreg @, s-ifblk ... , @ s-ixoth
+.coNP Variables @, s-ifmt @, s-iflnk @, s-ifreg @, s-ifblk ..., @ s-ixoth
.desc
The following variables exist, having integer values. These are bitmasks
which can be applied against the value given by the
@@ -58475,7 +74385,7 @@ argument.
The difference between the two functions is that if
.meta target
-is the path name of a symbolic link, then
+is the pathname of a symbolic link, then
.code lutimes
operates on the symbolic link itself, whereas
.code utimes
@@ -58492,7 +74402,7 @@ relied on, with some reductions in functionality, that are documented below.
The
.meta target
argument specifies the file to operate on. It may be an integer file descriptor,
-an open stream, or a character string representing a path name.
+an open stream, or a character string representing a pathname.
The
.meta atime-s
@@ -58642,10 +74552,11 @@ of the
.code s-ififo
type and the permission mode bits.
-.coNP Functions @ symlink and @ link
+.coNP Functions @, symlink @ link and @ rlink
.synb
.mets (symlink < target << path )
.mets (link < target << path )
+.mets (rlink < target << path )
.syne
.desc
The
@@ -58658,13 +74569,28 @@ are the absolute or relative path
.meta target
does not actually have to exist.
-The link function creates a hard link. The object at
+The
+.code link
+function creates a hard link. The object at
.meta target
is installed
into the filesystem at
.meta path
also.
+The
+.code rlink
+function is like
+.code link
+except that if
+.meta target
+is a symbolic link, it is resolved, and the link is made to the
+resulting object.
+On Linux, and some other platforms
+.code link
+will create a hard link to the symbolic link. The behavior is not specified by
+POSIX.
+
If these functions succeed, they return
.codn t .
Otherwise they throw an exception
@@ -58698,8 +74624,8 @@ by expanding all symbolic links, removes all superfluous
.str ".."
and
.str "."
-path components, and extra path-separating slash characters,
-to produce a canonical absolute path name.
+path components, and extra component-separating slash characters,
+to produce a canonical absolute pathname.
If the underlying POSIX function indicates failure, then
.code nil
@@ -58731,11 +74657,11 @@ Both paths are opened using
.code open-file
in binary mode, as if using
.mono
-.meti (open-file < from-path "b")
+.meti (open-file < from-path \(dqb\(dq)
.onom
and
.mono
-.meti (open-file < to-path "wb")
+.meti (open-file < to-path \(dqwb\(dq)
.onom
respectively. Then bytes are read from one stream and written to the other,
in blocks which whose size is a power of two at least as large as 16834.
@@ -58771,7 +74697,7 @@ into the target directory whose path is given by
The target directory must exist.
-For source each path in
+For each source path in
.metn from-list ,
the
.code copy-files
@@ -58823,6 +74749,26 @@ exception.
(file-error (throw 'skip)))
.brev
+.coNP Function @ cat-files
+.synb
+.mets (cat-files < to-path << from-path *)
+.syne
+.desc
+The
+.code cat-files
+function catenates the contents of zero or more files into one file.
+The destination path is specified by
+.metn to-path .
+Regardless of whether there are any
+.meta from-path
+arguments, the file named by
+.meta to-path
+is created, if necessary or else truncated to zero length.
+Then, the files named by each
+.meta from-path
+are traversed in left-to-right order; the contents of each file
+is appended to the destination file.
+
.coNP Function @ copy-path-rec
.synb
.mets (copy-path-rec < from-path < to-path << option *)
@@ -58830,7 +74776,7 @@ exception.
.desc
The
.code copy-path-rec
-function replicates a file system object identified by the path name
+function replicates a file system object identified by the pathname
.metn from-path ,
creating a similar object named
.metn to-path .
@@ -58851,9 +74797,11 @@ Propagate the permissions of all objects under
onto their
.meta to-path
counterparts. In the absence of this option, the copied objects
-receive permissions with are calculated by applying the
+receive the same permissions as a newly created files.
+On POSIX systems this means: readable and writable to the owner,
+group and others, by default, subject to the
.code umask
-of the calling process to the maximally liberal.
+that is in effect.
.IP :times
Propagate the modification and access time stamps of all objects under
.meta from-path
@@ -58904,7 +74852,7 @@ permissions, times, symlinks and ownership are replicated.
.IP
The
.code copy-path-rec
-function creates all necessary path name components required for
+function creates all necessary pathname components required for
.meta to-path
to come into existence, as if by using the
.code ensure-dir
@@ -58933,6 +74881,7 @@ of non-directory object.
If any object is copied to an existing non-directory object,
that target object is removed first, then the copy operation proceeds.
.RE
+.IP
Copying of files takes place similarly as what is described for the
.code copy-file
function.
@@ -58942,7 +74891,7 @@ are copied by creating a new, similar objects at the destination path.
In the case of devices, the major and minor numbers of the copy are
derived from the original, so that the copy refers to the same device.
However, the copy of a socket or a FIFO is effectively a new, different
-endpoint because these objects are identified by their path name.
+endpoint because these objects are identified by their pathname.
Processes using the copy of a socket or a FIFO will not connect to
processes which are working with the original.
@@ -59062,34 +75011,154 @@ and
allowing the caller to retry individual failed operations or skip the objects
on which operations have failed.
-.SS* Unix Filesystem Object Existence, Type and Access Tests
+.coNP Function @ touch
+.synb
+.mets (touch < path <> [ ref-path ])
+.syne
+.desc
+The
+.code touch
+function updates the modification timestamp of the filesystem object
+named by
+.metn path .
+If the object doesn't exist, it is created as a regular file.
-The following functions all accept, as the
+If
+.meta ref-path
+is specified, then the modification timestamp of the object denoted by
.meta path
-argument, either a character string, or a structure returned by the
-.code stat
-or
-.code lstat
-functions.
+is updated to be equivalent to the modification timestamp of
+the object denoted by
+.metn ref-path .
+Otherwise
+.meta ref-path
+being absent, the modification timestamp of
+.meta path
+is set to the current time.
+
+If
+.meta path
+is a symbolic link, it is dereferenced;
+.code touch
+operates on the target of the link.
+
+.coNP Function @ mkdtemp
+.synb
+.mets (mkdtemp << prefix )
+.syne
+.desc
+The
+.code mkdtemp
+function combines the
+.metn prefix ,
+which is a string, with a generated suffix to create a unique directory
+name. The directory is created, and the name is returned.
If the
+.code prefix
+argument ends in with a sequence of one or more
+.code X
+characters, the behavior is unspecified.
+
+Note: this function is implemented using the same-named POSIX function.
+Whereas the POSIX function requires the template to end in a sequence of
+at least six
+.code X
+characters, which are replaced by the generated suffix, the \*(TL function
+handles this detail internally, requiring only the prefix part without those
+characters.
+
+.coNP Function @ mkstemp
+.synb
+.mets (mkstemp < prefix <> [ suffix ])
+.syne
+.desc
+The
+.code mkstemp
+function create a unique file name by adding a generated infix between the
+.meta prefix
+and
+.meta suffix
+strings.
+The file is created, and a stream open in
+.str w+b
+mode for the file is returned.
+
+If either the
+.meta prefix
+or
+.meta suffix
+contain
+.code X
+characters, the behavior is unspecified.
+
+If
+.meta suffix
+is omitted, it defaults to the empty string.
+
+The name of the file is available by interrogating the returned stream's
+.code :name
+property using the function
+.codn stream-get-prop .
+
+Notes: this function is implemented using the POSIX function
+.code mkstemp
+or, if available, using the
+.code mkstemps
+function which is not standardized, but appears in the GNU C Library
+and some other systems. If
+.code mkstemps
+is unavailable, then the suffix functionality is not available: the
+.meta suffix
+argument must either be omitted, or must be an empty string.
+
+Whereas the C library functions require the template to contain a sequence
+at least six
+.code X
+characters, which are replaced by the generated portion, the \*(TL function
+handles this detail internally, requiring no such characters in any of its
+inputs.
+
+.SS* Unix Filesystem Object Existence, Type and Access Tests
+
+Functions in this category perform various tests on the attributes of
+filesystem objects.
+
+The functions all have a
.meta path
-argument is a string, then
+parameter, which accepts three types of arguments. If a character
+string is specified, it denotes a filesystem path to
+be probed for properties such as ownership and permissions.
+The object is probed using the
.code stat
-is used to retrieve information about it, except in the case of
-the
+function except in the case of
.code path-symlink-p
-function, which uses
+which uses
.codn lstat .
-The subsequent test is then based on the result of this call.
-
-If the
-.meta path
-argument is the result of a
+If instead a stream is specified as
+.metn path ,
+then the associated filesystem descriptor is probed for these properties.
+If an integer value is specified, it is treated as a POSIX
+open file descriptor that is to be probed.
+Otherwise, a
+.code stat
+structure, for example one returned by the
.code stat
or
.code lstat
-call, then the testing is based on that object.
+function may be specified, in which case no system object
+is probed. The properties to be tested are those given in the
+.code stat
+object.
+
+Note: in a situation when it is necessary to use any of these functions to
+probe the properties of a symbolic link itself (other than the function
+.code path-symlink-p
+which does so implicitly) it is necessary to first invoke
+.code lstat
+on the symlink's path, and then pass the resulting
+.code stat
+structure to that function instead of the path.
Some of the accessibility tests (functions which determine whether the
calling process has certain access rights) may not be perfectly accurate, since
@@ -59097,12 +75166,29 @@ they are based strictly on portable information available via
.codn stat ,
together with the basic, portable POSIX APIs for inquiring about
security credentials, such as
-.codn geteuid .
+.codn getuid .
They ignoring any special permissions which may exist such as operating system
and file system specific extended attributes (for example, file immutability
connected to a "secure level" and such) and special process capabilities
not reflected in the basic credentials.
+With the exception of two functions, the accessibility tests use the real
+credentials of the caller, rather than the effective credentials. Thus, in a
+setuid process, where the real and effective privileges are different, the
+access tests inquire about whether the real user has the given access, not the
+effective user. In this aspect, the functions are similar to the POSIX
+.code access
+function which also uses real credentials.
+The functions
+.code path-private-to-me-p
+and
+.code path-strictly-private-to-me-p
+use effective credentials, because they answer a different question:
+can the given filesystem object be trusted? The trust has to be determined
+from the point of view of the effective user, because security-sensitive
+actions are being performed in their context; and the effective user
+does not trust the real user.
+
.coNP Function @ path-exists-p
.synb
.mets (path-exists-p << path )
@@ -59227,14 +75313,14 @@ exists and has the "sticky" permission bit set.
tests whether
.meta path
exists, and is effectively owned by the calling process; that is,
-it has a user ID equal to the effective user ID of the process.
+it has a user ID equal to the real user ID of the process.
.code path-my-group-p
tests whether
.meta path
exists, and is effectively owned by a group to which the calling process
belongs. This means that the group owner is either the same as the
-effective group ID of the calling process, or else is among the
+real group ID of the calling process, or else is among the
supplementary group IDs of the calling process.
.coNP Function @ path-readable-to-me-p
@@ -59246,8 +75332,8 @@ supplementary group IDs of the calling process.
tests whether the calling process can read the
object named by
.metn path .
-If necessary, this test examines the effective user ID of the
-calling process, the effective group ID, and the list of supplementary groups.
+If necessary, this test examines the real user ID of the
+calling process, the real group ID, and the list of supplementary groups.
.coNP Function @ path-writable-to-me-p
.synb
@@ -59258,8 +75344,8 @@ calling process, the effective group ID, and the list of supplementary groups.
tests whether the calling process can write the
object named by
.metn path .
-If necessary, this test examines the effective user ID of the
-calling process, the effective group ID, and the list of supplementary groups.
+If necessary, this test examines the real user ID of the
+calling process, the real group ID, and the list of supplementary groups.
.coNP Function @ path-read-writable-to-me-p
.synb
@@ -59270,8 +75356,8 @@ calling process, the effective group ID, and the list of supplementary groups.
tests whether the calling process can both read and write the
object named by
.metn path .
-If necessary, this test examines the effective user ID of the
-calling process, the effective group ID, and the list of supplementary groups.
+If necessary, this test examines the real user ID of the
+calling process, the real group ID, and the list of supplementary groups.
.coNP Function @ path-executable-to-me-p
.synb
@@ -59284,8 +75370,8 @@ object named by
.metn path ,
or perform a search (name lookup, not implying sequential readability) on it,
if it is a directory.
-If necessary, this test examines the effective user ID of the
-calling process, the effective group ID, and the list of supplementary groups.
+If necessary, this test examines the real user ID of the
+calling process, the real group ID, and the list of supplementary groups.
.coNP Functions @ path-private-to-me-p and @ path-strictly-private-to-me-p
.synb
@@ -59338,28 +75424,49 @@ only the caller as a member. But by the time the file is subsequently accessed,
the group might have been innocently extended by the system administrator to
include additional users, who can maliciously modify the file.
-Also note that the function is vulnerable to a time-of-check to time-of-use
-race if
-.meta path
-is a string rather than a
-.code stat
-structure. If any components of the
-.meta path
-are symbolic links or directories that can be manipulated by other
-users, then the object named by
-.meta path
-file can pass the check, but can later
+Another issue is that if any components of
.meta path
-can be subverted to refer to a different object.
+can be subverted by another user, test may not be trusted. It becomes
+vulnerable to a time-of-check to time-of-use race condition.
-One way to guard against this race is to open the file, then use
-.code fstat
-on the stream to obtain a
-.code stat
-structure which is then used as an argument to
-.code path-private-to-me-p
-or
-.codn path-strictly-private-to-me-p .
+The function
+.code path-components-safe
+function is provided to perform a security check on an entire path.
+
+.coNP Function @ path-components-safe
+.synb
+.mets (path-components-safe << path )
+.syne
+.desc
+On Unix platforms, the
+.code path-components-safe
+performs a security check on an entire relative or absolute
+.metn path ,
+returning
+.code t
+if the entire path is examined without encountering an error, and
+the check passes, otherwise
+.codn nil .
+On native Microsoft Windows, the function unconditionally returns true.
+
+An exception may be thrown if an an inaccessible or nonexistent path
+component is encountered, too many symbolic links have to be resolved
+or there is some other problem preventing the traversal of
+.metn path .
+
+The objective of this function is to determine that every portion of
+.code path
+is writable only to the effective user: that if the path is used for
+filesystem access, its meaning cannot be altered by an adversarial
+user who is able to control a symbolic link or a directory component.
+
+The function expands symbolic links on its own, one level at a time,
+and walks the components coming from a link target.
+
+Note: directories which are owned by root, and have the sticky bit, as
+is the usual configuration of
+.code tmp
+are considered safe, even though multiple users have write permissions.
.coNP Functions @ path-newer and @ path-older
.synb
@@ -59388,7 +75495,7 @@ with the arguments reversed.
Note:
.code path-newer
-takes advantage of sub-second timestamp resolution information,
+takes advantage of subsecond timestamp resolution information,
if available. The implementation is based on using the
.code mtime-nsec
field of the
@@ -59412,6 +75519,82 @@ and
resolve to the same filesystem object: the same inode number on the same
device.
+.coNP Function @ path-search
+.synb
+.mets (path-search < name <> [ search-path ])
+.syne
+.desc
+The
+.code path-search
+function searches for the existence of a filesystem object named by
+.meta name
+in the directories specified
+.metn search-path .
+
+If
+.meta name
+is the empty string or one of the two strings
+.str .
+(dot)
+or
+.str ..
+(dotdot),
+then
+.code nil
+is returned. If
+.meta name
+contains any path separator characters (any of the set of characters
+found in the
+.code path-sep-chars
+string) then the function returns
+.meta name
+without performing any search. In all these trivial cases, the
+.meta search-path
+argument is ignored.
+
+The
+.meta search-path
+argument, if present, may be a string or a list of strings.
+If omitted, then it takes on the value of the
+.code PATH
+environment variable if that variable exists, or else takes on
+the value
+.code nil
+indicating an empty search path.
+
+If
+.meta search-path
+is a string, it is converted to a list of directories by splitting on the
+separator character, which may be
+.code :
+(colon)
+or
+.code ;
+(semicolon) depending on the system. Then, for each directory in the list,
+.code path-search
+affixes the
+.meta name
+to that component, as if using the
+.code path-cat
+function, and tests whether the resulting path refers to an existing filesystem
+object.
+If so, then the search terminates and that resulting path is returned.
+If the entire list is traversed without finding a filesystem object, then
+.code nil
+is returned.
+If any error whatsoever occurs while determining whether the resulting path
+exists, the situation is treated as nonexistence, and the search continues.
+
+Note: subtle discrepancies may exist between
+.code path-search
+and the host platform's mechanisms for searching for an executable program.
+For instance, since
+.code path-search
+is interested in existence only, it may return a path which exists, but is
+not executable. Whereas a path searching implementation which tests for
+executability will in that case continue searching, and not return that
+path.
+
.SS* Unix Credentials
.coNP Functions @, getuid @, geteuid @ getgid and @ getegid
@@ -59696,15 +75879,32 @@ platform function. The hash value is assumed to be UTF-8 and converted to
Unicode characters, though it is not expected to contain anything but 7
bit ASCII characters.
-Note: the underlying C library function uses a static buffer for its return
-value. The return value of the \*(TL function is a copy of that buffer.
+Note: if C library function
+.code crypt
+uses a static buffer for its return value. If that function is used,
+the Lisp string returned by the \*(TL function carries its own copy of
+that buffer. Where available, the
+.code crypt_r
+function is used which avoids static storage.
+
+Implementations of the C function vary in their error reporting.
+Some implementations return a null pointer for invalid salts,
+whereas others return valid "error token" strings which vary
+between implementations. To work consistently across numerous
+implementations, the \*(TL
+.code crypt
+function throws an
+.code error
+exception if the C library function returns either a null pointer,
+or a valid pointer to a string that is less than 13 characters long,
+regardless of its content.
.SS* Unix Signal Handling
On platforms where certain advanced features of POSIX signal handling are
available at the C API level, \*(TX exposes signal-handling functionality.
-A \*(TX program can install a \*(TL function (such as an anonymous.
+A \*(TX program can install a \*(TL function (such as an anonymous
.codn lambda ,
or the function object associated with a named function) as the handler for
a signal.
@@ -59910,6 +76110,16 @@ The return value is
if the function succeeds, otherwise
.codn nil .
+.coNP Function @ strsignal
+.synb
+.mets (strsignal << signal )
+.syne
+.desc
+The
+.code strsignal
+function returns a character string describing the specified signal number.
+It is based on the same-named POSIX C library function.
+
.SS* Unix Processes
.coNP Functions @ fork and @ wait
@@ -60081,7 +76291,7 @@ argument is treated exactly like that of the
.code exit
function. Unlike that function, this one exits the process immediately,
cleaning up only low-level operating system resources such as closing file
-descriptors and releasing memory mappings, without performing user-space
+descriptors and releasing memory mappings, without performing userspace
cleanup.
.code exit*
@@ -60102,7 +76312,7 @@ and
.coNP Function @ daemon
.synb
-.mets (daemon < nochdir-p << noclose-p )
+.mets (daemon < nochdir << noclose )
.syne
.desc
This is a wrapper for the function
@@ -60117,16 +76327,22 @@ otherwise, and the
.code errno
variable is set in that case.
+Unlike in the underlying same-named platform function, the
+.meta nochdir
+and
+.meta noclose
+arguments are Boolean, rather than integer values.
+
.SS* Unix File Descriptors
.coNP Function @ open-fileno
.synb
-.mets (open-fileno < file-descriptor <> [ mode-string ])
+.mets (open-fileno < file-descriptor >> [ mode-string <> [ pid ]])
.syne
.desc
The
.code open-fileno
-function creates a \*(TX stream over a file descriptor. The
+function creates and returns a \*(TX stream over a file descriptor. The
.meta file-descriptor
argument must be an integer denoting a valid file descriptor.
@@ -60136,6 +76352,16 @@ see the
.code open-file
function.
+If the
+.meta pid
+argument is present, it must be a positive integer corresponding
+to a process ID. The
+.code open-fileno
+function will associate the process ID with the returned stream.
+When the stream is closed with
+.codn close-stream ,
+special handling takes place, as documented for that function.
+
.coNP Function @ fileno
.synb
.mets (fileno << stream )
@@ -60175,7 +76401,7 @@ when called with one or two arguments, respectively.
The
.code pipe
function, if successful, returns a pair of integer file descriptors
-as a cons cell pair. The descriptor in the
+as a cons-cell pair. The descriptor in the
.code car
field of the pair is the read end of the pipe.
The
@@ -60187,7 +76413,7 @@ If the function fails, it throws an exception of type
.coNP Function @ close
.synb
-.mets (close < fileno <> [ throw-on-error-p ])
+.mets (close < fileno <> [ throw-on-error-p ])
.syne
.desc
The
@@ -60219,7 +76445,7 @@ for specified events. It is a wrapper for the same-named POSIX function.
The
.meta poll-list
-argument is a list of
+argument is a sequence of
.code cons
pairs. The
.code car
@@ -60258,6 +76484,39 @@ only entries which polled positive. The
.code cdr
of every pair now holds a bitmask of the events which were to have occurred.
+.coNP Function @ isatty
+.synb
+.mets (isatty << stream )
+.mets (isatty << fileno )
+.syne
+.desc
+The
+.code isatty
+function provides access to the underlying POSIX function of the same name.
+
+If the argument is a
+.meta stream
+object which has a
+.code :fd
+property, then the file descriptor number is retrieved. The behavior is
+then as if that descriptor number were passed as the
+.meta fileno
+argument.
+
+If the argument is not a
+.metn stream ,
+it must be a
+.metn fileno :
+an integer in the representation range of the C type
+.codn int .
+
+The POSIX
+.code isatty
+is invoked on this integer. If it that returns 1, then
+.code t
+is returned, otherwise
+.codn nil .
+
.SS* Unix File Control
.coNP Variables @, o-accmode @, o-rdonly @, o-wronly @, o-rdwr @, o-creat @, o-noctty @, o-trunc @, o-append @, o-nonblock @, o-sync @, o-async @, o-directory @, o-nofollow @, o-cloexec @, o-direct @ o-noatime and @ o-path
@@ -60511,7 +76770,7 @@ See notes about
in the documentation for
.codn log-authpriv .
-.coNP Special variables @, log-user @, log-daemon @ log-auth and @ log-authpriv
+.coNP Special Variables @, log-user @, log-daemon @ log-auth and @ log-authpriv
.desc
These variables take on the values of the corresponding C preprocessor
constants from the
@@ -60552,7 +76811,7 @@ These are the integer priority codes specified in the
.code syslog
function.
-.coNP The @ *stdlog* special variable
+.coNP Special Variable @ *stdlog*
.desc
The
.code *stdlog*
@@ -60714,7 +76973,9 @@ header:
.codn GLOB_NOSORT ,
etc.
-These values are passed as the optional second argument of the
+These values are passed as an argument to the optional
+.meta flags
+argument of the
.code glob
function. They are bitmasks and so multiple values can be combined
using the
@@ -60734,23 +76995,93 @@ variables may not be available. They are extensions in the GNU C library
implementation of
.codn glob .
-.coNP Function @ glob
+The standard
+.code GLOB_APPEND
+flag is not represented as a \*(TX variable. The
+.code glob
+function uses it internally when calling the C library function
+multiple times, due to having been given multiple patterns.
+
+.coNP Variable @ glob-xnobrace
+.desc
+This value holds an integer bitmask value that may be given as an argument to
+the optional
+.meta flags
+parameter of the
+.code glob*
+function. It may be used alone, combine with the other
+.code glob
+mask values using the
+.code logior
+function.
+
+If used with
+.codn glob* ,
+it disables brace expansion, which is enabled in
+.code glob*
+by default.
+
+If used with the
+.code glob
+function, it has no effect.
+
+This value is a \*(TL extension; it does not appear in the API of the
+.code glob
+C function.
+
+.coNP Functions @ glob and @ glob*
.synb
-.mets (glob < pattern >> [ flags <> [ errfun ]])
+.mets (glob >> { pattern | << patterns } >> [ flags <> [ errfun ]])
+.mets (glob* >> { pattern | << patterns } >> [ flags <> [ errfun ]])
.syne
.desc
The
.code glob
function is a interface to the Unix function of the same name.
-The
-.meta pattern
-argument must be a string, which holds a glob pattern: a pattern which
-matches zero or more path names, similar to a regular expression.
-The function tries to expand the pattern and return a list of strings
-representing the matching path names in the file system.
+The first argument must either be a single
+.metn pattern ,
+which is a string, or else sequence of strings specifying multiple
+.metn patterns ,
+which are strings.
+Each string is a glob pattern: a pattern which
+matches zero or more pathnames, similar to a regular expression.
+The function tries to expand the patterns and return a list of strings
+representing the matching pathnames in the file system.
If there are no matches, then an empty list is returned.
+The
+.code glob*
+function is a \*(TL extension built on
+.codn glob .
+
+The
+.code glob*
+functions supports a
+.code **
+("double star")
+pattern which matches zero or more path components. The double
+star match is described in detail below.
+
+The
+.code glob*
+function also supports brace expansion, independently of whether or not
+.code glob
+supports brace expansion. Brace expansion is enabled by default in
+.code glob*
+and can be disabled using the
+.code glob-xnobrace
+flag. Brace expansion is described in detail below.
+
+Lastly, the
+.code glob*
+function performs a path-aware sort of the emerging path names that
+is not influenced by locale, whereas the sort performed by
+.code glob
+is influenced by locale, defaulting to a lexicographic sort in the
+.str C
+locale.
+
The optional
.meta flags
argument defaults to zero. If given, it may be a bitwise combination of the
@@ -60758,7 +77089,8 @@ values of the variables
.codn glob-err ,
.codn glob-mark ,
.code glob-nosort
-and others.
+and others. The
+.code glob-append
If the
.meta errfun
@@ -60780,7 +77112,7 @@ an exception or performing a block return.
The
.meta errfun
-may not re-enter the
+may not reenter the
.code glob
function. This situation is detected and diagnosed by an exception.
@@ -60792,12 +77124,183 @@ which surrounds the
.code glob
call. Such an attempt is detected and diagnosed by an exception.
+If a sequence of
+.meta patterns
+is specified instead of a single pattern,
+.code glob
+makes multiple calls to the underlying C library function. The
+second and subsequent calls specify the
+.code GLOB_APPEND
+flag to add the matches to the result. The following equivalence applies:
+
+.verb
+ (glob (list p0 p1 ...) f e) <--> (append (glob p0 f e)
+ (glob p1 f e)
+ ...)
+.brev
+
Details of the semantics of the
.code glob
function, and the meaning of all the
.meta flags
arguments are given in the documentation for the C function.
+The
+.code glob*
+function supports brace expansion, which is enabled by default,
+and can be disabled with
+.codn glob-xnobrace .
+
+On some platforms, such as the GNU C Library, the
+.code glob
+function also supports brace expansion. If available, then the
+.code glob-brace
+variable has a nonzero value and must be included in the
+.meta flags
+argument.
+
+These two brace expansion features are independent; the \*(TL
+.code glob*
+function does not rely on
+.code glob
+for brace expansion, even if it is available.
+
+The brace expansion supported by
+.code glob*
+is a string generation mechanism driven by a syntax which specifies
+comma-separated elements enclosed in braces.
+
+When a single brace expansion appears in a pattern, that pattern turns
+into a list of patterns. There are as many elements in the list
+as there are elements between the braces. Each element replaces the
+braces with a different element from between the braces.
+
+For instance,
+.str x{a,b}y
+denotes the list of strings
+.codn "(\(dqxay\(dq \(dqxby\(dq)" .
+The there are two elements in the list because the braces contain
+two elements. The first string replaces
+.str {a,b}
+with
+.str a
+and the second replaces it with
+.strn b .
+
+When multiple braces occur in a pattern, then all combinations
+(Cartesian product) of the braces is produced.
+
+Braces may also nest. When the element of a brace itself uses braces, then that
+element is subject to brace expansion. The elements which emerge then become
+items of the enclosing brace, as if they were comma-separated elements.
+For instance
+.str x{a,{b,c}y}z
+is equivalent to
+.str x{a,by,cy}z
+which then expands to the three strings
+.strn xaz ,
+.str xbyz
+and
+.strn xcyz .
+
+Braces may be escaped by a backslash to disable their special meaning.
+Likewise, the commas may be escaped by a backslash to preserve their special
+meaning. Brace expansion preserves these backslashes; they appear in the
+resulting patterns, and must be recognized and removed by subsequent
+processing.
+
+When the
+.meta pattern
+arguments of
+.code glob*
+use brace expansion, those arguments produce multiple patterns.
+The order of these patterns is preserved: the patterns are matched
+in that order. For each pattern, the matching path names are sorted,
+unless the
+.code glob-nosort
+flag is in effect.
+
+The
+.code **
+("double star")
+operator recognized by
+.code glob*
+matches zero or more path components. It may be used more than once.
+It cannot be combined with other characters or globbing operators.
+
+It is valid for
+.str **
+to be an entire pattern. This expands the relative path names of
+all files, directories and other objects in the current directory
+and its children.
+
+Otherwise the double star may appear at the start of a pattern if it is
+followed by a slash; at the end of a pattern if it is preceded by a slash,
+or in the middle of a pattern if it is surrounded by two slashes.
+The double star is not recognized in a bracket-enclosed character
+class.
+
+Thus, the following examples all contain one double star:
+
+.verb
+ **
+ foo/**
+ **/bar
+ here/**/there
+.brev
+
+These do not contain a double star; the two asterisks in these
+patterns will be passed to the underlying
+.code glob
+function without being processed as a double star by
+.codn glob* ,
+with unspecified consequences:
+
+.verb
+ foo**
+ **bar
+ here**/there
+ etc/**conf
+ foo[/**/]bar
+.brev
+
+Each double star matches a maximum of ten path components,
+and all of the double stars in a single pattern together do not
+match more than 48 components. Using more than three double
+stars in a pattern is not recommended for performance reasons.
+
+If the double star is followed by a slash, it matches only
+directories.
+
+The
+.code glob*
+function sorts paths in such a way that the slash character
+is ranked lower than all other characters. Thus the path
+.str test/
+sorts before
+.str test-data/
+even though in ASCII and Unicode, the
+.code -
+character has a lower code than the
+.code /
+character.
+
+.TP* Examples:
+
+.verb
+ ;; find all jpg and gif paths under the current directory,
+ ;; (up to ten levels deep).
+ (glob* "**/*.{jpg,gif}")
+
+ ;; find all "2023" directories under the current directory,
+ ;; which have .jpg or .gif files under them, listing those
+ ;; .jpg and .gif paths:
+ (glob* "**/2023/**/*.{jpg,gif}")
+
+ ;; find all "2023" directories under the current directory.
+ (glob* "**/2023/**/")
+.brev
+
.coNP Variables @, fnm-pathname @, fnm-noescape @, fnm-period @, fnm-leading-dir @ fnm-casefold and @ fnm-extmatch
.desc
These variables take on the values of the corresponding C preprocessor
@@ -60819,10 +77322,11 @@ function.
Note that the
.codn fnm-leading-dir ,
-.code fnm-case-fold
+.code fnm-casefold
and
.code fnm-extmatch
-may not be available. They are GNU extensions, found in the GNU C library.
+functions may not be available.
+They are GNU extensions, found in the GNU C library.
.coNP Function @ fnmatch
.synb
@@ -60835,7 +77339,7 @@ function, if available, provides access
to the like-named POSIX C library function.
The
.meta pattern
-argument specifies a POSIX-shell-style file pattern matching expression.
+argument specifies a POSIX-shell-style filename-pattern-matching expression.
Its exact features and dialect are controlled by
.metn flags .
If
@@ -60858,6 +77362,15 @@ the form of the analogous Lisp function
.codn ftw ,
accompanied by some numeric constants.
+Likewise, on platforms where the POSIX functions
+.code opendir
+and
+.code readdir
+are available, \*(TX provides the functionality in the form of same-named
+Lisp functions, a structure type named
+.code dirent
+and some accompanying numeric constants.
+
.coNP Variables @, ftw-phys @, ftw-mount @, ftw-chdir @ ftw-depth and @ ftw-actionretval
.desc
These variables hold numeric values that may be combined into a single
@@ -60869,10 +77382,10 @@ argument of the
.code ftw
function.
-These variables corresponds to the C constants
+These variables correspond to the C constants
.codn FTW_PHYS ,
.codn FTW_MOUNT ,
-.IR "et cetera" .
+etc.
Note that
.code ftw-actionretval
@@ -60893,7 +77406,7 @@ error condition encountered.
These variables correspond to the C constants
.codn FTW_F ,
.codn FTW_D ,
-.IR "et cetera" .
+etc.
Not all of them are present. If the underlying platform doesn't have
a given constant, then the corresponding variable doesn't exist in \*(TX.
@@ -60917,7 +77430,7 @@ the search and nonzero to stop.
These variables correspond to the C constants
.codn FTW_CONTINUE ,
.codn FTW_STOP ,
-.IR "et cetera" .
+etc.
.coNP Function @ ftw
.synb
@@ -60938,13 +77451,26 @@ and
arguments are reversed with respect to the C language interface.
They are both optional;
.meta flags
-defaults to zero, and
+defaults to the value of
+.code ftw-phys
+and
.meta nopenfd
defaults to 20.
+If an argument is given to
+.metn flags ,
+then the presence of the
+.code ftw-phys
+is no longer implied; the flag must be explicitly
+included in the argument in order to be present.
+
+Compatibility Note: the
+.meta flags
+parameter defaults to an argument value of zero in \*(TX
+versions 283 or lower.
The
.meta path-or-list
-argument may be a string specifying the top-level path name that
+argument may be a string specifying the top-level pathname that
.code ftw
shall visit. Or else,
.meta path-or-list
@@ -61114,7 +77640,7 @@ an exception or performing a block return.
The
.meta callbackfun
-may not re-enter the
+may not reenter the
.code ftw
function. This situation is detected and diagnosed by an exception.
@@ -61126,6 +77652,262 @@ which surrounds the
.code ftw
call. Such an attempt is detected and diagnosed by an exception.
+.coNP Structure @ dirent
+.synb
+.mets (defstruct dirent nil
+.mets \ \ name ino type)
+.syne
+.desc
+Objects of the
+.code dirent
+structure type are returned by the
+.code readdir
+function.
+
+The
+.code name
+slot is a character string giving the name of the directory entry.
+If the
+.code opendir
+function's
+.meta prefix-p
+argument is specified as true,
+then
+.code readdir
+operations produce
+.code dirent
+structures whose
+.code name
+slot is a path formed by combining the directory path with the directory
+entry name.
+
+The
+.code ino
+slot is an integer giving the inode number of the object named by the
+directory entry.
+
+The
+.code type
+slot indicates the type of the object, which is an integer code. Support for
+this member is platform-dependent. If the directory traversal doesn't provide
+the information, then this slot takes on the
+.code nil
+value. In this situation, the
+.code dirstat
+function may be used to backfill the missing information.
+
+.coNP Variables @, dt-blk @, dt-chr @, dt-dir @, dt-fifo @, dt-lnk @, dt-reg @ dt-sock and @ dt-unknown
+.desc
+These variables give the possible type code values exhibited by the
+.code type
+slot of the
+.code dirent
+structure.
+
+If the underlying host platform does not feature a
+.code d_type
+field in the
+.code dirent
+C structure, then almost all these variables are defined anyway using the values that they
+have on GNU/Linux.
+These definitions are useful in conjunction with the
+.code dirstat
+function below.
+
+If the host platform does does not feature a
+.code d_type
+field in the
+.code dirent
+structure, then the variable
+.code dt-unknown
+is not defined. Note: the application can take advantage of this this to detect
+the situation, in order to conditionally define code in such a way that some
+run-time checking is avoided.
+
+.coNP Function @ opendir
+.synb
+.mets (opendir < dir-path <> [ prefix-p ])
+.syne
+.desc
+The
+.code opendir
+function initiates a traversal of the directory object named by the
+string argument
+.metn dir-path ,
+which must be the name of a directory. If
+.code opendir
+is not able to open the directory traversal, it throws an exception of type
+.codn system-error .
+Otherwise an object of type
+.code dir
+is returned, which is a directory traversal handle suitable as an argument
+for the
+.code readdir
+function.
+
+If the
+.meta prefix-p
+argument is specified and has a true value, then it indicates that
+the subsequent
+.code readdir
+operations should produce the value of the
+.code name
+slot of the
+.code dirent
+structure by combining
+.meta dir-path
+with the directory entry name using the
+.code path-cat
+function.
+
+.coNP Function @ readdir
+.synb
+.mets (readdir < dir-handle <> [ dirent-struct ])
+.syne
+.desc
+The
+.code readdir
+function returns the next available directory entry from the directory
+traversal controlled by
+.metn dir-handle ,
+which must be a
+.code dir
+object returned by
+.codn opendir .
+
+If no more directory entries remain, then
+.code readdir
+returns
+.codn nil .
+In this situation, the
+.meta dir-handle
+is also closed, as if by a call to
+.codn closedir .
+
+Otherwise, the next available directory entry is returned as a
+structure object of type
+.codn dirent .
+
+The
+.code readdir
+function internally skips and does not report the
+.str .
+(dot)
+and
+.str ..
+(dotdot) directory entries.
+
+If the
+.meta dirent-struct
+argument is specified, then it must be a
+.code dirent
+structure, or one which has all of the required slots.
+In this case,
+.code readdir
+stores values in that structure and returns it. If
+.meta dirent-struct
+is absent, then
+.code readdir
+allocates a fresh
+.code dirent
+structure.
+
+.coNP Function @ closedir
+.synb
+.mets (opendir << dir-handle )
+.syne
+.desc
+The
+.code closedir
+function terminates the directory traversal managed by
+.metn dir-handle ,
+releasing its resources.
+
+If this has already been done before,
+.code closedir
+returns
+.codn nil ,
+otherwise it returns
+.codn t .
+
+Further
+.code readdir
+calls on the same
+.meta dir-handle
+return
+.codn nil .
+
+Note: the
+.code readdir
+function implicitly closes
+.meta dir-handle
+when the handle indicates that no more directory entries remain to be traversed.
+
+.coNP Function @ dirstat
+.synb
+.mets (dirstat < dirent-struct >> [ dir-path <> [ struct ]])
+.syne
+.desc
+The
+.code dirstat
+function invokes
+.code lstat
+on the object represented by the
+.code dirent
+structure
+.metn dirent-struct ,
+sets the
+.code type
+slot of the
+.meta dirent-struct
+accordingly, and then returns the value that
+.code lstat
+returned.
+
+If the
+.meta struct
+argument is specified, it is passed to
+.codn lstat .
+
+The
+.meta dir-path
+parameter must be specified, if the
+.code name
+slot of
+.meta dirent-struct
+is a simple directory entry name, rather than the full path to the object.
+In that case, the slot's value gives the effective path.
+If the
+.code name
+slot is already a path (due to, for instance, a true value of
+.meta prefix-p
+having been passed to
+.codn opendir )
+then
+.meta dir-path
+must not be specified.
+If
+.meta dir-path
+is specified, then its value is combined with the
+.meta name
+slot of
+.meta dirent-struct
+using
+.code path-cat
+to form the effective path.
+
+The
+.code lstat
+function is invoked on the effective path, and if it succeeds,
+then type information is obtained from the resulting
+structure to set the value of the
+.code type
+slot of
+.metn dirent-struct .
+The same structure that was returned by
+.code lstat
+is then returned.
+
.SS* Unix Sockets
On platforms where the underlying system interface is available, \*(TX provides
@@ -61152,7 +77934,7 @@ and
.code sock-shutdown
are used for enacting socket communication scenarios.
-Stream sockets use ordinary streams, re-using the same underlying framework
+Stream sockets use ordinary streams, reusing the same underlying framework
that is used for file I/O and process types.
Datagram socket streams are implemented using special datagram socket streams.
@@ -61272,8 +78054,7 @@ not actually connected to a specific peer. The receive operation could
receive a datagram from any peer, without any indication which peer that is.
Datagram servers should issue a new
.code sock-accept
-call should be issued for each client datagram, treating it as a new
-stream.
+call for each client datagram, treating it as a new stream.
Datagram sockets ignore almost all aspects of the
.meta mode-string
@@ -61304,7 +78085,8 @@ newly created datagram socket which is returned.
.coNP Structure @ sockaddr
.synb
.mets (defstruct sockaddr nil
-.mets \ \ (:static family nil))
+.mets \ canonname
+.mets \ (:static family nil))
.syne
.desc
The
@@ -61316,16 +78098,27 @@ several other types are derived:
and
.codn sockaddr-un .
-It has a single slot called
+It has a single static slot named
.code family
-which is static, and initialized to
+and a single instance slot
+.codn canonname ,
+both initialized to
.codn nil .
+Note: the
+.code canonname
+slot is optionally set by the
+.code getaddrinfo
+function on address structures that it returns, if requested via the
+.code ai-canonname
+flag. The slot only provides information to the application, playing no
+semantic role in addressing.
+
.coNP Structure @ sockaddr-in
.synb
.mets (defstruct sockaddr-in sockaddr
-.mets \ \ (addr 0) (port 0)
-.mets \ \ (:static family af-inet))
+.mets \ (addr 0) (port 0) (prefix 32)
+.mets \ (:static family af-inet))
.syne
.desc
The
@@ -61358,6 +78151,12 @@ function is used with the aim of looking up the address of a host, without
caring about the port number.
The
+.code prefix
+field is set by the function
+.codn inaddr-str ,
+when it recognizes and parses a prefix field in the textual representation.
+
+The
.code family
static slot holds the value
.codn af-inet .
@@ -61365,8 +78164,9 @@ static slot holds the value
.coNP Structure @ sockaddr-in6
.synb
.mets (defstruct sockaddr-in6 sockaddr
-.mets \ \ (addr 0) (port 0) (flow-info 0) (scope-id 0)
-.mets \ \ (:static family af-inet6))
+.mets \ (addr 0) (port 0) (flow-info 0) (scope-id 0)
+.mets \ (prefix 128)
+.mets \ (:static family af-inet6))
.syne
.desc
The
@@ -61400,6 +78200,12 @@ slots of the
C language structure. Their meaning and use are beyond the scope of this document.
The
+.code prefix
+field is set by the function
+.codn in6addr-str ,
+when it recognizes and parses a prefix field in the textual representation.
+
+The
.code family
static slot holds the value
.codn af-inet6 .
@@ -61407,13 +78213,13 @@ static slot holds the value
.coNP Structure @ sockaddr-un
.synb
.mets (defstruct sockaddr-un sockaddr
-.mets \ \ path
-.mets \ \ (:static family af-unix))
+.mets \ path
+.mets \ (:static family af-unix))
.syne
.desc
The
.code sockaddr-un
-address represents a socket address used for inter-process communication
+address represents a socket address used for interprocess communication
within a single operating system node, using the "Unix domain" sockets
of the
.code af-unix
@@ -61485,10 +78291,11 @@ slot holds a bitwise or combination (see the
.code logior
function) of
.code getaddrinfo
-flags: values given by the variables.
+flags: values given by the variables
.codn ai-passive ,
.codn ai-numerichost ,
.codn ai-v4mapped ,
+.codn ai-canonname ,
.codn ai-all ,
.code ai-addrconfig
and
@@ -61498,6 +78305,16 @@ These correspond to the C constants
.code AI_NUMERICHOST
and so forth.
+If
+.code ai-canonname
+is specified, then every returned address structure will have its
+.code canonname
+member set to a string value rather than
+.codn nil .
+This string is a copy of the canonical name reported by the underlying
+C library function, which that function places only into the first
+returned address structure.
+
The
.code family
slot holds an address family, which may be the value of
@@ -61578,7 +78395,7 @@ Address family values are used in the
argument of the
.code getaddrinfo
function, and in the
-.code socket-open
+.code open-socket
function.
Note that unlike the C language socket addressing structures,
the \*(TX socket addresses do not contain an address family slot.
@@ -61659,7 +78476,7 @@ The
.meta family
parameter specifies the address family of the socket. One of the
values
-.codn af-inet ,
+.codn af-unix ,
.code af-inet
or
.code af-inet6
@@ -61690,21 +78507,21 @@ data flow, the default mode string is
rather than the usual
.strn r .
-Rationale for including the
+The rationale for including the
.str b
flag in the default mode string is that network protocols are usually defined
in a way that is independent of machine and operating system, down to the byte
level, even when they are textual. It doesn't make sense for the same \*(TX
program to see a network stream differently based on what platform it is
-running on. Line ending conversion has to do with how a platform locally stores
+running on. Line-ending conversion has to do with how a platform locally stores
text files, whereas network streams are almost always external formats.
-Like other stream types, stream sockets are buffered and marked as no
+Like other stream types, stream sockets are buffered and marked as
non-real-time streams. Specifying the
.str i
mode in
.meta mode-string
-marks a socket as a real-time-stream, and, if it is opened for writing
+marks a socket as a real-time stream, and, if it is opened for writing
or reading and writing, changes it to use line buffering.
.coNP Function @ open-socket-pair
@@ -61855,7 +78672,10 @@ is thrown.
.desc
The
.code sock-bind
-function binds a socket stream to a local address.
+function binds a socket stream to a local address
+after enabling the socket stream's
+.code so-reuseaddr
+option.
The
.meta address
@@ -61868,10 +78688,6 @@ If the operation fails, an exception of type
is thrown. Otherwise, the function returns
.codn t .
-Returns
-.code t
-if successful.
-
.coNP Function @ sock-listen
.synb
.mets (sock-listen < socket <> [ backlog ])
@@ -61913,9 +78729,9 @@ The
.code mode-string
parameter is applied to the new socket just like the
similar argument in
-.codn socket-open .
+.codn open-socket .
It defaults to
-.strn r+ .
+.strn r+b .
If the
.meta timeout-usec
@@ -61952,7 +78768,7 @@ The
.code direction
parameter is one of the values given by the variables
.codn shut-rd ,
-.code shut-rw
+.code shut-wr
or
.codn shut-rdwr .
These values shut down communication in the read direction, write direction,
@@ -62005,6 +78821,185 @@ is thrown when an output operation waits for at least
.code usec
microseconds for the availability of buffer space in the socket.
+.coNP Variables @, sol-socket @, ipproto-ip @, ipproto-ipv6 @ ipproto-tcp and @ ipproto-udp
+.desc
+These variables represent the protocol levels of socket options and are
+suitable for use as the
+.meta level
+argument of the
+.code sock-opt
+and
+.code sock-set-opt
+functions.
+The variables correspond to the POSIX C constants
+.codn SOL_SOCKET ,
+.codn IPPROTO_IP ,
+.codn IPPROTO_IPV6 ,
+.code IPPROTO_TCP
+and
+.codn IPPROTO_UDP .
+
+.coNP Variables @, so-acceptconn @, so-broadcast @, so-debug @, so-dontroute @, so-error @, so-keepalive @, so-linger @, so-oobinline @, so-rcvbuf @, so-rcvlowat @, so-rcvtimeo @, so-reuseaddr @, so-sndbuf @, so-sndlowat @ so-sndtimeo and @ so-type
+.desc
+These variables represent socket options at the
+.code sol-socket
+protocol level and are suitable for use as the
+.meta option
+argument of the
+.code sock-opt
+and
+.code sock-set-opt
+functions.
+The variables correspond to the POSIX C constants
+.codn SO_ACCEPTCONN ,
+.codn SO_BROADCAST ,
+.codn SO_DEBUG ,
+etc.
+
+Note that the
+.code sock-recv-timeout
+and
+.code sock-send-timeout
+are a more convenient interface for setting the value of the
+.code so-rcvtimeo
+and
+.code so-sndtimeo
+socket options.
+
+.coNP Variables @, ipv6-join-group @, ipv6-leave-group @, ipv6-multicast-hops @, ipv6-multicast-if @, ipv6-multicast-loop @ ipv6-unicast-hops and @ ipv6-v6only
+.desc
+These variables represent socket options at the
+.code ipproto-ipv6
+protocol level and are suitable for use as the
+.meta option
+argument of the
+.code sock-opt
+and
+.code sock-set-opt
+functions.
+The variables correspond to the POSIX C constants
+.codn IPV6_JOIN_GROUP ,
+.codn IPV6_LEAVE_GROUP ,
+.codn IPV6_MULTICAST_HOPS ,
+etc.
+
+.coNP Variable @ tcp-nodelay
+.desc
+This variable represents a socket option at the
+.code ipproto-tcp
+protocol level and is suitable for use as the
+.meta option
+argument of the
+.code sock-opt
+and
+.code sock-set-opt
+functions.
+The variable corresponds to the POSIX C constant
+.codn TCP_NODELAY .
+
+.coNP Accessor @ sock-opt
+.synb
+.mets (sock-opt < socket < level < option <> [ ffi-type ])
+.mets (set (sock-opt < socket < level < option <> [ ffi-type ]) << value )
+.syne
+.desc
+The
+.code sock-opt
+function retrieves the value of the specified socket option,
+at the specified protocol level,
+associated with
+.codn socket ,
+which must be a socket stream.
+
+The
+.code level
+argument should be one of the protocol levels
+.codn sol-socket ,
+.codn ipproto-ip ,
+.codn ipproto-ipv6 ,
+.code ipproto-tcp
+and
+.codn ipproto-udp .
+
+The
+.code option
+argument should be one of the socket options
+.codn so-acceptconn ,
+.codn so-broadcast ,
+.codn so-debug ,
+\&...,
+.codn ipv6-join-group ,
+\&...,
+.code ipv6-v6only
+and
+.codn tcp-nodelay .
+
+The
+.meta ffi-type
+argument, which must be a compiled FFI type,
+specifies the type of the socket option's value.
+The type is most commonly
+.code int
+or
+.codn uint ,
+but it can be any other fixed-size type, including
+.codn struct s.
+(Variable-size types, such as C
+.code char
+arrays, are unsupported.)
+The
+.meta ffi-type
+argument defaults to
+.codn "(ffi int)" .
+
+Assigning a value to a
+.code sock-opt
+place is equivalent to calling
+.code sock-set-opt
+with that value.
+
+Note: the
+.code sock-opt
+and
+.code sock-set-opt
+functions call the POSIX C
+.code getsockopt
+and
+.code setsockopt
+functions, respectively.
+Consult the POSIX specification for more information about these
+functions and in particular the various socket options
+(and the types they require).
+
+.coNP Function @ sock-set-opt
+.synb
+.mets (sock-set-opt < socket < level < option < value <> [ ffi-type ])
+.syne
+.desc
+The
+.code sock-set-opt
+function sets the value of the specified socket option,
+at the specified protocol level,
+associated with
+.codn socket ,
+which must be a socket stream.
+
+See the documentation of the
+.code sock-opt
+function for a description of the
+.metn level ,
+.meta option
+and
+.meta ffi-type
+arguments.
+Like the
+.code sock-opt
+function,
+.codn sock-set-opt 's
+.meta ffi-type
+argument defaults to
+.codn "(ffi int)" .
+
.coNP Functions @ str-inaddr and @ str-in6addr
.synb
.mets (str-inaddr address <> [ port ])
@@ -62025,7 +79020,7 @@ in the hybrid notation exemplified by
The
.meta address
-parameter must be a non-negative integer in the appropriate range
+parameter must be a nonnegative integer in the appropriate range
for the address type.
If the
@@ -62073,6 +79068,241 @@ excluding the contiguous all-zero bits in the least significant position:
how many times the address can be shifted to the right before a 1 appears
in the least significant bit.
+.coNP Functions @ inaddr-str and @ in6addr-str
+.synb
+.mets (inaddr-str << string )
+.mets (in6addr-str << string )
+.syne
+.desc
+The
+.code inaddr-str
+and
+.code in6addr-str
+functions recover an IPv4 or IPv6 address from a textual representation.
+If the parse is successful, the address is returned as, respectively, a
+.code sockaddr-in
+or
+.code sockaddr-in6
+structure.
+
+If
+.meta string
+is a malformed address, due to any issue such as invalid syntax or
+a numeric value being out of range, an exception is thrown.
+
+The
+.code inaddr-str
+function recognizes the dot notation consisting of four decimal numbers
+separated by period characters. The numbers must be in the range 0 to 255.
+Note: superfluous leading zeros are permitted, though this is a nonstandard
+extension; not all implementations of this notations support this.
+
+A prefix may be specified in the notation as a slash followed by a decimal
+number, in the range 0 to 32. In this case, the integer value of the
+prefix appears as the
+.code prefix
+member of the returned
+.code sockaddr-in
+structure. Furthermore, the address is masked, so that any bits not
+included in the prefix are zero. For instance, the address
+.str 255.255.255.255/1
+is equivalent to
+.strn 128.0.0.0 ,
+except that the
+.code prefix
+if the returned structure is 1 rather than 32.
+When a prefix is not specified, the
+.code prefix
+member of the structure retains its default value of 32.
+When the prefix is specified, the address part need not contain all four
+octets; it may contain between one and four octets. Thus,
+.str 192.168/16
+is a valid address, equivalent to
+.strn 192.168.0.0/16 .
+
+A port number may be specified in the notation as a colon, followed by a
+decimal number in the range 0 to 65535. The integer value of this port
+number appears as the
+.code port
+member of the returned structure. An example of this notation is
+.strn 127.0.0.1:23 .
+
+A prefix and port number may both be specified; in this case the prefix must
+appear first, followed by the port number. For example,
+.strn "127/8:23" .
+
+The
+.code in6addr-str
+function recognizes the IPv6 notation consisting of 16-bit hexadecimal pieces
+separated by colons. If the operation is successful, it returns a
+.code sockaddr-in6
+structure. Each piece must be a value in the range 0 to FFFF.
+The hexadecimal digits may be any mixture of uppercase and lowercase. Leading
+zeros are permitted.
+Up to eight such pieces must be specified. If fewer pieces are specified,
+then the token
+.code ::
+(double colon)
+must appear in the address exactly once. That token denotes the condensation of
+a sufficient number of zero-valued pieces to make eight pieces.
+The token must be in one of three positions: it may be the leftmost element of
+the address, immediately followed by a hexadecimal piece; it may be the rightmost element
+of the address, preceded by a hexadecimal piece; or else, it may be in the
+middle of the address, flanked on both sides by hexadecimal pieces.
+
+The
+.code in6addr-str
+also recognizes the special notation for IPv6-mapped IPv4 addresses. This
+notation consists of the address string
+.str ::FFFF
+which may appear in any uppercase/lowercase mixture, possibly with leading
+zeros, followed by an IPv4 address given in the four-octet dot notation.
+For example,
+.strn ::FFFF:127.0.0.1 .
+
+A prefix may be specified using a slash, followed by a decimal number in the
+range 0 to 128. The handling of the prefix is similar to that of
+.code inaddr-str
+except that pieces of the address may not be omitted. Condensing the
+pieces of the IPv6 address is always done by means of the
+.code ::
+token, whether or not a prefix is present. Furthermore, the octets specified in
+the IPv6-mapped IPv4 notation must all be present, regardless of the prefix.
+
+A port number may be specified in the notation as follows: the entire address,
+including any slash-separated prefix, must appear surrounded in square
+brackets. The closing square bracket must be followed by a colon and one or
+more digits denoting a decimal number in the range 0 to 65535. For instance
+.strn "[1:2:3::4/64]:1234".
+
+.coNP Function @ sockaddr-str
+.synb
+.mets (sockaddr-str << string )
+.syne
+.desc
+The function
+.code sockaddr-str
+analyzes the
+.meta string
+argument to determine whether it represents a valid IPv4, IPv6 or Unix domain
+address. If so, it constructs an object, representing that address, of type
+.codn sockaddr-in ,
+.code sockaddr-in
+or
+.codn sockaddr-un .
+
+The slash prefix notation, and port numbers are handled, and represented
+in the returned structures accordingly.
+
+The
+.code sockaddr-str
+function works by applying simple tests to the input, and then invoking
+the functions
+.code inaddr-str
+or
+.codn in6addr-str ,
+or constructing a
+.code sockaddr-un
+structure whose
+.code path
+slot is
+.metn string .
+
+The precise procedure followed is:
+.RS
+.IP 1.
+If
+.meta string
+starts with
+.str [
+then it is handled via
+.codn in6addr-str .
+.IP 2.
+If
+.meta string
+starts with
+.str /
+then it is assumed to be the path of a Unix socket.
+A
+.code sockaddr-un
+structure is constructed whose
+.code path
+slot is
+.metn string .
+This is the only case in which a structure of type
+.code sockaddr-un
+is returned.
+.IP 3.
+If
+.meta string
+contains
+.str "::"
+as a substring, it is handled via
+.codn in6addr-str .
+.IP 4.
+If
+.meta string
+contains
+.str .
+then it is handled via
+.codn inaddr-str .
+.IP 5.
+If the above tests fail,
+.meta string
+is passed to
+.codn in6addr-str ,
+and if that call returns normally,
+.code sockaddr-str
+returns that value.
+.IP 6.
+Otherwise,
+.code string
+is passed to
+.codn inaddr-str .
+.RE
+
+.coNP Method @ str-addr
+.synb
+.mets << sockaddr .(str-addr)
+.syne
+.desc
+A method named
+.code str-addr
+is defined for the struct types
+.codn sockaddr-in ,
+.code sockaddr-in6
+and
+.codn sockaddr-un .
+It returns a text representation of the address as a string. If the
+.code port
+slot of
+.code sockaddr-in
+or
+.code sockaddr-in6
+is a nonzero integer, then it is incorporated into the text representation.
+Likewise if the
+.code prefix
+slot has a non-default value specifying fewer bits than the width of
+the address, the prefix notation is produced.
+
+The intent is that the representations produced are suitable as input
+to the
+.code sockaddr-str
+function which will reproducing an address object of the same type,
+featuring the same
+.codn addr ,
+.code port
+and
+.codn prefix .
+In the case of
+.codn sockaddr-un ,
+the
+.code sockaddr-str
+function will reproduce the same address only if the
+.code path
+slot is a string starting with
+.strn / .
+
.SS* Unix Terminal Control
\*(TX provides access to the terminal control "termios" interfaces defined by
@@ -62112,8 +79342,8 @@ values and the speed constants (like
.codn B38400 )
used by the C API.
-All of the various termios-related constants are provided, including some non-standard
-ones. They appear in lower case. For instance
+All of the various termios-related constants are provided, including some nonstandard
+ones. They appear in lowercase. For instance
.code IGNBRK
and
.code PARENB
@@ -62152,7 +79382,7 @@ slots correspond to the
and
.code c_lflag
members of the C structure. They hold integer values representing
-bit fields.
+bitfields.
The
.code cc
@@ -62559,7 +79789,7 @@ function.
.desc
The
.code tcflow
-function provides bi-directional flow control on the
+function provides bidirectional flow control on the
specified terminal device. It is a direct wrapper
for the like-named POSIX C function.
@@ -62736,8 +79966,9 @@ character-at-a-time input. However, most input translations are preserved,
except that the conversion of CR characters to NL is disabled. The
signal-generating characters are processed in this mode. This latter feature of
the configuration is the likely inspiration for the word "cbreak". Unless
-otherwise configured, the interrupt character corresponds to the Ctrl-C key,
-and "break" is another term for an interactive interruption.
+otherwise configured, the interrupt character corresponds to the
+.key Ctrl-C
+key, and "break" is another term for an interactive interruption.
.coNP Methods @ string-encode and @ string-decode
.synb
@@ -62822,6 +80053,623 @@ slot of the returned
structure will have the value
.codn nil .
+.SS* Unix Resource Limits
+
+.coNP Structure @ rlim
+.synb
+.mets (defstruct rlim nil
+.mets \ \ cur max)
+.syne
+.desc
+The
+.code rlim
+structure is required by the functions
+.code getrlimit
+and
+.codn setrlimit .
+It is analogous to the C structure by the same name described in POSIX.
+
+.coNP Variables @, rlim-saved-max @ rlim-saved-cur and @ rlim-infinity
+.desc
+These variables correspond to the POSIX constants
+.codn RLIM_SAVED_MAX ,
+.code RLIM_SAVED_CUR
+and
+.codn RLIM_INFINITY .
+They have the same values, and are suitable as slot values of the
+.code rlim
+structure.
+
+Variables @, rlimit-core @, rlimit-cpu @, rlimit-data @, rlimit-fsize @, rlimit-nofile @ rlimit-stack and @ rlimit-as
+.desc
+These variables correspond to the POSIX constants
+.codn RLIMIT_CORE ,
+.codn RLIMIT_CPU ,
+.code RLIMIT_DATA
+and so forth.
+
+.coNP Functions @ getrlimit and @ setrlimit
+.synb
+.mets (getrlimit < resource <> [ rlim ])
+.mets (setrlimit < resource << rlim )
+.syne
+.desc
+The
+.code getrlimit
+function retrieves information about the limits imposed for a particular parameter indicated by the
+.meta resource
+integer.
+
+The
+.code setrlimit
+function changes the limit information for a resource parameter.
+
+The
+.meta resource
+parameter is the value of one of the variables
+.codn rlimit-core ,
+.codn rlimit-cpu ,
+.code rlimit-data
+and so forth.
+
+The
+.meta rlim
+argument is a structure of type
+.codn rlim .
+If this argument is given to the
+.code getrlimit
+function, then it fills in that structure with the retrieved
+parameters. Otherwise it allocates a new structure and fills
+that one. In either situation, the filled structure is returned,
+if the underlying call to the host operating system is successful.
+
+In the case of
+.codn setrlimit ,
+the
+.code rlim
+object must have non-negative integer values which are in the range
+of the platform's
+.code rlim_t
+type.
+
+If the underlying system call fails, then these functions throw
+an exception. In the successful case, the
+.code getrlimit
+function returns the
+.code rlim
+structure, and
+.code setrlimit
+returns
+.codn t .
+
+Further information about resource limits is available in the POSIX standard
+and platform documentation.
+
+.SS* Unix Memory Mapping
+
+The \*(TL interface to the POSIX
+.code mmap
+family of functions is based around the
+.code carray
+type. The
+.code mmap
+function returns a special variant of a
+.code carray
+object which keeps track of the memory mapping. When such an object
+becomes unreachable and is reclaimed by garbage collection, the mapping
+is automatically unmapped.
+
+In addition to
+.codn mmap ,
+the functions
+.codn munmap ,
+.codn mprotect ,
+.code madvise
+and
+.code msync
+are provided, all taking a
+.code carray
+as their leftmost argument.
+
+The \*(TL functions do not strictly follow the argument conventions of the
+same-named, corresponding POSIX functions. Adjustments which are likely to
+be defaulted are moved to the right.
+For instance, the
+.code msync
+operation is often applied to the entire memory mapping. Therefore,
+the first argument is the
+.code carray
+object which keeps track of the mapping. The second argument specifies
+the flags to be applied, which constitute the last argument of the
+underlying POSIX function.
+The remaining two arguments are the size and offset. If these are omitted,
+then
+.code msync
+applies to the entire region, whose address and size are known to the
+.code carray
+object.
+
+Cautionary note: misuse of
+.code mmap
+and related functions can easily cause the \*(TX image to receive
+a fatal signal due to a bad memory access. Care must be taken to prevent
+such a situation, or else to catch such signals and recover.
+
+.coNP Function @ mmap
+.synb
+.mets (mmap < ffi-type < length < prot < flags
+.mets \ \ \ \ \ >> [ source >> [ offset <> [ addr ]]])
+.syne
+.desc
+The
+.code mmap
+function provides access to the same-named POSIX platform function
+for creating memory mappings. The POSIX function can be used for creating
+virtual memory views of files and special devices. Views can be read-only,
+and they can be mutable. They can be in such a way that changes appear
+only in the mapping itself, or in such a way that the changes are actually
+propagated to the mapped object itself. Mappings can be shared among
+processes, providing a shared memory mechanism: for instance, if
+.code fork
+is called, any
+.code map-shared
+mappings created by the parent are shared with the child: the child
+process does not get a copy of a shared mapping, but a reference to it.
+The function can also be used simply for allocating memory: on some
+platforms, the POSIX
+.code mmap
+function is used as the basis for the
+.code malloc
+function. It behaves as a pure allocator when asked to create a mapping which
+is private, and anonymous (not backed by an object).
+
+The \*(TL
+.code mmap
+function is integrated with the
+.code carray
+type and the FFI type system. A mapping returned by
+.code mmap
+is represented by a
+.code carray
+object.
+
+The required
+.meta ffi-type
+argument specifies the element type of the array; it must be a compiled
+FFI type. Note: this may be produced by the
+.code ffi
+macro. For instance, the type
+.code int
+may be specified using the expression
+.codn "(ffi int)" .
+The type must be a complete type suitable as the element type of an array;
+a type with a zero size such as
+.code void
+is invalid.
+
+The
+.meta length
+argument specifies the requested length of the mapping in bytes. Note that
+.code mmap
+allocates or configures virtual memory pages, not bytes. Internally
+to the system, the
+.meta length
+argument is converted to a number of pages. If it specifies a fractional
+number of pages, it is rounded up. For instance, if the page size is 4096
+bytes, and
+.meta length
+is specified as 5000, it will be internally rounded up to 8192.
+The returned \*(TL
+.code carray
+object is oblivious to this padding: it works with the given 5000-byte size.
+Note: the
+.code page-size
+variable holds the system's page size. However, by the use of
+.code mmap
+extensions, it is possible for individual mappings to have their own page size.
+Mixed page size virtual memory systems exist.
+
+The
+.code mmap
+function determines the number of elements in the array by dividing the
+.meta length
+by the size of
+.metn type ,
+using a division that truncates toward zero. The returned
+.code carray
+shall have that many elements. If the division is inexact, it means that
+some bytes from the underlying memory mapping are unused, even if
+.code length
+is a multiple of the page size.
+
+The required
+.meta prot
+argument must be some bitwise combination of the portable values
+.codn prot-read ,
+.code prot-write
+and
+.codn prot-exec .
+Additional system-specific
+.code prot-
+values may be available also for specifying additional properties. If
+.meta prot
+is specified as zero, then the mapping, if successfully created, may be
+inaccessible:
+.code prot-read
+must be present to ensure read access, and
+.code prot-write
+to ensure write access.
+
+The
+.meta flags
+argument is a bitwise combination of values given by various
+.code map-
+variables. At the very least, it must contain exactly one of
+.code map-shared
+or
+.codn map-private ,
+to request a shared or private mapping, respectively.
+If a mapping is requested which is neither shared nor private,
+the underlying POSIX function will likely fail.
+
+If a
+.meta source
+is specified, indicating a filesystem object to be mapped, the
+.code map-anon
+flag must be omitted. Vice versa, if
+.meta source
+is not specified, this means that the mapping will be anonymous.
+In this situation, the
+.code map-anon
+flag must be present.
+
+The
+.meta source
+argument may be an integer file descriptor. If so, this value
+will be passed to the underlying POSIX function directly.
+The
+.meta source
+argument may be a stream object, in which case the
+.code fileno
+function will be applied to it, which must retrieve an integer
+file descriptor which will be passed to the POSIX function.
+The
+.meta source
+argument may be a filename. The specified file is opened as if via
+.codn open-file ,
+with a
+.meta mode-string
+which is
+.str "r+"
+if the
+.meta prot
+argument includes the
+.code prot-write
+flag, otherwise
+.strn "r" .
+The integer file descriptor from this open stream is used in the underlying
+.code mmap
+call. The file is immediately closed when
+.code mmap
+returns. In all cases, the integer file descriptor passed to the POSIX
+function must be a value suitable for conversion to the
+.code int
+type.
+
+Note: in the context of
+.codn mmap ,
+"anonymous" means "not associated with a filesystem object referenced by a
+descriptor". It does not mean "without a name", but refers to a pure memory
+allocation from virtual memory. Memory maps do not have a name, whether
+anonymous or not. Moreover, the filesystem object associated with a memory map
+itself does not necessarily have a name. An open file that has been deleted
+from the directory structure is anonymous, yet a memory mapping can be created
+using its descriptor, and that mapping is not "anonymous".
+
+The
+.meta offset
+argument is used with a non-anonymous mapping. It specifies that the mapping
+doesn't begin at the start of the file or file-like object, but rather at
+the specified offset. The offset may not be an arbitrary integer; it must be
+a multiple of the page size. Unless certain nonportable
+.meta flags
+are used to specify an alternative page size, the value of the
+.code page-size
+variable may be relied upon to indicate the page size. If an
+.meta offset
+is specified for an anonymous mapping, with a nonzero value, the
+underlying POSIX function may indicate failure.
+
+If the
+.meta length
+and
+.meta offset
+values cause one or more pages to be mapped which are beyond the end of the
+file, then accessing those pages may produce a signal which is fatal if
+not handled.
+
+The
+.meta addr
+argument is used for specifying the address in conjunction with the
+.code map-fixed
+flag. Possibly, certain nonportable values in the
+.meta flags
+argument may similarly require
+.metn addr .
+If no bit is present in
+.meta flags
+which requires
+.metn addr ,
+then
+.meta addr
+should either not be specified, or specified as zero.
+A nonzero value of
+.meta addr
+must be a multiple of the page size.
+
+The
+.code mmap
+function returns a
+.code carray
+object if successful. Upon failure, an exception derived from
+.code error
+is thrown.
+
+Note: when a
+.code carray
+object returned by
+.code mmap
+is identified by the garbage collector as unreachable, and reclaimed,
+the memory mapping is unmapped. The
+.code munmap
+function can be invoked on the
+.code carray
+to release the mapping before the object becomes garbage. The
+.code carray-free
+function cannot be used on a mapped
+.codn carray .
+
+.coNP Function @ munmap
+.synb
+.mets (munmap << carray )
+.syne
+.desc
+The
+.code munmap
+function releases the memory mapping tracked by
+.metn carray ,
+which must be an object previously returned by
+.codn mmap .
+An exception is thrown if the object is any other kind of
+.codn carray .
+
+Note: the memory mapping is released by means of the same-named POSIX function.
+No provision is made for selectively unmapping the pages of a mapping;
+the entire mapping associated with a
+.meta carray
+is removed.
+
+When the memory mapping is released,
+.code munmap
+returns
+.codn t .
+Thereafter, the
+.metn carray 's
+contents may no longer be accessed, subject to
+.code error
+exceptions being thrown.
+
+If
+.code munmap
+is called again on a
+.code carray
+on which it had previously been successfully called, the additional calls
+return
+.codn nil .
+
+.coNP Functions @, mprotect @ madvise and @ msync
+.synb
+.mets (mprotect < carray < prot >> [ offset <> [ size ]])
+.mets (madvise < carray < advice >> [ offset <> [ size ]])
+.mets (msync < carray < flags >> [ offset <> [ size ]])
+.syne
+.desc
+The functions
+.codn mprotect ,
+.code madvise
+and
+.code msync
+perform various operations and adjustments on a memory mapping, using the
+same-named, corresponding POSIX functions.
+
+All functions follow the same argument conventions with regard to the
+.meta carray
+argument and the optional
+.meta offset
+and
+.meta size
+arguments. The respective second arguments
+.metn prot ,
+.meta advice
+and
+.meta flags
+are all integers. Of these,
+.meta prot
+and
+.meta flags
+are bitmapped flags, whereas
+.meta advice
+specifies an enumerated command.
+
+The
+.meta prot
+argument is a bitwise combination of
+.code prot-
+values such as
+.codn prot-read ,
+.code prot-write
+and
+.codn prot-exec .
+The
+.code mprotect
+function adjusts the protection bits of the mapping accordingly.
+
+The
+.meta advice
+argument of
+.code madvise
+should specify one of the following portable values, or else some
+system-specific nonportable
+.code madv-
+value:
+.codn madv-normal ,
+.codn madv-random ,
+.codn madv-sequential ,
+.code madv-willneed
+or
+.codn madv-dontneed .
+
+The
+.meta flags
+argument of
+.code msync
+should specify exactly one of the values
+.code ms-async
+and
+.codn ms-sync .
+Additional
+.code ms-
+values such as
+.code ms-invalidate
+may be combined in.
+
+If
+.meta offset
+and
+.meta size
+are omitted, they default to zero and the size of the entire mapping, respectively,
+so the operation applies to the entire mapping.
+
+If only
+.meta size
+is specified, it must not exceed the mapping size, or an error exception is
+thrown. The
+.meta offset
+argument defaults to zero.
+
+If only
+.meta offset
+is specified, it must not exceed the length of the mapping, or else
+an error exception is thrown. The size is calculated as the difference between
+the offset and the length. It may be zero.
+
+If both
+.meta offset
+and
+.meta size
+are specified, they must not specify a region any portion of which lies outside
+the mapping. If
+.meta size
+is zero,
+.meta offset
+may be equal to the length of the mapping.
+
+The
+.meta offset
+must be a multiple of the page size, or else the operation will fail,
+since these functions work with virtual memory pages, and not individual
+bytes. The
+.meta length
+is adjusted by the system to a multiple of the applicable page size,
+as noted in the description of
+.codn mmap .
+
+When any of these three functions succeeds, it returns
+.codn t .
+Otherwise, it throws an exception.
+
+.coNP Variables @, map-shared @, map-private @ map-anon and @ map-fixed
+.desc
+The integer values of these variables are bitmasks, intended to be combined with
+.code logior
+to prepare a value for the
+.meta flags
+argument of
+.codn mmap .
+
+Additional nonportable, system-dependent
+.code map-
+variables may be available. Their names are derived by taking the
+.codn MAP_ -prefixed
+symbol from the platform header file, converting it to lowercase and
+replacing underscores by hyphen characters.
+Any such variable which exists, but has a value of zero, is
+present only for compatibility with other systems. For instance
+.code map-huge-shift
+may be present in non-Linux ports of \*(TX, but with a zero value; it has
+a nonzero value on Linux systems to which it is specific. Applications critically
+relying on certain flags should test the corresponding variables for nonzero to
+make sure they are actually available.
+
+.coNP Variables @, prot-none @, prot-read @ prot-write and @ prot-exec
+.desc
+The integer values of these variable are bitmasks, intended to be combined with
+.code logior
+to prepare a value for the
+.meta prot
+argument of
+.code mmap
+and
+.codn mprotect .
+
+Additional nonportable, system-dependent
+.code prot-
+variables may be available. Their names are derived by taking the
+.codn PROT_ -prefixed
+symbol from the platform header file, converting it to lowercase and
+replacing underscores by hyphen characters.
+Any such variable which exists, but has a value of zero, is
+present only for compatibility with other systems.
+
+.coNP Variables @, madv-normal @, madv-random @, madv-sequential @ madv-willneed and @ madv-dontneed
+.desc
+The integer values of these variable are bitmasks, intended to be combined with
+.code logior
+to prepare a value for the
+.meta advice
+argument of the
+.code madvise
+function.
+
+Additional nonportable, system-dependent
+.code madv-
+variables may be available. Their names are derived by taking the
+.codn MADV_ -prefixed
+symbol from the platform header file, converting it to lower case and
+replacing underscores by hyphen characters.
+Any such variable which exists, but has a value of zero, is
+present only for compatibility with another system.
+
+.coNP Variables @, ms-async @ ms-sync and @ ms-invalidate
+.desc
+The integer values of these variable are bitmasks, intended to be combined with
+.code logior
+to prepare a value for the
+.meta advice
+argument of the
+.code msync
+function.
+
+As described under
+.codn msync ,
+exactly one of
+.code ms-async
+and
+.code ms-sync
+should be present;
+.code ms-invalidate
+is optional.
+
.SS* Web Programming Support
.coNP Functions @ url-encode and @ url-decode
@@ -62848,7 +80696,7 @@ More generally, strings can consists of Unicode characters, but the URL
encoding consists only of printable ASCII characters. Unicode characters in the
original string are encoded by expanding into UTF-8, and applying
percent-encoding the UTF-8 bytes, which are all in the range
-.codn \exx80-\exxFF .
+.codn \ex80-\exFF .
Decoding is the reverse process: reconstituting the UTF-8 byte sequence
specified by the URL-encoding, and then decoding the UTF-8 sequence into the
@@ -62876,7 +80724,7 @@ If the argument is a value other than
then spaces are encoded as the
character
.code +
-.codn (plus) .
+(plus).
The
.code url-decode
@@ -62886,7 +80734,7 @@ argument is omitted or specified as
.codn nil ,
then
.code +
-.code (plus)
+(plus)
characters in the
encoded data are retained as
.code +
@@ -62896,6 +80744,7 @@ plus characters are converted to spaces.
.coNP Functions @, html-encode @ html-encode* and @ html-decode
.synb
.mets (html-encode << text-string )
+.mets (html-encode* << text-string )
.mets (html-decode << html-string )
.syne
.desc
@@ -63051,7 +80900,7 @@ stream must support output. In the decode operation, it must support
byte output.
The
.meta in
-stream must support input. In in the encode operation it must support
+stream must support input. In the encode operation it must support
byte input.
The
@@ -63062,7 +80911,7 @@ stream and writes characters to the
.meta out
stream comprising the Base64 encoding of that sequence. If the
.meta nbytes
-argument is specified, it must be a non-negative integer. At most
+argument is specified, it must be a nonnegative integer. At most
.meta nbytes
bytes will be read from the
.meta in
@@ -63178,7 +81027,7 @@ Dictionaries are unordered collections of keys, which are strings, which
have associated values, which are also strings. A trie can be used to filter
text, such that keys appearing in the text are replaced by the corresponding
values. A trie supports this filtering operation by providing an efficient
-prefix-based lookup method which only looks at each input character ones, and
+prefix-based lookup method which only looks at each input character once, and
which does not require knowledge of the length of the key in advance.
.coNP Function @ make-trie
@@ -63313,7 +81162,7 @@ for each successive operation. If every character is found, it means
that either that exact string is found in the trie, or a prefix.
The ambiguity can be resolved by testing whether the trie has a value
at the last node using
-.codn tree-value-at .
+.codn trie-value-at .
For instance, if
.str catalog
is inserted into an empty trie with value
@@ -63330,7 +81179,7 @@ indicating that
.str cat
is only a prefix of one or more entries in the trie.
-.coNP Function @ tree-value-at
+.coNP Function @ trie-value-at
.synb
.mets (trie-value-at << trie-context )
.syne
@@ -63351,15 +81200,15 @@ a value hold the value
.desc
The
.code filter-string-tree
-a tree structure similar to
-.metn obj ,
+function returns a tree structure similar to
+.meta obj
in which all of the
string atoms have been filtered through
.metn filter .
The
.meta obj
-argument is a string tree structure: either the symbol
+argument is a string-tree structure: either the symbol
.codn nil ,
denoting an empty structure; a string; or a list of tree structures. If
.meta obj
@@ -63438,7 +81287,7 @@ The
.code regex-from-trie
function returns a representation of
.meta trie
-as regular expression abstract syntax, suitable for
+as regular-expression abstract syntax, suitable for
processing by the
.code regex-compile
function.
@@ -63457,13 +81306,13 @@ results in more compact syntax.
Note: this function is useful for creating a compact, prefix-compressed
regular expression which matches a list of strings.
-.coNP Special variable @ *filters*
+.coNP Special Variable @ *filters*
.desc
The
.code *filters*
special variable holds a hash table which associates symbols with
filters. This hash table defines the named filters used in the
-\*(TX pattern language. The names are the hash table keys, and filter
+\*(TX pattern language. The names are the hash-table keys, and filter
objects are the values. Filter objects are one of three representations.
The value
.code nil
@@ -63479,7 +81328,7 @@ with values which conform to the above representation of filters.
The behavior is unspecified if any of the predefined filters
are removed or redefined, and are subsequently used, or if the
.code *filters*
-variable is replaced or rebound with a hash table value which omits
+variable is replaced or rebound with a hash-table value which omits
those keys, or associates them with different values.
Note that functions
@@ -63532,11 +81381,17 @@ which will be interpreted as pattern variables, and may be bound or unbound.
If they are not symbols, then they are treated as expressions (of the
pattern language, not \*(TL) and evaluated accordingly.
-The
+The optional
.meta input
-argument is a list of strings, which may be lazy. It represents the
-lines of the text stream to be processed. If omitted, it defaults to
-.codn nil .
+argument is an object of one of several types. It may be a stream,
+character string or list of strings. If it is a string, then
+it is converted to a list containing that string.
+A list of strings represents zero or more lines of text to be
+processed. If the
+.meta input
+argument is omitted, then it defaults to
+.codn nil ,
+interpreted as an empty list of lines.
The
.meta files
@@ -63636,6 +81491,21 @@ out of the pattern function
.codn foo ;
it is local inside it.
+.coNP Function @ match-fboundp
+.synb
+.mets (match-fboundp << symbol )
+.syne
+.desc
+The
+.code match-fboundp
+function returns
+.code t
+or
+.code nil
+if, respectively,
+.meta symbol
+is the name of an existing pattern function.
+
.coNP Macro @ txr-if
.synb
.mets (txr-if < name <> ( argument *) < input
@@ -63644,11 +81514,15 @@ it is local inside it.
.desc
The
.code txr-if
-macro invokes the \*(TX pattern matching function
+macro invokes the \*(TX pattern-matching function
.meta name
on some input given by the
.meta input
-parameter, which is a list of strings, or a single string.
+parameter, whose semantics are the same as the
+.meta input
+argument of the
+.code match-fun
+function.
If
.meta name
@@ -63810,6 +81684,75 @@ otherwise the forms are evaluated in order and the value of the last
one specifies the result of
.codn txr-case .
+The value of the input
+.meta input-form
+is expected to be one of the same kinds of objects as given by the
+requirements for the
+.meta input
+argument of the
+.code match-fun
+functions.
+
+If
+.meta input-form
+evaluates to a stream object according to the
+.code streamp
+function, then the stream is converted to a lazy list of lines,
+as if by invoking the
+.code get-lines
+function on that stream; that list then serves as input to the clauses.
+
+.coNP Function @ txr-parse
+.synb
+.mets (txr-parse >> [ source >> [ error-stream
+.mets \ \ \ \ \ \ \ \ \ \ \ >> [ error-retval <> [ name ]]]])
+.syne
+.desc
+The
+.code txr-parse
+function converts textual \*(TX query syntax into a Lisp data
+structure representation.
+
+The
+.meta source
+argument may be either a character
+string, or a stream. If it is omitted, then
+.code *stdin*
+is used as the stream.
+
+The
+.meta source
+must provide the text representation of one complete \*(TX query.
+
+The optional
+.meta error-stream
+argument can be used to specify a stream to which
+diagnostics of parse errors are sent.
+If absent, the diagnostics are suppressed.
+
+The optional
+.meta name
+argument can be used to specify the file name which is used for reporting
+errors. If this argument is missing, the name is taken from the name
+property of the
+.meta source
+argument if it is a stream, or else the word
+.code string
+is used as the name if
+.meta source
+is a string.
+
+If there are no parse errors, the function returns the parsed data
+structure. If there are parse errors, and the
+.meta error-retval
+parameter is
+present, its value is returned. If the
+.meta error-retval
+parameter
+is not present, then an exception of type
+.code syntax-error
+is thrown.
+
.SS* Debugging Functions
.coNP Functions @ source-loc and @ source-loc-str
.synb
@@ -63913,7 +81856,7 @@ has location info, the expander propagates that info to that form's
expansion. In some situations, it is useful for a macro or other code
transformer to perform this action explicitly.
-.coNP Special variable @ *rec-source-loc*
+.coNP Special Variable @ *rec-source-loc*
.desc
The Boolean special variable
.code *rec-source-loc*
@@ -63974,7 +81917,7 @@ If there are no forms, the prof operator measures the smallest measurable
operation of evaluating nothing and producing
.codn nil .
-If the evaluation terminates normally (not abruptly by a non-local
+If the evaluation terminates normally (not abruptly by a nonlocal
control transfer), then
.code prof
yields a list consisting of:
@@ -64030,16 +81973,16 @@ The
macro is similar to
.codn progn .
It evaluates
-.metn form -s,
+.metn form s,
and returns the rightmost one, or
.code nil
if there are no forms.
Over the evaluation of
-.metn form -s,
+.metn form s,
it counts memory allocations, and measures
CPU time. If
-.metn form -s
+.metn form s
terminate normally, then just prior to returning,
.code pprof
prints these statistics in a concise report on the
@@ -64054,20 +81997,30 @@ operator.
.SS* Garbage Collection
.coNP Function @ sys:gc
.synb
-.mets (sys:gc)
+.mets (sys:gc <> [ full ])
.syne
.desc
The
.code gc
function triggers garbage collection. Garbage collection means
that unreachable objects are identified and reclaimed, so that their
-storage can be re-used.
+storage can be reused.
The function returns
.code nil
if garbage collection is disabled (and consequently nothing is done), otherwise
.codn t .
+The Boolean
+.meta full
+argument, defaulting to
+.codn nil ,
+indicates whether a full garbage collection should be requested.
+
+Even if this argument is
+.codn nil ,
+a full garbage collection may occur due to having been scheduled.
+
.coNP Function @ sys:gc-set-delta
.synb
.mets (sys:gc-set-delta << bytes )
@@ -64120,8 +82073,13 @@ will be called with
.meta object
as its only argument.
-Multiple finalizer functions can be registered for the same object.
-They are all called when the object becomes unreachable.
+Multiple finalizer functions can be registered for the same object,
+up to an internal limit which is not required to be greater than 255.
+If the limit is exceeded,
+.code finalize
+throws an error exception.
+
+All registered finalizers are called when the object becomes unreachable.
Finalizers registered against an object may also be invoked
and removed using the
.code call-finalizers
@@ -64159,9 +82117,25 @@ A finalizer is itself permitted to call
.code finalize
to register the original
.code object
-or any other object for finalization. Such registrations made during
-finalization execution are not eligible for the current phase of finalization
-processing; they will be processed in a later garbage collection pass.
+or any other object for finalization. Finalization processing can be
+understood as taking place in one or more rounds. At the start of each round,
+finalizers are identified that are to be called, arranged in order, and removed
+from the registration list. If this identification stage produces no
+finalizers, then finalization ends. Otherwise, those finalizers are processed,
+and then another round is initiated, to look for eligible finalizers that may have been
+registered during the previous round.
+
+Note: it is possible for the application to create an infinite finalization
+loop, if one or more objects have finalizers that register new finalizers,
+which register new finalizers and so on.
+
+Note: if a finalizer is invoked by the garbage collector rather than explicit
+finalization via
+.codn call-finalizers ,
+and that finalizer calls
+.code finalize
+to make a registration, that registration will not be eligible for processing in
+the same phase, because the criteria for finalization is unreachability.
.coNP Function @ call-finalizers
.synb
@@ -64177,12 +82151,22 @@ If any finalizers are called, it returns
otherwise
.codn nil .
+Finalization performed by
+.code call-finalizers
+works in the manner described under the specification of the
+.code finalize
+function.
+
It is permissible for a finalizer function itself to call
.codn call-finalizers .
-Such a call can happen in two possible contexts: during actual
-reclamation driven by garbage collection, or under the scope of a
+Such a call can happen in two possible contexts: finalization
+initiated by by garbage collection, or under the scope of a
.code call-finalizers
-invocation from application code.
+invocation from application code. Doing so is safe, since the finalization
+logic may be reentered recursively. When finalizers are being called during a
+round of processing, those finalizers have already been removed from the
+registration list, and will not be redundantly invoked by a recursive
+invocation of finalization.
Under the scope of garbage-collection-driven reclamation, the
order of finalizer calls may not be what the application logic
@@ -64203,7 +82187,7 @@ finalizer performs the explicit
.code call-finalizers
invocation against
.codn B .
-Thus the the call either has no effect at all, or only calls some remaining
+Thus the call either has no effect at all, or only calls some remaining
.code B
finalizers that have not yet been processed, rather than all of them,
as the application expects.
@@ -64214,22 +82198,123 @@ only correct under an explicit
.code call-finalizers
but incorrect under spontaneous reclamation driven by garbage collection.
+.SS* Stack-Overflow Protection
+
+\*(TX features a rudimentary mechanism for guarding against stack overflows,
+which cause the \*(TX process to crash. This capability is separate
+from and exists in addition to the possibility of catching a
+.code sig-segv
+(segmentation violation) signal upon stack overflow using
+.codn set-sig-handler .
+
+The stack-overflow guard mechanism is based on \*(TX, at certain key places
+in the execution, checking the current position of the stack relative to
+a predetermined limit. If the position exceeds the limit, then an exception
+of type
+.codn stack-overflow ,
+derived from
+.codn error ,
+is thrown.
+
+The stack-overflow guard mechanism is configured on startup.
+On platforms where it is possible to
+inquire the system's actual stack limit, and where the stack limit is
+at least 512 kilobytes, \*(TX sets the limit to within a
+certain percentage of the actual value. If it is not possible to determine the
+system's stack limit, or if the system indicates that the stack size is
+unlimited, then a default limit is imposed. If the system's limit is
+configured below a certain small value, then that small value is used
+as the stack limit.
+
+The
+.code get-stack-limit
+and
+.code set-stack-limit
+functions are provided to manipulate the stack limit.
+
+The mechanism cannot contain absolutely all sources of stack-overflow threat
+under all conditions. External functions are not protected, and not all
+internal functions are monitored. If \*(TX is close to the limit, but
+a function is called whose stack growth is not monitored, such as
+an external function or unmonitored internal function, it is possible that
+the stack may overflow anyway.
+
+.coNP Functions @ get-stack-limit and @ set-stack-limit
+.synb
+.mets (get-stack-limit)
+.mets (set-stack-limit << value )
+.syne
+.desc
+The
+.code get-stack-limit
+returns the current value of the stack limit. If the guard mechanism is
+not enabled, it returns
+.codn nil ,
+otherwise it returns a positive integer, which is measured in bytes.
+
+The
+.code set-stack-limit
+configures the stack limit according to
+.metn value ,
+possibly enabling or disabling the guard mechanism, and returns the previous
+stack limit in exactly the same manner as
+.codn get-stack-limit .
+
+The
+.meta value
+must be a non-negative integer or else the symbol
+.codn nil .
+
+The values zero or
+.code nil
+disable the guard mechanism. Positive integer values set the limit.
+The value may be truncated to a multiple of some denomination or
+otherwise adjusted, so that a subsequent call to
+.code get-stack-limit
+need not retrieve that exact value.
+
+If
+.meta value
+is too close to the system's stack limit or beyond, the effectiveness
+of the stack-overflow detection mechanism is compromised.
+Likewise, if
+.meta value
+is too low, the operation of \*(TX shall become unreliable. Values
+smaller than 32767 bytes are strongly discouraged.
+
.SS* Modularization
.coNP Variable @ self-path
.desc
-This variable holds the invocation path name of the \*(TX program.
+This variable holds the invocation pathname of a \*(TX program
+that was specified on the command line.
+
The value of
.code self-path
-when \*(TL expressions are being evaluated in command line arguments
+when \*(TL expressions are being evaluated in command-line arguments
is the string
.strn cmdline-expr .
The value of
.code self-path
when a \*(TX query is supplied on the command line via the
.code -c
-command line option is the string
+command-line option is the string
.strn cmdline .
+When a file is being compiled using the
+.code --compile
+option, the value of
+.code self-path
+is the source file path.
+
+When the interactive listener is entered,
+.code self-path
+is set to the value
+.strn listener ,
+even if prior to that, a file was compiled
+or executed, for which
+.code self-path
+had been set to the name of that file.
+
Note that for programs read from a file,
.code self-path
holds the resolved name, and not the invocation name. For instance if
@@ -64240,6 +82325,15 @@ whereby \*(TX infers the suffix, then
.code self-path
holds the suffixed name.
+Note that the functions
+.codn load ,
+.code compile-file
+and
+.code compile-update-file
+have no effect on the value of
+.code self-path.
+The variable is set strictly by command line processing.
+
.coNP Variable @ stdlib
.desc
The
@@ -64253,13 +82347,13 @@ a \*(TL library function, macro or variable is referenced for the first time,
the library module which defines it is loaded. This includes references
which occur during the code expansion phase, at "macro time", so it works for
macros. In the middle of processing a syntax tree, the expander may encounter a
-symbol that is registered for auto-loading, and trigger the load. When the load
+symbol that is registered for autoloading, and trigger the load. When the load
completes, the symbol might now be defined as a macro, which the expander
can immediately use to expand the given form that is being traversed.
.coNP Function @ load
.synb
-.mets (load << target )
+.mets (load < target << load-arg *)
.syne
.desc
The
@@ -64286,7 +82380,7 @@ If an existing load operation is in progress, then the special variable
has a binding. In this case,
.code load
will assume that the relative pathname is a reference relative to the
-directory portion of that path name.
+directory portion of that pathname.
If
.code *load-path*
has the value
@@ -64296,42 +82390,71 @@ then a pure relative
pathname is used as-is, and thus resolved relative to the current working
directory.
-Once the tentative path name is determined,
+Once the tentative pathname is determined,
.code load
determines whether the name is suffixed. The name is suffixed if it
ends in any of these four suffixes:
.codn .tlo ,
+.codn .tlo.gz ,
.codn .tl ,
.code .txr
or
.codn .txr_profile .
-Depending on whether the tentative path name is suffixed,
+Depending on whether the tentative pathname exists, and whether
+or not it is suffixed,
.code load
tries to make one or more attempts to open several variations of that name.
These variations are called
-.I "actual paths" .
+.IR "actual paths" .
If any attempt fails due to an error other than non-existence,
such as a permission error, then no further attempts are made; the
error exception propagates to
.codn load 's
caller.
-If the tentative path name is suffixed, then
+Regardless of whether the tentative pathname is suffixed,
.code load
-tries to open a file by that actual path name. If that attempt
-fails, no other names are tried.
+tries to open a file by that actual pathname first. If that attempt
+fails for a suffixed pathname, or fails due to a reason other than
+non-existence, no other names are tried.
-If the tentative path name is unsuffixed, then first the suffix
+If an unsuffixed tentative pathname refers to a nonexistent file,
.code .tlo
is appended to the name, and an attempt is made to open a file
-with this actual path. If that file is not found, then the suffix
+with the resulting path. If that file is not found, then the suffixes
+.code .tlo.gz
+and
.code .tl
-is similarly tried. If that file is not found, then the unsuffixed
-name is tried.
+are similarly tried.
-If an unsuffixed file is opened, its contents are treated as interpreted Lisp.
-Files ending in
+If the above
+.I "initial attempts"
+to find the file fail, and the failure
+is due to the file not being found rather than some other problem such as a
+permission error, and
+.meta target
+isn't an absolute path according to
+.codn abs-path-p ,
+then additional attempts are made by searching for the file in the
+list of directories given in the
+.code *load-search-dirs*
+variable. For each directory taken from this variable, the directory
+is combined with the relative
+.meta target
+as if using the
+.code path-cat
+function, and the resulting path is tried, with all the same suffix probing
+that is performed by the initial attempts. If any such a path is pure relative,
+it is interpreted relative to the current working directory, and not relative
+.codn *load-path* :
+only the initial attempts have that special behavior.
+
+An exception is thrown if a file is not found, or if any attempt to open
+a file results in an error other than non-existence.
+
+If an unsuffixed file is successfully opened, its contents are treated as
+interpreted Lisp. Files ending in
.code .txr_profile
are also treated as interpreted Lisp. Files ending in
.code .tlo
@@ -64339,6 +82462,12 @@ are treated as compiled Lisp, and those ending in
.code .txr
are treated as the \*(TX Pattern Language.
+The
+.code .tlo.gz
+suffix denotes a file which is expected to be compressed in the
+.code gzip
+format, and to contain compiled Lisp.
+
If the file is treated as \*(TL, then Lisp forms are read from it in
succession. Each form is evaluated as if by the
.code eval
@@ -64369,17 +82498,77 @@ stream.
Over the evaluation of either a \*(TL, compiled file, or \*(TX file,
.code load
establishes a new dynamic binding for several special
-variables. The variable
-.code *load-path*
-is given a new binding containing the actual path name.
-The
-.code *package*
-variable is also given a new dynamic binding, whose value is the
-same as the existing binding. Thus if the processing of the
+variables:
+
+.RS
+.coIP *load-path*
+This variable is bound to the actual pathname being loaded.
+
+.coIP *load-args*
+The values of the
+.meta load-arg
+arguments which follow
+.meta target
+are combined into a list which is bound to
+.codn *load-args* .
+By this mechanism,
+.code load
+can pass arguments to the loaded file.
+
+.coIP *package*
+is given a new dynamic binding, whose value is the same as its
+existing binding. Thus if the processing of the
loaded file has the effect of altering the value of
.codn *package* ,
that effect will be undone when the binding is removed
after the load completes.
+.RE
+
+.IP
+Over the evaluation of either a \*(TL, compiled file, or \*(TX file,
+.code load
+establishes a block named
+.codn load ,
+which makes it possible for the loaded module to abort the loading
+using the
+.mono
+.meti (return-from load << expr )
+.onom
+expression. In this situation, the value of
+.meta expr
+will appear as the return value of the
+.code load
+function.
+
+When a \*(TL file, or compiled file, is executed from the \*(TX command line
+in such a way that \*(TX will terminate when that file's last form
+has been evaluated, then if that file performs a
+.code return-from
+the
+.code load
+block, the value of
+.meta expr
+will turn into the termination status in exactly the same way as if
+that value were used as an argument to the
+.code exit
+function. However, if \*(TX has been instructed to enter into the
+Listener after executing the file, then the value of
+.meta expr
+is discarded.
+
+A block named
+.code load
+is also established by the
+.code @(load)
+directive in the pattern language. That directive provides
+no access to the returned value. The block is also visible to the
+file processed from the command line. When a such a file aborts
+the load via
+.codn return ,
+the returned value is discarded. If the interactive option
+.code -i
+was specified, the interactive listener will be entered, otherwise
+the process will terminate successfully.
When the
.code load
@@ -64398,7 +82587,7 @@ fails, causing subsequent directives not to be processed.
A \*(TX pattern language file loaded with the Lisp
.code load
function does not have the usual implicit access to the
-command line arguments, unlike a top-level \*(TX query.
+command-line arguments, unlike a top-level \*(TX query.
If the directives in the file try to match input, they
work against the
.code *stdin*
@@ -64409,13 +82598,46 @@ are available.
If the source or compiled file begins with the characters
.codn #! ,
-usually indicating "hash bang" script,
+usually indicating a hash-bang script,
.code load
reads reads the first line of the file and discards it.
Processing of the file then begins with the first byte
following that line.
-.coNP Special variable @ *load-path*
+Two or more
+.code .tlo
+files produced by the same version of \*(TX may be catenated
+together (for instance, using the
+.code cat-files
+function) to produce a single
+.code .tlo
+file. Such a combined file can be loaded with the
+.code load
+function. The same is true of
+.code .tlo.gz
+files, because the
+.code gzip
+format supports catenation. Mixing is not possible:
+.code .tlo
+and
+.code .tlo.gz
+files cannot be catenated together.
+
+Note: this is a single
+.code load
+operation: all of the binding and unbinding of variables like
+.code *load-path*
+and
+.code *package*
+is performed once over the entire contents of the combined file, and any
+.code *load-hooks*
+are performed one time after the load operation. Therefore it is possible that
+the load-time behavior differs from that of loading the original files
+individually. The
+.code *load-path*
+is bound to the name of the combined file.
+
+.coNP Special Variable @ *load-path*
.desc
The
.code *load-path*
@@ -64423,17 +82645,17 @@ special variable has a top-level value which is
.codn nil .
When a file is being loaded, it is dynamically bound to the
-path name of that file. This value is visible to the forms
+pathname of that file. This value is visible to the forms
are evaluated in that file during the loading process.
The
.code *load-path*
-variable is is bound when a file is loaded from the command
+variable is bound when a file is loaded from the command
line.
If the
.code -i
-command line option is used to enter the interactive listener,
+command-line option is used to enter the interactive listener,
and a file to be loaded is also specified, then the
.code *load-path*
variable remains bound to the name of that file inside the
@@ -64462,9 +82684,371 @@ parsing and processing of a loaded \*(TX source file.
Also, during the processing of the profile file (see Interactive Profile File),
the variable is bound to the name of that file.
+.coNP Special Variable @ *load-search-dirs*
+.desc
+The
+.code *load-search-dirs*
+variable holds a list of directories which are searched for a file to be
+loaded by the
+.code load
+function, the
+.code @(load)
+and
+.code @(include)
+directives, as well as by \*(TX's command line processing.
+
+Each of these situations first searches for a file in its characteristic
+way. If that fails due to the file not being found, and the name is
+a relative path, then the directories in
+.code *load-search-dirs*
+are probed, in order.
+
+The variable is initialized to a list which contains exactly one directory: a
+.code lib/
+directory dynamically calculated relative to \*(TX the executable location.
+Then intent is that third-party library modules may be installed there,
+and easily found by
+.codn load .
+For more information, see the section Deployment Directory Structure.
+
+The
+.code *load-search-dirs*
+isn't influenced by any environment variables, which is deliberate.
+If a system has multiple installations of different versions of \*(TX
+in different locations, an environment variable intended for one installation
+could be mistakenly used by the others, resulting in chaos.
+
+.coNP Special Variable @ *load-hooks*
+.desc
+The
+.code *load-hooks*
+variable is at the centre of a mechanism which associates the deferred
+execution of actions, associated with a loaded module or program termination.
+
+The application may push values onto this list which are expected to be
+functions, or objects that may be called as functions. These objects must
+be capable of being called with no arguments.
+
+In the situations specified below, the list of functions is processed as follows.
+First
+.code *load-hooks*
+is examined, the list which it holds is remembered. Then the variable
+is reset to
+.codn nil ,
+following which the remembered list is traversed in order. Each of the
+functions in the list is invoked, with no arguments.
+
+The
+.code *load-hooks*
+list is processed, as described above, whenever the
+.code load
+function terminates, whether normally or by throwing an exception. In this
+situation, the
+.code *load-hooks*
+variable which is accessed is that binding which was established by that
+invocation of
+.codn load .
+The execution of the functions from the
+.code *load-hooks*
+list takes place in the dynamic environment of the
+.codn load :
+all of the dynamic variable bindings established by that
+.code load
+are still visible, including that of
+.codn *load-hooks* .
+
+The
+.code *load-hooks*
+list is also processed after processing a \*(TX or \*(TL file that
+is specified on the command line. If the interactive listener is
+also being entered, this processing of
+.code *load-hooks*
+occurs prior to entering the listener. This situation occurs in the
+context of the top-level dynamic environment, and so the global value of
+.code *load-hooks*
+is referenced.
+
+Lastly,
+.code *load-hooks*
+is also processed if the \*(TX process terminates normally, regardless
+of its exit status. This processing executes in whatever dynamic
+environment is current at the point of exit, using its value of the
+.code *load-hooks*
+variable is used. It is unspecified whether, at exit time, the
+.code *load-hooks*
+functions are executed first, or whether the functions registered by
+.code at-exit-call
+are executed first. However, their executions do not interleave.
+
+Note that
+.code *load-hooks*
+is not processed after the listener reads the
+.code .txr_profile
+file. Hooks installed by the profile file will activate when the process
+exits.
+
+
+.coNP Function @ load-args-recurse
+.synb
+.mets (load-args-recurse << file-list )
+.mets (load-args-recurse << file *)
+.syne
+.desc
+The
+.code load-args-recurse
+function loads multiple files, passing down the current
+.code *load-args*
+to each one.
+
+It may be invoked with a single argument which is a list of files, or else it
+may be given multiple arguments which are files.
+
+Each
+.meta file
+is passed to the
+.code load
+function, along with extra arguments coming from the current
+.code *load-args*
+value.
+
+Note: the purpose of
+.code load-args-recurse
+is to support a module organization of system whereby modules
+have local top-level files that respond to various actions specified via
+.codn *load-args* ,
+actions such as compiling, loading or cleaning.
+The
+.code load-args-recurse
+function allows such modules to not only perform the actions requested in
+.code *load-args*
+locally, but also pass it down to submodules which then do the same.
+
+.coNP Function @ load-args-process
+.synb
+.mets (load-args-process << file-list )
+.mets (load-args-process << file *)
+.syne
+.desc
+The
+.code load-args-process
+function performs one of several actions over the specified files,
+those actions being distinguished by the value in
+.codn *load-args* .
+
+In addition, some of the actions are also performed for the file
+indicated in the current value of
+.codn *load-path* .
+
+It may be invoked with a single argument which is a list of files, or else it
+may be given multiple arguments which are files.
+
+If there is exactly one argument in
+.codn *load-args* ,
+the function responds to the following values of that argument:
+.RS
+.coIP :compile
+First, the current file in
+.code *load-path*
+is processed with
+.codn compile-update-file .
+Then each file in the argument list is also processed with
+.codn compile-update-file .
+Whenever that function returns
+.code nil
+for any file, that file is loaded with
+.codn load .
+No additional arguments are passed to this
+.code load
+invocation.
+.coIP :clean
+The current file in
+.code *load-path*
+as well as the files passed as arguments, are processed with
+.codn clean-file .
+.RE
+.IP
+Any other value of
+.code *load-args*
+causes the function to
+.code load
+the files passed in the argument, as if by
+.codn load-args-recurse .
+
+Note:
+The
+.code load-args-process
+function supports a protocol for organizing a program into library modules.
+
+.TP* Example:
+
+Suppose a module located in the
+.str path/to/application
+path consists of the files
+.strn command
+.strn data
+.str reports
+and
+.str main .
+Further, suppose that there are two submodules in the
+.str utils
+directory relative to this directory:
+.str database
+and
+.strn date .
+
+Then the application might have a file called
+.str "path/to/application/app.tl"
+with this content:
+
+.verb
+ (compile-only
+ (load-args-recurse
+ "utils/database/db"
+ "utils/date/date")
+
+ (load-args-process
+ "command"
+ "data"
+ "reports"
+ "main"))
+.brev
+
+Furthermore, the
+.str database
+module similarly provides a
+.str "path/to/application/utils/database/db.tl"
+file with this content:
+
+.verb
+ (compile-only
+ (load-args-process
+ "postgres"
+ "mariadb"
+ "sqlite"))
+.brev
+
+Lastly, the
+.str date
+module provides a file
+.str "path/to/application/utils/date/date.tl"
+with this content:
+
+.verb
+ (compile-only
+ (load-args-process
+ "src/date.tl"))
+.brev
+
+Then, to load the application and the submodules, all that is needed is
+.codn "(load \(dqpath/to/application/app\(dq)" .
+
+Furthermore, the modules may be compiled using
+.codn "(load \(dqpath/to/application/app\(dq :compile)" .
+Now the
+.code *load-args*
+being passed is
+.code "(:compile)"
+which tells every
+.code load-args-process
+invocation to compile the file in which it occurs as well as its arguments.
+
+First, the
+.code app
+module's
+.code load-args-recurse
+call is executed, causing the
+.str database
+and
+.str date
+modules to compile.
+
+First, the
+.str database
+module's
+.str db.tl
+top file is compiled, if necessary, and then likewise the
+.strn postgres.tl ,
+.str mariadb.tl
+and
+.str sqlite.tl
+files.
+
+Then the
+.str date
+module is similarly processed, due to its own invocation of
+.codn load-args-process .
+
+Finally the
+.code load-args-process
+call in the
+.str app
+module compiles
+.strn app.tl ,
+.strn command.tl ,
+.str data.tl
+.str reports.tl
+and
+.strn main.tl
+
+If the
+.code :clean
+keyword is passed via
+.code *load-args*
+instead of
+.codn :compile ,
+then compiled files are recursively removed. The next time the
+application is loaded, source files will be loaded rather
+than compiled files.
+
+Note that the
+.code load-args-recurse
+and
+.code load-args-process
+forms are placed into a
+.code compile-only
+form so that the file compiler refrains from executing them.
+
+.coNP Macros @ push-after-load and @ pop-after-load
+.synb
+.mets (push-after-load << form *)
+.mets (pop-after-load)
+.syne
+.desc
+The
+.code push-after-load
+and
+.code pop-after-load
+macros work with the
+.code *load-hooks*
+list.
+
+The
+.code push-after-load
+macro's arguments are zero or more
+.metn form s.
+These forms are converted into the body of an anonymous function,
+which is pushed onto the
+.code *load-hooks*
+list. The return value is the new value of
+.codn *load-hooks* .
+
+The
+.code pop-after-macro
+removes the first item from
+.codn *load-hooks* .
+The return value is the new value of
+.codn *load-hooks* .
+
+The following equivalences hold:
+
+.verb
+ (push-after-load ...) <--> (push (lambda () ...) *load-hooks*)
+ (pop-after-load) <--> (set *load-hooks* (cdr *load-hooks*))
+.brev
+
.coNP Macro @ load-for
.synb
-.mets (load-for >> {( kind < sym << target )}*)
+.mets (load-for >> {( kind < sym < target << load-arg* )}*)
.syne
.desc
The
@@ -64478,7 +83062,7 @@ has a certain kind of binding.
Each argument clause has the syntax
.mono
-.meti >> ( kind < sym << target )
+.meti >> ( kind < sym < target << load-arg *)
.onom
where
.meta kind
@@ -64501,7 +83085,7 @@ function.
First, all
.code target
-expressions in all clauses are unconditionally evaluated in left to right
+expressions in all clauses are unconditionally evaluated in left-to-right
order. Then the clauses are processed in that order. If the
.meta kind
symbol of a clause is
@@ -64564,18 +83148,31 @@ of the right
If this isn't the case, an error is thrown.
The
+.code load
+function is invoked with any
+.meta load-arg
+arguments specified in the clause.
+The
+.meta load-arg
+expressions of all clauses are unconditionally evaluated in order before
+.code load-arg
+performs any other action.
+
+The
.code load-for
-function returns
+function returns the value returned by the rightmost
+.code load
+that was actually performed. If no loads are performed, it returns
.codn nil .
.coNP Variable @ txr-exe-path
.desc
-This variable holds the absolute path name of the executable file
+This variable holds the absolute pathname of the executable file
of the running \*(TX instance.
.SS* Function Tracing
-.coNP Special variable @ *trace-output*
+.coNP Special Variable @ *trace-output*
.desc
The
.code *trace-output*
@@ -64839,7 +83436,569 @@ named
.codn RTLD_LAZY ,
.codn RTLD_NOW ,
.codn RTLD_LOCAL ,
-.IR "et cetera" .
+etc.
+
+.SS* Data Interchange Support
+
+.coNP Macro @ json
+.synb
+.mets (json [quote | sys:qquote] << object )
+.syne
+.desc
+The
+.code json
+macro exists in support of the JSON literal and quasiliteral
+.mono
+.meti >> #J json-syntax
+.onom
+and
+.mono
+.meti >> #J^ json-syntax
+.onom
+notations, which use the macro as their target abstract syntax.
+
+The macro transforms itself by deleting the
+.code json
+symbol, producing either the
+.mono
+.meti (quote << object )
+.onom
+quote syntax, or else the
+.mono
+.meti (sys:qquote << object )
+.onom
+quasiquote syntax, depending on which quoting symbol is present.
+
+If the application produces and expands a
+.code json
+macro form which does not conform to this syntax, or does not
+specify one of the above two quoting symbols, the behavior is unspecified.
+
+.coNP Functions @ put-json and @ put-jsonl
+.synb
+.mets (put-json < obj >> [ stream <> [ flat-p ]])
+.mets (put-jsonl < obj >> [ stream <> [ flat-p ]])
+.syne
+.desc
+The
+.code put-json
+function converts
+.meta obj
+into JSON notation, and writes that notation into
+.meta stream
+as a sequence of characters.
+
+If
+.meta stream
+is an external stream such as a file stream, then the JSON is
+rendered by conversion of the characters into UTF-8, in the usual
+manner characteristic of those streams.
+
+The behavior is unspecified if
+.meta obj
+or any component of
+.meta obj
+is an object incompatible with the JSON representation conventions.
+An exception may be thrown.
+
+An object conforms to the JSON representation conventions if it is:
+.RS
+.IP 1.
+one of the symbols
+.codn nil ,
+.code t
+or
+.codn null ,
+which map to the JSON keywords
+.codn false ,
+.code true
+and
+.codn null ,
+respectively.
+.IP 2.
+a floating-point number or integer.
+.IP 3.
+a character string.
+.IP 4.
+a vector or list of JSON-conforming objects.
+.IP 5.
+a hash table whose keys and values are JSON-conforming objects.
+.RE
+.IP
+Note that unless the keys in a hash table are all strings, nonstandard JSON
+is produced, since RFC 8259 requires JSON object keys to be strings.
+
+A list of object is rendered in the same way as vector, in the JSON
+.code []
+notation. When such JSON notation is parsed, a vector is produced.
+
+When integer objects are output, they may not constitute valid JSON, since the
+JSON specification supports only IEEE 64 bit floating-point numbers. JSON
+numbers are read as floating-point.
+
+If the
+.code flat-p
+argument is present and has a true value, then the JSON is generated
+without any line breaks or indentation. Otherwise, the JSON output is subject
+to such formatting.
+
+The difference between
+.code put-json
+and
+.code put-jsonl
+is that the latter emits a newline character after the JSON output.
+
+When a string object is output as JSON string syntax, the following rules
+
+.RS
+.IP 1.
+The characters
+.code \e
+(backslash, reverse solidus) and
+.code \(dq
+(double quote)
+are preceded by a backslash escape.
+.IP 2.
+The characters U+0008 (BS), U+0009 (TAB), U+000A (LF), U+000C (FF) and
+U+000D (CR) are rendered as, respectively,
+.codn \eb ,
+.codn \et ,
+.codn \en ,
+.code \ef
+and
+.codn \er .
+.IP 3.
+If the character sequence
+.code "</script"
+occurs in a string, then in the JSON representation the slash is escaped, such
+that the sequence is rendered as
+.codn "<\e/script" .
+Instances of
+.code /
+(forward slash, solidus) in other situations are unescaped. Rationale: this is
+a feature of JSON which allows for safer embedding of the resulting
+JSON into HTML
+.code script
+tags.
+.IP 4
+If the character sequence
+.code <!--
+occurs in a string, then in the JSON representation, the sequence is
+rendered as
+.codn <\eu0021-- .
+Instances of
+.code !
+(exclamation mark) in other situations are not encoded. Rationale: safe
+embedding in HTML
+.code script
+tags.
+.IP 5
+If the character sequence
+.code -->
+occurs in a string, then in the JSON representation, the sequence is
+rendered as
+.codn -\eu002D> .
+Instances of
+.code -
+(hyphen) in other situations are not encoded. Rationale: safe
+embedding in HTML
+.code script
+tags.
+.IP 6.
+The code point U+DC00 (\*(TX's pseudo-null character) is translated into the
+.code "\eu0000"
+escape syntax.
+.IP 7.
+The code points U+DC01 through U+DCFF are send to the stream as-is.
+If the stream performs UTF-8 encoding, these characters turn into individual
+bytes in the range 0 to 255.
+.IP 8.
+Control characters in the U+0001 to U+001F other than the ones subject
+to rule 1 above are rendered as
+.code \eu
+escape sequences. Likewise, code points in the range U+007F to U+00BF,
+the range U+D800 to U+DBFF, U+DD00 to U+DFFF, and the code points
+U+FFFE and U+FFFF are also encoded as
+.code \eu
+escape sequences.
+.IP 9.
+A character outside of the BMP (Basic Multilingual Plane) in the range
+U+10000 to U+10FFFF is encoded using as a pair of consecutive
+.code \eu
+escape sequences, specifying the code points of a UTF-16 surrogate pair
+encoding that character. This representation is described in RFC 8259.
+.RE
+
+The
+.code put-json
+and
+.code put-jsonl
+functions return
+.codn t .
+
+Some of the JSON-related functions carry a
+.meta mode-opts
+optional parameter. These functions open a file as if using the
+.code open-file
+function, using a
+.meta mode-string
+appropriate to their direction of data transfer. If an argument is given to
+.metn mode-opts ,
+it specifies the
+.meta options
+part to be added to the
+.metn mode-string .
+
+.coNP Function @ tojson
+.synb
+.mets (tojson < obj <> [ flat-p ])
+.syne
+.desc
+The
+.code tojson
+function converts
+.meta obj
+into JSON notation, returned as a character string.
+
+The function can be understood as constructing a string output stream,
+calling the
+.code put-json
+function to write the object into that stream,
+and then retrieving and returning the constructed string.
+
+The
+.meta flat-p
+argument is passed to
+.codn put-json .
+
+.coNP Function @ get-json
+.synb
+.mets (get-json >> [ source
+.mets \ \ \ \ \ \ \ \ \ \ >> [ err-stream
+.mets \ \ \ \ \ \ \ \ \ \ \ >> [ err-retval >> [ name <> [ lineno ]]]]])
+.syne
+.desc
+The
+.code get-json
+function closely resembles the
+.code read
+function, and follows the same argument and error reporting conventions.
+
+Rather than reading a Lisp object from the input source, it reads a JSON
+object, with support for \*(TX's JSON extensions.
+
+If an object is successfully read, its Lisp representation is returned.
+JSON numbers produce floating-point number objects.
+JSON strings produce string objects. The keywords
+.codn true ,
+.code false
+and
+.code null
+map to the Lisp symbols
+.codn t ,
+.codn nil ,
+and
+.codn null ,
+respectively.
+JSON objects map to hash tables, and JSON arrays to vectors.
+
+.coNP Function @ put-jsons
+.synb
+.mets (put-jsons < seq >> [ stream <> [ flat-p ]])
+.syne
+.desc
+The
+.code put-jsons
+function writes multiple JSON representations into
+.metn stream .
+The objects are specified by the
+.meta seq
+argument, which must be an iterable object. The
+.code put-jsons
+function iterates over
+.meta seq
+and writes each element to the stream as if by using the
+.code put-jsonl
+function. Consequently, a newline character is written after each object.
+
+If the
+.meta stream
+argument is not specified, the parameter takes on the value of
+.metn *stdout* .
+
+The
+.meta flat-p
+argument has the same meaning as in
+.code put-json
+with regard to the individual elements. If it is specified and true,
+then exactly as many lines of text are written to
+.meta stream
+as there are elements in
+.metn seq .
+
+The
+.code put-jsons
+function returns
+.codn t .
+
+.coNP Function @ get-jsons
+.synb
+.mets (get-jsons <> [ source ])
+.syne
+.desc
+The
+.meta get-jsons
+function reads zero or more JSON representations from
+.meta source
+until an end-of-stream or error condition is encountered.
+
+If
+.meta source
+is a character string, then the input takes place from a stream
+created from the character string using
+.codn make-string-byte-input-stream .
+Otherwise, if
+.meta source
+is specified, it must be an input stream supporting byte input;
+input takes place from that stream. If the
+.meta source
+argument is omitted, it defaults to
+.codn *stdin* .
+
+The objects are read as if by calls to
+.code get-json
+and accumulated into a list.
+
+If the end-of-stream condition is read, then the list of accumulated objects is
+returned. If an error occurs, then an exception is thrown and the list of
+accumulated objects is not available.
+
+If an end-of-stream condition occurs before any character is seen other than
+JSON whitespace, then the empty list
+.code nil
+is returned.
+
+.coNP Functions @ file-get-json and @ file-get-jsons
+.synb
+.mets (file-get-json < name <> [ mode-opts ])
+.mets (file-get-jsons < name <> [ mode-opts ])
+.syne
+.desc
+The
+.code file-get-json
+and
+.code file-get-jsons
+function open a text stream over the file indicated by the string argument
+.meta name
+for reading. The functions ensure that the stream is closed when
+they terminate.
+
+The
+.code file-get-json
+function invokes
+.code get-json
+to read a single JSON object, which is returned if that function
+returns normally.
+
+The
+.code file-get-jsons
+function invokes
+.code get-jsons
+to retrieve a list of JSON objects from the stream, which is returned
+if that function returns normally.
+
+.coNP Functions @ file-put-json and @ file-put-jsons
+.synb
+.mets (file-put-json < name < obj >> [ flat-p <> [ mode-opts ]])
+.mets (file-put-jsons < name < seq >> [ flat-p <> [ mode-opts ]])
+.syne
+.desc
+The
+.code file-put-json
+and
+.code file-put-jsons
+functions open a text stream over the file indicated by the string argument
+.metn name ,
+using the function
+.code open-file
+with a
+.meta mode-string
+argument of
+.strn w ,
+write the argument object into the stream in their specific manner,
+and then close the stream.
+
+The
+.code file-put-json
+function writes a JSON representation of
+.meta obj
+using the
+.code put-json
+function. The
+.meta flat-p
+argument is passed to that function, defaulting to
+.codn nil .
+The value returned is that of
+.codn put-json .
+
+The
+.code file-put-jsons
+function writes zero or more JSON representations of objects from
+.metn seq ,
+which must be an iterable object, using the
+.code put-jsons
+function. The
+.meta flat-p
+argument is passed to that function, defaulting to
+.codn nil .
+The value returned is that of
+.codn put-jsons .
+
+.coNP Functions @ file-put-json and @ file-put-jsons
+.synb
+.mets (file-append-json < name < obj >> [ flat-p <> [ mode-opts ]])
+.mets (file-append-jsons < name < seq >> [ flat-p <> [ mode-opts ]])
+.syne
+.desc
+The
+.code file-append-json
+and
+.code file-append-jsons
+are identical in almost all requirements to the functions
+.code file-put-json
+and
+.codn file-put-jsons .
+
+The only difference is that when these functions open
+a text stream using
+.codn open-file ,
+they specify a
+.meta mode-string
+argument of
+.str a
+rather than
+.strn w ,
+in order to append data to the target file rather than overwrite it.
+
+.coNP Functions @ command-get-json and @ command-get-jsons
+.synb
+.mets (command-get-json < cmd <> [ mode-opts ])
+.mets (command-get-jsons < cmd <> [ mode-opts ])
+.syne
+.desc
+The
+.code command-get-json
+and
+.code command-get-jsons
+functions opens text stream over an input command pipe created for
+the command string
+.metn cmd ,
+as if by the
+.code open-command
+function. They ensure that the stream is closed when they terminate.
+
+The
+.code command-get-json
+function calls
+.code get-json
+on the stream, and returns the value returned by that function.
+
+Similarly,
+.code command-get-jsons
+function calls
+.code get-jsons
+on the stream, and returns the value returned by that function.
+
+.coNP Functions @ command-put-json and @ command-put-jsons
+.synb
+.mets (command-put-json < cmd < obj >> [ flat-p <> [ mode-opts ]])
+.mets (command-put-jsons < cmd < seq >> [ flat-p <> [ mode-opts ]])
+.syne
+.desc
+The
+.code command-put-json
+and
+.code command-put-jsons
+functions open an output text stream over an output command pipe created
+for the command specified in the string argument
+.metn cmd ,
+using the function
+.code open-command
+function, write the argument object into the stream, in their specific manner,
+and then close the stream.
+
+The
+.code command-put-json
+function writes a JSON representation of
+.meta obj
+using the
+.code put-json
+function. The
+.meta flat-p
+argument is passed to that function, defaulting to
+.codn nil .
+The value returned is that of
+.codn put-json .
+
+The
+.code command-put-jsons
+function writes zero or more JSON representations of objects from
+.metn seq ,
+which must be an iterable object, using the
+.code put-jsons
+function. The
+.meta flat-p
+argument is passed to that function, defaulting to
+.codn nil .
+The value returned is that of
+.codn put-jsons .
+
+.coNP Variable @ *print-json-format*
+.desc
+The
+.code *print-json-format*
+variable controls the formatting style exhibited by
+.code put-json
+and related functions. The initial value of this variable is
+.codn nil .
+
+If the value is the keyword symbol
+.codn :standard ,
+then a widely-used format is used, in which the opening and closing
+braces and brackets of vectors and dictionaries are printed
+on separate lines, as are the elements of those objects.
+
+If the variable
+has any other value, including the initial value
+.codn nil ,
+then a default format is used in which braces, brackets
+and elements appear on the same line, subject to automatic
+breaking and indentation, similar to the way Lisp nested
+list structure is printed.
+
+.coNP Variable @ *read-bad-json*
+.desc
+This dynamic variable, initialized to a value of
+.codn nil ,
+controls whether the parser is tolerant to certain non-conformances in the
+syntax of JSON data, which are ordinarily syntax errors.
+
+If the value of this variable is true, then the last element in a JSON
+array or the last element pair in a JSON object may be followed by spurious
+trailing comma, which is ignored.
+
+Note: in the future, the variable may be extended to enable other instances of
+tolerance in the area of JSON parsing.
+
+.TP* Example:
+
+.verb
+ (get-json "{ 3:4, }") -> ;; syntax error
+
+ (let ((*read-bad-json* t))
+ (get-json "{ 3:4, }"))
+ --> #H(() (3.0 4.0))
+.brev
.SH* FOREIGN FUNCTION INTERFACE
@@ -64868,7 +84027,7 @@ The FFI module supports passing and returning both structures and arrays
by value. Passing arrays by value isn't a feature of the C language syntax;
from the C point of view, these by-value array objects in the \*(TX FFI
type system are equivalent to C arrays encapsulated in
-.codn struct -s.
+.codn struct s.
A
.code carray
@@ -64882,9 +84041,9 @@ requires more responsibility from the application.
The FFI feature is inherently unsafe. If the FFI type language is used to write
incorrect type definitions which do not match the actual binary interface of a
-foreign function, undefined behavior results. Incorrect use of FFI can corrupt
-memory, creating instability and security problems. Also, incorrect use of FFI
-can cause memory leaks and/or use-after-free errors due to inappropriate
+foreign function, undefined behavior results. Improper use of FFI can corrupt
+memory, creating instability and security problems. It can also
+cause memory leaks and/or use-after-free errors due to inappropriate
deallocation of memory.
The implicit memory management behaviors encoded in the FFI type system
@@ -64896,7 +84055,7 @@ in the middle of some nested type can make the difference between correct code
and code which causes a memory leak, or instability by freeing memory which is
in use.
-FFI developers are encouraged to unit-test their FFI definitions carefully
+FFI developers are encouraged to unit test their FFI definitions carefully
and use tools such as Valgrind to detect memory misuses and leaks.
.SS* Key Concepts
@@ -64904,7 +84063,7 @@ and use tools such as Valgrind to detect memory misuses and leaks.
.NP* The \fIput\fP operation
When a function call takes place from the \*(TL arena into a foreign
-library function, argument values must be prepared in the foreign
+library function, argument values must be prepared into the foreign
representation. This takes place by converting Lisp objects into
stack-allocated temporary buffers representing C objects. For aggregate objects
containing pointers, additional buffers are allocated dynamically. For
@@ -64923,8 +84082,8 @@ callback return value to the foreign caller is also the put operation.
After a foreign function call returns from a foreign library back to the \*(TL
arena, the arguments have to be examined one more time, because two-way
-communication is possible, and because some of the material has temporary
-dynamically-allocated buffers associated with it which must be released. For
+communication is possible, and because some of the material has temporary,
+dynamically allocated buffers associated with it which must be released. For
instance a structure passed by pointer may be updated by the foreign function.
FFI needs to propagate the changes which the foreign function performed to the
C version of the structure, back to the original Lisp structure. Furthermore,
@@ -64942,15 +84101,15 @@ by-pointer nuance.
Data passed into a function by value such as function arguments or via
.code ptr-in
are subject to the by-value nuance. Updates to the foreign representation
-of these objects does not propagate back to the Lisp representation to the
-external representation; however, those objects may contain pointers requiring
+of these objects does not propagate back to the Lisp representation;
+however, those objects may contain pointers requiring
the by-pointer nuance of the in operation of those pointers to be invoked.
.NP* The \fIget\fP operation
After a foreign call completes, it is also necessary to retrieve the call's
return value, convert it to a Lisp object, and free any dynamic memory.
-This is preformed by the
+This is performed by the
.I get
operation.
@@ -65047,7 +84206,7 @@ and
types correspond to
.codn "unsigned char" .
Both Lisp integers and character values
-convert to these representation, if they are in their numeric range.
+convert to these representations if they are in their numeric range.
Out-of-range values produce an exception.
A foreign
.codn char ,
@@ -65089,7 +84248,7 @@ other than for expressing the element type of an
or
.codn zarray .
-.coNP FFI types @, short @, ushort @, int @, uint @, long @ and @ ulong
+.coNP FFI types @, short @, ushort @, int @, uint @ long and @ ulong
These types correspond to the C integer types
.codn short ,
.codn "unsigned short" ,
@@ -65111,7 +84270,7 @@ and
.codn "unsigned long long" .
.coNP FFI types @ int8 and @ uint8
-These types correspond to 8 bit signed and unsigned integers.
+These types correspond to 8-bit signed and unsigned integers.
They convert like integer types: both Lisp integers and characters
convert to these types, if in a suitable range; and under
the reverse conversion, the foreign values become Lisp integers.
@@ -65231,26 +84390,23 @@ object can be passed as the argument of
.code fclose
to close the stream.
-.coNP FFI types @, str @, bstr @ str-d and @ bstr-d
+.coNP FFI types @, str @ str-d @ and @ str-s
These FFI types correspond to the C pointer type
.codn "char *" ,
providing automatic conversion between Lisp strings and null-terminated
-C strings. The
-.code str
-and
-.code str-d
-types use UTF-8 encoding. The
-.code bstr
+C strings. The null pointer corresponds to the
+.B nil
+symbol.
+
+The related types
+.codn bstr ,
+.codn bstr-d ,
+.codn bstr-s ,
+.codn wstr ,
+.code wstr-d
and
-.code bstr-d
-types do not use UTF-8: only Lisp strings which contain strictly
-code points in the range U+0000 to U+00FF may convert to these types;
-out-of-range characters trigger an error exception.
-The
-.code -d
-suffixed types differ from the unsuffixed variants
-in that they denote the transfer of ownership of dynamically allocated memory,
-and thus the responsibility for freeing that memory.
+.code wstr-s
+are also provided; these are described in the following sections.
The
.code str
@@ -65284,17 +84440,19 @@ it deallocates that C string by invoking the C library function
.code free
on it.
-The type
-.code bstr-d
-behaves like
-.code str-d
-with regard to memory management; it differs from
-.code str-d
-in the same way that
-.code str
-differs from
-.codn bstr :
-it doesn't perform UTF-8 encoding or decoding.
+Type type
+.code str-
+is similar to
+.codn str-d ;
+it also has no in-operation, and doesn't deallocate the buffer
+allocated in the put operation.
+Under the get operation, the
+.code str-s
+type does not assume ownership of memory, and therefore does not
+free the pointer received from the foreign function. The
+.code str-s
+type is intended for receiving strings via a pointer-to-pointer
+argument, in situations when the string must not be freed.
Like other types, the string types combine with the
.code ptr
@@ -65304,7 +84462,7 @@ family has memory management semantics, as does the string family,
it is important to understand the memory management implications
of the combination of the two.
-The types
+The derived pointer types
.code "(ptr str-d)"
and
.code "(ptr str)"
@@ -65325,20 +84483,19 @@ pointer, and then pass that pointer to the C
.code free
function.
-To receive a string pointer by pointer from a foreign
-function, one of the types
-.code "(ptr-out str)"
-or
-.code "(ptr-out str-d)"
-should be used, which have different semantics. In either situation, FFI will
-prepare a pointer-sized uninitialized buffer, which the called function fills
-with a
-.code "char *"
-pointer. In the
-.code str
-case, FFI will duplicate that string to a Lisp string. In the
-.code str-d
-case, FFI will also free the string received from the foreign function.
+Receiving a string by pointer from a foreign function is achieved
+by treating the situation as a pointer to an array of one element.
+So that is to say, an argument like
+.code "char **pstr"
+can be treated as either
+.code "(ptr-out (array 1 str-d))"
+if the foreign function passes ownership of the string, or else
+.code "(ptr-out (array 1 str-s))"
+if the foreign function retains ownership of the string.
+In either case, the argument is a vector of one element, which
+will be updated to the returned string, or else
+.code nil
+if the function passes back a null pointer.
The type combination
.code "(ptr-in str-d)"
@@ -65350,18 +84507,76 @@ passes the string pointer in the same way, but the foreign module mustn't
use the pointer after returning. FFI will free the pointer that had been
passed.
-.coNP FFI types @ wstr and @ wstr-d
+.coNP FFI types @, bstr @ bstr-d @ and @ bstr-s
+The
+.code bstr
+family corresponds to null-terminated
+.code "char *"
+C strings, like the
+.code str
+family, and the family members have memory management semantics
+similar to their
+.code str
+counterparts. Likewise, under these types also, the null pointer corresponds to
+.codn nil .
+
+The
+.code b
+prefix in the naming denotes "byte". It indicates that unlike the
+.code str
+family, the
+.code bstr
+family does not use UTF-8 encoding; only Lisp strings which contain strictly
+code points in the range U+0000 to U+00FF may convert to these types;
+out-of-range characters trigger an error exception.
+
+Likewise, in the reverse direction, no UTF-8 decoding is performed: every byte value
+turns into the corresponding character code. The byte 0 is interpreted as the
+string terminator.
+
+Note: the
+.code bstr
+type may be advantageous in situations when character handling is known
+to be confined to the ASCII range, since UTF-8 conversion is then
+unnecessary overhead. Because \*(TX strings use wide characters internally,
+converting to and from the
+.code bstr
+type still requires memory management overhead, just like in the case of the
+.code str
+type. The
+.code wstr
+type described in the next section avoids memory management and conversion
+overhead. Thus, even in situations in which characters are confined to the
+ASCII range, if wide functions are available in the foreign API, it may
+be more efficient to use them, particularly if the foreign component
+uses that representation internally.
+
+.coNP FFI types @, wstr @ wstr-d and @ wstr-s
The FFI type
.code wstr
corresponds to the C type
.code "wchar_t *"
pointing to the first character of a null terminated wide string.
It converts between Lisp strings and symbols, and C strings.
-The memory management is similar to the
+The family members of
+.code wstr
+have memory management semantics similar to their
.code str
-and
-.code str-d
-types, except that no UTF-8 conversion takes place.
+counterparts, Likewise, under these types also, the null pointer corresponds to
+.codn nil .
+
+Note: because wide characters do not require UTF-8 conversion, the
+.code wstr
+family is more efficient. A
+.code wstr
+string passes into foreign code directly: the Lisp object already contains
+a null-terminated wide character string, and so the pointer to that is
+given directly to the foreign code. Similarly, ownership transfer in
+either direction is a pointer passage with no memory management or conversion
+overheads.
+Whenever some foreign API offers a choice between UTF-8 strings, and wide
+strings, the wide version should be targeted by FFI, particularly if the
+API is known to works with wide strings internally also.
.coNP FFI types @ buf and @ buf-d
The
@@ -65378,7 +84593,7 @@ type syntax which specifies a size.
Under the
.code buf
type's put operation, no memory allocation takes place. The pointer to the
-buffer object's data is is written into the argument space, so the foreign
+buffer object's data is written into the argument space, so the foreign
function can manipulate the buffer directly. If the object isn't a buffer
but rather the symbol
.codn nil ,
@@ -65463,11 +84678,29 @@ the foreign function alters the pointer.
.coNP FFI type @ closure
The
.code closure
-type converts two kinds of Lisp objects to a C pointer: the
+type converts three kinds of Lisp objects to a C pointer: the object
+.codn nil ,
+the
+.code cptr
+type, or the special
+.code ffi-closure
+type.
+
+When the
+.code nil
+symbol is converted to a
+.code closure
+type, it becomes a null function pointer.
+
+A
.code cptr
-type, and the special
+object of any kind converts to a
+.codn closure ;
+the internal pointer is converted to a function pointer.
+
+Instances of the
.code ffi-closure
-type, whose instances are produced by the
+type are produced by the
.code ffi-make-closure
function, or by calls to functions defined by the
.code deffi-cb
@@ -65476,6 +84709,15 @@ macro. The
type is useful for passing callbacks to foreign functions: Lisp functions
which appear to be C functions to foreign code.
+In the reverse direction, when a
+.code closure
+object is converted from the foreign function pointer representation
+to a Lisp object, it becomes a
+.code cptr
+object whose tag is the
+.code closure
+symbol.
+
.coNP FFI type @ void
The
.code void
@@ -65527,7 +84769,9 @@ symbol has been assigned the highest possible value of the FFI
type, then an error exception is thrown.
If
+.mono
.meti >> ( sym << value )
+.onom
is given, then
.meta sym
is given the specified value. The
@@ -65536,7 +84780,7 @@ is an expression which must evaluate to an integer value in range of the FFI
.code int
type.
It is evaluated in an environment in which the previous
-symbols from the same enumeration appear as variables whose binding are the
+symbols from the same enumeration appear as variables whose bindings are
their enumeration values, making it possible to use earlier enumerations in the
definition of later enumerations.
@@ -65587,11 +84831,29 @@ The values associated with the enumeration symbols must be in
the representation range of
.metn type ,
which is not checked until the conversion of a symbol
-through the enumeration is is attempted at run time.
+through the enumeration is attempted at run time.
+
+The
+.code enumed
+type is a clone of the underlying type, inheriting most of its properties.
+In particular, it is possible to derive an
+.code enumed
+type from an underlying bitfield type. The resulting type is still a bitfield,
+and may only be used as a
+.code struct
+or
+.code union
+member. Moreover, because it is a bitfield type, there is a restriction against
+creating aliases for it with
+.codn typedef .
+
+An
+.code enumed
+bitfield allows the values of a bit field to be specified symbolically.
.coNP FFI type @ struct
.synb
-.mets (struct < name >> {( slot << type <> [ init-form ])}*)
+.mets (struct < name >> {( slot < type <> [ init-form ])}*)
.syne
.desc
The FFI
@@ -65602,11 +84864,12 @@ and a C
.codn struct .
The
.meta name
-argument of the syntax gives the structure type name, known as the tag.
+argument of the syntax gives the structure type's name, known as the tag.
If this argument is the symbol
-.meta nil
+.code nil
then the structure type is named by a newly generated uninterned
-symbol (gensym).
+symbol (with
+.codn gensym ).
The
.meta name
@@ -65622,7 +84885,7 @@ name associated with the FFI type.
The
.meta slot
and
-.code type
+.meta type
pairs specify the structure members. The
.meta slot
elements must be symbols, and the
@@ -65630,8 +84893,8 @@ elements must be symbols, and the
elements must be FFI type expressions.
A
-.meta struct
-definition with no member refers to a previously defined
+.code struct
+definition with no members refers to a previously defined
.code struct
or
.code union
@@ -65645,14 +84908,14 @@ If no prior
.code struct
or
.code union
-exists, then a definition with no slots specifies a new,
-structure type that is incomplete.
+exists, then a definition with no slots specifies a new, incomplete
+structure type.
A
-.meta struct
+.code struct
definition with no members never causes a Lisp structure type to be created.
A
-.meta struct
+.code struct
definition that specifies one or more members either defines a new structure
type, or completes an existing one. If an incomplete structure or union
type which has the same
@@ -65670,7 +84933,7 @@ same
already exists, then the newly appearing definition replaces that type
in the tag namespace.
-A struct
+A
.code struct
definition with members is entered into the
.cod3 struct / union
@@ -65682,7 +84945,7 @@ except in the special situation when that member causes the type to become
a flexible structure, described several paragraphs below.
A
-.meta struct
+.code struct
definition that specifies members causes a Lisp
.code struct
having the same
@@ -65765,7 +85028,7 @@ and
.code bit
compound type operators.
-A structure member must not be an incomplete or zero sized array,
+A structure member must not be an incomplete or zero-sized array,
unless it is the last member. If the last member of FFI structure is
an incomplete array, then it is a flexible structure.
@@ -65804,9 +85067,10 @@ The
.meta name
argument specifies the name for the union type, known as a tag.
If this argument is the symbol
-.meta nil
+.code nil
then the union type is named by a newly generated uninterned
-symbol (gensym).
+symbol (with
+.codn gensym ).
The
.meta name
@@ -65961,7 +85225,7 @@ to manage the conversion.
The
.meta dim
argument is an ordinary Lisp expression expanded and evaluated in the
-top-level environment. It must produce a non-negative integer value.
+top-level environment. It must produce a nonnegative integer value.
In addition, several types are treated specially: when
.meta type
@@ -65981,8 +85245,11 @@ element, it denotes a variable length
array. It corresponds to the concept of an incomplete array
in the C language, except that no implicit array-to-pointer conversion
concept is implemented in the FFI type system. This type may not
-be used as an array element or structure member. It also may not
+be used as an array element or structure member, other than as the
+last structure member. It also may not
be passed or returned by value, only by pointer.
+If the last member of a structure has this type, then it is a flexible
+array member; see the Flexible Structures section below.
Since the type has unknown length, it has a trivial get operation which returns
.codn nil .
@@ -66073,11 +85340,11 @@ converts it to a Lisp string accordingly. The regular
type doesn't assume null termination. In particular, this means that whereas
.code "(array 42 char)"
will decode 42 bytes of UTF-8, even if some of them are null, converting
-those null bytes the U+DC00 pseudo-null, in contrast, a
+those null bytes to the U+DC00 pseudo-null, in contrast, a
.code zarray
will treat the 42 bytes as a null-terminated string, and decode UTF-8 only
up to the first null.
-In the other direction, when converting from Lisp string to the foreign array,
+In the other direction, when converting from Lisp string to foreign array,
.code zarray
ensures null termination.
@@ -66096,9 +85363,11 @@ syntax which omits the
.meta dim
argument specifies a null-terminated variant of the variable-length array.
Like that type, it corresponds to the concept of an incomplete
-array in the C language. It may not be used as an array element
-or structure member, and cannot be passed as an argument or returned
-as a value.
+array in the C language. It may not be used as an array element,
+and may not be used as a structure member other than the last member.
+It cannot be passed as an argument or returned as a value.
+If the last member of a structure has this type, then it is a flexible
+array member; see the Flexible Structures section below.
Unlike the ordinary variable-length
.codn array ,
@@ -66133,7 +85402,7 @@ using a C pointer as the external representation.
When used for passing a value to a foreign function, the
.code ptr
type has in-out semantics: it supports the interfacing concept that
-the called function can update datum which has been passed to it "by pointer",
+the called function can update the datum which has been passed to it "by pointer",
thereby altering the caller's object. Since a Lisp value requires a conversion
to the FFI external representation, it cannot be directly passed by pointer.
Instead, this semantics is simulated. The put semantics of
@@ -66169,7 +85438,7 @@ valid pointer. The pointer is retrieved from the argument space, and the
Lisp value is encoded into the memory referenced by that pointer.
Note that only Lisp objects with mutable slots can be meaningfully passed by
-pointer with in-out semantics. If a Lisp objects without immutable slots, such
+pointer with in-out semantics. If a Lisp object without immutable slots, such
as an integer, is passed using
.code ptr
the incoming updated value of the external representation will be ignored.
@@ -66190,7 +85459,7 @@ member is declared as of type
then the Lisp
.code struct
is expected to have an integer-valued slot corresponding to that member.
-The slot is then subject to a bi-directional transfer. FFI will create an
+The slot is then subject to a bidirectional transfer. FFI will create an
.codn int -sized
temporary data area, encode the slot into that area and place that area's
pointer into the encoded structure. After the call, the new value of the
@@ -66415,7 +85684,7 @@ The
.code ubit
and
.code sbit
-types denote C language style bitfields. These types can only appear
+types denote C-language-style bitfields. These types can only appear
as members of structures. A bitfield type cannot be the argument or return
value of a foreign function or closure, and cannot be a foreign variable.
Arrays of bitfields and pointers, of any kind, to bitfields are a forbidden
@@ -66482,7 +85751,7 @@ are given in the paragraph below entitled
A
.code ubit
field stores values which follow a pure binary enumeration. For instance,
-a bit field of width 4 stores values from 0 to 15. On conversion from
+a bitfield of width 4 stores values from 0 to 15. On conversion from
the Lisp structure to the foreign structure, the corresponding member
must be a integer value in this range, or an error exception is thrown.
@@ -66490,7 +85759,7 @@ On conversion from the foreign representation to Lisp, the integer
corresponding to the bit pattern is recovered. Bitfields follow the
bit order of the underlying storage word. That is to say, the most
significant binary digit of the bitfield is the one which is closest
-to the the most significant bit of the underlying storage unit.
+to the most significant bit of the underlying storage unit.
If a four-bit field is placed into an empty storage unit and the value
8 its stored, then on a big-endian machine, this has the effect of
setting to 1 the most significant bit of the underlying storage word.
@@ -66501,7 +85770,7 @@ The
.code sbit
field creates a correspondence between a range of Lisp integers,
and a foreign representation based on the two's complement system.
-The most significant bit of the bit field functions as a sign bit.
+The most significant bit of the bitfield functions as a sign bit.
Values whose most significant bit is clear are positive, and use
a pure binary representation just like their
.code ubit
@@ -66509,8 +85778,8 @@ counterparts. The representation of negative values is defined
by the "two's complement" operation, which maps each value to
its additive inverse. The operation consists of temporarily treating the
entire bitfield as unsigned, and inverting the logical value of all the
-bits, and then adding 1 with "wrap-around" to zero if 1 is added to a field
-consisting of all 1 bits. (Thus zero maps to zero, as expected).
+bits, and then adding 1 with "wraparound" to zero if 1 is added to a field
+consisting of all 1 bits. (Thus zero maps to zero, as expected.)
An anomaly in the two's complement system is that the most negative
value has no positive counterpart. The two's complement operation
on the most negative value produces that same value itself.
@@ -66539,25 +85808,7 @@ operator is more general than
.code ubit
and
.codn sbit .
-It allows for bitfields based on integer units smaller than or equal to
-.codn uint .
-
-The
-.meta type
-argument may be any of the types
-.codn char ,
-.codn short ,
-.codn int ,
-.codn uchar ,
-.codn ushort ,
-.codn uint ,
-.codn int8 ,
-.codn int16 ,
-.codn int32 ,
-.codn uint8 ,
-.code uint16
-and
-.codn uint32 .
+It allows for bitfields based on on any integer type up to 64 bits wide.
When the character types
.code char
@@ -66567,7 +85818,7 @@ are used as the basis of bitfields, they convert integer values, not
characters.
In the case of
.codn char ,
-the bitfield is signed.
+the bitfield is signed.
All remarks about
.code ubit
@@ -66581,6 +85832,82 @@ Details about the algorithm by which bitfields are allocated within a structure
are given in the paragraph below entitled
.BR "Bitfield Allocation Rules" .
+Under the
+.code bit
+operator, the endian types such as
+.code be-int32
+or
+.code le-int16
+may also be used as the basis for bitfields.
+If
+.meta type
+is an endian type, the bitfield is then allocated in the same way that a
+bitfield of the corresponding ordinary type would be allocated on a target
+machine which has the byte order of that endian type.
+
+When a bitfield member follows a member which has a different byte order,
+the bitfield is placed into a new allocation cell. This is true even if
+the previous member has the same alignment.
+
+Note: the allocation of bits within a bitfield based on a byte storage
+cells also differs between different endian systems. However, the FFI
+type system does not offer one byte endian types such as
+.codn be-uint8 .
+The workaround is to switch to a wider type.
+
+Note: endian bitfields may be used to match the image of a C structure which
+contains bitfields, without having to conditionally define the FFI struct type
+differently based on whether the current machine is big or little endian.
+Conditionally defining a structure for two different byte orders adds
+verbiage to the program and is highly error-prone, since the bitfields
+change order within an allocation unit.
+
+For instance, on a big endian system, the definition of a structure
+representing an IPv4 packet might begin like this:
+
+.verb
+ (struct ipv4-header
+ (ver (bit 4 uint16))
+ (ihl (bit 4 uint16))
+ (dscp (bit 6 uint16))
+ (ecn (bit 2 uint16))
+ (len uint16)
+ ...)
+.brev
+
+to port this to a little endian system, the programmer has to recognize
+that the first pair of fields is packed into one byte, and the next pair
+of fields into a second byte. The bytes stay in the same order, but
+the pairs are reversed:
+
+.verb
+ (struct ipv4-header
+ (ihl (bit 4 uint16)) ;; reversed pair
+ (ver (bit 4 uint16))
+ (ecn (bit 2 uint16)) ;; reversed pair
+ (dscp (bit 6 uint16))
+ (len be-uint16)
+ ...)
+.brev
+
+Endian bitfields allow this to be defined naturally. The IPv4 header
+is based on network byte order, which is big-endian, so big endian types
+are used. The little endian version above already uses
+.code be-uint16
+for the
+.meta len
+field. This just has to be done for the bitfields also:
+
+.verb
+ (struct ipv4-header
+ (ver (bit 4 be-uint16))
+ (ihl (bit 4 be-uint16))
+ (dscp (bit 6 be-uint16))
+ (ecn (bit 2 be-uint16))
+ (len be-uint16)
+ ...)
+.brev
+
.coNP FFI types @ buf and @ buf-d
.synb
.mets ({buf | buf-d} << size )
@@ -66597,7 +85924,7 @@ and
respectively. The
.meta size
argument is an expression which is evaluated in the top-level
-environment, and must produce a non-negative integer.
+environment, and must produce a nonnegative integer.
Because they have a size, these types have useful get
semantics.
@@ -66643,8 +85970,7 @@ a freshly allocated
.code carray
object which holds that pointer, and is marked as having an unknown
size. No copy is made of the underlying array. When the application
-determines the size of the array, it can inform that object by means
-of calling the
+determines the size of the array, it can inform that object by calling the
.code carray-set-length
function.
@@ -66657,13 +85983,42 @@ whose element type matches that of the FFI type.
The
.code carray
-type lacks in or out semantics, since FFI doesn't manage any foreign
-memory for the passage of a
+type has in semantics. When a
+.code carray
+is passed to a foreign function as an argument to a
+.code ptr
+or
+.code ptr-out
+parameter to either a
+.code carray
+or
+.code cptr
+type, what is passed to the function is a pointer to the
+.codn carray 's
+pointer. The foreign function may update this pointer to a
+new value, and this value is stored back into the
+.code carray
+object. The array's length is reset to zero.
+If it is an owned
+.codn carray ,
+arranged by
+.codn carray-own ,
+then the current array freed before the new pointer is assigned,
+and the object's type is reset to borrowed array. The
+.code carray
+object must not be memory mapped
+.code carray
+coming from the
+.code mmap
+function.
+
+The
.code carray
-and any two-directional communication of data through the array
-handled by performing direct operations on the
+type lacks out semantics, since Lisp code cannot change its address;
+so there is no new pointer to propagate back to a foreign caller
+which passes a
.code carray
-Lisp object in application code.
+to a Lisp callback, and no other memory management tasks to perform.
The
.code carray
@@ -66672,7 +86027,7 @@ foreign code generates such an array, and the size of that array
isn't known from the object itself.
It is also useful, instead of a variable-length
-.code zarray
+.codn zarray ,
for passing a dynamic array to foreign code in situations when the application benefits
from managing the memory for the array. The variable-length
.code zarray
@@ -66703,6 +86058,13 @@ It is possible to create a
view over a buffer, using
.codn carray-buf .
+Lastly, the
+.code carray
+type is the basis for the \*(TL
+.code mmap
+function, which is documented in the section
+.BR "Unix Memory Mapping" .
+
.coNP FFI type @ cptr
.synb
.mets (cptr << type-sym )
@@ -66714,7 +86076,10 @@ type is similar to the unparametrized
.codn cptr .
It also converts between Lisp objects of type
.code cptr
-and foreign pointers. However, it provides a measure of type safety.
+and foreign pointers. Unlike the unparametrized type, it provides a measure of
+type safety, and also supports the conversion of
+.code carray
+objects.
When a foreign pointer is converted to a Lisp object under control of the
parametrized
@@ -66745,7 +86110,34 @@ is specified as
.codn nil ,
then this is precisely equivalent to the unparametrized
.code cptr
-which doesn't provides the above safety measure.
+which doesn't provide the above safety measure.
+
+A
+.code carray
+object may also be converted to a foreign pointer under the control of
+a parametrized
+.code cptr
+type. The
+.code carray
+object's internal pointer becomes the foreign pointer value.
+The conversion is only permitted if the following two restrictions are not met,
+otherwise an error exception is thrown.
+Firstly, the
+.meta type-sym
+of the
+.code cptr
+type must be the name of an FFI type, at the time when the
+.code cptr
+type expression is processed, otherwise the
+.code cptr
+is not associated with a type.
+Secondly, the
+.code carray
+object being converted must have an element type which matches the
+FFI type denoted by the
+.code cptr
+object's
+.metn type-sym .
Pointer type safety is useful, because FFI can be used to create bindings
to large application programming interfaces (APIs) in which objects of
@@ -66760,32 +86152,70 @@ If handles of different types are all mapped to
types with different tags, the situation is intercepted and diagnosed
with an error exception.
-.coNP FFI type @ align
+.coNP FFI types @ align and @ pack
.synb
-.mets (align < width << type )
+.mets (align <> [ width ] << type )
+.mets (pack <> [ width ] << type )
.syne
.desc
-The FFI type operator
+The FFI type operators
.code align
-defines a type which is a copy of
+and
+.code pack
+define a type which is a copy of
.metn type ,
-but with the alignment requirement replaced by the
-.metn width .
+but with adjusted alignment requirements. In some cases,
+.code pack
+(but not
+.codn align )
+works by replacing itself with a transformed version of the
+.code type
+syntax.
-The
+If the
.meta width
-argument is an expression which is evaluated in the top-level
+argument is present, it is an expression which is evaluated in the top-level
environment. It must produce a positive integer which is a power of two.
+If
+.meta width
+is absent, a different default value is used depending on which type
+operator is specified. For
+.codn align ,
+it defaults to some platform-specific maximum useful alignment value,
+typically 16.
+For
+.codn pack ,
+a missing
+.meta width
+defaults to 1.
+
The
.code align
operator can be used to create a version of
.meta type
-with stricter or weaker alignment. Alignment affects the placement of
+which is aligned at least as strictly as the specified
+.metn width .
+That is to say, values of
+.meta width
+which are less than or equal to
+.metn type 's
+existing alignment have no effect on alignment, except when the
+type is used as a bitfield.
+
+The
+.code pack
+operator can be used to create a version of
+.meta type
+which is less strictly aligned than its existing alignment.
+
+Alignment affects the placement of
the type as a structure member, and as an array element.
-A type with alignment 1 can be placed at any byte offset. A type with
-alignment 2 can be placed only at even addresses and offsets.
+A type with alignment 1, like the default alignment for
+.codn pack ,
+can be placed at any byte offset, and thus is effectively unaligned. A type
+with alignment 2 can be placed only at even addresses and offsets.
Alignment can be applied to all types, including arrays and structs.
It may also be applied to bitfields, but special considerations have
@@ -66805,28 +86235,246 @@ a structure can be read or written at the misaligned offsets depends on whether
the individual members support it. If they are integer or floating-point types,
or aggregates thereof, the usage is supported in a machine-independent manner.
-A struct type declared to have a weaker alignment, such as 1, does not
-lose any of the padding at its end. That is to say, alignment has no effect
-on structure size. It affects the offset at which a structure is placed as
-a member of an array or another structure, with its padding intact. To
-eliminate the padding at the end of a structure, it is necessary to use
-.code align
-to manipulate the alignment of individual members.
+Alignment interacts with the allocation of bitfields in special ways. If
+.meta width
+is greater than 1, or regardless of
+.meta width
+if the operator is
+.codn align ,
+the type is marked with a Boolean attribute indicating that it has
+altered alignment. Then, when a bitfield is based on a type which has altered
+alignment, then that bitfield isn't packed together with the previous
+field, even if the allocation rules otherwise call for it. Due to the
+alignment request, the byte offset is first adjusted according to the requested
+alignment and the bit offset is reset to zero. The bit field is then allocated
+at the new alignment. This requirement applies even if the requested alignment
+is 1, which is possible via a combination of both
+.code pack
+and
+.codn align ,
+both specified with a
+.meta width
+of 1. If the requested alignment for the type of a bitfield is 1, and
+the previous member is a bitfield which has left a byte partially filled,
+then the new bitfield starts on a fresh byte, even if it would otherwise
+be packed with the previous bitfield. If a named bitfield has weakened
+alignment, other than one byte alignment produced by
+.codn pack ,
+the bitfield's original type's alignment is used for the purposes of
+determining its contribution to the alignment of the structure.
When
+.meta type
+is one of two kinds of types, the
+.code pack
+type operator exhibits special behaviors, as follows.
+In these situations, the
+.code pack
+operator has no semantics other than these behaviors.
+.RS
+.IP 1.
+When
+.meta type
+is
+.code struct
+or
+.code union
+syntax which defines at least one member, then the
+.code pack
+operator performs the following syntactic transformation:
+each member of
+.meta type
+is edited, by specifying a
+.code pack
+operator around its type, with the given
+.metn width .
+The surrounding
+.code pack
+operator is deleted.
+The effect is that
+.code pack
+is applied not to the struct or union type itself, but to its members.
+For example
+.code "(pack (struct s (x int) (y double))"
+is transformed into
+.codn "(struct s (pack 1 (x int)) (pack 1 (y double)))" .
+The 1 comes from the defaulting of
+.metn width .
+
+The rationale for this behavior is that alignment weakening is often
+required for all members of a structure, rather than select members. Moreover,
+specifying weak alignment for a structure type itself, while leaving members
+with strict alignments, rarely makes sense. Weakening the alignment of a
+structure will not eliminate the padding between the members or at the end;
+it will only have any useful effect when that structure is itself used
+as the member of another structure.
+An important rationale also is that the GNU C
+.code packed
+attribute works this way, and so C structures declarations using
+that attribute are easier to translate to the \*(TL FFI type system.
+
+Deriving a less strictly aligned version of a structure or union type without
+any effect on the alignment of its members may be obtained by applying the
+.code bit
+operator to either
+.code typedef
+name for a structure or union type, or else to syntax which refers
+to an existing type without defining members.
+Given the definition
+.codn "(typedef s (struct s (a int) (b char)))" ,
+the type
+.code s
+is an eight byte structure with three bytes of padding at the end, which has
+four byte alignment. The type expression
+.code "(pack s)"
+produces a version of this type which has one byte alignment.
+The expression
+.codn "(pack (struct s))" ,
+likewise. The resulting
+unaligned type is still eight bytes wide, and has three padding bytes.
+In other words, the
+.code pack
+operator does not transform the syntax of a structure which is already
+defined as an object,
+
+.IP 2.
+When
+.meta type
+is a
.code align
-is applied to the type of a bitfield member of a structure, it has no effect on
-placement. The alignment of a non-zero bitfield which begins a new
-storage unit is taken into consideration for the purpose of determining
-the most strictly alignment member of the structure. The alignment of all
-other bitfields is ignored.
-.PP
+operation, then
+.code pack
+transforms the syntax as follows: the
+.code pack
+operator surrounding the
+.code align
+expression is removed, and introduced around the type expression
+that is
+.codn align 's
+own operand. Thus
+.code "(pack 2 (align 16 int))"
+is transformed into
+.codn "(align 16 (pack 2 int))" .
+
+The rationale for this transformation is that when both
+.code align
+and
+.code pack
+are applied to a type, the combination only makes sense when
+.code pack
+is first. For a non-structure type like
+.codn int ,
+.code "(pack x (align y int))"
+is equivalent to just
+.codn "(pack x int)" ,
+because
+.code pack
+will set the alignment to
+.code x
+regardless of the effect of
+.codn align .
+Whereas
+.code "(align y (pack x int))"
+is meaningful in that the
+.code align
+takes precedence over
+.code pack
+if
+.codn "(> y x)" .
+The main rationale is that
+.code pack
+may be applied to structure members via a code transformation.
+Those members may already have types which use
+.codn align .
+This transformation ensures that the semantics is applied
+in a useful order.
+For example
+.code "(pack (struct s (a char) (x (align 2 int))))"
+is first transformed into
+.codn "(struct s (a (pack 1 char)) (x (pack 1 (align 2 int)))))" .
+If this is left as-is, then the
+.code align
+on
+.code x
+is obliterated by the
+.codn pack ,
+rendering it useless.
+A further transformation takes place to
+.codn "(struct s (a (pack 1 char)) (x (align 2 (pack 1 int)))))" .
+Now the
+.code align
+directive is increasing the alignment of
+.code x
+to 2, so that
+.code x
+will be placed at offset 2, leaving one byte of padding after the
+.code a
+member. This is how attributes work in GNU C also: the
+.code aligned
+attribute on the member of a packed structure can take precedence
+and increase its alignment.
+
+.RE
+
+.IP
+After these transformations are applied, the nested
+.code pack
+forms which occur in the transformed syntax may perform
+more such transformations, depending on their operands.
+
+Note that the two-argument form of
+.code pack
+with a
+.meta width
+value greater than 1 doesn't directly correspond to any
+single attribute specifier in GNU C. The GNU C
+.code packed
+attribute is Boolean, implicitly reducing alignment to 1.
+A combination of the GNU C attributes
+.code aligned
+and
+.code packed
+is used to produce the effect of
+.mono
+.meti (pack < n << type )
+.onom
+for values of
+.meta n
+> 1.
+In GNU C, the
+.code packed
+attribute, when applied to a structure, distributes to its members,
+but isn't capable of distributing an alignment exceeding 1. So the
+.mono
+.meti (pack < n (struct ...))
+.onom
+expression, for values of
+.meta n
+> 1, doesn't correspond to anything in GNU C; its effect
+can be simulated by attributing the structure type with
+.codn packed ,
+and then individually applying the required alignment to
+the member declarations.
.SS* Additional Types
-.coNP FFI types @, size-t @, ptrdiff-t @, int-ptr-t @, uint-ptr-t @, wint-t @, sig-atomic-t @ time-t and @ clock-t .
+.coNP FFI types @, size-t @, ptrdiff-t @, int-ptr-t @, uint-ptr-t @, intmax-t @, uintmax-t @ wint-t @, sig-atomic-t @ time-t and @ clock-t
+.desc
These additional FFI types for common C language types are provided as
.code typedef
aliases.
+The
+.code intmax-t
+and
+.code uintmax-t
+types are provided only if the host platform's
+.code intmax_t
+is no wider than 64 bits. If the host platform lacks
+.code intmax_t
+then the above two FFI types are defined as aliases for
+.code longlong
+and
+.codn ulonglong ,
+respectively.
.coNP FFI type @ qref
.synb
@@ -66889,7 +86537,7 @@ The macro expression
is equivalent to the expression
.codn "(ffi (elemtype X))" .
-.coNP FFI types @, blkcnt-t @, blksize-t @, clockid-t @, dev-t @, fsblkcnt-t @, fsfilcnt-t @, gid-t @, id-t @, ino-t @, key-t @, loff-t @, mode-t @, nlink-t @, off-t @, pid-t @ ssize-t and @ uid-t
+.coNP FFI types @, blkcnt-t @, blksize-t @, clockid-t @, dev-t @, fsblkcnt-t @, fsfilcnt-t @, gid-t @, id-t @, ino-t @, key-t @, loff-t @, mode-t @, nlink-t @, off-t @, pid-t @, ssize-t @ uid-t and @ socklen-t
The additional names of various common POSIX types may also be available,
depending on platform. They are provided as
.code typedef
@@ -66925,7 +86573,7 @@ and the two floating-point types
.code float
and
.codn double ,
-the FFI type system provides a big-endian and little endian version,
+the FFI type system provides a big-endian and little-endian version,
whose names are derived by prefixing the
.code be-
or
@@ -67004,7 +86652,7 @@ stored in the last slot of the Lisp structure. The length includes the
terminating null element for
.code zarray
types. The conversion is consistent with the semantics of an incomplete
-arrays that is not a structure member.
+array that is not a structure member.
In the reverse direction, when a foreign representation is being converted
to a Lisp structure under the control of a flexible structure FFI type,
@@ -67014,9 +86662,9 @@ is a
.code zarray
from detecting null-termination of the foreign array. The conversion of
the array itself is consistent with the semantics of an incomplete
-arrays that is not a structure member.
+array that is not a structure member.
Before the conversion takes place, all of the members of the
-structure prior to the the terminating array, are extracted and converted to
+structure prior to the terminating array, are extracted and converted to
Lisp representations. The corresponding slots of the Lisp structure are
updated. Then if the Lisp structure type has a
.code length
@@ -67081,16 +86729,6 @@ bitfield, according to the bitfield's width, then the bitfield is
placed into that unit. Otherwise, the bitfield is placed into the
next available unit.
-Whenever a bitfield is placed at the start of new unit of its size,
-it is called the
-.IR "leading bitfield" .
-The alignment of the leading bitfield is taken into account for
-the purposes of determining the most strictly aligned member of
-the structure. This alignment property of the leading bitfield
-can be altered with the
-.code align
-type operator, applied either to the bitfield type, or to its base type.
-
After a bitfield is placed, the values of
.I O
and
@@ -67113,7 +86751,9 @@ partially filled, then
is adjusted to point to the next unit after that, and
.I B
is reset to zero. Note that according to this semantics, a zero-width bitfield
-can have an effect even if placed between non-bitfield members.
+can have an effect even if placed between non-bitfield members, or appears
+as the last member of a structure. Also, a structure containing only a
+zero-width bitfield has size zero.
If, after the placement of all structure members,
.I B
@@ -67124,10 +86764,17 @@ is incremented by one to cover that byte.
As the last allocation step, the size of the structure is then padded up to a
size which is a multiple of the alignment of the most strictly aligned member.
+A named bitfield contributes to the alignment of the structure, according to
+its type, the same way as a non-bitfield member of the same type.
+An unnamed bitfield doesn't contribute alignment, or else may be regarded as
+having the weakest possible alignment, which is byte alignment.
+If all of the members of a structure are unnamed bitfield members of any type,
+it exhibits byte alignment.
+
The description isn't complete without a treatment of byte and bit order.
Bitfield allocation follows an imaginary "bit endianness" whose direction
-follows the machine's byte order: most significant bits are allocated first on
-big endian, least significant bits first on little-endian.
+follows the machine's byte order: most-significant bits are allocated first on
+big endian, least significant bits first on little endian.
If a one-bit-wide bitfield is allocated into a hitherto empty structure, it
will be placed into the first byte of that structure, regardless of the
@@ -67136,18 +86783,77 @@ that bitfield. Within that first byte, it will be placed into the most
significant bit position on a big-endian machine (bit 7); and on a
little-endian machine, it will be placed into the least significant bit
position (bit 0). If another one-bit-wide is allocated, it is placed into
-bit 6 on big-endian, and bit 1 on little-endian.
+bit 6 on big endian, and bit 1 on little endian.
More generally, whenever a bitfield is allocated for a big-endian machine, and
-the storage unit is determined into which that bitfield shall be placed, that
-field will be placed at that unit's most significant bit position that is still
-available for allocation. On a little-endian machine, that field will be placed
-at the least significant available bit position of the storage unit. On either
-type of machine, that field will be placed at the lowest-addressed byte or
-bytes that are available, and within that byte or those bytes, the field
-will occupy the most significant bit positions that are available. If the
-field partially occupies a byte, the bits that remain free are the least
-significant ones.
+the storage unit is determined into which that bitfield shall be placed, the
+most significant bits of that storage unit are filled first on a big-endian
+machine, whereas the least significant bits are filled first on a little-endian
+machine. From this it follows that on either type of machine, that field shall
+be placed at the lowest-addressed byte or bytes in which unallocated bits
+remain.
+
+.SS* Returning Scalar Objects by Pointer
+
+There are situations in which an a foreign function takes the address of a
+storage location, and writes a new value into that location. Informally,
+this referred to as an "out parameter" or "in-out parameter", in the
+case of bidirectional data transfer. In the C language, the familiar pattern
+looks like this:
+
+.verb
+ void function(int *ptr);
+ int val = 0;
+ function(&val);
+.brev
+
+In the case of an aggregate type, such as a structure, being an in-out or out
+parameter, this pattern is easily handled in FFI because the corresponding
+Lisp object is also an aggregate, and therefore has reference semantics:
+it can be updated to receive the new value. In the case of a scalar, however,
+such as
+.code int
+in the above example, this may not be not possible. A Lisp integer
+doesn't have the referential semantics required to receive a new value by
+pointer, and there is no "address-of" concept to create a reference to
+its location.
+
+To understand the following FFI trick, it helps to first rework the C into a
+different form:
+
+.verb
+ void function(int *ptr);
+ int val[1] = { 0 };
+ abc_function(val);
+.brev
+
+Instead of a scalar value, we can declare an array of 1 element of that
+same type, and pass the array (which converts into a pointer to that element).
+This approach inspires a similar trick in the FFI domain:
+
+.verb
+ (with-dyn-lib (...)
+ (deffi abc-function "abc_function" void ((ptr (array 1 int)))))
+
+ (let ((val (vec 0)))
+ (abc-function val)
+
+ ;; [vec 0] has updated value coming from function
+ )
+.brev
+
+We define the parameter of
+.code abc-function
+as being a pointer to an array of 1
+.code int
+rather than an int, and then pass a vector as the argument.
+If the parameter is in-out, then the vector must be constructed or initialized
+to contain a value that will convert to the C type. If the parameter is out
+only, then the FFI definition can use
+.code ptr-out
+and the vector can contain the
+.code nil
+value.
.SS* FFI Call Descriptors
@@ -67180,7 +86886,7 @@ in the call descriptor mechanism for expressing a variadic function,
it expresses a particular
.B instance
of a variadic function, rather than the variadic function's type
-.IR "per se" .
+per se.
To call the same variadic function using different variadic arguments,
different call descriptors are required. For instance to perform
the equivalent of the C function call
@@ -67226,7 +86932,8 @@ a Lisp expression denoting FFI syntax.
.coNP Function @ ffi-make-call-desc
.synb
-.mets (ffi-make-call-desc < ntotal < nfixed < rettype << argtypes )
+.mets (ffi-make-call-desc < ntotal < nfixed < rettype
+.mets \ \ < argtypes <> [ name ])
.syne
.desc
The
@@ -67235,18 +86942,21 @@ function constructs a FFI call descriptor.
The
.meta ntotal
-argument must be a non-negative integer; it indicates the number
+argument must be a nonnegative integer; it indicates the number
of arguments in the call.
If the call denotes a variadic function, the
.meta nfixed
-argument must be an integer between 1 and
+argument must be an integer at least 1 and less than
.metn ntotal ,
denoting the number of fixed arguments.
If the call denotes an ordinary, non-variadic function, then
.meta nfixed
-must be specified as
-.codn nil .
+must either be specified specified as
+.code nil
+or else equal to the
+.meta ntotal
+argument.
The
.meta rettype
@@ -67265,12 +86975,39 @@ If the function is variadic, then the first
elements of this list specify the types of the fixed arguments;
the remaining elements specify the variadic arguments.
+The
+.meta name
+argument gives the name of the function for which this description is intended,
+or some other identifying symbol. This symbols is used in diagnostic messages
+related to errors in the construction of the descriptor itself or its
+subsequent use. If this parameter is omitted, then the involved FFI functions
+use their own names in reporting diagnostics.
+
Note: variadic functions must not be called using a non-variadic
-descriptor, and
-.IR "vice versa" ,
+descriptor, and vice versa,
even if the return types and
argument types match.
+Note: unlike the
+.code deffi
+and
+.code deffi-cb
+macros,
+the
+.code ffi-make-call-desc
+function doesn't perform any special treatment of variadic parameter types.
+When any of the types
+.codn float ,
+.code be-float
+or
+.code le-float
+occur in the variadic portion of
+.metn argtypes ,
+it is unspecified whether a descriptor is successfully produced and returned
+or whether an exception is thrown. If a descriptor is successfully produced,
+and then subsequently used for making or accepting calls, the behavior is
+undefined.
+
.TP* Example:
.verb
@@ -67369,7 +87106,7 @@ the capture of delimited continuations across foreign code. Delimited
continuations can be captured inside a closure dispatched that way, but the
delimiting prompt must be within the callback's local stack frame, without
traversing across the foreign stack frames. Secondly, a callback closure which
-is safely dispatched doesn't permit direct non-local control transfers across
+is safely dispatched doesn't permit direct nonlocal control transfers across
foreign code, such as exception handling. Such transfers, however, appear to
work anyway (with caveats): this is because they are specially handled. The
closure dispatch mechanism intercepts all dynamic control transfers, converts
@@ -67443,7 +87180,7 @@ object. It is assumed to point to a foreign function.
The
.meta call-desc
argument must be a FFI call descriptor, produced by
-.codn ffi-call-desc .
+.codn ffi-make-call-desc .
The
.meta call-desc
@@ -67489,7 +87226,8 @@ type object it represents.
The
.code ffi-typedef
-function returns type.
+function returns
+.metn type .
.TP* Example:
@@ -67715,7 +87453,7 @@ macros.
When a
.code deffi
form appears as one of the
-.metn body-form -s
+.metn body-form s
of the
.code with-dyn-lib
macro, that
@@ -67806,7 +87544,7 @@ holds the library handle.
.coNP Macro @ deffi
.synb
-.mets (defmacro deffi < name < fun-expr < rettype << argtypes )
+.mets (deffi < name < fun-expr < rettype << argtypes )
.syne
.desc
The
@@ -67841,14 +87579,15 @@ literal list, using FFI type syntax. The macro arranges for these types
to be compiled. Furthermore, a special convention may be used for
specifying a variadic function: if the
.code :
-(colon keyword)
-symbol appears as one of the elements of
+(colon)
+keyword symbol appears as one of the elements of
.metn argtypes ,
then the
.code deffi
form specifies a fixed call to a foreign function which is variadic. The
-argument types before the colon keyword are the fixed arguments. The types
-after the colon, if any, are the variadic arguments.
+argument types before the colon keyword are the types of the fixed arguments.
+The types after the colon, if any, are of the variadic arguments. Special
+considerations apply to some variadic argument types, described below.
The following syntactic variants are permitted of the
.meta fun-expr
@@ -67862,7 +87601,7 @@ is a literal string, then the
form must be enclosed in the
.code with-dyn-lib
macro, appearing as one of that macro's
-.metn body-form -s.
+.metn body-form s.
In this situation the literal character string
.meta name-string
specifies a symbol to be found within the library established by the
@@ -67890,6 +87629,40 @@ macro.
.RE
.IP
+When the FFI type
+.code float
+is used as the type of a variadic parameter,
+.code deffi
+replaces it by the FFI type
+.codn double .
+This treatment is necessary because the C variadic argument mechanism promotes
+.code float
+values to
+.codn double .
+Note: due to this substitution, it is possible to pass floating-point values
+which are out of range of the
+.code float
+type, without any diagnosis. The behavior of is undefined in the
+Lisp-to-C direction, if the C function extracts an out-of-range
+.code double
+argument as if it were of type
+.codn float .
+
+The FFI types
+.code be-float
+and
+.code le-float
+cannot be used for specifying the types of a variadic argument. If any of
+these occur in that position,
+.code deffi
+throws an error.
+Rationale: these types are related to the C type
+.code float
+type, which requires promotion in variadic passing. Promotion cannot
+be performed on floating-point values whose byte order has been rearranged,
+because promotion is a value-preserving conversion.
+
+.IP
The result value of a
.code deffi
form is
@@ -67946,7 +87719,7 @@ to be returned by the callback in the event that a dynamic control
transfer is intercepted. The purpose of this value is to indicate
to the foreign code that the callback wishes to abort operation;
it is useful in situations when a suitable return value will induce
-the foreign code to co-operate and itself return to the Lisp code
+the foreign code to cooperate and itself return to the Lisp code
which will then continue the dynamic control transfer.
The
@@ -68039,7 +87812,7 @@ is a literal string, then the
form must be enclosed in the
.code with-dyn-lib
macro, appearing as one of that macro's
-.metn body-form -s.
+.metn body-form s.
In this situation the literal character string
.meta name-string
specifies a symbol to be found within the library established by the
@@ -68091,7 +87864,7 @@ The
is syntax which specifies the foreign pointer, using exactly the same
conventions as described for the
.code deffi-var
-macro, allowing for a short-hand notation if this form is
+macro, allowing for a shorthand notation if this form is
enclosed in a
.code with-dyn-lib
macro invocation.
@@ -68129,6 +87902,36 @@ macro yields the compiled version of
.meta type-syntax
as its value.
+.coNP Macros @ deffi-struct and @ deffi-union
+.synb
+.mets (deffi-struct < name >> {( slot < type <> [ init-form ])}*)
+.mets (deffi-union < name >> {( slot < type <> [ init-form ])}*)
+.syne
+.desc
+The
+.code deffi-struct
+and
+.code deffi-union
+macros provide a more compact notation for defining FFI structure and union
+types together with matching
+.code typedef
+names.
+
+The semantics follows from these equivalences:
+
+.verb
+ (deffi-struct S ...) <--> (typedef S (struct S ...))
+ (deffi-union U ...) <--> (typedef U (union U ...))
+.brev
+
+.TP* Example:
+
+.verb
+ (deffi-struct point
+ (x double)
+ (y double))
+.brev
+
.coNP Macro @ sizeof
.synb
.mets (sizeof < type-syntax <> [ object-expr ])
@@ -68152,7 +87955,8 @@ If
denotes an incomplete array or structure type, and the
.meta object-expr
argument is present, then a
-.I "dynamic size" is computed: the actual number of bytes required to store
+.I "dynamic size"
+is computed: the actual number of bytes required to store
that object value as a foreign representation.
The
@@ -68275,7 +88079,7 @@ FFI type expression to the corresponding type object. The
following equivalence holds:
.verb
- (ffi expr) <--> (ffi-type-compile 'expr)
+ (ffi expr) <--> (load-time (ffi-type-compile 'expr))
.brev
.SS* Zero-filled Object Support
@@ -68334,7 +88138,7 @@ Finally, each slot of the struct which is not initialized via
.meta slot-sym
and
.meta init-value
-pair, and which is known to the FFI type, is re-initialized by a conversion
+pair, and which is known to the FFI type, is reinitialized by a conversion
from a foreign object of all-zero bits to a Lisp value.
argument. The
.code struct
@@ -68675,7 +88479,7 @@ If the read is successful, these bytes are decoded, producing a Lisp
object, which is returned.
If the read is incomplete, the value returned is
-.metn nil .
+.codn nil .
All other stream error situations throw exceptions.
@@ -68685,7 +88489,7 @@ All other stream error situations throw exceptions.
.syne
.desc
The
-.code get-obj
+.code fill-obj
function reads from
.meta stream
the bytes corresponding to a foreign representation according to the FFI type
@@ -68699,7 +88503,7 @@ semantics of the FFI type and returned. If a by-value update of
isn't possible, then a new object is decoded from the data and returned.
If the read is incomplete, the value returned is
-.metn nil .
+.codn nil .
All other stream error situations throw exceptions.
@@ -68752,15 +88556,14 @@ The optional
.meta offset
argument specifies a byte offset from the beginning of the data area of
.meta dst-buf
-where the foreign-representation of
+where the foreign representation of
.meta obj
is stored. The default value is zero.
These functions perform the "put semantics" encoding action similar to
what happens to the arguments of an outgoing foreign function call.
-
-Caution: incorrect use of this this function, or its use in isolation
+Caution: incorrect use of this function, or its use in isolation
without a matching
.code ffi-in
call, can cause memory leaks, because, depending on
@@ -68780,15 +88583,14 @@ to the treatment applied to the arguments of a callback prior to
returning to foreign code.
It is assumed that
+.code obj
+is an object that was returned by an earlier call to
+.codn ffi-get ,
+and that the
.meta dst-buf
-is a buffer that was earlier used in a call to
-.code ffi-get
-and that
-.meta type
and
-.meta obj
-are the same values that were passed as the
-corresponding arguments of that function.
+.meta type
+arguments are the same objects that were used in that call.
The
.meta copy-p
@@ -68810,7 +88612,7 @@ The optional
.meta offset
argument specifies a byte offset from the beginning of the data area of
.meta dst-buf
-where the foreign-representation of
+where the foreign representation of
.meta obj
is understood to be stored, and where it is updated if requested by
.metn copy-p .
@@ -68888,7 +88690,7 @@ The optional
.meta offset
argument specifies a byte offset from the beginning of the data area of
.meta src-buf
-from which the foreign-representation of
+from which the foreign representation of
.meta obj
is taken.
@@ -69101,7 +88903,7 @@ is overlaid onto the storage of
as follows:
First,
-.meta offs
+.meta offset
is subtracted from the bytewise length of
.metn buf ,
as reported by
@@ -69227,11 +89029,47 @@ then the returned
.code carray
object will be of unknown length. Otherwise,
.meta length
-must be a non-negative integer which will be taken as the
+must be a nonnegative integer which will be taken as the
length of the array.
Note: this conversion is inherently unsafe.
+.coNP Function @ cptr-carray
+.synb
+.mets (cptr-carray < carray <> [ type-symbol ])
+.syne
+.desc
+The
+.code cptr-carray
+function returns a
+.code cptr
+object which holds a pointer to a
+.code carray
+object's storage area. The
+.meta carray
+argument must be of type
+.codn carray .
+
+The
+.meta type-symbol
+argument should be a symbol. If omitted, it defaults to
+.codn nil .
+This symbol becomes the
+.code cptr
+object's type tag.
+
+The lifetime of the returned
+.code cptr
+object is independent from that of
+.metn carray .
+If the lifetime of
+.meta carray
+reaches its end before that of the
+.codn cptr ,
+the pointer stored inside the
+.code cptr
+becomes invalid.
+
.coNP Function @ length-carray
.synb
.mets (length-carray << carray )
@@ -69283,7 +89121,7 @@ type.
The
.meta length
argument indicates the new length, which must be
-a non-negative integer.
+a nonnegative integer.
The operation throws an
.code error
@@ -69322,7 +89160,7 @@ converting that element to a Lisp value, which is returned.
The
.meta idx
-argument must be a non-negative integer. If
+argument must be a nonnegative integer. If
.meta carray
has a known length,
.meta idx
@@ -69330,7 +89168,7 @@ must be less than the length.
If
.meta carray
-has an unknown length, then the the access is permitted regardless of how
+has an unknown length, then the access is permitted regardless of how
positive is the value of
.metn idx .
Whether the access has well-defined behavior depends on the actual extent of
@@ -69352,9 +89190,9 @@ a Lisp object, a region of data starting at calculated byte offset in the array
storage. The resulting object is returned.
Assigning an a value to a
-.code caddr-ref
+.code carray-ref
form is equivalent to using
-.code caddr-refset
+.code carray-refset
to store the value.
.coNP Function @ carray-refset
@@ -69375,7 +89213,7 @@ The return value is
The
.meta idx
-argument must be a non-negative integer. If
+argument must be a nonnegative integer. If
.meta carray
has a known length,
.meta idx
@@ -69383,7 +89221,7 @@ must be less than the length.
If
.meta carray
-has an unknown length, then the the access is permitted regardless of how
+has an unknown length, then the access is permitted regardless of how
positive is the value of
.metn idx .
Whether the access has well-defined behavior depends on the actual extent of
@@ -69483,7 +89321,7 @@ The
.code carray-own
function resembles
.codn carray-dup ,
-differing from that function only in in two ways.
+differing from that function only in two ways.
Instead of allocating a duplicate copy of the underlying array storage,
.code carray-own
causes
@@ -69778,7 +89616,7 @@ itself.
.coNP Function @ carray-pun
.synb
-.mets (carray-pun < carray << type )
+.mets (carray-pun < carray < type >> [ offset <> [ size-limit ]])
.syne
.desc
The
@@ -69794,13 +89632,37 @@ The
.meta type
argument specifies the element type used by the returned aliasing array.
+If the
+.meta offset
+argument is specified, then the aliased view is displaced by that many
+bytes from the start of the
+.meta carray
+object. The
+.meta offset
+argument must not be larger than the bytewise length of the array,
+or an error exception is thrown. The bytewise length of the array
+is the product of the number of elements and the element size.
+The default value of
+.meta offset
+is zero: no displacement.
+
+If
+.meta size-limit
+is specified, it indicates the size, in bytes, of the aliased view.
+This limit must not be such that the aliased view would extend beyond the
+array, or an error exception is thrown. If omitted,
+.meta size-limit
+defaults to the entire remainder of the array, after the offset.
+The number of elements of the returned array are then calculated from
+.metn size-limit .
+
The
.code carray-pun
-function considers the byte size of the array, which is a product of
-the original length and element size. It then calculates how many elements of
+function calculates how many elements of
.meta type
-fit into this size. This value becomes the length of the aliasing array
-which is returned.
+fit into
+.metn size-limit .
+This value becomes the length of the aliasing array which is returned.
Since the returned aliasing array and the original refer to the same
storage, modifications performed in one view are reflected in the other.
@@ -69814,6 +89676,19 @@ is invoked on the aliasing array.
The meaning of the aliasing depends entirely on the bitwise representations of
the types involved.
+Note:
+.code carray-pun
+does not check whether
+.meta offset
+is a value that is suitably aligned for accessing elements of
+.metn type ;
+on some platforms that must be ensured.
+
+The
+.code carray-pun
+function may be invoked on an object that was itself returned by
+.codn carray-pun .
+
.coNP Functions @ carray-uint and @ carray-int
.synb
.mets (carray-uint < number <> [ type ])
@@ -69835,7 +89710,7 @@ The
argument, a compiled FFI type, determines the element type for the returned
.codn carray .
If it is omitted, it defaults to the
-.code uint
+.code uchar
type, so that the array is effectively of bytes.
Regardless of
@@ -69854,9 +89729,9 @@ left, near the beginning of the array.
In the case of
.codn carray-uint ,
.meta number
-must be a non-negative integer. An unsigned representation is produced
+must be a nonnegative integer. An unsigned representation is produced
which carries no sign bit. The representation is as many bytes wide as
-are required to cover the number up to its most significant bit whose
+are required to cover the number up to its most-significant bit whose
value is 1. If any padding bytes are required due to the array being larger,
they are always zero.
@@ -69865,19 +89740,19 @@ The
function encodes negative integers also, using a variable-length two's
complement representation. The number of bits required to hold the number
is calculated as the smallest width which can represent the value in two's
-complement, including a sign bit. Any unused bits in the most significant
+complement, including a sign bit. Any unused bits in the most-significant
byte are filled with copies of the sign bit: in other words, sign extension
takes place up to the byte size. The sign extension continues through the
padding bytes if the array is larger than the number of bytes required to represent
.metn number ;
the padding bytes are filled with the value
.code #b11111111
-(255) if the number is negative, or else 0 if it is non-negative.
+(255) if the number is negative, or else 0 if it is nonnegative.
.coNP Functions @ uint-carray and @ int-carray
.synb
.mets (uint-carray << carray )
-.mets (int-carray < number <> [ type ])
+.mets (int-carray << carray )
.syne
.desc
The
@@ -69892,7 +89767,7 @@ The
.code uint-carray
function simply treats all of the bytes as a big-endian unsigned integer in
a pure binary representation, and returns that integer, which is necessarily
-always non-negative.
+always nonnegative.
The
.code int-carray
@@ -69913,14 +89788,14 @@ the value -1 is returned.
.coNP Functions @ fill-carray and @ put-carray
.synb
-.mets (fill-array < carray >> [ pos <> [ stream ]])
-.mets (put-array < carray >> [ pos <> [ stream ]])
+.mets (fill-carray < carray >> [ pos <> [ stream ]])
+.mets (put-carray < carray >> [ pos <> [ stream ]])
.syne
.desc
The
-.code fill-array
+.code fill-carray
and
-.code put-array
+.code put-carray
functions perform stream output using the
.code carray
object as a buffer.
@@ -69930,11 +89805,11 @@ A temporary buffer is created which aliases the storage of
.meta carray
and this buffer is used as an argument in an invocation of, respectively,
the buffer I/O function
-.meta fill-buf
+.code fill-buf
or
-.metn put-buf .
+.codn put-buf .
-The value returned by buffer I/O function is returned.
+The value returned by the buffer I/O function is returned.
The
.meta pos
@@ -69947,9 +89822,199 @@ and
and have the same meaning. In particular,
.meta pos
indicates a byte offset into the
-.meta carray
+.code carray
object's storage, not an array index.
+.NP* C Non-Local Jumps
+
+\*(TL supports interfacing with modules that make use of the C
+.code setjmp
+and
+.code longjmp
+feature across their boundaries. It is possible to save a jump
+location in Lisp code with the
+.code setjmp
+macro, such that a foreign function can perform a
+.code longjmp
+to that saved context.
+
+The jump context buffer, known as the type
+.code jmp_buf
+in C, is modelled as a
+.code carray
+object whose element type is
+.codn uchar .
+The function
+.code jmp-buf
+returns such an object. Foreign functions that return a pointer to a
+.code jmp_buf
+may be suitably defined via
+.code deffi
+such that the pointer is mapped to a
+.code carray
+object whose element type is
+.codn uchar .
+The resulting object will then be usable as a jump buffer.
+
+The features described here are unsafe. When used in certain incorrect ways,
+the behavior is undefined.
+
+Using the
+.code setjmp
+macro and
+.code longjmp
+function as control primitives in Lisp code not interacting with foreign
+functions is strongly discouraged.
+
+There are situations in which the foreign function calling mechanism allocates
+temporary dynamic memory for converting between Lisp and C objects. These
+situations occur when objects are referenced by pointers, and so are are
+outside of the stack-based argument space. In such a situation, if the foreign
+function performs a
+.code longjmp
+terminating in a
+.code setjmp
+macro in Lisp code, that temporary storage will leak.
+
+.coNP Function @ jmp-buf
+.synb
+.mets (jmp-buf)
+.syne
+.desc
+The
+.code jmp-buf
+function returns a new
+.code carray
+object suitable for use as a jump buffer with the
+.code setjmp
+macro and
+.code longjmp
+function.
+
+.coNP Function @ longjmp
+.synb
+.mets (longjmp < jmp-buf << value )
+.syne
+.desc
+The
+.code longjmp
+function restores the context saved into the
+.meta jmp-buf
+object by the
+.code setjmp
+macro. If that macro already terminated, the behavior is undefined.
+
+The
+.meta value
+must be an integer in range of the FFI type
+.codn int .
+That value will be observed in the
+.code setjmp
+form, as described.
+If
+.meta value
+is
+.code 0
+(zero) the value
+.code 1
+is used instead. This is a behavior of the underlying
+.code longjmp
+C library function.
+
+Note: a context abandoned via
+.code longjmp
+will not perform unwinding, similarly to
+.codn sys:abscond* .
+The form which is abandoned by
+.code longjmp
+should not be using scoped management of resources that relies on
+.code unwind-protect
+for clean-up.
+
+.coNP Macro @ setjmp
+.synb
+.mets (setjmp < jmp-buf < result-var < main-form << longjmp-form *)
+.syne
+.desc
+The
+.code setjmp
+macro saves the jump context into the
+.meta jmp-buf
+object, and evaluates the
+.meta main-form
+expression.
+
+If the
+.meta main-form
+expression terminates normally then the value
+it produces becomes the result of
+.codn setjmp ,
+which terminates.
+
+If the
+.meta main-form
+performs a
+.code longjmp
+to the context saved in
+.codn jmp-buf ,
+then that form is abruptly terminated, without
+performing any unwinding.
+Then, the zero or more
+.metn longjmp-form s
+are evaluated. The
+.code setjmp
+form terminates, yielding the value of the last
+.meta longjmp-form
+or else
+.codn nil .
+
+The
+.codn longjmp-form s
+are evaluated in a scope in which the
+.code result-var
+symbol is bound as a variable, taking on the
+integer value passed to
+.codn longjmp ,
+which is never zero.
+
+The
+.meta jmp-buf
+argument must be a
+.code carray
+object suitable for use as a jump buffer.
+
+The
+.code result-var
+argument must be a bindable symbol.
+
+Once
+.code setjmp
+terminates, the contents of
+.meta jmp-buf
+become indeterminate. Any
+.code longjmp
+attempt using an indeterminate
+.code jmp-buf
+is undefined behavior.
+
+.TP* Example:
+
+.verb
+ (let ((jb (jmp-buf)))
+ (setjmp jb result
+ (progn (put-line "setjmp") ;; "setjmp" is printed
+ (longjmp jb 42))
+ (put-line `result is: @result`))) ;; "result is: 42" is printed
+.brev
+
+.IP
+Note: this example is for illustration only. Using
+.code setjmp
+and
+.code longjmp
+as Lisp control flow constructs in code not interacting with foreign
+functions is strongly discouraged.
+
.SH* LISP COMPILATION
.SS* Overview
@@ -69997,7 +90062,7 @@ The
function is provided to list the compiled code in a more understandable way;
.code disassemble
takes a compiled code object and decodes it into an assembly language
-presentation of its virtual machine code, accompanied by a dump of the various
+presentation of its virtual-machine code, accompanied by a dump of the various
information tables.
File compilation via
@@ -70036,7 +90101,6 @@ which is not enclosed by another one. Rather, in this specific context, it has
this specific definition, which allows some enclosed forms to still be
considered top-level forms:
-.RS
.IP 1.
If a form appearing in a \*(TL source file isn't enclosed in another
form, it is a top-level form.
@@ -70055,18 +90119,21 @@ If an
.code eval-only
form is top-level form, then each of its constituent forms is also a top-level
form.
-.IP 5
+.IP 5.
If a
.code load-time
form is top-level form, then its argument is a top-level form.
.IP 6.
-When a form is identified as a top-level form by the above rule 1,
-its constituents are considered under rules 2-4 only after the form is
-fully macro-expanded.
+When a macro form is identified as a top-level form, it is macro-expanded
+as if by
+.code macroexpand
+before considering whether it contains top-level forms under rules 2\(en5.
.IP 7.
+Rules 2\(en6 are applied recursively.
+.IP 8.
No other forms are top-level forms.
.RE
-
+.IP
A top-level form is a
.I primary
top-level form if it doesn't contain any other top-level forms.
@@ -70076,6 +90143,31 @@ This means that it is not a form based on any of the operators
or
.codn eval-only .
+Note that the constituent body forms of a
+.code macrolet
+or
+.code symacrolet
+top-level form are not individual top-level forms, even if the
+expansion of the construct combines the expanded versions of those
+forms with
+.codn progn .
+
+Note: the
+.code eval
+function implements a similar concept, specially recognizing
+.codn progn ,
+.code compile-only
+and
+.code eval-only
+top-level forms, taking care to macro-expand and evaluate their constituents
+separately. In turn, the
+.code load
+function, when processing Lisp source, evaluates each primary top-level form as
+if by using the
+.code eval
+function. The result is that the behavior of loaded source and compiled
+files is consistent in this regard.
+
.SS* File Compilation Model
The file compiler reads each successive forms from a file, performs a partial
@@ -70105,12 +90197,12 @@ similar to the algorithm used by the
.code eval
function:
.RS
-.IP 1
+.IP 1.
First, if
.meta form
is a macro, it is macro-expanded as if by an application of the function
.codn macroexpand .
-.IP 2
+.IP 2.
If the resulting expanded form is a
.codn progn ,
.codn compile-only ,
@@ -70120,10 +90212,22 @@ form, then
.code compile-file
iterates over that form's argument expressions, compiling each expression
recursively as if it were a separate expression.
-.IP 3
+.IP 3.
Otherwise, if the expanded form isn't one of the above three kinds of
expressions, it is subject to a full expansion and compilation.
.RE
+.IP
+Note: the structure of these three processing rules above closely resembles
+that of the three rules given in the description of the
+.code eval
+function, which is the basis for handling source files in
+.codn load .
+Consequently, macro expansion behaves consistently between
+.code compile-file
+and
+.code load
+of a source file.
+
.SS* Treatment of Literals
Programs specify not only code, but also data. Data embedded in a program is
@@ -70171,22 +90275,36 @@ special variable has no influence on this.
Circular structures in compiled literals are preserved; on loading, similar
circular structures are reproduced.
-.SS* Treatment of The Hash Bang Line
+.SS* Treatment of the Hash-Bang Line
-\*(TX supports the hash bang mechanism in compiled
+\*(TX supports the hash-bang mechanism in compiled
.code .tlo
files, thereby allowing compiled scripts to be executable.
When a source file begins with the
.code #!
-("hash-bang") character sequence, the file compiler propagates that
+(hash bang) character sequence, the file compiler propagates that
line (all characters up to and including the terminating newline) to the
-compiled file, subject to the following transformation: occurrences of
+compiled file, subject to the following transformation steps:
+.IP 1
+The line is divided into arguments, on the assumption that they are separated
+by exactly one space.
+.IP 2
+Then, all occurrences of the argument
.str --lisp
-which are not followed by a dash are replaced with
+are replaced by
.strn --compiled .
+.IP 3
+Next, all arguments which end in the suffix
+.str "txrlisp"
+have that suffix replaced by
+.strn "txrvm" .
+.IP 4
+The hash bang line is then reconstituted by joining the arguments
+with a single space.
+.PP
-Furthermore, certain permissions are propagated from a hash bang source
+Furthermore, certain permissions are propagated from a hash-bang source
file to the target file. If the source file is executable to its owner,
then the target file is made executable as if by using
.code chmod
@@ -70204,9 +90322,9 @@ bit is set on the target file.
.SS* Compiled File Compatibility
-\*(TX's virtual machine architecture for executing compiled code
+\*(TX's virtual-machine architecture for executing compiled code
is evolving, and that evolution has implications for the compatibility between
-compiled files the \*(TX executable image.
+compiled files and the \*(TX executable image.
The basic requirement is that a given version of \*(TX can load and execute
the compiled files which that same version has produced.
@@ -70215,13 +90333,18 @@ Furthermore, these files are architecture-independent, except that their
encoding is in the local byte order ("endianness") of the host machine.
The byte order is explicitly indicated in the files, and the
.code load
-function resolves it. Thus a file produced by \*(TX running on a 64 bit big
-endian Power PC can be loaded by \*(TX running on 32 bit x86, which is
+function resolves it. Thus a file produced by \*(TX running on a 64-bit
+big-endian Power PC can be loaded by \*(TX running on 32-bit x86, which is
little endian.
A given \*(TX version may also be capable of loading files produced by
an older version, or even ones produced by a newer version. Whether this
-is possible depends on the versions involved.
+is possible depends on the versions involved. Furthermore,
+there is a general issue at play: code compiled by newer
+versions of \*(TX may require functions that are not present
+in older versions, preventing that code from running. Newer
+\*(TX may support new syntax not recognized by older \*(TX,
+and that syntax may end up in compiled files.
Compiled files contain a minor and major version number (which is independent
of the \*(TX version). The
@@ -70238,9 +90361,180 @@ version.
Versions 193 through 198 produce version 2 compiled files and load only
that version.
-Version 199 produces version 3 files and loads version 2 or 3.
+Version 199 produces version 3 files and loads versions 2 and 3.
+
+Versions 200 through 215 produce version 4 files and load
+versions 2, 3 and 4.
+
+Versions 216 through 243 produce version 5.0 files and load
+versions 2, 3, 4 and 5, regardless of minor version.
+
+Versions 244 through 251 produce version 5.1 files and load
+versions 2, 3, 4 and 5, regardless of minor version.
+
+Versions 252 through 259 produce version 6.0 files and load
+only version 6, regardless of minor version.
+
+Versions 260 through 294 produce version 7.0 files and load
+versions 6 and 7, regardless of minor version.
+Version 261 introduces JSON
+.code #J
+syntax. Compiled code which contains embedded JSON literals
+is not loadable by \*(TX 260 and older.
+
+.SS* Recommendations for Unused Variable Diagnostics
+
+By default, the
+.code unused
+diagnostic option is enabled in
+.codn *compile-opts* ,
+causing unused variables to be diagnosed.
+
+The first step in resolving an unused variable diagnostic is to determine
+whether it is caused by a bug in the code. If so, the resolution is
+to address the bug.
+
+If the situation isn't a bug, then the diagnostic is a false positive,
+and may be silenced. There are multiple ways to do that, six of
+which are given here:
+
+.IP 1.
+.BR "Disable the diagnostic" :
+for instance, compile
+.str foo.tl
+with unused warnings disabled:
+
+.verb
+ (with-compile-opts (nil unused)
+ (compile-file "foo.tl"))
+.brev
+
+.IP 2.
+.B "Use the"
+.code ignore
+.BR function :
+the compiler specially recognizes the
+.code ignore
+function such that when any of its arguments are lexical variables,
+they are marked used:
+
+.verb
+ (defun stub-function (arg1 arg2)
+ (ignore arg1 arg2))
+.brev
+
+Note that an
+.code ignore
+call may be elided if it occurs in dead code, in which case it
+won't have the right effect:
+
+.verb
+ (defun unused-arg (arg) ;; diagnosed as unused
+ (when (= (+ 2 2) 5)
+ (ignore arg) ;; wrongly placed
+ (dead-code)))
+
+ (defun unused-arg (arg) ;; no diagnostic
+ (ignore arg) ;; correctly placed
+ (when (= (+ 2 2) 5)
+ (dead-code)))
+.brev
+
+.IP 3.
+.B "Use the"
+.code use
+.BR function .
+In the following code, parameter
+.code arg
+is diagnosed as unused on platforms in which the
+equality being tested is false, since the
+expression is constant. In situations like this,
+the variable is not unused, but only conditionally so.
+Therefore the name of the
+.code ignore
+function doesn't express the intent very well.
+The
+.code use
+function may be stylistically preferred:
+
+.verb
+ (defun platform-specific-action (arg)
+ (use arg)
+ (if (eql (sizeof wchar) 2)
+ (do-something arg)))
+.brev
+
+However, unlike
+.codn ignore ,
+.code use
+takes exactly one argument, and returns that
+argument rather than
+.codn nil .
+
+.IP 4.
+.BR "Use an uninterned symbol: "
+unused variable diagnostics are not reported against variables
+named by uninterned symbols.
+
+.verb
+ (lambda (x y) y) ;; unused x diagnosed
+ (lambda (#:x y) y) ;; no diagnostic
+.brev
+
+.IP 5.
+.BR "In destructuring and pattern matching, put catch-all variable to use" :
+
+Examples:
+
+.verb
+ (tree-case obj
+ ((a b) (calculate-something a b))
+ (else (transform obj))) ;; unused else
-Versions 200 through 233 produce version 4 files and load version 2, 3 or 4.
+ (tree-case obj
+ ((a b) (calculate-something a b))
+ (else (transform else))) ;; diagnostic gone
+
+ (match-case obj
+ ((@a @b) (calculate-something a b))
+ (@else (transform obj))) ;; unused else
+
+ (match-case obj
+ ((@a @b) (calculate-something a b))
+ (@else (transform else))) ;; diagnostic gone
+.brev
+
+.IP 6.
+In pattern matching, use the
+.code @nil
+pattern:
+
+.verb
+ (match-case obj
+ ((@a @nil) (calculate-something a))
+ (@nil (transform obj)))
+.brev
+
+.IP 7.
+.B "In macro parameter lists use t symbol" :
+in macro-style parameter lists, any variable may be replaced by the
+.code t
+symbol to consume a value without binding a variable. This is
+intended for suppressing unused variable warnings:
+
+.verb
+ (defmacro foo (x y) ;; y unused
+ ^(a b c ,x))
+
+ (defmacro foo (x t) ;; no diagnostic
+ ^(a b c ,x))
+
+ (tree-bind (a . (b . c)) obj ;; a, b, unused
+ c)
+
+ (tree-bind (t . (t . c)) obj ;; no diagnostic
+ c)
+.brev
.SS* Semantic Differences between Compilation and Interpretation
@@ -70252,7 +90546,7 @@ operators can be used to deliberately produce code which behaves differently
when compiled and interpreted. In addition, unwanted differences in behavior
can also occur. The situations are summarized below.
-.coNP Differences due to @ load-time
+.coNP Differences Due to @ load-time
Forms evaluated by
.code load-time
@@ -70294,8 +90588,7 @@ No such de-duplication is performed for interpreted code.
Consequently, code which depends on multiple occurrences of these objects to be
distinct objects may behave correctly when interpreted, but misbehave when
-compiled. Or
-.IR "vice versa .
+compiled. Or vice versa.
One example is code which modifies a string literal.
Under compilation, the change will affect all occurrences of that literal
that have been merged into one object. Another example is an
@@ -70322,6 +90615,48 @@ operator. If a macro calculates a new string each time it is expanded,
and inserts it into the expansion as a literal, the compiler will identify
and consolidate groups of such strings that are identical.
+.coNP Treatment of symbols
+
+A source file may contain unqualified symbol tokens which are interned
+in the current package.
+
+In contrast, a compiled file encodes symbols with full package qualification.
+When a compiled file is loaded, the current package at that time has no effect
+on the symbols in the compiled file, even if those symbols were specified as
+unqualified in the original source file.
+
+This difference can lead to surprising behaviors. Suppose a source file
+contains references to functions or variables or other entities which do not
+exist. Furthermore, suppose the entities were referenced, in that file, using
+unqualified symbols which didn't exist, and were expected to come from a
+different package from the one where they ended up interned. For instance,
+supposed the file is being processed in a package called
+.code abc
+and is expecting to use a function
+.code calc
+which should come from the
+.code xyz
+package. Unfortunately, no such symbol exists. Therefore, the symbol is
+interned as
+.code abc:calc
+and not
+.codn xyz:calc .
+In that case, it
+should be
+sufficient to ensure that the
+.code xyz:calc
+function exists, and then reload the source file. The unqualified symbol token
+.code calc
+in that file will be correctly resolved to
+.code xyz:calc
+that time. However, if the file is compiled, reloading will not be sufficient.
+Even though the symbol
+.code xyz:calc
+exists, the file will continue to try to refer a function using the symbol
+.code abc:calc
+which comes from a fully qualified representation stored in the compiled file.
+The file will have to be recompiled to fix the issue.
+
.coNP Treatment of unbound variables
Unbound variables are treated differently by the compiler. A reference
@@ -70337,7 +90672,7 @@ The compiler treats a variable as dynamic if a
.code defvar
has been processed which marked that variable as special.
-.coNP Unbound symbols in @ dwim
+.coNP Unbound Symbols in @ dwim
Arguments of a
.code dwim
@@ -70378,7 +90713,7 @@ treated as a function. If it has both bindings, it is treated as a variable.
The difference is that this is resolved at compile time for compiled code,
and at evaluation time for interpreted code.
-.coNP File-wide insertion of gensyms
+.coNP File-Wide Insertion of Gensyms
The following degenerate situation occurs, illustrated by example. Suppose the
following definitions are given:
@@ -70410,7 +90745,7 @@ prints 42 to standard out. This works both interpreted and compiled with
Each of these two macro calls generates a top-level form into which
the same gensym is inserted. This works under file compilation due to a
deliberate strategy in the layout of compiled files, which allows such
-uses. Namely, the file compiler combines multiple top-level forms are combined
+uses. Namely, the file compiler combines multiple top-level forms
into a single object, which is read at once, and which uses the circle
notation to unify gensym references.
@@ -70424,7 +90759,7 @@ However, suppose the following change is introduced:
(call-secret-fun 42)
.brev
-This still works interpreted, and appears to compiles. However, when the
+This still works when interpreted, and compiles successfully. However, when the
compiled file is loaded, the compiled version of the
.code call-secret-fun
form fails with an error complaining that the
@@ -70474,7 +90809,7 @@ The
function takes the Lisp form
.meta form
and compiles it. The return value is a
-.I "virtual machine description"
+.I "virtual-machine description"
object representing the compiled form. This object isn't of function type, but may be
invoked as if it were a function with no arguments.
@@ -70573,12 +90908,22 @@ If the argument is a lambda expression, then that function is
compiled.
If the argument is a function object, and that object is an interpreted
-function, then its code is retrieved and compiled.
+function, then its code and lexical environment are retrieved and compiled.
In all cases, the return value of
.code compile
is the compiled function.
+Note: when an interpreted function object is compiled, the compiled environment
+does not share bindings with the original interpreted environment.
+Modifications to the bindings of either environment have no effect on the
+other. However, the objects referenced by the bindings are shared. Shared
+bindings may be arranged using the
+.code hlet
+or
+.code hlet*
+macros.
+
.coNP Functions @ compile-file and @ compile-update-file
.synb
.mets (compile-file < input-path <> [ output-path ])
@@ -70592,7 +90937,7 @@ function reads forms from an input file, and produces a compiled output file.
First,
.meta input-path
is converted to a
-.I "tentative path name"
+.I "tentative pathname"
as follows.
If
@@ -70605,7 +90950,7 @@ If an existing load operation is in progress, then the special variable
has a binding. In this case,
.code load
will assume that the relative pathname is a reference relative to the
-directory portion of that path name.
+directory portion of that pathname.
If
.code *load-path*
@@ -70616,20 +90961,20 @@ then a pure relative
pathname is used as-is, and thus resolved relative to the current working
directory.
-The tentative path name is converted to an
-.I "actual input path name"
-as follows. Firstly, if the tentative path name ends with one of the suffixes
+The tentative pathname is converted to an
+.I "actual input pathname"
+as follows. Firstly, if the tentative pathname ends with one of the suffixes
.code .tl
or
.code .txr
then it is considered suffixed, otherwise it is considered unsuffixed.
-If it is suffixed, then the actual path name is the same as the tentative path name.
-In the unsuffixed case, two possible actual input path names are formed. First,
+If it is suffixed, then the actual pathname is the same as the tentative pathname.
+In the unsuffixed case, two possible actual input pathnames are considered.
+First, if the unsuffixed path refers to a file that can be opened, then that
+unsuffixed path is taken as actual path. Otherwise,
the suffix
.code .tl
-is added to the tentative path name. If that path exists, it is taken
-taken as the actual path. Otherwise, the unmodified tentative path
-is taken as the actual input path.
+is added to the tentative pathname, and that becomes the actual path.
If the actual path ends in the suffix
.code .txr
@@ -70663,7 +91008,7 @@ Over the compilation of the input file,
establishes a new dynamic binding for several special
variables. The variable
.code *load-path*
-is given a new binding containing the actual input path name.
+is given a new binding containing the actual input pathname.
The
.code *package*
variable is also given a new dynamic binding, whose value is the
@@ -70721,6 +91066,147 @@ or
.code eval-only
top-level forms.
+Two or more compiled files that are compiled by the same version of \*(TX may be
+catenated together to produce a single
+.code .tlo
+file. Such a file may be loaded by the
+.code load
+function. The behavior of loading such a file may differ from loading the individual
+files, because such a
+.code load
+is treated as a single operation.
+
+.coNP Special Variable @ *opt-level*
+.desc
+The special variable
+.code *opt-level*
+provides control over compiler optimizations.
+
+The variable takes on integer
+values. If the value is
+.codn nil ,
+it is interpreted as zero. The meaningful range is from 0 to 7.
+The initial value of the variable is 7.
+
+The meanings of the values are as follows:
+
+.RS
+.IP 0
+Almost all optimizations are disabled, except for some strength
+reductions of instances of he
+.code equal
+function, to take advantage of certain conditional instructions.
+.IP 1
+Constant folding is applied, as well as algebraic reductions to list processing
+and arithmetic code. Two-argument calls to several common arithmetic operators
+are translated into calls to more efficient two-argument internal functions.
+.IP 2
+Blocks which can be easily confirmed not to be used as exit points are removed.
+Variable frames in which no lexically captured variables are bound, and no
+dynamic variables are bound, are eliminated.
+.IP 3
+Lambda expressions and calls to combinator functions such as
+.code chain
+and
+.code andf
+are lifted to load time, if possible.
+.IP 4
+Control flow optimizations are applied: jump threading and elimination of
+unreachable code. Some peephole optimizations are applied to improve
+certain instruction patterns.
+.IP 5
+Data flow optimizations are applied, such as elimination of dead register
+moves, or useless propagations of values from one register to another.
+More peephole optimizations are applied.
+.IP 6
+Additional iterations of the levels 4 and 5 optimizations are performed,
+if the previous iterations have coalesced some basic blocks of the program
+graph. Also, at this level,
+.code chain
+expressions containing lambdas are inlined, eliminating the closures.
+These expressions arise out of
+.code opip
+syntax and its derivatives.
+.IP 7
+Certain more rarely applicable optimizations are applied which reduce code size
+by merging some identical code blocks, or improving some more rarely
+occurring instruction patterns.
+.RE
+
+.coNP Function @ clean-file
+.synb
+.mets (compile-file << path )
+.syne
+.desc
+The
+.code clean-file
+function removes a previously compiled file associated with
+.metn path ,
+if such a file exists. In situations when it successfully removes
+a file, it returns
+.codn t ,
+otherwise
+.codn nil .
+The function may also throw an exception, in situations such as
+encountering a nonexistent directory component or permission problem.
+
+First, if
+.meta path
+specifies a pure relative pathname, as defined by the
+.code pure-rel-path-p
+function, and if the
+.code *load-path*
+variable contains a value other than
+.codn nil ,
+then
+.code clean-file
+calculates the directory name of
+.code *load-path*
+as if by using
+.code dir-name
+and catenates that directory name with
+.meta path
+to produce an intermediate path.
+Otherwise
+.meta path
+is considered to be the intermediate path.
+
+Next, the suffix of the intermediate path is examined.
+If it ends with
+.str .tlo
+or
+.strn .tlo.gz ,
+then an attempt is made to remove that path,
+and the function terminates.
+
+If the intermediate path ends with
+.str .tl
+or
+.strn .txr ,
+then two attempts are made to remove a file: first,
+the suffix is replaced with
+.str .tlo
+and that is attempted to be removed. If that fails
+due to non-existence, then the suffix
+.str .tlo.gz
+is tried.
+
+Otherwise, if the intermediate path doesn't have
+any of the above suffixes, then an attempt is made
+to remove the path with the
+.str .tlo
+suffix added, and then with the
+.str .tlo.gz
+suffix added.
+
+Note: no attempt is made to remove the unmodified
+intermediate path itself, except in the cases when it ends with
+.str .tlo
+or
+.strn .tlo.gz ,
+because that risks removing a source file rather than
+a compiled file.
+
.coNP Macro @ with-compilation-unit
.synb
.mets (with-compilation-unit << form *)
@@ -70748,11 +91234,11 @@ is returned.
It is permissible to nest
.code with-compilation-unit
-forms, lexically or dynamically. The outer-most invocation of
+forms, lexically or dynamically. The outermost invocation of
.code with-compilation-unit
dominates; all deferred
.code compile-file
-actions are held until the outer-most enclosing
+actions are held until the outermost enclosing
.code with-compilation-unit
terminates.
@@ -70768,7 +91254,7 @@ When a
.code compile-only
or
.code eval-only
-form is processed by the evaluator rather than compiler, or when it is
+form is processed by the evaluator rather than the compiler, or when it is
processed outside of file compilation, or when it is appears as other than a
top-level form even under file compilation, then these operators behave
in a manner identical to
@@ -70778,17 +91264,17 @@ When a
.code compile-only
form appears as a top-level form under file compilation, it indicates to the
file compiler that the
-.metn form -s
+.metn form s
enclosed in it are not to be evaluated. By default, the file compiler executes
each top-level form after compiling it. The
.code compile-only
operator suppresses this evaluation.
-When a
+When an
.code eval-only
form appears as a top-level form under file compilation, it indicates to the
file compiler that the
-.metn form -s
+.metn form s
enclosed in it are not to be emitted into the output file. By default, the file
compiler includes the compiled image in the output written to the output file.
The
@@ -70872,6 +91358,277 @@ Macros definitions may be treated with
if the intent is only to make the expanded code available in the compiled file,
and not to propagate compiled versions of the macros which produced it.
+.coNP Structure @ compile-opts
+.synb
+.mets (defstruct compile-opts ()
+.mets \ \ shadow-fun shadow-var shadow-cross unused
+.mets \ \ log-level constant-throws)
+.syne
+.desc
+The
+.code compile-opts
+structure represents compiler options: its slots are variables which affect
+compiler behavior.
+The compiler expects the special variable
+.code *compile-opts*
+to hold a
+.code compile-opts
+structure. It is recommended to manipulate options using the
+.code with-compile-opts
+macro.
+
+Currently, all of the options are diagnostic. In the future, there may be other
+kinds of options.
+
+Diagnostic options which are Boolean take on the values
+.codn nil ,
+.codn t ,
+.code :warn
+or
+.codn :error .
+Numeric options take integer values.
+The
+.code t
+and
+.code :warn
+value are synonyms. A value of
+.code nil
+means that the option is disabled.
+The
+.code t
+and
+.code :warn
+values mean that the diagnostic controlled by the option will be emitted as a warning.
+The
+.code :error
+value indicates that the diagnostic will be an error.
+
+The slots of
+.code compile-opts
+are as follows:
+
+.RS
+.coIP shadow-fun
+Diagnostic option, off by default. This option controls whether a diagnostic is
+emitted whenever a lexical function shadows another lexical function,
+a global function or a global macro. Note: shadowing of local macros is not
+diagnosed, because the compiler operates on code in which macros no longer exist.
+.coIP shadow-var
+Diagnostic option, off by default. This option controls whether a diagnostic is
+emitted whenever a lexical variable shadows another lexical variable,
+a global variable, or a global macro. Note: shadowing of local
+macros is not diagnosed, because the compiler operates on code in which macros
+no longer exist. Note: special variables are not diagnosed for shadowing.
+.coIP shadow-cross
+Diagnostic option, off by default. This option controls whether a diagnostic is
+emitted whenever a lexical function shadows a variable, or vice versa: whether
+a lexical variable shadows a function.
+.coIP unused
+Diagnostic option, set to warn by default. This option controls whether a
+diagnostic is emitted whenever a lexical variable is defined whose
+value is not used. Variables whose names are uninterned symbols
+are exempt from this diagnostic. The rationale is that uninterned
+symbols are used for naming machine-generated variables, in generated
+code such as macro expansions. Situation in which a machine-generated
+variable is unused arise fairly often, and are and are not the result of a
+programming error. For the purpose of this diagnostic, what constitutes use of
+a variable is an access to its value, which isn't optimized away before being
+noted. Storing a value isn't use. An example of an access which is optimized
+away before being noted is an access which occurs in trivially dead code: for
+instance
+.code "(if nil a)"
+does not access
+.code a
+because the compiler discards the
+.meta then
+expression of an
+.code if
+whose
+.meta test
+expression is constantly false. The discarded expression is never
+traversed in a way that would cause it to be noted as accessing the
+.code a
+variable.
+.coIP log-level
+Diagnostic option,
+.code nil
+by default. When set to a positive integer value, it enables logging, with
+increasing values implying more detailed logging. The value 1 causes
+.code compile-file
+and
+.code compile-update-file
+to emit an informational message whenever a file is compiled.
+The value 2 causes informational messages emitted for each compound
+top-level that is compiled, if it is a compound form beginning with
+a symbol.
+.coIP constant-throws
+Diagnostic option,
+.code t
+by default. Controls whether the compiler issues diagnostics when
+it encounters a constant expression, whose evaluation throws
+an exception, such as
+.codn "(/ 0 0)" .
+.RE
+
+.coNP Special Variable @ *compile-opts*
+.desc
+The special variable
+.code *compile-opts*
+holds a value of type
+.code compile-opts
+which is a structure type. It is recommended to manipulate options using the
+.code with-compile-opts
+macro.
+
+.coNP Macro @ with-compile-opts
+.synb
+.mets (with-compile-opts >> {( value << option *) | << form }*)
+.syne
+.desc
+The
+.code with-compile-opts
+macro takes zero or more arguments. Each argument is either a clause
+which affects compiler options or else an ordinary
+.meta form
+which is processed in a context in which the
+.code *compile-options*
+variable has been affected by all of the previous clauses.
+
+It is unspecified whether the clauses operate destructively on
+.code *compile-options*
+or freshly bind it. However, the macro dynamically binds
+.code *compile-options*
+at least once, so that when it terminates, its previous value is restored.
+This binding is performed using
+.codn compiler-let .
+
+When
+.code with-compile-opts
+occurs in code processed by the compiler, all of the clause-driven compile
+option manipulation is performed in the compiler's own context. The changes
+to the
+.code *compile-options*
+variable are not visible to the code being compiled. Thus the macro may be
+used to transparently change compiler options over individual subexpressions in
+compiled code.
+
+When
+.code with-compile-opts
+occurs in interpreted code, the manipulations of
+.code *compile-options*
+are visible to the
+.metn form s.
+This allows interpreted build steps to configure compiler options
+around functions such as
+.codn compile-file .
+
+The clauses which operate on options have list syntax consisting of a value
+followed by one or more symbols which must be the names of options which are
+compatible with that value. The clause indicates that all those options take on
+that value.
+
+The possible values are:
+.codn nil ,
+.codn t ,
+.code :warn
+and
+.codn :error .
+These values are documented under the description of the
+.code compile-opts
+structure.
+
+.TP* Example:
+
+The following expression specifies that the file
+.str foo.tl
+is to be compiled with function and variable shadowing
+treated as error, but unused variable checking disabled. Then compile
+.str bar.tl
+with unused variable checking enabled.
+
+.verb
+ ;; this form must be interpreted in order for
+ ;; the compile-file call to "see" the effect of the
+ ;; option manipulation.
+ (with-compile-opts
+ (:error shadow-var shadow-fun)
+ (nil unused)
+ (compile-file "foo.tl")
+ (:warn unused)
+ (compile-file "bar.tl"))
+
+ ;; when the following form is compiled, the unused
+ ;; variable warning will be disabled just around
+ ;; the (let (y) x).
+ (lambda (x)
+ (with-compile-opts (nil unused)
+ (let (y) x)))
+
+ ;; Show detailed traces of what forms are
+ ;; compiled in these two files.
+ (with-compile-opts
+ (2 log-level)
+ (compile-file "foo.tl")
+ (compile-file "bar.tl"))
+.brev
+
+.coNP Operator @ compiler-let
+.synb
+.mets (compiler-let >> ({( sym << init-form )}*) << body-form *)
+.syne
+.desc
+The
+.code compiler-let
+operator strongly resembles
+.code let*
+but has different semantics, relevant to compilation.
+It also has a stricter syntax in that variables may not
+be symbols without a
+.metn init-form :
+only variable binding specifications of the form
+.mono
+.meti >> ( sym << init-form )
+.onom
+are allowed.
+
+Symbols bound using
+.code compiler-let
+are expected to be special variables. For every
+.metn sym ,
+the expression
+.mono
+.meti (special-var-p << sym )
+.onom
+should be true. The behavior is unspecified for any
+.meta sym
+which doesn't name a special variable.
+
+When the compiler encounters the
+.code compiler-let
+construct, the compiler itself establishes a dynamic scope in which the
+implied special variable bindings are in effect. This effect is not
+incorporated into the compiled code. The compiler then implicitly places the
+.metn body-form s,
+into a
+.code progn
+from, and compiles that form. While the implicit
+.code progn
+is being compiled, the dynamic bindings established by
+.code compiler-let
+are in scope.
+
+Thus
+.code compiler-let
+may be used to bind special variables which influence compiler behavior.
+
+The
+.code compiler-let
+form is treated like
+.code let*
+by the interpreter, provided that every
+.meta sym
+names a special variable.
+
.coNP Macro @ load-time
.synb
.mets (load-time << form )
@@ -70890,14 +91647,14 @@ From time to time, certain situations benefit from the program being
able to perform an evaluation, and then have the result of that evaluation
treated as a literal.
-There is already an operator named
+The
.code macro-time
-which makes this possible in its particular manner: that operator
+macro makes this possible in its particular manner: that macro
allows one or more expressions to be evaluated during macro expansion.
The result of the
.code macro-time
is then quoted and substituted in place of the expression. That result
-then appears as a true quoted literal to the executing code.
+then appears as a true literal to the executing code.
The
.code load-time
@@ -70928,7 +91685,7 @@ they were literal. Or else, the evaluation may be performed late: when the
form itself is encountered during normal evaluation. In that case,
.meta form
will still be evaluated only once and then its value will be be
-inserted as a literal in subsequent re-evaluations of that
+inserted as a literal in subsequent reevaluations of that
.code load-time
form, if any.
@@ -70972,7 +91729,7 @@ form appearing in a form passed to
.code compile-toplevel
is translated such that its embedded
.meta form
-will be executed each time the virtual machine description returned by
+will be executed each time the virtual-machine description returned by
.code compile-toplevel
is executed, and the execution of all such forms is placed ahead
of other code.
@@ -71040,7 +91797,7 @@ is evaluated in the dynamic environment of the caller which invokes
the execution of the resulting compiled object.
When a
.code load-time
-form occurs in the code of an function being processed by
+form occurs in the code of a function being processed by
.codn compile ,
then
.meta form
@@ -71055,6 +91812,52 @@ the immediately enclosing form which surrounds the
.code load-time
form.
+A
+.code load-time
+form may be nested inside another
+.code load-time
+form. In this situation, two cases occur.
+
+If the two forms are not embedded in a
+.codn lambda ,
+or else are embedded in the same
+.codn lambda ,
+then the inner
+.code load-time
+form is superfluous due to the presence of the outer
+.codn load-time .
+That is to say, the inner
+.mono
+.meti (load-time << form )
+.onom
+expression is equivalent to
+.metn form ,
+because the outer form already establishes its evaluation to be in a load-time
+context.
+
+If the inner
+.code load-time
+form occurs in a
+.codn lambda ,
+but the outer form occurs outside of that
+.codn lambda ,
+then the semantics of the inner
+.code load-time
+form is relevant and necessary. This is because expressions occurring in a
+.code lambda
+are evaluated when the
+.code lambda
+is called, which may take place from a non-load-time context, even if the
+.code lambda
+itself was produced in a load-time context.
+
+An expression being embedded in a
+.code lambda
+means that it appears either in the
+.code lambda
+body, or else in the parameter list as the initializing
+expression for an optional parameter.
+
.TP* Notes:
When interpreted code containing
@@ -71105,6 +91908,20 @@ closure which is returned. Invoking the closure doesn't cause the
.code load-time
expressions to be evaluated.
+The
+.code load-time
+form is subject to compiler optimizations. A top-level expression is assumed to
+be evaluated at load time, so
+.code load-time
+does nothing in a top-level expression. It becomes active inside forms
+embedded in a
+.code lambda
+expressions. Since
+.code load-time
+may be used to hoist calculations outside of loops,
+.code load-time
+is also active in those parts of loops which are repeatedly evaluated.
+
The use of
.code load-time
is similar to defining a variable and then referring to the variable.
@@ -71139,7 +91956,7 @@ Furthermore, the use of
versus
.cod3 defparm / defparml
controls whether the variable gets replaced with a new value when the
-file is re-loaded.
+file is reloaded.
The advantage of
.code load-time
@@ -71195,7 +92012,7 @@ to stage the evaluation of global effects that the macro expansion depends on
simply by bundling these effects into the expansion, wrapped in
.codn load-time .
-.TP* "Dialect note:"
+.TP* "Dialect Note:"
The
.code load-time
macro is similar to the ANSI Common Lisp
@@ -71239,7 +92056,7 @@ a suffix that adds no value. Lastly,
.code load-time
is shorter, and harmonizes with
.codn macro-time ,
-which preceded it by four years.
+which existed earlier.
.coNP Function @ disassemble
.synb
@@ -71250,7 +92067,7 @@ which preceded it by four years.
.desc
The
.code disassemble
-function presents a disassembly listing of the virtual machine
+function presents a disassembly listing of the virtual-machine
code of a compiled function or form. It also presents the literal data
contained in that compiled object in a tabular form which is readily
cross-referenced with the disassembly listing.
@@ -71265,7 +92082,7 @@ argument.
A
.meta function
-argument is one that is a function object. Only compiled virtual machine
+argument is one that is a function object. Only compiled virtual-machine
functions can be disassembled; other kinds of functions are rejected by
.codn disassemble .
@@ -71317,7 +92134,7 @@ Each
must be be one of three kinds of values:
.RS
.IP 1.
-a virtual machine description object returned by
+a virtual-machine-description object returned by
.code compile-toplevel
function; or
.IP 2.
@@ -71337,8 +92154,8 @@ writes some preamble information into
.metn stream .
Then, for each
.meta object
-that is not already a virtual machine description, its corresponding
-virtual machine description is retrieved. The virtual machine description
+that is not already a virtual-machine description, its corresponding
+virtual-machine description is retrieved. The virtual-machine description
is converted into the externalized format required for the object format
and that externalized format is written into
.metn stream .
@@ -71352,11 +92169,11 @@ is used to populate an initially empty file, and no other data are
written into the file, then that file is a valid compiled file.
If that file is processed by
.code load-file
-then each of the externalized forms is converted to a virtual machine
+then each of the externalized forms is converted to a virtual-machine
description and executed.
-Note that virtual machine descriptions are not functions. A function's
-virtual machine description is the compiled version of the top-level form
+Note that virtual-machine descriptions are not functions. A function's
+virtual-machine description is the compiled version of the top-level form
whose evaluation produced that function.
For example, if the following top-level form is compiled and executed,
@@ -71381,7 +92198,7 @@ Whether the
.code a
or
.code b
-symbol is used to specify the object to be dumped, the same virtual machine
+symbol is used to specify the object to be dumped, the same virtual-machine
description is externalized and deposited into the stream. That machine
description, when loaded and executed, defines two functions.
@@ -71392,7 +92209,7 @@ description, when loaded and executed, defines two functions.
On some target platforms, \*(TX provides an interactive listener, which is
invoked using the
.code -i
-command line option, or by executing
+command-line option, or by executing
.code txr
with no arguments. The interactive listener provides features like visual
editing of the command line, tab completion on \*(TL symbols, and history
@@ -71408,7 +92225,9 @@ interpreted as editing commands or other special characters, or else are
inserted into the editing buffer. However, control characters which don't
correspond to commands are silently rejected.
-The carriage return character generated by the Enter key indicates that a
+The carriage return character generated by the
+.key Enter
+key indicates that a
complete line has been entered, and it is to be interpreted. The listener
parses the line as a \*(TL expression, evaluates it, and prints the resulting
value. If the evaluation of the line throws an exception, the listener
@@ -71427,20 +92246,41 @@ such a line
.B is
entered into the history.
+The listener does not allow lines containing certain bad syntax to be submitted
+with
+.keyn Enter .
+If the buffer contains an expression with unbalanced parentheses
+or brackets, or unterminated literals, then
+.key Enter
+generates a newline character
+which is inserted into the buffer. In that situation, if that newline character
+is being added at the very end of the buffer, the listener flashes the
+exclamation mark character (!) two times to warn the user that line has not
+been submitted: no computation is taking place, and the listener is waiting for
+more input. It is possible to force the submission of an unbalanced line using
+the sequence
+.key Ctrl-X
+.keyn Ctrl-F .
+
.SS* Limitations
The interactive listener can only accept up to 4095 abstract characters of
input in a single command line.
Though the edit buffer is referred as the "command line", it may contain
-multi-line input. The carriage return characters which separate multiple lines
+multiline input. The carriage return characters which separate multiple lines
count as one abstract character each, and are understood to occupy two display
positions.
-The command line must contain exactly one complete \*(TL expression, or a
-comment. Multiple expressions will not be evaluated.
+Until \*(TX 286, the command line had to contain exactly one complete \*(TL
+expression, or a comment. Multiple expressions were not evaluated.
+This restriction has been lifted: multiple expressions in the command line
+are parsed as one unit, and evaluated as if they were placed into a
+.code progn
+form. If all the expressions evaluate and terminate normally, the value of the
+last expression is printed.
-In multi-line mode, if the number of lines exceeds the number of lines
+In multiline mode, if the number of lines exceeds the number of lines
of the terminal display, the editing experience is adversely affected
in unspecified ways.
@@ -71452,7 +92292,9 @@ environment variable is ignored.
.SS* Ways to Quit
-Pressing Ctrl-D in a completely empty command line terminates the listener.
+Pressing
+.key Ctrl-D
+in a completely empty command line terminates the listener.
Another way to quit is to enter the
.code :quit
keyword symbol. When the form input into the listener consists of this symbol,
@@ -71491,13 +92333,16 @@ The previous remark about not saving the listener history applies here also.
.SS* Interrupting Evaluation
-Ctrl-C typed while editing a command line is interpreted as an editing command
+.key Ctrl-C
+typed while editing a command line is interpreted as an editing command
which causes that command line to be canceled. The listener prints the string
.str ** intr
and repeats the same prompt.
If a command line is submitted for evaluation, the evaluation might take
-a long time or block for input. In these situations, typing Ctrl-C will issue
+a long time or block for input. In these situations, typing
+.key Ctrl-C
+will issue
an interrupt signal. The listener has installed a handler for this signal which
generates an exception of type
.code error
@@ -71505,13 +92350,15 @@ which is caught by the listener. The exception's message is the string
.str intr
so that the listener ends up printing
.str intr **
-like in the case of the Ctrl-C editing command. In this situation, though new
-command line prompt is issued with an incremented number, and the exception
+like in the case of the
+.key Ctrl-C
+editing command. In this situation, though, a new
+command-line prompt is issued with an incremented number, and the exception
is recorded as a value.
.SS* Listener Variables
-.coNP Variables @, *0 @, *1 @, *2 @, ... @ *99
+.coNP Variables @, *0 @, *1 @, *2 ..., @ *99
.desc
The listener provides useful variables which allow commands to reference
the results of previous commands. As noted previously, the commands
@@ -71520,7 +92367,7 @@ corresponds to one of the variables
.codn *0 ,
.codn *1 ,
.codn *2 ,
-.codn ... ,
+\&...,
.codn *99 .
Thus, up to the previous hundred results can be referenced:
@@ -71534,11 +92381,30 @@ Thus, up to the previous hundred results can be referenced:
10
.brev
+.coNP Symbol Macros @, *-1 @, *-2 ..., @ *-20
+The listener provides small number of symbol macros for referencing the
+results of previous commands in a relative. The macro
+.code *-1
+refers to the value of the immediately previous command. The macro
+.code *-2
+refers to the value of the command before that one and so on.
+
+Note: each of these macros expands to a reference to the
+.code *r
+vector, according to the following pattern:
+
+.mono
+ *-1 --> [*r (mod (- *v 1) 100)]
+ *-2 --> [*r (mod (- *v 2) 100)]
+ ...
+ *-20 --> [*r (mod (- *v 20) 100)]
+.onom
+
.coNP Variable @ *n
.desc
The listener variable
.code *n
-evaluates to the current command line number: the number of the command in
+evaluates to the current command-line number: the number of the command in
which the variable occurs:
.verb
@@ -71612,32 +92478,54 @@ or that is immediately to the right of an I-beam cursor.
.NP* Move Left and Right
-Moving within the line is achieved using the left and right arrow keys. In
-addition, Ctrl-B ("back") and Ctrl-F ("forward") perform this movement.
+Moving within the line is achieved using the left and right arrow keys
+.key \[<-]
+and
+.keyn \[->] .
+In addition,
+.key Ctrl-B
+("back") and
+.key Ctrl-F
+("forward") perform this movement.
.NP* Jump to Beginning and End of Line
-The Ctrl-A command moves to the beginning of the line. ("A" is the beginning
-of the alphabet). The Ctrl-E ("end") command jumps to the end of the line,
+The
+.key Ctrl-A
+command moves to the beginning of the line. ("A" is the beginning
+of the alphabet). The
+.key Ctrl-E
+("end") command jumps to the end of the line,
such that the last character of the line is to the left of the cursor
position. On terminals which have the Home and End keys, these may also
-be used instead of Ctrl-A and Ctrl-E.
+be used instead of
+.key Ctrl-A
+and
+.keyn Ctrl-E .
In line mode, these commands move the cursor to the beginning or end of the
edit buffer.
-In multi-line mode, if the cursor is not already at the beginning of a physical
-line, then Ctrl-A moves it to the first character of the physical line.
-Otherwise, Ctrl-A moves the cursor to the beginning of the edit buffer.
+In multiline mode, if the cursor is not already at the beginning of a physical
+line, then
+.key Ctrl-A
+moves it to the first character of the physical line.
+Otherwise,
+.key Ctrl-A
+moves the cursor to the beginning of the edit buffer.
-Similarly, in multi-line mode, if the cursor not already at the end of a
-physical line, Ctrl-E moves it there. Otherwise, the cursor moves to the
+Similarly, in multiline mode, if the cursor not already at the end of a
+physical line,
+.key Ctrl-E
+moves it there. Otherwise, the cursor moves to the
end of the edit buffer.
.NP* Jump to Matching Parenthesis
If the cursor is on an opening or closing parenthesis, brace or bracket,
-the Ctrl-] command tries to jump to the matching character. The logic for
+the
+.key Ctrl-]
+command tries to jump to the matching character. The logic for
finding the matching character is identical to that of the Parenthesis Matching
feature. If no matching character is found, then no movement takes place.
@@ -71654,14 +92542,19 @@ outer one. Otherwise, if the two characters have opposite orientation (one is
opening and the other closing), then the one which is to the right of the
cursor position is chosen.
-Note: the Ctrl-] character can be produced on some terminals using Ctrl-5
+Note: the
+.key Ctrl-]
+character can be produced on some terminals using
+.key Ctrl-5
(using the keyboard home row 5, not the numeric keypad 5). This the same
key which produces the % character when Shift is used. The % character is
used in the Vi editor for parenthesis matching.
.NP* Character Swap
-The Ctrl-T (twiddle) command exchanges the character under the cursor with the
+The
+.key Ctrl-T
+(twiddle) command exchanges the character under the cursor with the
previous character.
.NP* Delete Character Left
@@ -71670,102 +92563,181 @@ The Backspace key erases the character to the left of the cursor, and moves the
cursor to the position which that character occupied.
It doesn't matter whether this key generates ASCII
-characters 8 (BS) or 127 (DEL): either one is acceptable. The Ctrl-H command
+characters 8 (BS) or 127 (DEL): either one is acceptable. The
+.key Ctrl-H
+command
also performs the same action, since it corresponds to ASCII BS.
.NP* Delete Character Right
-The Ctrl-D command is overloaded with two meanings. If the line is empty, it is
-a quit indication. Otherwise, it deletes the character under the cursor
-without changing the cursor position. On terminals which have a Delete key,
-the deleting action may also be performed with that key. The Delete key doesn't
-have the quit indication meaning of Ctrl-D.
+The
+.key Ctrl-D
+command deletes the character under the cursor, if the cursor
+is block-shaped, or to the right of the cursor if the cursor is an I-beam.
+the cursor maintains its current character position relative to the
+start of the line. In multiline mode, if
+.key Ctrl-D
+is at the end of a line that
+is not the last line, it deletes the newline character, causing the
+following line to be joined to the end of the current line.
+If the cursor is at the end of the buffer, then
+.key Ctrl-D
+does nothing,
+except if the buffer is completely empty, in which case it is a quit
+indication. The Delete key, if available on the terminal, is a near synonym of
+.keyn Ctrl-D .
+It performs all the same functions, except that it does not
+act as a quit indication; Delete has no effect when the buffer is empty.
+
+When a visual selection is in effect, then
+.key Ctrl-D
+and
+.key Del
+delete
+that selection, and copy it to the clipboard.
.NP* Delete Word Left
-The Ctrl-W ("word") command deletes the word to the left of the cursor
+The
+.key Ctrl-W
+("word") command deletes the word to the left of the cursor
position. More precisely, this command first deletes any consecutive whitespace
characters (spaces or tabs) to the left of the cursor. Then, it deletes
consecutive non-whitespace characters. Material under the cursor or to the
-right remains.
+right remains. The deleted material is copied into the clipboard.
.NP* Delete to Beginning of Line
-The Ctrl-U ("undo typing") command is a "super backspace" operation: it deletes
+The
+.key Ctrl-U
+("undo typing") command is a "super backspace" operation: it deletes
all characters to the left of the cursor position. The cursor is moved to
-the leftmost position.
-
-In multi-line mode, Ctrl-U deletes only to the beginning of the current
+the leftmost position. In multiline mode,
+.key Ctrl-U
+deletes only to the beginning of the current
physical line, not all the way to the first position of the buffer.
+.key Ctrl-U
+copies the deleted material into the clipboard.
.NP* Delete to End of Line
-The Ctrl-K ("kill") command deletes the character under the cursor position
+The
+.key Ctrl-K
+("kill") command deletes the character under the cursor position
and all subsequent characters. The cursor position doesn't change.
-
-In multi-line mode, Ctrl-K deletes only until the end of the current
+In multiline mode,
+.key Ctrl-K
+deletes only until the end of the current
physical line, not the entire buffer.
+The material deleted by
+.key Ctrl-K
+is copied into the clipboard.
.NP* Verbatim Character Insert
-The Ctrl-V ("verbatim") command places the listener's input editor into
+The
+.key Ctrl-V
+("verbatim") command places the listener's input editor into
a mode in which the next character is interpreted literally and inserted
-into the line, even if that character is a special character such as Enter,
+into the line, even if that character is a special character such as
+.keyn Enter ,
or a command character.
.NP* Verbatim Insert Mode
-The two-character sequence Ctrl-X, Ctrl-V ("extended verbatim", "super paste")
-enters into an verbatim insert mode useful for entry of free-form text. It is
-particularly useful in multi-line mode. In this mode, almost every character
-is inserted verbatim, including Enter. The only commands recognized are:
-Ctrl-X, which terminates this mode, Backspace (both ASCII BS and DEL
-variants) and arrow key navigation. Enter inserts a line break, which
-appears as such in multi-line mode, or as
+The two-character sequence
+.key Ctrl-X
+.key Ctrl-V
+("extended verbatim", "super paste")
+enters into a verbatim insert mode, useful for entry of free-form text. It is
+particularly useful in multiline mode. In this mode, almost every character
+is inserted verbatim, including
+.keyn Enter .
+The only commands recognized are:
+.keyn Ctrl-X ,
+which terminates this mode,
+.key Backspace
+(whether that key generates ASCII BS or DEL) and arrow key navigation.
+.key Enter
+inserts a line break, which
+appears as such in multiline mode, or as
.code ^M
in line mode.
.NP* Delete Current Line
-The Ctrl-X, Ctrl-K command sequence may be used in multi-line mode
+The
+.key Ctrl-X
+.key Ctrl-K
+command sequence may be used in multiline mode
to delete the entire physical line under the cursor. Any lines below that
line move up to close the gap. In line mode, the command has no effect,
-other than canceling select mode.
+other than canceling select mode. The deleted line, including the
+terminating newline character, if it has one, is copied into the
+clipboard.
.NP* History Recall
By default, the most recent 500 lines submitted to the interactive listener are
remembered in a history. This history is available for recall, making it
convenient to repair mistakes, or compose new lines which are based on previous
-lines. Note that the the history suppresses consecutive duplicate lines.
+lines. Note that the history suppresses consecutive, duplicate lines.
The number of lines retained may be customized using the
.code *listener-hist-len*
variable.
-If the up arrow is used while editing a line, the contents of the line are
+If the
+.key \[ua]
+key is used while editing a line, the contents of the line are
placed into a temporary save area. The line display is then updated to
-show the most recent line of history. Using the up arrow key additional times
+show the most recent line of history. Using
+.key \[ua] additional times
will recall successively less recent lines.
-The down arrow key navigates in the opposite direction: from older lines to
-newer lines. When the down arrow key is invoked on the most recent history line,
+The
+.key \[da]
+key navigates in the opposite direction: from older lines to
+newer lines. When
+.key \[da]
+is invoked on the most recent history line,
then the current line is restored from the temporary save area.
-Instead of the up and down arrow keys, the commands Ctrl-P ("previous")
-and Ctrl-N ("next") may be used.
+Instead of
+.key \[ua]
+and
+.keyn \[da] ,
+the commands
+.key Ctrl-P
+("previous")
+and
+.key Ctrl-N
+("next") may be used.
-If the Enter key is pressed while a recalled history line is showing, then that
+If the
+.key Enter
+key is pressed while a recalled history line is showing, then that
line will be submitted as if it were a newly composed line. The originally
edited line which had been placed in the save area is discarded.
When a recalled line is showing, it may be edited. There are two important
-behaviors to note here. If a recalled history line is edited, and then the
-up/down arrow keys or a navigation command is used to show a different
+behaviors to note here. If a recalled history line is edited, and then
+.key \[ua]
+or
+.key \[da]
+or a navigation command is used to show a different
history line, or to restore the original current line, then the edit is made
permanent: the edited line replaces its original version in the same
position in the history. This feature allows corrections to be made to the
-history. However, if a recalled line is edited and submitted without
-navigating to another line, then it is submitted as a newly composed line,
-without replacing the original in the history.
+history.
+
+The edit is recorded in the line's undo history as a single change; if the
+edited line is visited again, then a single
+.key Ctrl-O
+command will revert all the
+edits that were made.
+
+However, if a recalled line is edited and submitted without navigating to
+another line, then it is submitted as a newly composed line, without replacing
+the original in the history.
Each submitted line is entered into the history, if it is different
from the most recent line already in history. This is true whether it
@@ -71774,7 +92746,9 @@ history line.
.NP* History Search
It is possible to search backwards through the history interactively
-for a line containing a substring. The Ctrl-R command is used to initiate
+for a line containing a substring. The
+.key Ctrl-R
+command is used to initiate
search. The command prompt is replaced with the prefix
.code search:
next to which a pair of empty square brackets appears, indicating
@@ -71785,7 +92759,9 @@ In search mode, characters may be typed. They accumulate inside the search
box, and constitute the string to search for. The listener instantly
navigates to the most recent line which contains a substring match for the
search string, and places the cursor on the first character of the
-match. Control characters entered directly are ignored. The Ctrl-V command be
+match. Control characters entered directly are ignored. The
+.key Ctrl-V
+command be
used to add a character verbatim, as in edit mode.
To remove characters from the search box, Backspace can be used. The
@@ -71799,61 +92775,109 @@ when search mode is initiated. Searches work backward in history from
that line. If search text is edited by deleting characters and then
adding new ones, the new search proceeds from the home position.
-The Ctrl-R command can be used in search mode. It registers the currently
+The
+.key Ctrl-R
+command can be used in search mode. It registers the currently
showing line as the new home position, and then repeats the search using the
existing search text backwards from the new position. If the search text
-is empty, Ctrl-R has no effect.
+is empty,
+.key Ctrl-R
+has no effect.
-The Ctrl-C command leaves search mode at any time and causes the
+The
+.key Ctrl-C
+command leaves search mode at any time and causes the
listener to resume editing the original input at the original character
-position. The Enter key accepts the result of a search and submits it
+position. The
+.key Enter
+key accepts the result of a search and submits it
as if it were a newly composed line.
Navigation and editing keys may be used in search mode. A navigation or editing
key immediately cancels search mode, and is processed in edit mode, using
whatever line was located by the search, at the matching character position.
-The Ctrl-L (Clear Screen and Refresh), as well as Ctrl-Z
+The
+.key Ctrl-L
+(Clear Screen and Refresh), as well as
+.key Ctrl-Z
(Suspend to Background) commands are available in search mode. Their effects
takes place without leaving search mode.
-Navigating to a history line manually using the up and down arrow keys (or
-Ctrl-P/Ctrl-N) has the same net effect same as locating that line using
-Ctrl-R search.
+Navigating to a history line manually using
+.key \[ua]
+or
+.key \[da]
+(or
+.key Ctrl-P
+and
+.keyn Ctrl-N )
+has the same net effect same as locating that line using
+.key Ctrl-R
+search.
.NP* Submit and Stay in History
-Normally when the Enter key is used on a recalled history line,
-the next time the listener is re-entered, it jumps back to the
+Normally when the
+.key Enter
+key is used on a recalled history line,
+the next time the listener is reentered, it jumps back to the
newest history position where a new line is about to be composed.
-The alternative command sequence Ctrl-X, Enter provides a useful alternative
+The alternative command sequence
+.key Ctrl-X
+.key Enter
+provides a useful alternative
behavior. After the submitted line is processed, the listener doesn't jump to
the newest history position. Instead, it stays in the history, advancing
forward by one position to the successor of the submitted line.
-Ctrl-X, Enter can be used to conveniently submit a range of lines
+.key Ctrl-X
+.key Enter
+can be used to conveniently submit a range of lines
from the history, one by one, in their original order.
.NP* Insert Previous Word
-The equivalent command sequences Ctrl-X, w and Ctrl-X, Ctrl-W insert
+The equivalent command sequences
+.key Ctrl-X
+.key w
+and
+.key Ctrl-X
+.key Ctrl-W
+insert
a word from the previous line at the cursor position. A word is defined
as a sequence of non-whitespace characters, separated from other words
by whitespace. By default, the last word of the previous line is inserted.
-Between the Ctrl-X and Ctrl-W or w, a decimal number can be entered.
+Between the
+.key Ctrl-X
+and the following
+.key Ctrl-W
+or
+.keyn w ,
+a decimal number can be entered.
The number 1 specifies that the last word is to be inserted, 2 specifies
the second last word, 3 the third word from the right and so on.
Only the most recent three decimal digits are retained, so the number can range
from 0 to 999. A value of 0, or a value which exceeds the number of words
-causes the Ctrl-W or w to do nothing. Note that "previous line" means
+causes the
+.key Ctrl-W
+or
+.key w
+to do nothing. Note that "previous line" means
relative to the current location in the history. If the 42nd most recent
history line is currently recalled, this command takes material from the 43rd
history line.
.NP* Insert Previous Atom
-The equivalent command sequences Ctrl-X, a and Ctrl-X, Ctrl-A insert
+The equivalent command sequences
+.key Ctrl-X
+.key a
+and
+.key Ctrl-X
+.key Ctrl-A
+insert
an atom from the previous line at the cursor position. A line only
makes atoms available if it expresses a valid \*(TX form, free of syntax
errors. A line containing only whitespace or a comment makes no atoms
@@ -71863,20 +92887,41 @@ specified in the previous line. The line is flattened into atoms
as if by the
.code flatcar
function. By default, the last atom is extracted. A numeric argument
-typed between the Ctrl-X and Ctrl-A or a can be used to select a
+typed between the
+.key Ctrl-X
+and
+.key Ctrl-A
+or a can be used to select a
atoms by position from the end. The number 1 specifies the last atom,
2 the second last and so on.
Only the most recent three decimal digits are retained, so the number can range
from 0 to 999. A value of 0, or a value which exceeds the number of words
-causes the Ctrl-A or a to do nothing. Note that "previous line"
-has the same meaning as for the Ctrl-X, Ctrl-W (insert previous word) command.
+causes the
+.key Ctrl-A
+or a to do nothing. Note that "previous line"
+has the same meaning as for the
+.key Ctrl-X
+.key Ctrl-W
+(insert previous word) command.
.NP* Insert Previous Line
-The command sequences Ctrl-X, Ctrl-R ("repeat") and Ctrl-X, r, which are
+The command sequences
+.key Ctrl-X
+.key Ctrl-R
+("repeat") and
+.key Ctrl-X
+.keyn r ,
+which are
equivalent, insert an entire line of history into the current buffer. By
default, the previous line is inserted. A less recent line can be selected by
-typing a numeric argument between the Ctrl-X and the Ctrl-R/r. The immediately
+typing a numeric argument between the
+.key Ctrl-X
+and the
+.key Ctrl-R
+or
+.keyn r .
+The immediately
previous history line is numbered 1, the one before it 2 and so on.
If this command is used during history navigation, it references previous
lines relative to the currently recalled history line.
@@ -71885,9 +92930,16 @@ lines relative to the currently recalled history line.
If the Tab key is pressed while editing a line, it is interpreted as a
request for completion. There is a second completion command: the
-sequence Ctrl-X Tab.
+sequence
+.key Ctrl-X
+.keyn Tab .
-When completion is invoked with Tab or Ctrl-X Tab, the listener looks at a few
+When completion is invoked with
+.key Tab
+or
+.key Ctrl-X
+.keyn Tab ,
+the listener looks at a few
of the trailing characters to the left of the cursor position to determine the
applicable list of completions. Completions are determined from among the \*(TL symbols which have
global variable, function, macro and symbolic macro bindings, as well
@@ -71904,7 +92956,12 @@ immediately precede the prefix, then only those symbols are considered
which are methods: that is, each is the static slot of at least one structure,
in which that static slots holds a function.
-The difference between Tab and Ctrl-X Tab is that Tab completion looks only for
+The difference between
+.key Tab
+and
+.key Ctrl-X
+.key Tab
+is that Tab completion looks only for
prefix matches among the eligible identifiers. Thus it is a pure completion in
the sense that it suggests additional material that may follow what has been
typed. If the buffer contains
@@ -71918,7 +92975,10 @@ and
.codn list-str .
It will not suggest identifiers which rewrite the
.code list
-prefix. By contrast, the Ctrl-X Tab completion suggests not only pure
+prefix. By contrast, the
+.key Ctrl-X
+.key Tab
+completion suggests not only pure
completions but also alternatives to the partial identifier, by looking for
substring matches. For instance
.code copy-list
@@ -71934,11 +92994,17 @@ editing mode.
If completions are found, listener enters into completion selection mode.
The first available completion is placed into the line as if it had been typed
in. The other completions may be viewed one by one using the Tab key.
-(Note that the Ctrl-X is not used, only Tab, even if completion mode had been
-entered via Ctrl-X Tab).
+(Note that the
+.key Ctrl-X
+is not used, only Tab, even if completion mode had been
+entered via
+.key Ctrl-X
+.keyn Tab ).
When the completions are exhausted, the original uncompleted line is shown
again, and Tab can continue to be used to cycle through the completions again.
-In completion mode, the Ctrl-C character acts as a command to cancel completion mode
+In completion mode, the
+.key Ctrl-C
+character acts as a command to cancel completion mode
and return to editing the original uncompleted line. Any other input character causes
the listener to keep the currently shown completion, and return to edit mode,
where that character is immediately processed as if it had been typed in
@@ -71946,14 +93012,17 @@ edit mode.
.NP* Edit with External Editor
-The two character command Ctrl-X, Ctrl-E launches an external editor to
+The two character command
+.key Ctrl-X
+.key Ctrl-E
+launches an external editor to
edit the current command line. The command line is stored in a temporary
file first, and the editor is invoked on this file. When the editor
terminates, the file is read into the editing buffer.
The editor is determined from the
.code EDITOR
-environment variable. If this variable doesn't exist,
+environment variable. If this variable is unset or empty,
the command does nothing.
The temporary file is created in the home directory, if that can
@@ -71966,14 +93035,16 @@ environment variable in POSIX environments. On MS Windows, the
variable is probed for the user's directory.
If the command line contains embedded carriage returns (which denote
-line breaks in multi-line mode) these are replaced with newline characters
+line breaks in multiline mode) these are replaced with newline characters
when written out to the file. Conversely, when the edited file is read
-back, its newlines are converted to carriage returns, so that multi-line
-content is handled properly. (See the following section, Multi-Line Mode).
+back, its newlines are converted to carriage returns, so that multiline
+content is handled properly. (See the following section, Multiline Mode.)
.NP* Undo Editing
-The listener provides an undo feature. The Ctrl-O command ("old", "oops")
+The listener provides an undo feature. The
+.key Ctrl-O
+command ("old", "oops")
restores the edit buffer contents and cursor position to a previous state.
There is a single undo history which records up the 200 most recent edit
@@ -71982,7 +93053,9 @@ appears that each line has its own, independent undo history.
Undoing the edits in one line has no effect on the undo history of another
line.
-Undo also records edits for lines that have been canceled with Ctrl-C, and are
+Undo also records edits for lines that have been canceled with
+.key Ctrl-C
+and are
not entered into the history, making it possible to recall canceled lines.
The undo history is lost when \*(TX terminates.
@@ -71993,12 +93066,14 @@ There is no redo. When undo removes an edit to restore to a prior edit state,
the removed edit is permanently discarded.
Note that if undo is invoked on a historic line, each undo step updates that
-history entry instantly to the restored state. This is in contrast
-to the way new edits work. New edits are not committed to history until
-navigation takes place to a different history line.
+history entry instantly to the restored state, not only the visible edit
+buffer. This is in contrast to the way new edits work. New edits are not
+committed to history until navigation takes place to a different history line.
Also note that when new edits are performed on a historic line and it is
-submitted with Enter without navigating to another line, the undo information
+submitted with
+.key Enter
+without navigating to another line, the undo information
for those edits is retained, and belongs to the newly submitted line. The
historic line hasn't actually been modified, and so it has no new undo
information. However, if a historic line is edited, and then navigation takes
@@ -72009,14 +93084,16 @@ in the history entry.
.SS* Visual Selection Mode
The interactive listener supports visual copy and paste operation.
-Text may be visually selected for copying into a clipboard (copy)
-or deletion. In visual selection mode, the actions of some editing
+Text may be visually selected for copying into a clipboard or
+or for deletion. In visual selection mode, the actions of some editing
commands are modified so that they act upon the selection instead
of their usual target, or upon both the target and the selection.
.NP* Making a Selection
-The Ctrl-S command enters into visual selection mode and marks the
+The
+.key Ctrl-S
+command enters into visual selection mode and marks the
starting point of the selection, which is considered the position
immediately to the left of the current character.
@@ -72026,17 +93103,19 @@ tracks the movement.
The selected text is displayed in reverse video.
-Typing Ctrl-S again while in visual selection mode cancels
+Typing
+.key Ctrl-S
+again while in visual selection mode cancels
the mode.
Tab completion, history navigation, history search and editing in an external
editor all cancel visual selection mode.
-By default, the the selection excludes the character which lies to the right of
-the rightmost end-point. Thus, the selection simply consists of the text
+By default, the selection excludes the character which lies to the right of
+the rightmost endpoint. Thus, the selection simply consists of the text
between these two positions, whether or not they are reversed. This style of
selection pairs excellently with an I-beam style cursor, and has clear
-semantics. The end-points are referenced to the positions between the
+semantics. The endpoints are referenced to the positions between the
characters, and everything between them is selected.
The selection behavior may be altered using the Boolean configuration variable
@@ -72047,20 +93126,24 @@ by default. If it is changed to true, then the selection includes the
character to the right of the rightmost endpoint, if there is such a
character within the current line. This style of selection
pair well with a block-shaped cursor. It creates the apparent semantics that
-the end-points of the election are characters, rather than points
+the endpoints of the selection are characters, rather than points
between characters, and that these characters are included in the selection.
.NP* Selection Endpoint Toggle
In visual selection, the starting point of the selection remains fixed, while
-the ending point tracks the movement of the cursor. The Ctrl-^ command will
+the ending point tracks the movement of the cursor. The
+.key Ctrl-^
+command will
exchange the two points. The effect is that the cursor jumps to the opposite
end of the selection. That end is now the ending point which tracks the cursor
movement.
.NP* Visual Copy
-The Ctrl-Y command ("yank") copies the selected text into a clipboard buffer.
+The
+.key Ctrl-Y
+command ("yank") copies the selected text into a clipboard buffer.
The previous contents of the clipboard buffer, if any, are discarded.
Unlike the history, the clipboard buffer is not persisted.
@@ -72068,18 +93151,24 @@ If \*(TX terminates, it is lost.
.NP* Visual Cut
-If the Ctrl-D command is invoked while a selection is in effect, then
+If the
+.key Ctrl-D
+command is invoked while a selection is in effect, then
instead of deleting the character under the cursor, it deletes the
-selection, and copies it to the clipboard.
-
-Ctrl-D has no effect on the clipboard when visual selection is not in effect.
+selection, and copies it to the clipboard. The Delete key has the same
+effect.
-No other commands which delete text have any effect on the clipboard,
-whether or not selection mode is in effect.
+.key Ctrl-D
+and
+.key Del
+have no effect on the clipboard when visual selection is not in
+effect, and they operate on just one character.
.NP* Clipboard Paste
-The Ctrl-Q command ("quote the clipboard") inserts text from the clipboard
+The
+.key Ctrl-Q
+command ("quote the clipboard") inserts text from the clipboard
at the current cursor position. The cursor position is updated to
be immediately after the inserted text. The clipboard text remains available
for further pasting.
@@ -72089,15 +93178,21 @@ session, then this command has no effect.
.NP* Clipboard Swap Paste
-The Ctrl-X, Ctrl-Q command sequence ("exchange quote") exchanges the
+The
+.key Ctrl-X
+.key Ctrl-Q
+command sequence ("exchange quote") exchanges the
selected text with the contents of the clipboard. The selection is
-copied into the clipboard as if by Ctrl-Y and replaced by the
+copied into the clipboard as if by
+.key Ctrl-Y
+and replaced by the
previous contents of the clipboard.
If the clipboard has not yet been used in the current session,
If nothing has been yet been copied to the clipboard in the current
-session, then this command behaves like Ctrl-Y:
+session, then this command behaves like
+.keyn Ctrl-Y :
text is yanked into the clipboard, but not deleted.
.NP* Visual Replace
@@ -72108,46 +93203,60 @@ selection is first deleted and visual mode is canceled. Then the insertion
takes place and visual mode is canceled. The effect is that the newly inserted
text replaces the selected text.
-This applies to the Clipboard Paste (Ctrl-Q) command also. If a
-selection is effect when Ctrl-Q is invoked, the selected text
+This applies to the Clipboard Paste
+.key Ctrl-Q
+command also. If a
+selection is effect when
+.key Ctrl-Q
+is invoked, the selected text
is replaced with the clipboard buffer contents.
-When a selection is replaced, nothing is copied to the clipboard.
+When a selection is replaced in this manner, the contents
+of the clipboard are unaffected.
.NP* Delete in Selection Mode
In visual mode, it is possible to issue commands which delete text.
-One such command is Ctrl-D. It's special behavior in selection mode,
+One such command is
+.keyn Ctrl-D .
+Its special behavior in selection mode,
Visual Cut, is described above.
-The Backspace key and Ctrl-H also have a special behavior in select mode. If
+The
+.key Backspace
+key and
+.key Ctrl-H
+also have a special behavior in select mode. If
the cursor is at the rightmost endpoint of the selection, then these commands
delete the selection and nothing else. If the cursor is at the leftmost
endpoint of the selection, then these commands delete the selection, and take
their usual effect of deleting a character also. In both cases, selection mode
-is canceled.
+is canceled. The clipboard is not affected.
-The Ctrl-W command to delete the previous word, when used in visual
+The
+.key Ctrl-W
+command for deleting the previous word, when used in visual
selection mode, deletes the selection and cancels selection mode,
-and then deletes the word before the selection.
+and then deletes the word before the selection. Only the deleted
+selection is copied into the clipboard, not the deleted word.
-All other deletion commands such as Ctrl-K simply cancel visual
+All other deletion commands such as
+.key Ctrl-K
+simply cancel visual
selection mode and take their usual effect.
-No deletion command other than Ctrl-D has any effect on the clipboard,
-and Ctrl-D only copies to the clipboard when a selection is being
-deleted.
+.SS* Multiline Mode
-.SS* Multi-Line Mode
-
-The listener operates in one of two modes: line mode and multi-line mode.
+The listener operates in one of two modes: line mode and multiline mode.
This is determined by the special variable
.code *listener-multi-line-p*
whose default value is
.code t
-(multi-line mode). It is possible to toggle between
-line mode and multi-line mode using the Ctrl-J command.
+(multiline mode). It is possible to toggle between
+line mode and multiline mode using the
+.key Ctrl-J
+command.
In line mode, all input given to a single prompt appears to be on a single
line. When the line becomes longer than the screen width, it scrolls
@@ -72155,10 +93264,10 @@ horizontally. In line mode, carriage return characters embedded in a line
are displayed as
.codn ^M .
-In multi-line mode, when the input exceeds the screen width, it simply wraps to
+In multiline mode, when the input exceeds the screen width, it simply wraps to
take up additional lines rather than scrolling horizontally. Furthermore,
-multi-line mode not only wraps long lines of input onto multiple lines of
-the display, but also supports true multi-line input. In multi-line
+multiline mode not only wraps long lines of input onto multiple lines of
+the display, but also supports true multiline input. In multiline
mode, carriage return characters embedded in input are treated as line
breaks rather than being rendered as
.codn ^M .
@@ -72167,18 +93276,24 @@ Because carriage returns are not line terminators in text files,
lines which contain embedded carriage returns are correctly saved
into and retrieved from the persistent history file.
-When Enter is typed in multi-line mode, the listener tries to determine whether
+When
+.key Enter
+is typed in multiline mode, the listener tries to determine whether
the current input, taken as a whole, is an incomplete expression which requires
closing punctuation for elements like compound expressions and string literals.
-If the input appears incomplete, then the Enter is inserted verbatim at
+If the input appears incomplete, then the
+.key Enter
+is inserted verbatim at
the current cursor position, rather than signaling that the line is
-being submitted for evaluation. The Ctrl-X, Enter command sequence also has
-this behavior.
+being submitted for evaluation. The
+.key Ctrl-X
+.key Enter
+command sequence also has this behavior.
.SS* Reading Forms Directly from the Terminal
-In addition to multi-line mode, the listener provides support
+In addition to multiline mode, the listener provides support
for directly parsing input from the terminal, suitable for processing
large amounts of pasted material.
@@ -72187,7 +93302,8 @@ If the
keyword is entered into the listener, it will temporarily suspend
interactive editing and allow the \*(TL parser to read
directly from standard input. The reading stops when an error occurs,
-or EOF is indicated by entering Ctrl-D.
+or EOF is indicated by entering
+.keyn Ctrl-D .
In direct parsing mode, each expression which is read is evaluated, but its
value is not printed. However, the value of the last form evaluated is returned
@@ -72203,13 +93319,17 @@ command which triggers this parsing mode appears in the history.
.SS* Clear Screen and Refresh
-The Ctrl-L command clears the screen and re-draws the line being edited.
+The
+.key Ctrl-L
+command clears the screen and redraws the line being edited.
This is useful when the display is disturbed by the output of some
background process, or serial line noise.
.SS* Suspend to Background
-The Ctrl-Z ("Zzzz... (sleep)") command causes \*(TX to be placed into the
+The
+.key Ctrl-Z
+("Zzzz... (sleep)") command causes \*(TX to be placed into the
background in a suspended, and control returned to the system shell.
Bringing the suspended \*(TX back into the foreground is achieved with a shell
@@ -72217,7 +93337,7 @@ job-control command such as the
.code fg
command in GNU Bash.
-When \*(TX is resumed, the interactive listener will re-display the edited
+When \*(TX is resumed, the interactive listener will redisplay the edited
line and restore the previous cursor position.
Making full use of this feature requires a POSIX job control shell,
@@ -72227,11 +93347,25 @@ user to lose interactive control over that \*(TX instance.
.SS* Editing Help
-The Ctrl-X ? command shows a summary of commands, in a four-line
+The
+.key Ctrl-X
+.key ?
+command shows a summary of commands, in a four-line
display which temporarily replaces the editing area. The help text
-is divided into several pages. Ctrl-C dismisses the display, and
-returns to editing. The Ctrl-P, left arrow and up arrow keys return
-to the previous screen. The Ctrl-Z and Ctrl-L commands are available,
+is divided into several pages.
+.key Ctrl-C
+dismisses the display, and
+returns to editing. The
+.keyn Ctrl-P ,
+.key \[<-]
+and
+.key \[ua]
+keys return
+to the previous screen. The
+.key Ctrl-Z
+and
+.key Ctrl-L
+commands are available,
having their usual meaning of suspending and refreshing the display.
Any other key advances to the next screen.
Advancing from the last screen, dismisses the display, and returns
@@ -72248,8 +93382,14 @@ incrementing the prompt number. The
command prints just the current prompt number, followed by a newline,
without incrementing the number.
-These comments are useful in plain mode, in which no prompts are
-printed. See Plain Mode below.
+In plain mode, the
+.code :prompt-on
+command enables the printing of prompts. The full prompt is printed before
+reading each new command line. An abbreviated prompt is printed before reading
+the continuation lines of an incomplete expression. The printing of prompts
+is automatically enabled if the input device is an interactive terminal.
+
+None of these prompt-related commands are entered into the history.
.SS* Plain Mode
@@ -72257,14 +93397,14 @@ When the input device isn't an interactive terminal, or if the
.code -n
or
.code --noninteractive
-command line operations are used when invoking \*(TX,
+command-line operations are used when invoking \*(TX,
the listener operates in
.IR "plain mode" .
-It reads input without providing any editing features: no completion,
-history recall, selection, or copy and paste. Only the line editing
-features provided by the operating system are available.
-No prompts appear; however, there is still an incrementing counter,
-and the numbered variables
+It reads input without providing any of the editing features of visual mode: no
+completion, history recall, selection, or copy and paste. Only the line
+editing features provided by the operating system are available. Prompts
+appear if standard input is an interactive terminal, or if explicitly enabled.
+There is still an incrementing counter, and the numbered variables
.codn *1 ,
.codn *2 ,
.code ...
@@ -72272,9 +93412,22 @@ for accessing evaluation results are established.
Lines are still entered into the history, and the interactive profile
is still processed, as usual.
+Plain mode reads whole lines of input, yet recognizes multi-line expressions.
+Whenever a line of input is read which represents incomplete syntax, another
+line of input is read and appended to that line. This repeats until the
+accumulated input represents complete syntax, and is then processed as a unit.
+
+Like in visual mode, each unit of input may contain multiple expressions.
+These are parsed as a unit and evaluated as if they were the elements of a
+.code progn
+expression. The resulting value which is printed is that of the last
+expression.
+
.SS* Interactive Profile File
-When the listener starts up, it looks for file called
+Unless the
+.code --noprofile
+option has been used, when the listener starts up, it looks for file called
.code .txr_profile
in the user's home directory, as determined by the
.code HOME
@@ -72283,12 +93436,16 @@ environment variable in POSIX environments or the
environment variable on MS Windows. If that variable doesn't exist, no further
attempt is made to locate this file.
-If the file exists, it is subject to a security check.
-The function
-.code path-private-to-me-p
-is applied to the file. If it returns
-.code nil
-then an error message is displayed and the file is not loaded.
+If the file exists, it is subject to security checks. First, the
+.code path-components-safe
+is applied to its path name. The function validates that no component
+of the path name is a directory that is writable to another user, or
+a symbolic link that could be rewritten by another user.
+If that check passes, the file is then checked with the function
+.code path-strictly-private-to-me-p
+which requires that other users have no read or write permission.
+If the checks fail, then an error message is displayed and the file is not
+loaded.
If the file passes the security check, it is expected to be readable and
to contain
@@ -72301,7 +93458,7 @@ situations. Exceptions not derived from
.code error
will terminate the process.
-The profile file is not read by non-interactive invocations of \*(TX:
+The profile file is not read by noninteractive invocations of \*(TX:
that is, when the
.code -i
option isn't present.
@@ -72312,7 +93469,7 @@ The history is maintained in a text file called
.code .txr_history
in the user's home directory. Whenever the interactive listener terminates,
this file is updated with the history contents stored in the listener's
-memory. The next time the listener starts, it first re-loads the history from
+memory. The next time the listener starts, it first reloads the history from
this file, making the most recent
.code *listener-hist-len*
expressions of a previous session available for recall.
@@ -72357,6 +93514,20 @@ only adds to the history file new input since the most recent
.code :save
command.
+When the history file is loaded, security checks take place, in exactly
+the same way that the
+.str .txr_profile
+file is validated. First the path of the history file is checked using
+the function
+.codn path-components-safe ,
+which determines that no component of the path name can be subverted
+by another user, other than the superuser. If that check passes, then
+the file is checked using
+.code path-strictly-private-to-me-p
+which requires that other users have no read or write permission.
+If the checks fail, then an error message is displayed and the history
+file is not loaded.
+
.SS* Parenthesis Matching
A feature of the listener is visual parenthesis matching in the form of a
@@ -72383,7 +93554,7 @@ new character is typed during the brief time delay, the delay is immediately
canceled, so as not to hinder rapid typing.
This back-and-forth jump behavior also occurs when a character is erased using
-Backspace, and the the cursor ends up immediately to the right of a
+Backspace, and the cursor ends up immediately to the right of a
parenthesis.
Note that the matching is unsophisticated; it doesn't observe the
@@ -72397,36 +93568,36 @@ The listener's behavior can be influenced through values of certain
global variables. The settings can be made persistent by means
of setting these variables in the interactive profile file.
-.coNP Special variable @ *listener-hist-len*
+.coNP Special Variable @ *listener-hist-len*
.desc
This special variable determines how many lines of history are
retained by the listener. Changing this variable from within the listener
has an instant effect. If the number is reduced from its current value,
history lines are immediately discarded. The default value is 500.
-.coNP Special variable @ *listener-multi-line-p*
+.coNP Special Variable @ *listener-multi-line-p*
.desc
This is a Boolean variable which indicates whether the listener is
-in multi-line mode. The default value is
+in multiline mode. The default value is
.codn nil .
Changing this variable from within the listener takes effect
immediately for the next line of input.
-If multi-line mode is toggled interactively from within the listener,
+If multiline mode is toggled interactively from within the listener,
the variable is updated to reflect the latest state. This happens
when the command is submitted for evaluation.
-.coNP Special variable @ *listener-sel-inclusive-p*
+.coNP Special Variable @ *listener-sel-inclusive-p*
.desc
This Boolean variable controls the behavior of visual selection.
It is
.code nil
by default.
-A visual selection is determined by end-points, which are abstract positions
+A visual selection is determined by endpoints, which are abstract positions
understood as being between characters. When a visual selection begins,
-it marks an end-point immediately to the left of a block-shaped cursor,
+it marks an endpoint immediately to the left of a block-shaped cursor,
or precisely at the in-between position of an I-beam cursor.
The end of the visual selection is similarly determined from the ending
cursor position. The selection consists of those characters which lie
@@ -72442,7 +93613,7 @@ that the selection is determined by the starting and ending character,
and includes them. This type of selection pairs well with a block-shaped
cursor.
-.coNP Special variable @ *listener-pprint-p*
+.coNP Special Variable @ *listener-pprint-p*
.desc
This Boolean variable controls how the listener prints the results
of evaluations.
@@ -72463,7 +93634,7 @@ using the
.code pprinl
function.
-.coNP Special variable @ *listener-greedy-eval-p*
+.coNP Special Variable @ *listener-greedy-eval-p*
.desc
The special variable
.code *listener-greedy-eval-p*
@@ -72472,11 +93643,11 @@ in the listener. The default value is
.codn nil ,
disabling the feature.
-Greedy evaluation means that after the listener evaluates an expression
-successfully and prints its value, it then checks whether that value is
-an expression that may be further subject to non-trivial evaluation.
-If so, it evaluates that expression, and prints the resulting value.
-The process is then repeated with the resulting value. It keeps repeating until
+Greedy evaluation means that after the listener evaluates the input expressions
+successfully and prints the value of the last one, it then checks whether that
+value is an expression that may be further subject to nontrivial evaluation.
+If so, it evaluates that expression, and prints the resulting value. The
+process is then repeated with the resulting value. It keeps repeating until
evaluation throws an error, or produces a self-evaluating object.
These additional evaluations are performed in such a way that all warnings are
@@ -72485,7 +93656,7 @@ suppressed and all other exceptions are intercepted.
Greedy evaluation doesn't affect the state of the listener.
Only the original expression is entered into the
history. Only the value of the original expression is saved in the result hash
-or a numbered variable. The command line number
+or a numbered variable. The command-line number
.code *n
is incremented by one. The additional evaluations are only performed for
the purpose of producing useful output. The evaluations may
@@ -72531,12 +93702,144 @@ The object
.code 4
is self-evaluating, and so the greedy evaluation process stops.
+.coNP Special Variable @ *listener-auto-compound-p*
+.desc
+The special variable
+.code *listener-auto-compound-p*
+controls whether or the listener is operating in "auto compound
+expression" mode. The default value is
+.codn nil ,
+disabling the feature.
+
+Normally, an input line can contain multiple expressions, which
+are treated as if they were combined into a single expression by
+.codn progn .
+Thus all the expressions are evaluated, and the value from
+the last one is printed.
+
+In auto compound mode, the behavior changes. An input line
+which consists of multiple expressions is turned into a compound
+form whose constituents are those items. Thus, for instance,
+the input
+.code "+ 2 2"
+is treated as the compound expression
+.code "(+ 2 2)"
+resulting in
+.code 4
+being calculated.
+
+When a single expression is input, it is evaluated as-is, and thus
+in that case auto compound expression mode makes no difference.
+
+.coNP Special Variable @ *doc-url*
+.desc
+The special variable
+.code *doc-url*
+holds a character string representing a web URL intended to point to the HTML
+version of this document. The initial value points to the publicly hosted
+document on the Internet. The user may change this to point to another
+location, such as a locally hosted copy of the document.
+
+This variable is used by the
+.code doc
+function.
+
+.SS* Listener-Related Functions
+
+.coNP Function @ doc
+.synb
+.mets (doc <> [ symbol ])
+.syne
+.desc
+The
+.code doc
+function provides help for the library symbol
+.metn symbol .
+If information about
+.meta symbol
+is available in the HTML version of this document, and is indexed, then this
+function causes that document to be opened using a web browser,
+such that the browser navigates to the appropriate section of
+the manual.
+
+If the
+.meta symbol
+argument is omitted, then the document is opened without navigating to a
+particular section.
+
+The base URL for the document is configured by the
+.code *doc-url*
+variable.
+
+If
+.meta symbol
+is successfully found, or else not specified, and
+.code doc
+successfully invokes the URL-opening mechanism, it returns
+.codn t .
+Otherwise, it throws an error exception.
+
+The web browser is invoked using a system-dependent strategy.
+On MS Windows, the
+.code ShellExecuteW
+function is relied upon to open the URL.
+
+On other platforms, if the
+.code BROWSER
+environment variable exists and is nonempty,
+its value is assumed to indicate the name or path
+of the web-browsing program which can accept the URL as an argument.
+If this variable doesn't exist or is empty, then
+.code doc
+searches for a system-dependent URL-opening utility, such as
+.codn xdg-open .
+If this utility is not found, then
+.code doc
+falls back to searching for a browser using one of several names.
+If no URL-opening mechanism is identified using the above strategies, an error
+exception is thrown. However, if the mechanism is identified, but does not
+successfully dispatch the URL to a browser, there is no requirement to throw
+an error exception. It may appear that the
+.code doc
+function returns
+.code t
+but has no effect.
+
+.coNP Function @ quip
+.synb
+.mets (quip)
+.syne
+.desc
+The
+.code quip
+function returns a randomly selected string containing a humorous quip,
+quote or witticism. The following code may be added to
+.code .txr_profile
+to produce a random quip on startup:
+
+.verb
+ (put-line (quip))
+.brev
+
+The
+.code quip
+function was introduced in \*(TX 244. If the
+.code .txr_profile
+is used with installations of older \*(TX versions, it is recommended to use
+the following, to avoid calling the undefined function, as well as to
+prevent a warning:
+
+.verb
+ (if (fboundp 'quip)
+ (put-line (quip))
+ (defun quip ()))
+.brev
.SH* SETUID/SETGID OPERATION
On platforms with the Unix filesystem and process security model, \*(TX has
support for executing setuid/setgid scripts, even on platforms whose operating system
-kernel does not honor the setuid/setgid bit on hash bang scripts. On these
+kernel does not honor the setuid/setgid bit on hash-bang scripts. On these
systems, taking advantage of the feature requires \*(TX to be installed as a
setuid/setgid executable. For this reason, \*(TX is aware when it is executed
setuid and takes care to manage privileges. The following description about
@@ -72544,7 +93847,7 @@ the handling of setuid applies to the parallel handling of setgid also.
When \*(TX starts, early in its execution it determines whether or not is
is executing setuid. If so, it temporarily drops privileges, as a precaution.
-This is done before processing the command line arguments.
+This is done before processing the command-line arguments.
When \*(TX determines that it is executing a setuid script (a file marked
executable to its owner and attributed with the set-user-ID bit), it then
attempts to impersonate the owner of the script file by changing to
@@ -72595,7 +93898,7 @@ the C language expression
where
.code e
is the previously noted effective user ID. In other words, it
-attempts to re-gain the dropped privilege by recovering the previous
+attempts to regain the dropped privilege by recovering the previous
effective ID. If this attempt succeeds, \*(TX immediately aborts.
Dropping setgid privileges is similar. Where
.code setresgid
@@ -72630,10 +93933,10 @@ running with setuid privilege. No group IDs are added to the list which
need to be retracted when privileges are dropped. The supplementary
groups also persist across the execution of a setuid/setgid script.
-.SH* STAND-ALONE APPLICATION SUPPORT
+.SH* STANDALONE APPLICATION SUPPORT
The \*(TX executable image supports a general mechanism by means of which
-a custom program can be packaged as an apparent stand-alone executable.
+a custom program can be packaged as an apparent standalone executable.
.SS* The Internal Argument String
@@ -72645,10 +93948,10 @@ represents a null-terminated UTF-8 string. In the stock executable,
this area is filled with null bytes.
If the \*(TX executable is edited such that this area is replaced
-with a non-empty, null-terminated UTF-8 string, the program will,
-for the purposes of command line argument processing, treat this string as if
-it were the one and only command line argument. (The original command
-line arguments are still retained in the
+with a nonempty, null-terminated UTF-8 string, the program will,
+for the purposes of command-line-argument processing, treat this string as if
+it were the one and only command-line argument.
+(The original command-line arguments are still retained in the
.code *args*
and
.code *args-full*
@@ -72683,7 +93986,7 @@ bytes contains the following string:
When the
.code myapp
executable is invoked, it will process the above string as a single
-command line argument, causing the
+command-line argument, causing the
.code main.tl
\*(TL source file to be loaded.
Any arguments passed to
@@ -72701,13 +94004,18 @@ functionality invoked by the program code. Library files are located
relative to the installation directory, called the
.IR sysroot .
The executable tries to dynamically determine the sysroot from
-its own location, according to this directory structure:
+its own location, according to the following directory structure.
+The executable may be renamed, it need not be called
+.codn txr :
.verb
/path/to/sysroot/bin/txr
.../share/txr/stdlib/cadr.tl
+ .../stdlib/cadr.tlo
.../stdlib/except.tl
...
+ .../share/txr/lib/...
+
.brev
The above structure is assumed if the executable finds itself
@@ -72721,7 +94029,29 @@ the following structure is expected:
.verb
/path/to/installation/txr
+ .../stdlib/cadr.tl
+ .../stdlib/cadr.tlo
+ .../stdlib/except.tl
+ ...
+ .../lib/...
+.brev
+
+The
+.strn lib/
+directory shown above is for third-party libraries.
+This is the directory indicated in the default value of the
+.code *load-search-dirs*
+special variable. The directory is not required to exist.
+
+Note that this structure had changed starting in \*(TX 264. Older versions of
+\*(TX, when the executable is not in a directory named
+.strn bin ,
+expect the following structure:
+
+.verb
+ /path/to/installation/txr
.../share/txr/stdlib/cadr.tl
+ .../share/txr/stdlib/cadr.tlo
.../share/txr/stdlib/except.tl
...
.brev
@@ -72735,11 +94065,27 @@ subdirectory where the executable is located, on the
same level with the
.code share
directory, or else the second structure in which the
-.code share
-directory is a subdirectory of the executable directory.
+.code stdlib
+directory is a direct subdirectory of the executable directory.
If one of these structures is not observed, the application
may fail due to the failure of a library file to load.
+If the executable discovers that its name ends in the suffix
+.str lisp
+(or else
+.str lisp.exe
+on the MS Windows platform) then the behavior is as if the
+.code --lisp
+command line option had been given.
+Similarly, if the executable finds that its name ends in
+.str vm
+(or
+.str vm.exe
+on MS Windows)
+it behaves as if the
+.code --compiled
+option had been given.
+
.coSS Function @ save-exe
.synb
.mets (save-exe < path << arg-string )
@@ -72810,7 +94156,7 @@ The rationale for not requiring backward compatibility support for older
compiled files is that older files require the older implementation of the
virtual machine which they target. In some cases the differences between
the older virtual machine and new is so great that \*(TX would have to carry a
-whole separate virtual machine implementation for the sake of the older files,
+whole separate virtual-machine implementation for the sake of the older files,
which is a significant burden.
.coSS The @ -C compatibility option
@@ -72854,6 +94200,258 @@ of these version values, the described behaviors are provided if
is given an argument which is equal or lower. For instance
.code "-C 103"
selects the behaviors described below for version 105, but not those for 102.
+.IP 289
+Until \*(TX 289, the
+.code replace
+function had different semantics in the handling of the
+.meta index-list
+argument (now called
+.metn index-seq )
+and the
+.meta replacement-sequence
+argument.
+When the
+.meta index-list
+contained more indices than elements of
+.meta replacement-sequence
+then the replacement of elements in the main sequence would stop.
+No deletion of elements was performed. This behavior is restored by
+selecting 289 or lower compatibility. Note, however, that this breaks
+the ability of the
+.code del
+macro to delete items from a sequence by
+.metn index-list .
+The
+.code del
+macro could do that in version 289 or older, and the behavior
+That behavior didn't work in version 289 or older, and is supported
+by the new semantics of
+.metn replace ,
+which is capable of deleting items specified by
+.metn index-list .
+.IP 288
+Integers and ranges callable like functions are a new feature introduced
+after \*(TX 288. The latter, callable ranges, are a breaking change;
+certain expressions with a range in the function position interpreted
+the range as a sequence. Using this compatibility value disables ranges being
+callable, restoring the old behaviors.
+.IP 283
+In \*(TX 283 and older versions, the
+.meta flags
+parameter of the
+.code ftw
+function defaults to zero, rather than
+.codn ftw-phys .
+.IP 275
+In \*(TX 275 and older versions, the FFI type operator
+.code align
+can weaken the alignment of a type. The current behavior is that it can
+only increase the strictness of alignment, which mimics the
+.code aligned
+type attribute found in GNU C. For instance
+.code "(align 2 int)"
+will not have an effect, because 2 is lower than the alignment of
+.codn int .
+The
+.code pack
+type operator must be used instead to specify any alignment, including
+lower. A compatibility value of 275 or lower restores the ability of
+.code align
+to specify weaker alignment.
+.IP 273
+In \*(TX 273 and older versions,
+.code lazy-str-get-trailing-list
+has a flaw, which causes it to produce an extra empty string. Because the
+.code @(freeform)
+directive in the pattern language is based on lazy strings, and depends
+on this function, it is affected by this issue.
+The extra empty string is produced because the materialized prefix of the lazy
+string is split on the terminator without regard for the fact that it ends in
+the terminator, producing an extra empty piece. For instance, if the terminator is
+.strn \en
+the materialized prefix of the lazy string is
+.strn foo\en
+and the remaining list of not-yet-materialized lazy string material is
+.codn "(\(dqbar\(dq \(dqbaz\(dq)" ,
+then the returned list is
+.codn "(\(dqfoo\(dq \(dq\(dq \(dqbar\(dq \(dqbaz\(dq)" ,
+rather than
+.codn "(\(dqfoo\(dq \(dqbar\(dq \(dqbaz\(dq)" .
+Whenever the lazy string's
+.meta terminator
+is non-empty, this issue reproduces in almost all instances, because
+the materialized prefix, unless it is empty, is always terminated by the
+.meta terminator
+and so the split always produces the extra empty string. This is not a rare edge case.
+Compatibility values of 273 and lower restore this behavior.
+.IP 272
+The compatibility version value 272 restores old behaviors in the pattern
+language with regard to the regex and function cases of positive match variables.
+\*(TX 273, several semantic improvements took place in this area, which
+can break existing code. Pattern variables of the form
+.mono
+.meti >> @{ bident >> ( fun >> [ args ...])}
+.onom
+can now invoke a vertical function against the full input, and the variable
+consequently to be bound to multiple lines. Previously this syntax invoked
+only horizontal functions or else vertical functions in a single-line
+horizontal mode. That behavior is restored by 272 or lower compatibility.
+Secondly, the function is now always invoked, whether or not the variable
+has a binding. The variable is then matched against the text spanned
+by the function to either give it a new binding or match the existing binding.
+The old behavior, restored by 272 or lower compatibility, is that the
+function is not invoked when the variable has a binding; the
+variable's value is instead used to match text. Lastly, a similar change
+took place in positive match regular expression variables of the
+.mono
+.meti >> @{ bident <> / regex /}
+.onom
+form.
+Prior to 273, when a variable of this form has an existing binding, the regex
+is ignored, and the situation is treated as a match for the variable content.
+This old behavior is also restored.
+.IP 265
+Until \*(TX 265, the
+.code with-resources
+macro exhibited an undocumented behavior: the three-element binding expression
+.mono
+.meti >> ( var < init << cleanup )
+.onom
+immediately caused the
+.code with-resources
+form to terminate with a return value of
+.code nil
+if the
+.meta init
+form returned
+.codn nil .
+Neither the
+.meta cleanup
+in the same expression, nor any subsequent binding expressions or the body
+of the construct, would be evaluated.
+Prior cleanup forms would be evaluated in reverse order, as documented.
+A compatibility value of 265 or less restores this behavior.
+.IP 262
+Selection 262 compatibility restores a wrong behavior which existed between
+versions 191 and 262 due to a regression. The wrong behavior is that the
+.code defsymacro
+operator macro-expanded the replacement form, instead of associating the
+macro symbol with the unexpanded form. This makes a crucial difference
+to symbol macros which rely on expansion-time effects, such as producing a
+different expansion each time they are used.
+.IP 258
+Selecting 258 or lower compatibility causes
+.code abs-path-p
+to behave like
+.codn portable-abs-path-p .
+.IP 257
+Until \*(TX 257, the function
+.code lexical-var-p
+returned
+.code t
+for not only lexical variables, but also for locally bound special variables,
+which are not lexical. The behavior is restored if 257 or older compatibility
+is selected.
+.IP 251
+Until \*(TX 251, the syntax
+.code "obj.[fun arg]"
+was equivalent to
+.codn "[obj.fun arg]" ,
+providing little utility.
+A compatibility value of 251 or lower restores that behavior. The new
+behavior is that
+.code "obj.[fun arg]"
+is equivalent to
+.codn "obj.[fun obj arg]" ,
+with
+.code obj
+evaluated only once, performing method dispatch.
+.IP 248
+Until \*(TX 248, the
+.code hash-revget
+function defaulted to using
+.code eql
+equality for searching the hash table for matching values rather than the
+current
+.codn equal .
+Also, until 248, the
+.code @
+token for denoting meta-expressions was treated with a low precedence
+relative to the range dot
+.code ..
+token. This led to strange results, such as
+.code @(a)..@(b)
+parsing in a way equivalent to
+.code "@(rcons a @(b))"
+rather than
+.codn "(rcons @(a) @(b))" .
+Not is that undesirable due to the lack of symmetry, it's also
+inconsistent with
+.code "@a..@b"
+denoting
+.codn "(rcons @a @b)" .
+The latter is because in that case the
+.code @
+is handled as part of the symbol token as a token, and not as a separate operator.
+A compatibility value of 248 or lower restores the above old behaviors of
+.code @
+and
+.codn hash-revget .
+.IP 244
+Until \*(TX 244, the
+.code env-hash
+function returned a new hash table each time it was called. The behavior is
+restored if 244 or older compatibility is selected.
+.IP 243
+Two mistakes in the pseudorandom number generator (PRNG) were discovered,
+affecting \*(TX 243 and older. Using this compatibility value, or lower, will
+restore the buggy behavior, allowing pseudorandom number sequences produced
+by those older versions can be reproduced. The PRNG is intended to be an
+implementation of the WELL512a PRNG described by Panneton and L'Ecuyer.
+The coding mistakes, however, resulted in the PRNG being an implementation of
+something other than WELL512a.
+.IP 242
+In \*(TX 242 and older, the instantiation of an object whose type inherits
+from the same supertype more than once resulted in duplicate execution
+of the supertype's initialization. This was a documented behavior.
+After 242, duplicate initialization is suppressed. For more information, see
+the section
+.BR "Duplicate Supertypes" . A compatibility value of 242 or lower restores
+the duplicate initialization behavior.
+.IP 237
+Compatibility values of 237 or lower restore the destructive behavior of the
+.code sort
+and
+.code shuffle
+functions.
+.IP 234
+In \*(TX 234 and older versions, the exception throwing functions
+.code throw
+and
+.code throwf
+did not return, regardless of the exception type. All unhandled exceptions
+triggered internal handling leading to unwinding and termination.
+The current behavior is that only
+.code error
+exceptions lead to termination. When a non-error exception isn't intercepted
+by a catch or handler, the
+.code throw
+or
+.code throwf
+returns normally, yielding the value
+.codn nil .
+If a compatibility value equal to or lower than 234 is requested,
+the old behavior occurs: all unhandled exceptions terminate.
+.IP 231
+Versions of \*(TX until 231 contained an undocumented feature: some
+library functions which are documented as having parameters that must be of
+string type were allowing the arguments to be symbols. For such symbolic
+arguments, the name of the symbol obtained from
+.code symbol-name
+was implicitly taken as the required string value. This behavior was removed:
+passing symbolic arguments to library function parameters documented as
+strings will cause an exception to the thrown. If a compatibility value
+of 231 or lower is specified, however, the tolerant behavior is restored.
.IP 227
In \*(TX 227 and older versions, the functions
.codn carray-uint ,
@@ -72870,16 +94468,6 @@ and
respectively.
If 227 or lower compatibility is selected, these functions become
available under their old names in addition to their new names.
-.IP 231
-Versions of \*(TX until 231 contained an undocumented feature: some
-library functions which are documented as having parameters that must be of
-string type were allowing the arguments to be symbols. For such symbolic
-arguments, the name of the symbol obtained from
-.code symbol-name
-was implicitly taken as the required string value. This behavior was removed:
-passing symbolic arguments to library function parameters documented as
-strings will cause an exception to the thrown. If a compatibility value
-of 231 or lower is specified, however, the tolerant behavior is restored.
.IP 225
After \*(TX 225, the behavior of the
.code do
@@ -72940,8 +94528,23 @@ variable. In cases where
resolved the path by adding a suffix,
.code *load-path*
was bound to the unsuffixed name, which was a documented behavior.
-The old behavior is restored if 215 or lower compatibility
-is requested.
+After \*(TX 215, also, the behavior of the
+.code sub-str
+function changed. When the arguments implicate the entire string,
+.code sub-str
+started just returning the original string, and not making a copy.
+The old behavior was to always make a copy.
+The above old behaviors of
+.code load
+and
+.code sub-str
+are restored if 215 or lower compatibility
+is requested. Note, however, that the restoration of the
+.code sub-str
+behavior in response to the compatibility option was only
+introduced in \*(TX 251. In \*(TX 249 and older, the
+compatibility value has no effect on the behavior of
+.codn sub-str .
.IP 202
Up to \*(TX 202, the
.code logxor
@@ -72983,7 +94586,20 @@ symbol package didn't exist; the
variable was initialized to the user package and so symbols introduced
by application code were interned in the same package as the \*(TL
library.
-All these old behaviors are restored in compatibility
+Until \*(TX 190,
+.code defmacro
+and
+.code defsymacro
+forms were evaluated immediately during macro expansion; in \*(TX 191
+or later, this eager evaluation was abandoned.
+Unfortunately, this change introduced
+a regression, causing the replacement form of a
+.code defsymacro
+to be macro-expanded at the time that form is traversed by the
+expander, so that the macro is associated with the expanded version
+of that form. This is something which had been fixed in 137.
+It went unnoticed until much later, after the 262 release.
+All the above old behaviors are restored in compatibility
with version 190 or earlier.
Finally, one more change after \*(TX 190 that is controlled by the
compatibility mechanism was a critical redesign of the requirements
@@ -73052,8 +94668,8 @@ and
.code do
macros which was replaced starting in \*(TX 185. Also, this has the
effect of disabling the special recognition of meta-expressions
-and meta-variables in the dot position of function calls, and
-the macro expansion of meta-variables in quasiliterals. This is
+and meta-symbols in the dot position of function calls, and
+the macro expansion of meta-symbols in quasiliterals. This is
because the old
.code op
implementation implements these behaviors itself. The implication
@@ -73085,10 +94701,10 @@ and
A value of 183 or lower restores an inconsistent behavior in the
.code "@(bind)"
directive and other places in the \*(TX pattern language where binding
-takes place. Prior to version 184, a string tree match was only tried in
-both directions when the left hand side of a binding (the "pattern") was a
+takes place. Prior to version 184, a string-tree match was only tried in
+both directions when the left-hand side of a binding (the "pattern") was a
variable. For non-variable pattern terms, such as Lisp expressions or atoms,
-the string tree match was tried in one direction only: a string tree arising
+the string-tree match was tried in one direction only: a string tree arising
out of the pattern could match a string atom value on the right side.
A string tree is a nested list structure whose leaves are strings: a list
of strings, a list of lists of strings, and so on, in any mixture.
@@ -73164,7 +94780,9 @@ and
.code partition*
ignored negative indices in their
.meta index-list
-argument. The new behavior is that the length of the input sequence
+argument (now called
+.metn index-seq ).
+The new behavior is that the length of the input sequence
is added to any negative index values. The resulting values are then
ignored if they are still negative.
.IP 165
@@ -73251,7 +94869,7 @@ and
.code tok-where
functions changed semantics. Previously, these functions exhibited the
flaw that under some conditions they extracted an empty token immediately
-following a non-empty token. This behavior was working as designed and
+following a nonempty token. This behavior was working as designed and
documented, but the design was flawed, creating a major difficulty in simple
tokenizing tasks when tokens may be empty strings. Requesting compatibility
with version 155 or earlier restores the behavior.
@@ -73389,7 +95007,7 @@ convention on data sources. Data sources beginning with the character
were treated as system command pipes, and data sources beginning with
.code $
indicated that a directory is to be scanned. This convention was recognized
-both for command line arguments, the arguments of the
+both for command-line arguments, the arguments of the
.code @(next)
directive, and of the
.code @(output)
@@ -73403,7 +95021,7 @@ as denoting standard input, and
.code @(output)
recognized it as standard output. These behaviors were also removed;
versions after 142 recognize this convention only when it appears
-as a command line argument. Lastly, until version 142, the
+as a command-line argument. Lastly, until version 142, the
.code @(output)
directive evaluated the
.meta destination
@@ -73413,11 +95031,11 @@ to be used to denote a Lisp expression. This is no longer required.
All these old behaviors are provided
if compatibility with 142 or earlier is requested.
.IP 139
-After \*(TX 139, changes were implemented in the area of pseudo-random
+After \*(TX 139, changes were implemented in the area of pseudorandom
number generation. Compatibility with 139 brings back the previous
seeding algorithm used by
.codn make-random-state ,
-allowing the old pseudo-random sequences to be reproduced. This is only
+allowing the old pseudorandom sequences to be reproduced. This is only
the case if the default value of 8 is used for the
.meta warmup-period
argument of that function (which didn't exist in 139 or earlier versions).
@@ -73504,7 +95122,7 @@ If the compatibility option is set to 124 or lower, the old behavior
is restored. However, even without the presence of the compatibility option,
if the
.meta source
-argument is a meta-expression or meta-variable (denotes by the
+argument is a meta-expression or meta-symbol (denotes by the
.code @
prefix in front of a compound expression or symbol, respectively)
it is also treated in the old way. This latter behavior is obsolescent
@@ -73673,8 +95291,8 @@ in the empty list case. Moreover, in the
.code @(output)
case, the value of TXR Lisp expressions was not subject to filtering.
Starting with \*(TX 100, these issues
-are fixed, making the the behavior is consistent with
-the behavior of TXR Lisp quasiliterals.
+are fixed, making the behavior consistent with
+that of TXR Lisp quasiliterals.
.IP 97
Up to \*(TX 97, the error exception symbols such as
.code file-error
@@ -73717,12 +95335,12 @@ to a library feature requires familiarity with the implementation.
.SS* A. NOTES ON EXOTIC REGULAR EXPRESSIONS
Users familiar with regular expressions may not be familiar with the complement
and intersection operators, which are often absent from text processing tools
-that support regular expressions. The following remarks are offered in hope
-that they are of some use.
+that support regular expressions. The following remarks are offered in the
+hope that they may be of some use.
.TP* "Equivalence to Sets"
Regexp intersection is not essential; it may be obtained from complement and
-union as follows, since De Morgan's law applies to regular expression algebra:
+union as follows, since De Morgan's law applies to regular-expression algebra:
.code (R1)&(R2)
=
.codn ~(~(R1)|~(R2)) .
@@ -73786,7 +95404,7 @@ This
idiom is also called set
difference, sometimes notated with a minus sign:
.code A-B
-(which is not supported in \*(TX regular expression syntax). Elements which
+(which is not supported in \*(TX regular-expression syntax). Elements which
are in the set
.codn A ,
but not
@@ -73845,7 +95463,7 @@ actually consists of the comment
.codn "/* /* nested */" ,
which is followed by the trailing junk
.codn */ .
-Our simple characterization of interior part of a C comment as a string
+Our simple characterization of the interior part of a C comment as a string
which does not contain the terminating digraph makes use of the
complement, and can be expressed using the complemented regular expression like
this:
@@ -73882,7 +95500,7 @@ by something other than a slash, so let's include this via union:
([^*]|[*][^/])*.
.brev
-Alas, already, we have a bug in this expression. The
+Alas, we already have a bug in this expression. The
subexpression
.code [*][^/]
can match
@@ -73927,7 +95545,7 @@ interior asterisks before the comment close:
([^*]|[*]*[^*/])*[*]*
.brev
-Thus our the semi-final regular expression is
+Thus the semi-final regular expression is
.verb
[/][*]([^*]|[*]*[^*/])*[*]*[*][/]
diff --git a/txr.c b/txr.c
index ae639782..d1c02db0 100644
--- a/txr.c
+++ b/txr.c
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stdio.h>
@@ -56,36 +57,53 @@
#include "regex.h"
#include "arith.h"
#include "sysif.h"
+#include "itypes.h"
#if HAVE_GLOB
#include "glob.h"
#endif
#include "txr.h"
+#if CONFIG_FULL_REPL
+#define if_full_repl(THEN, ELSE) (THEN)
+#else
+#define if_full_repl(THEN, ELSE) (ELSE)
+#endif
+
const wchli_t *version = wli(TXR_VER);
+#ifdef TXR_BUILD_ID
+const wchli_t *build_id = wli(TXR_BUILD_ID);
+#endif
wchar_t *progname;
static const char *progname_u8;
static val prog_path = nil, sysroot_path = nil;
-int opt_noninteractive;
+int opt_noninteractive = if_full_repl(0, 1);
+int opt_noprofile;
int opt_compat;
int opt_dbg_expansion;
+int opt_free_all;
val stdlib_path;
+val self_path_s;
+
+#if HAVE_FORK_STUFF
+#define IF_HAVE_FORK_STUFF(THEN, ELSE) THEN
+#else
+#define IF_HAVE_FORK_STUFF(THEN, ELSE) ELSE
+#endif
static void help(void)
{
val text = lit(
"\n"
"TXR Version ~a\n"
-"Copyright 2009-2020 Kaz Kylheku <kaz@kylheku.com>\n"
+"Copyright 2009-2024 Kaz Kylheku <kaz@kylheku.com>\n"
"\n"
"Usage:\n"
"\n"
-" ~a [ options ] query-file { data-file }*\n"
+" ~a [ options ] script-file { argument }*\n"
"\n"
-#if HAVE_TERMIOS
"If no arguments are present, TXR will enter into interactive listener mode.\n"
"\n"
-#endif
-"The query-file or data-file arguments may be specified as -, in which case\n"
+"The script-file or data-file arguments may be specified as -, in which case\n"
"standard input is used. All data-file arguments which begin with a !\n"
"character are treated as command pipes. Those which begin with a $\n"
"are interpreted as directories to read. Leading arguments which begin\n"
@@ -104,8 +122,6 @@ static void help(void)
"-Dvar Predefine variable var, with empty string value.\n"
"-q Quiet: don't report errors during query matching.\n"
"-v Verbose: extra logging from matcher.\n"
-"-b Don't dump list of bindings, or 'false'\n"
-" on unsuccessful termination.\n"
"-B Force list of bindings to be dumped, or false\n"
" if termination is unsuccessful.\n"
"-l If dumping bindings, use TXR Lisp format.\n"
@@ -121,44 +137,53 @@ static void help(void)
" Additional dimensions beyond N are fudged\n"
" by generating numeric suffixes. Implies -B.\n"
"-c query-text The query is read from the query-text argument\n"
-" itself. The query-file argument is omitted in\n"
+" itself. The script-file argument is omitted in\n"
" this case; the first argument is a data file.\n"
-"-f query-file Specify the query-file as an option argument.\n"
-" option, instead of the query-file argument.\n"
+"-f script-file Specify the script-file as an option argument\n"
+" instead of as the script-file argument.\n"
" This allows #! scripts to pass options through\n"
-" to the utility.\n"
-"-e expression Evaluate TXR Lisp expression. Can be specified\n"
-" multiple times. The query-file arg becomes optional.\n"
-"-p expression Like -e, but prints the result of the expression\n"
+" to the txr utility.\n"
+"-e expressions Evaluate zero or more TXR Lisp expressions.\n"
+" Can be specified multiple times. The script-file\n"
+" arg becomes optional.\n"
+"-p expression Evaluate a single expression, and print the value\n"
" using the prinl function.\n"
"-P expression Like -p, but prints using pprinl.\n"
"-t expression Like -p, but prints using tprint.\n"
+"-b var=value Bind a Lisp global variable as if by defparml.\n"
+" var and value are parsed as Lisp syntax.\n"
+" value is not evaluated.\n"
"-C N Request backward-compatible behavior to the\n"
" specified version of TXR.\n"
"--help Reproduce this help text.\n"
-"--version Display program version\n"
-"--license Display software license\n"
+"--version Display program version.\n"
+"--build-id Print build ID string if compiled in.\n"
+"--license Display software license.\n"
" Use of txr implies agreement with the disclaimer\n"
" section at the bottom of the license.\n"
"--lisp Treat unsuffixed query files as TXR Lisp.\n"
"--compiled Treat unsuffixed query files as compiled TXR Lisp.\n"
-"--lisp-bindings Synonym for -l\n"
-"--debugger Synonym for -d\n"
+"--lisp-bindings Synonym for -l.\n"
+"--debugger Synonym for -d.\n"
"--backtrace Enable backtraces.\n"
-"--noninteractive Synonym for -n\n"
-"--compat=N Synonym for -C N\n"
+"--noninteractive Synonym for -n.\n"
+"--compat=N Synonym for -C N.\n"
+"--in-package=name Switch to specified package\n"
+"--compile=src[:target] Compile a file.\n"
"--gc-delta=N Invoke garbage collection when malloc activity\n"
" increments by N megabytes since last collection.\n"
"--args... Allows multiple arguments to be encoded as a single\n"
-" argument. This is useful in hash-bang scripting.\n"
-" Peculiar syntax. See manual.\n"
+" argument. This is useful in hash-bang scripts.\n"
+" Peculiar syntax. See the manual.\n"
"--eargs... arg Extended version of --args: additionally consumes\n"
-" the following argument arg, and allows one or more\n"
+" the following argument arg and allows one or more\n"
" copies of it to be to be embedded in the\n"
-" encoded arguments. See manual.\n"
-#if HAVE_FORK_STUFF
-"--reexec Re-execute TXR with remaining arguments.\n"
-#endif
+" encoded arguments. See the manual.\n"
+"--noprofile Do not read .txr_profile when entering listener.\n"
+IF_HAVE_FORK_STUFF(
+"--reexec Re-execute TXR with remaining arguments.\n",
+""
+)
"--debug-autoload Allow debugger to step through library auto-loading.\n"
"--debug-expansion Allow debugger to step through macro-expansion of query.\n"
"--yydebug Debug Yacc parser, if compiled with YYDEBUG support.\n"
@@ -173,21 +198,21 @@ static void help(void)
format(std_output, text, static_str(version), prog_string, nao);
}
-#if HAVE_TERMIOS
-static void banner(void)
+static void banner(val self)
{
+ if (!isatty(c_int(stream_fd(std_input), self)))
+ return;
+
format(std_output,
- lit("This is the TXR Lisp interactive listener of TXR ~a.\n"
- "Quit with :quit or Ctrl-D on empty line. Ctrl-X ? for cheatsheet.\n"),
+ if3(opt_noninteractive,
+ lit("This is the TXR Lisp plain mode listener of TXR ~a.\n"
+ "Quit with :quit or Ctrl-D on an empty line.\n"),
+ if_full_repl(lit("This is the TXR Lisp interactive "
+ "listener of TXR ~a.\n"
+ "Quit with :quit or Ctrl-D on an empty line. "
+ "Ctrl-X ? for cheatsheet.\n"), nil)),
static_str(version), nao);
}
-#else
-static void hint(void)
-{
- format(std_error, lit("~a: incorrect arguments: try --help\n"),
- prog_string, nao);
-}
-#endif
static val check_hash_bang(val stream, val args, int *occurs)
{
@@ -254,11 +279,16 @@ static val get_self_path(void)
val execname = string_utf8(getexecname());
if (car(execname) == chr('/'))
return execname;
- return format(nil, lit("~a/~a"), getcwd_wrap(), execname, nao);
+ return scat3(getcwd_wrap(), chr('/'), execname);
}
#else
static val get_self_path(void)
{
+ char self[PATH_MAX];
+
+ if (progname_u8 && realpath(progname_u8, self))
+ return string_utf8(self);
+
return lit(TXR_INST_PATH);
}
#endif
@@ -278,45 +308,50 @@ static val substitute_basename(val edited_path, val source_path)
source_path);
return if3(lslash,
- format(nil, lit("~a~a"),
- sub_str(edited_path, 0, succ(lslash)),
- basename, nao),
+ scat2(sub_str(edited_path, 0, succ(lslash)), basename),
basename);
}
static val sysroot(val target)
{
- return format(nil, lit("~a~a"), sysroot_path, target, nao);
+ return scat2(sysroot_path, target);
}
static void sysroot_init(void)
{
val prog_dir;
- const wchar_t *psc = wref(coerce(const wchar_t *, path_sep_chars));
+ const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);
+ int share_txr_stdlib = 1;
-#if HAVE_WINDOWS_H
- val slash = regex_compile(lit("\\\\"), nil);
-#endif
protect(&prog_path, &sysroot_path, &stdlib_path, convert(val *, 0));
prog_path = get_self_path();
#if HAVE_WINDOWS_H
- prog_path = regsub(slash, lit("/"), prog_path);
+ prog_path = regsub(lit("\\"), lit("/"), prog_path);
#endif
prog_dir = dir_name(prog_path);
if (ref(prog_dir, negone) != chr(psc[0]))
- prog_dir = format(nil, lit("~a~a"), prog_dir, chr(psc[0]), nao);
+ prog_dir = scat3(prog_dir, chr(psc[0]), null_string);
if (!(maybe_sysroot(lit(TXR_REL_PATH)) ||
- maybe_sysroot(lit(TXR_REL_PATH EXE_SUFF)) ||
- maybe_sysroot(lit(PROG_NAME)) ||
- maybe_sysroot(lit(PROG_NAME EXE_SUFF)) ||
- maybe_sysroot(substitute_basename(lit(TXR_REL_PATH), prog_path))))
+ maybe_sysroot(substitute_basename(lit(TXR_REL_PATH), prog_path)) ||
+ (share_txr_stdlib = 0) ||
+ maybe_sysroot(lit(PROG_NAME EXE_SUFF))))
{
sysroot_path = prog_dir;
}
- stdlib_path = sysroot(lit("share/txr/stdlib/"));
+ stdlib_path = sysroot(if3(share_txr_stdlib,
+ lit("share/txr/stdlib/"),
+ lit("stdlib/")));
+
+ {
+ loc lsd = lookup_var_l(nil, load_search_dirs_s);
+ set(lsd, cons(sysroot(if3(share_txr_stdlib,
+ lit("share/txr/lib/"),
+ lit("lib/"))),
+ nil));
+ }
reg_varl(intern(lit("stdlib"), user_package), stdlib_path);
reg_varl(intern(lit("*txr-version*"), user_package),
@@ -359,7 +394,7 @@ static int license(void)
for (iter = path_list; iter; iter = cdr(iter)) {
val lic = open_file(car(iter), lit("r"));
- put_lines(lazy_stream_cons(lic), std_output);
+ put_lines(lazy_stream_cons(lic, nil), std_output);
put_char(chr('\n'), std_output);
}
}
@@ -378,6 +413,16 @@ static int license(void)
return retval;
}
+static void free_all(void)
+{
+ if (opt_free_all) {
+ regex_free_all();
+ gc_free_all();
+ arith_free_all();
+ free(progname);
+ }
+}
+
int txr_main(int argc, char **argv);
int main(int argc, char **argv)
@@ -386,6 +431,7 @@ int main(int argc, char **argv)
repress_privilege();
progname = utf8_dup_from(argv[0] ? argv[0]: "txr");
progname_u8 = argv[0];
+ atexit(free_all);
init(&stack_bottom);
match_init();
debug_init();
@@ -399,6 +445,38 @@ static void requires_arg(val opt)
prog_string, opt, nao);
}
+static void do_compile_opt(val arg)
+{
+ val compile_update_file = intern(lit("compile-update-file"), user_package);
+ val col_pos = search_str(arg, lit(":"), nil, nil);
+ val source = arg;
+ val target = nil;
+
+ if (col_pos) {
+ target = sub_str(source, succ(col_pos), t);
+ source = sub_str(source, zero, col_pos);
+ }
+
+ reg_varl(self_path_s, source);
+
+ funcall2(compile_update_file, source, target);
+}
+
+static int do_in_package_opt(val opt, val arg)
+{
+ val pkg_binding = lookup_var(nil, package_s);
+ val package = find_package(arg);
+
+ if (!package) {
+ format(std_error, lit("~a: option --~a: ~a package not found\n"),
+ prog_string, opt, arg, nao);
+ return 0;
+ }
+
+ rplacd(pkg_binding, package);
+ return 1;
+}
+
static int do_fixnum_opt(int (*opt_func)(val), val opt, val arg)
{
if (arg) {
@@ -420,7 +498,7 @@ static int do_fixnum_opt(int (*opt_func)(val), val opt, val arg)
static int compat(val optval)
{
- int compat = c_num(optval);
+ int compat = c_num(optval, lit("txr"));
int min = compat_fixup(compat);
if (min) {
@@ -431,6 +509,8 @@ static int compat(val optval)
}
sysroot_compat_fixup(compat);
+ match_compat_fixup(compat);
+
opt_compat = compat;
reg_varl(intern(lit("compat"), system_package), num(compat));
return 1;
@@ -438,33 +518,21 @@ static int compat(val optval)
static int array_dim(val optval)
{
- opt_arraydims = c_num(optval);
+ opt_arraydims = c_num(optval, lit("txr"));
opt_print_bindings = 1;
return 1;
}
static int gc_delta(val optval)
{
- opt_gc_delta = c_num(mul(optval, num_fast(1048576)));
+ opt_gc_delta = c_num(mul(optval, num_fast(1048576)), lit("gc"));
return 1;
}
-static void free_all(void)
-{
- static int called;
-
- if (!called) {
- called = 1;
- regex_free_all();
- gc_free_all();
- arith_free_all();
- free(progname);
- }
-}
-
#ifndef CONFIG_DEBUG_SUPPORT
static void no_dbg_support(val arg)
{
+ drop_privilege();
format(std_error,
lit("~a: option ~a requires debug support compiled in\n"),
prog_string, arg, nao);
@@ -473,21 +541,21 @@ static void no_dbg_support(val arg)
static int parse_once_noerr(val stream, val name)
{
- val pfx = format(nil, lit("~a:"), name, nao);
+ val pfx = scat2(name, lit(":"));
ignerr_func_body(int, 0, parse_once(prog_string, stream, name),
std_error, pfx);
}
static val read_compiled_file_noerr(val self, val stream, val name, val error_stream)
{
- val pfx = format(nil, lit("~a:"), name, nao);
+ val pfx = scat2(name, lit(":"));
ignerr_func_body(val, nil, read_compiled_file(self, stream, error_stream),
std_error, pfx);
}
static val read_eval_stream_noerr(val self, val stream, val name, val error_stream)
{
- val pfx = format(nil, lit("~a:"), name, nao);
+ val pfx = scat2(name, lit(":"));
ignerr_func_body(val, nil, read_eval_stream(self, stream, error_stream),
std_error, pfx);
}
@@ -508,7 +576,6 @@ int txr_main(int argc, char **argv)
val txr_lisp_p = nil;
val enter_repl = nil;
val args_s = intern(lit("*args*"), user_package);
- val self_path_s = intern(lit("self-path"), user_package);
val compat_var = lit("TXR_COMPAT");
val compat_val = getenv_wrap(compat_var);
val orig_args = nil, ref_arg_list = nil;
@@ -518,6 +585,13 @@ int txr_main(int argc, char **argv)
static char alt_args_buf[128 + 7] = "@(txr):", *alt_args = alt_args_buf + 7;
+ self_path_s = intern(lit("self-path"), user_package);
+
+ if (ends_with(lit("lisp" EXE_SUFF), prog_path, nil, nil))
+ txr_lisp_p = t;
+ else if (ends_with(lit("vm" EXE_SUFF), prog_path, nil, nil))
+ txr_lisp_p = chr('o');
+
setvbuf(stderr, 0, _IOLBF, 0);
if (compat_val && length(compat_val) != zero) {
@@ -553,13 +627,8 @@ int txr_main(int argc, char **argv)
arg_list = list(string_utf8(alt_args), nao);
} else if (argc <= 1) {
drop_privilege();
-#if HAVE_TERMIOS
- banner();
+ banner(self);
goto repl;
-#else
- hint();
- return EXIT_FAILURE;
-#endif
}
for (ref_arg_list = arg_list, arg = upop(&arg_list, &arg_undo);
@@ -574,7 +643,7 @@ int txr_main(int argc, char **argv)
if (car(arg) != chr('-')) {
if (!parse_stream) {
spec_file_str = arg;
- open_txr_file(arg, &txr_lisp_p, &spec_file_str, &parse_stream);
+ open_txr_file(arg, &txr_lisp_p, &spec_file_str, &parse_stream, t, self);
simulate_setuid_setgid(parse_stream);
dyn_env = make_env(nil, nil, dyn_env);
env_vbind(dyn_env, load_path_s, spec_file_str);
@@ -634,18 +703,31 @@ int txr_main(int argc, char **argv)
/* Odd case 3: -Dfoo=bar syntax. */
if (equal(sub(arg, zero, two), lit("-D"))) {
val dopt_arg = sub(arg, two, t);
- cons_bind(var, def, split_str(dopt_arg, lit("=")));
- val deflist = if2(def, split_str(car(def), lit(",")));
- val sym = intern(var, cur_package);
+ val eq_pos = search_str(dopt_arg, lit("="), nil, nil);
- if (rest(deflist))
- bindings = cons(cons(sym, deflist), bindings);
- else if (deflist)
- bindings = cons(cons(sym, car(deflist)), bindings);
- else
- bindings = cons(cons(sym, t), bindings);
+ if (eq_pos) {
+ val var = sub_str(dopt_arg, zero, eq_pos);
+ val def = sub_str(dopt_arg, succ(eq_pos), t);
+ val deflist = split_str(def, lit(","));
+ val sym = intern(var, cur_package);
- match_reg_var(sym);
+ if (rest(deflist))
+ bindings = cons(cons(sym, deflist), bindings);
+ else
+ bindings = cons(cons(sym, car(deflist)), bindings);
+
+ match_reg_var(sym);
+ } else {
+ if (search_str(dopt_arg, lit(","), nil, nil)) {
+ format(std_error,
+ lit("~a: bad -D syntax: ~a\n"), prog_string, arg, nao);
+ return EXIT_FAILURE;
+ } else {
+ val sym = intern(dopt_arg, cur_package);
+ bindings = cons(cons(sym, null_string), bindings);
+ match_reg_var(sym);
+ }
+ }
continue;
}
@@ -670,8 +752,29 @@ int txr_main(int argc, char **argv)
continue;
}
+ if (equal(opt, lit("compile"))) {
+ if (!org) {
+ requires_arg(opt);
+ return EXIT_FAILURE;
+ }
+ reg_var(args_s, or2(orig_args, arg_list));
+ do_compile_opt(org);
+ evaled = t;
+ continue;
+ }
+
+ if (equal(opt, lit("in-package"))) {
+ if (!org) {
+ requires_arg(opt);
+ return EXIT_FAILURE;
+ }
+ if (!do_in_package_opt(opt, org))
+ return EXIT_FAILURE;
+ continue;
+ }
+
/* Long opts with no arguments */
- if (org) {
+ if (0) noarg: {
drop_privilege();
format(std_error,
lit("~a: option --~a takes no argument, ~a given\n"),
@@ -680,12 +783,24 @@ int txr_main(int argc, char **argv)
}
if (equal(opt, lit("version"))) {
+ if (org)
+ goto noarg;
drop_privilege();
format(std_output, lit("~a: version ~a\n"),
prog_string, static_str(version), nao);
return 0;
}
+ if (equal(opt, lit("build-id"))) {
+ if (org)
+ goto noarg;
+ drop_privilege();
+#ifdef TXR_BUILD_ID
+ format(std_output, lit("~a\n"), static_str(build_id), nao);
+#endif
+ return 0;
+ }
+
if (equal(opt, lit("help"))) {
drop_privilege();
help();
@@ -693,46 +808,65 @@ int txr_main(int argc, char **argv)
}
if (equal(opt, lit("license"))) {
+ if (org)
+ goto noarg;
drop_privilege();
return license();
}
if (equal(opt, lit("gc-debug"))) {
+ if (org)
+ goto noarg;
drop_privilege();
opt_gc_debug = 1;
continue;
} else if (equal(opt, lit("vg-debug"))) {
- drop_privilege();
#if HAVE_VALGRIND
+ if (org)
+ goto noarg;
+ drop_privilege();
opt_vg_debug = 1;
continue;
#else
+ drop_privilege();
format(std_error,
lit("~a: option ~a requires Valgrind support compiled in\n"),
prog_string, arg, nao);
return EXIT_FAILURE;
#endif
} else if (equal(opt, lit("dv-regex"))) {
+ if (org)
+ goto noarg;
opt_derivative_regex = 1;
continue;
} else if (equal(opt, lit("lisp-bindings"))) {
+ if (org)
+ goto noarg;
opt_lisp_bindings = 1;
opt_print_bindings = 1;
continue;
} else if (equal(opt, lit("lisp"))) {
+ if (org)
+ goto noarg;
txr_lisp_p = t;
continue;
} else if (equal(opt, lit("compiled"))) {
+ if (org)
+ goto noarg;
txr_lisp_p = chr('o');
continue;
#if HAVE_FORK_STUFF
} else if (equal(opt, lit("reexec"))) {
+ if (org)
+ goto noarg;
exec_wrap(prog_path, arg_list);
return EXIT_FAILURE;
#endif
} else if (equal(opt, lit("debugger"))) {
- drop_privilege();
#if CONFIG_DEBUG_SUPPORT
+ if (org)
+ goto noarg;
+ drop_privilege();
opt_debugger = 1;
debug_set(DBG_ENABLE | DBG_BACKTRACE);
continue;
@@ -741,8 +875,10 @@ int txr_main(int argc, char **argv)
return EXIT_FAILURE;
#endif
} else if (equal(opt, lit("debug-autoload"))) {
- drop_privilege();
#if CONFIG_DEBUG_SUPPORT
+ if (org)
+ goto noarg;
+ drop_privilege();
opt_debugger = 1;
opt_dbg_autoload = 1;
debug_set(DBG_ENABLE | DBG_BACKTRACE);
@@ -752,8 +888,10 @@ int txr_main(int argc, char **argv)
return EXIT_FAILURE;
#endif
} else if (equal(opt, lit("debug-expansion"))) {
- drop_privilege();
#if CONFIG_DEBUG_SUPPORT
+ if (org)
+ goto noarg;
+ drop_privilege();
opt_debugger = 1;
opt_dbg_expansion = 1;
debug_set(DBG_ENABLE | DBG_BACKTRACE);
@@ -763,6 +901,8 @@ int txr_main(int argc, char **argv)
return EXIT_FAILURE;
#endif
} else if (equal(opt, lit("yydebug"))) {
+ if (org)
+ goto noarg;
drop_privilege();
if (have_yydebug) {
yydebug_onoff(1);
@@ -778,6 +918,8 @@ int txr_main(int argc, char **argv)
return EXIT_FAILURE;
}
} else if (equal(opt, lit("backtrace"))) {
+ if (org)
+ goto noarg;
#if CONFIG_DEBUG_SUPPORT
debug_set(DBG_BACKTRACE);
continue;
@@ -786,11 +928,20 @@ int txr_main(int argc, char **argv)
return EXIT_FAILURE;
#endif
} else if (equal(opt, lit("noninteractive"))) {
+ if (org)
+ goto noarg;
opt_noninteractive = 1;
stream_set_prop(std_input, real_time_k, nil);
continue;
} else if (equal(opt, lit("free-all"))) {
- atexit(free_all);
+ if (org)
+ goto noarg;
+ opt_free_all = 1;
+ continue;
+ } else if (equal(opt, lit("noprofile"))) {
+ if (org)
+ goto noarg;
+ opt_noprofile = 1;
continue;
} else {
drop_privilege();
@@ -827,20 +978,27 @@ int txr_main(int argc, char **argv)
case 'b':
drop_privilege();
{
- val pair = partition_star(arg, pos(chr('='), arg, nil, nil));
- val sym = lisp_parse(pop(&pair), std_error,
- colon_k, lit("cmdline-expr"), colon_k);
- val obj = lisp_parse(pop(&pair), std_error,
- colon_k, lit("cmdline-expr"), colon_k);
-
- if (!bindable(sym)) {
+ val pair = split_str(arg, chr('='));
+ if (cdr(pair)) {
+ val sym = lisp_parse(pop(&pair), std_error,
+ colon_k, lit("cmdline-expr"), colon_k);
+ val obj = lisp_parse(pop(&pair), std_error,
+ colon_k, lit("cmdline-expr"), colon_k);
+
+ if (!bindable(sym)) {
+ format(std_error,
+ lit("~a: ~s isn't a bindable symbol\n"),
+ prog_string, sym, nao);
+ return EXIT_FAILURE;
+ }
+
+ reg_var(sym, obj);
+ } else {
format(std_error,
- lit("~a: ~s isn't a bindable symbol\n"),
- prog_string, sym, nao);
+ lit("~a: -b argument must be var=val syntax\n"),
+ prog_string, nao);
return EXIT_FAILURE;
}
-
- reg_var(sym, obj);
}
break;
case 'c':
@@ -874,8 +1032,10 @@ int txr_main(int argc, char **argv)
prog_string, arg, spec_file_str, nao);
return EXIT_FAILURE;
}
- if (wcscmp(c_str(spec_file), L"-") != 0) {
- open_txr_file(spec_file, &txr_lisp_p, &spec_file_str, &parse_stream);
+ if (wcscmp(c_str(spec_file, self), L"-") != 0) {
+ spec_file_str = spec_file;
+ open_txr_file(spec_file, &txr_lisp_p, &spec_file_str,
+ &parse_stream, t, self);
simulate_setuid_setgid(parse_stream);
dyn_env = make_env(nil, nil, dyn_env);
env_vbind(dyn_env, load_path_s, spec_file_str);
@@ -895,10 +1055,17 @@ int txr_main(int argc, char **argv)
reg_varl(self_path_s, lit("cmdline-expr"));
reg_var(args_s, or2(orig_args, arg_list));
- eval_intrinsic(lisp_parse(arg, std_error, colon_k,
- lit("cmdline-expr"), colon_k),
- make_env(bindings, nil, nil));
+ {
+ val forms = read_objects_from_string(arg, std_error, colon_k,
+ lit("cmdline-expr"));
+
+ if (forms != colon_k)
+ eval_intrinsic(cons(progn_s, forms),
+ make_env(bindings, nil, nil), nil);
+ }
+
evaled = t;
+
args_new = cdr(lookup_global_var(args_s));
if (args_new != args_saved) {
@@ -926,7 +1093,7 @@ int txr_main(int argc, char **argv)
obj = eval_intrinsic(lisp_parse(arg, std_error, colon_k,
lit("cmdline-expr"), colon_k),
- make_env(bindings, nil, nil));
+ make_env(bindings, nil, nil), nil);
gc_hint(obj);
pf(z(obj), std_output);
@@ -967,15 +1134,8 @@ int txr_main(int argc, char **argv)
break;
case 'i':
drop_privilege();
-#if HAVE_TERMIOS
enter_repl = t;
break;
-#else
- format(std_error,
- lit("~a: option ~a requires a platform with termios\n"),
- prog_string, arg, nao);
- return EXIT_FAILURE;
-#endif
case 'd':
drop_privilege();
#if CONFIG_DEBUG_SUPPORT
@@ -1031,13 +1191,8 @@ int txr_main(int argc, char **argv)
goto repl;
if (evaled)
return EXIT_SUCCESS;
-#if HAVE_TERMIOS
- banner();
+ banner(self);
goto repl;
-#else
- hint();
- return EXIT_FAILURE;
-#endif
}
drop_privilege();
@@ -1061,10 +1216,11 @@ int txr_main(int argc, char **argv)
val parser_obj = ensure_parser(parse_stream, spec_file_str);
parser_t *parser = parser_get_impl(prog_string, parser_obj);
parse_once_noerr(parse_stream, spec_file_str);
+ mut(parser_obj);
gc_state(gc);
close_stream(parse_stream, nil);
-
+ run_load_hooks(dyn_env);
uw_release_deferred_warnings();
spec = parser->syntax_tree;
@@ -1103,36 +1259,41 @@ int txr_main(int argc, char **argv)
reg_varl(car(binding), cdr(binding));
}
- if (txr_lisp_p == chr('o')) {
- val result = read_compiled_file_noerr(self, parse_stream, spec_file_str,
- std_error);
- if (!enter_repl)
- return result ? 0 : EXIT_FAILURE;
- } else {
- val result = read_eval_stream_noerr(self, parse_stream, spec_file_str,
- std_error);
-
- close_stream(parse_stream, nil);
-
- uw_release_deferred_warnings();
-
- if (!enter_repl)
- return result ? 0 : EXIT_FAILURE;
+ {
+ if (txr_lisp_p == chr('o')) {
+ uw_block_begin (load_s, ret);
+ ret = read_compiled_file_noerr(self, parse_stream,
+ spec_file_str, std_error);
+ uw_block_end;
+ if (!enter_repl)
+ exit_wrap(ret);
+ } else if (enter_repl) {
+ uw_block_begin (load_s, ret);
+ ret = read_eval_stream_noerr(self, parse_stream,
+ spec_file_str, std_error);
+ uw_block_end;
+ close_stream(parse_stream, nil);
+ run_load_hooks(dyn_env);
+ uw_release_deferred_warnings();
+ } else {
+ uw_block_begin (load_s, ret);
+ ret = read_eval_stream(self, parse_stream, std_error);
+ uw_block_end;
+ exit_wrap(ret);
+ }
}
repl:
-#if HAVE_TERMIOS
if (compat_val)
format(std_output,
lit("Note: operating in TXR ~a compatibility mode "
"due to environment variable.\n"),
num(opt_compat), nao);
reg_var(args_s, or2(orig_args, arg_list));
- reg_varl(intern(lit("self-path"), user_package), lit("listener"));
+ reg_varl(self_path_s, lit("listener"));
env_vbind(dyn_env, package_s,
opt_compat && opt_compat <= 190 ? user_package : public_package);
env_vbind(dyn_env, load_recursive_s, nil);
repl(bindings, std_input, std_output, nil);
-#endif
return 0;
}
diff --git a/txr.h b/txr.h
index 96196257..4a0585eb 100644
--- a/txr.h
+++ b/txr.h
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
extern int opt_loglevel;
@@ -39,6 +40,8 @@ extern int opt_compat;
extern int opt_debugger;
extern int opt_dbg_autoload;
extern int opt_dbg_expansion;
+extern int opt_noprofile;
+extern int opt_free_all;
extern alloc_bytes_t opt_gc_delta;
extern const wchli_t *version;
extern wchar_t *progname;
diff --git a/txr.vim b/txr.vim
index eb0a0661..9682c83d 100644
--- a/txr.vim
+++ b/txr.vim
@@ -20,98 +20,113 @@ syn spell toplevel
setlocal iskeyword=a-z,A-Z,48-57,!,$,%,&,*,+,-,<,=,>,?,\\,_,~,/,^
-syn keyword tl_keyword contained %e% %pi% * *args*
-syn keyword tl_keyword contained *args-eff* *args-full* *filters* *full-args*
-syn keyword tl_keyword contained *gensym-counter* *hash-seed* *lib-version* *listener-greedy-eval-p*
-syn keyword tl_keyword contained *listener-hist-len* *listener-multi-line-p* *listener-pprint-p* *listener-sel-inclusive-p*
-syn keyword tl_keyword contained *load-path* *package* *package-alist* *param-macro*
-syn keyword tl_keyword contained *place-clobber-expander* *place-delete-expander* *place-macro* *place-update-expander*
-syn keyword tl_keyword contained *pprint-flo-format* *print-base* *print-circle* *print-flo-digits*
-syn keyword tl_keyword contained *print-flo-format* *print-flo-precision* *random-state* *random-warmup*
-syn keyword tl_keyword contained *rec-source-loc* *stddebug* *stderr* *stdin*
-syn keyword tl_keyword contained *stdlog* *stdnull* *stdout* *trace-output*
-syn keyword tl_keyword contained *tree-fun-whitelist* *txr-version* *unhandled-hook* +
-syn keyword tl_keyword contained - / /= :
-syn keyword tl_keyword contained :abandoned :addr :all :apf
+syn keyword tl_keyword contained %e% %fun% %pi% *
+syn keyword tl_keyword contained *args* *args-eff* *args-full* *child-env*
+syn keyword tl_keyword contained *compile-opts* *doc-url* *filters* *full-args*
+syn keyword tl_keyword contained *gensym-counter* *hash-seed* *lib-version* *listener-auto-compound-p*
+syn keyword tl_keyword contained *listener-greedy-eval-p* *listener-hist-len* *listener-multi-line-p* *listener-pprint-p*
+syn keyword tl_keyword contained *listener-sel-inclusive-p* *load-args* *load-hooks* *load-path*
+syn keyword tl_keyword contained *load-search-dirs* *match-macro* *opt-level* *package*
+syn keyword tl_keyword contained *package-alist* *param-macro* *place-clobber-expander* *place-delete-expander*
+syn keyword tl_keyword contained *place-macro* *place-update-expander* *pprint-flo-format* *print-base*
+syn keyword tl_keyword contained *print-circle* *print-flo-digits* *print-flo-format* *print-flo-precision*
+syn keyword tl_keyword contained *print-json-format* *random-state* *random-warmup* *read-bad-json*
+syn keyword tl_keyword contained *read-unknown-structs* *rec-source-loc* *stddebug* *stderr*
+syn keyword tl_keyword contained *stdin* *stdlog* *stdnull* *stdout*
+syn keyword tl_keyword contained *struct-clause-expander* *trace-output* *tree-fun-whitelist* *txr-version*
+syn keyword tl_keyword contained *unhandled-hook* + - /
+syn keyword tl_keyword contained /= : :abandoned :abs
+syn keyword tl_keyword contained :addr :all :android :apf
syn keyword tl_keyword contained :append :args :atime :auto
syn keyword tl_keyword contained :awk-again :awk-file :awk-rec :begin
syn keyword tl_keyword contained :begin-file :blksize :blocks :bool
syn keyword tl_keyword contained :byte-oriented :cdigit :chars :cint
-syn keyword tl_keyword contained :close :continue :counter :cspace
-syn keyword tl_keyword contained :ctime :cword-char :dec :decline
-syn keyword tl_keyword contained :dev :digit :downcase :end
-syn keyword tl_keyword contained :end-file :env :eq-based :eql-based
-syn keyword tl_keyword contained :equal-based :explicit-no :fallback :fd
-syn keyword tl_keyword contained :fence :filter :fini :finish
-syn keyword tl_keyword contained :float :form :from-current :from-end
-syn keyword tl_keyword contained :from-start :from_html :frombase64 :fromhtml
+syn keyword tl_keyword contained :clean :close :compile :continue
+syn keyword tl_keyword contained :counter :cspace :ctime :cword-char
+syn keyword tl_keyword contained :cygnal :cygwin :dec :decline
+syn keyword tl_keyword contained :delegate :dev :digit :downcase
+syn keyword tl_keyword contained :end :end-file :env :eq-based
+syn keyword tl_keyword contained :eql-based :equal-based :error :explicit-no
+syn keyword tl_keyword contained :fallback :fd :fence :fields
+syn keyword tl_keyword contained :filter :fini :finish :float
+syn keyword tl_keyword contained :form :from-current :from-end :from-start
+syn keyword tl_keyword contained :from_html :frombase64 :frombase64url :fromhtml
syn keyword tl_keyword contained :frompercent :fromurl :fun :function
syn keyword tl_keyword contained :gap :gid :greedy :hex
-syn keyword tl_keyword contained :hextoint :inf :init :ino
-syn keyword tl_keyword contained :inp :inputs :instance :into
-syn keyword tl_keyword contained :key :let :lfilt :lines
-syn keyword tl_keyword contained :list :lists :local :longest
-syn keyword tl_keyword contained :mandatory :maxgap :maxtimes :method
-syn keyword tl_keyword contained :mid :mingap :mintimes :mode
-syn keyword tl_keyword contained :mtime :name :named :next-spec
-syn keyword tl_keyword contained :nlink :nothrow :oct :outf
-syn keyword tl_keyword contained :outp :output :owner :perms
-syn keyword tl_keyword contained :postinit :prio :rdev :real-time
-syn keyword tl_keyword contained :reflect :repeat-spec :resolve :rfilt
-syn keyword tl_keyword contained :set :set-file :shortest :size
-syn keyword tl_keyword contained :space :static :str :string
-syn keyword tl_keyword contained :symacro :symlinks :text :times
-syn keyword tl_keyword contained :tlist :to_html :tobase64 :tofloat
-syn keyword tl_keyword contained :tohtml :tohtml* :toint :tonumber
-syn keyword tl_keyword contained :topercent :tourl :uid :upcase
-syn keyword tl_keyword contained :use :use-from :use-syms :userdata
-syn keyword tl_keyword contained :var :vars :weak-keys :weak-vals
-syn keyword tl_keyword contained :whole :word-char :wrap <
-syn keyword tl_keyword contained <= = > >=
-syn keyword tl_keyword contained abort abs abs-path-p acons
-syn keyword tl_keyword contained acons-new aconsql-new acos acosh
+syn keyword tl_keyword contained :hextoint :inf :inherit :init
+syn keyword tl_keyword contained :ino :inp :inputs :instance
+syn keyword tl_keyword contained :into :key :let :lfilt
+syn keyword tl_keyword contained :lines :linux :list :lists
+syn keyword tl_keyword contained :local :longest :macos :macro
+syn keyword tl_keyword contained :mandatory :mass-delegate :match :maxgap
+syn keyword tl_keyword contained :maxtimes :method :mid :mingap
+syn keyword tl_keyword contained :mintimes :mode :mtime :name
+syn keyword tl_keyword contained :named :next-spec :nlink :noclose
+syn keyword tl_keyword contained :nothrow :oct :ok :openbsd
+syn keyword tl_keyword contained :outf :outp :output :owner
+syn keyword tl_keyword contained :perms :postfini :postinit :prio
+syn keyword tl_keyword contained :rdev :real-time :reflect :repeat-spec
+syn keyword tl_keyword contained :resolve :rfilt :set :set-file
+syn keyword tl_keyword contained :shortest :size :solaris :solaris10
+syn keyword tl_keyword contained :space :standard :static :str
+syn keyword tl_keyword contained :string :symacro :symlinks :text
+syn keyword tl_keyword contained :times :tlist :to_html :tobase64
+syn keyword tl_keyword contained :tobase64url :tofloat :tohtml :tohtml*
+syn keyword tl_keyword contained :toint :tonumber :topercent :tourl
+syn keyword tl_keyword contained :uid :unknown :upcase :use
+syn keyword tl_keyword contained :use-from :use-syms :use-syms-as :userdata
+syn keyword tl_keyword contained :var :vars :warn :weak-and
+syn keyword tl_keyword contained :weak-keys :weak-or :weak-vals :whole
+syn keyword tl_keyword contained :word-char :wrap < <=
+syn keyword tl_keyword contained = > >= abort
+syn keyword tl_keyword contained abs abs-path-p acons acons-new
+syn keyword tl_keyword contained aconsql-new acos acosh add-suffix
syn keyword tl_keyword contained ado af-inet af-inet6 af-unix
syn keyword tl_keyword contained af-unspec ai-addrconfig ai-all ai-canonname
syn keyword tl_keyword contained ai-numerichost ai-numericserv ai-passive ai-v4mapped
syn keyword tl_keyword contained alet align alignof alist-nremove
syn keyword tl_keyword contained alist-remove all allocate-struct and
syn keyword tl_keyword contained andf ap apf append
-syn keyword tl_keyword contained append* append-each append-each* apply
-syn keyword tl_keyword contained aret array arraysize ash
-syn keyword tl_keyword contained asin asinh assoc assq
-syn keyword tl_keyword contained assql at-exit-call at-exit-do-not-call atan
-syn keyword tl_keyword contained atan2 atanh atom awk
-syn keyword tl_keyword contained base-name base64-decode base64-decode-buf base64-encode
-syn keyword tl_keyword contained base64-stream-dec base64-stream-enc bchar be-double
-syn keyword tl_keyword contained be-float be-int16 be-int32 be-int64
-syn keyword tl_keyword contained be-uint16 be-uint32 be-uint64 bignum-len
-syn keyword tl_keyword contained bignump bindable bit bitset
-syn keyword tl_keyword contained blkcnt-t blksize-t block block*
-syn keyword tl_keyword contained bool boundp bracket break-str
-syn keyword tl_keyword contained brkint bs0 bs1 bsdly
-syn keyword tl_keyword contained bstr bstr-d buf buf-alloc-size
-syn keyword tl_keyword contained buf-carray buf-d buf-get-char buf-get-cptr
-syn keyword tl_keyword contained buf-get-double buf-get-float buf-get-i16 buf-get-i32
-syn keyword tl_keyword contained buf-get-i64 buf-get-i8 buf-get-int buf-get-long
-syn keyword tl_keyword contained buf-get-short buf-get-u16 buf-get-u32 buf-get-u64
-syn keyword tl_keyword contained buf-get-u8 buf-get-uchar buf-get-uint buf-get-ulong
-syn keyword tl_keyword contained buf-get-ushort buf-int buf-list buf-put-buf
-syn keyword tl_keyword contained buf-put-char buf-put-cptr buf-put-double buf-put-float
-syn keyword tl_keyword contained buf-put-i16 buf-put-i32 buf-put-i64 buf-put-i8
-syn keyword tl_keyword contained buf-put-int buf-put-long buf-put-short buf-put-u16
-syn keyword tl_keyword contained buf-put-u32 buf-put-u64 buf-put-u8 buf-put-uchar
-syn keyword tl_keyword contained buf-put-uint buf-put-ulong buf-put-ushort buf-set-length
-syn keyword tl_keyword contained buf-str buf-trim buf-uint bufp
-syn keyword tl_keyword contained build build-list buildn butlast
-syn keyword tl_keyword contained butlastn caaaaar caaaadr caaaar
-syn keyword tl_keyword contained caaadar caaaddr caaadr caaar
-syn keyword tl_keyword contained caadaar caadadr caadar caaddar
-syn keyword tl_keyword contained caadddr caaddr caadr caar
-syn keyword tl_keyword contained cadaaar cadaadr cadaar cadadar
-syn keyword tl_keyword contained cadaddr cadadr cadar caddaar
-syn keyword tl_keyword contained caddadr caddar cadddar caddddr
-syn keyword tl_keyword contained cadddr caddr cadr call
-syn keyword tl_keyword contained call-clobber-expander call-finalizers call-super-fun call-super-method
+syn keyword tl_keyword contained append* append-each append-each* append-each-prod
+syn keyword tl_keyword contained append-each-prod* append-match-products append-matches apply
+syn keyword tl_keyword contained aret arithp array arraysize
+syn keyword tl_keyword contained ash asin asinh assert
+syn keyword tl_keyword contained assoc assq assql at-exit-call
+syn keyword tl_keyword contained at-exit-do-not-call atan atan2 atanh
+syn keyword tl_keyword contained atom awk base-name base64-decode
+syn keyword tl_keyword contained base64-decode-buf base64-encode base64-stream-dec base64-stream-enc
+syn keyword tl_keyword contained base64url-decode base64url-decode-buf base64url-encode base64url-stream-dec
+syn keyword tl_keyword contained base64url-stream-enc bchar be-double be-float
+syn keyword tl_keyword contained be-int16 be-int32 be-int64 be-uint16
+syn keyword tl_keyword contained be-uint32 be-uint64 bignum-len bignump
+syn keyword tl_keyword contained bindable bit bitset blkcnt-t
+syn keyword tl_keyword contained blksize-t block block* bool
+syn keyword tl_keyword contained boundp bracket break-str brkint
+syn keyword tl_keyword contained bs0 bs1 bsdly bstr
+syn keyword tl_keyword contained bstr-d bstr-s buf buf-alloc-size
+syn keyword tl_keyword contained buf-carray buf-compress buf-d buf-decompress
+syn keyword tl_keyword contained buf-get-char buf-get-cptr buf-get-double buf-get-float
+syn keyword tl_keyword contained buf-get-i16 buf-get-i32 buf-get-i64 buf-get-i8
+syn keyword tl_keyword contained buf-get-int buf-get-long buf-get-short buf-get-u16
+syn keyword tl_keyword contained buf-get-u32 buf-get-u64 buf-get-u8 buf-get-uchar
+syn keyword tl_keyword contained buf-get-uint buf-get-ulong buf-get-ushort buf-int
+syn keyword tl_keyword contained buf-list buf-put-buf buf-put-char buf-put-cptr
+syn keyword tl_keyword contained buf-put-double buf-put-float buf-put-i16 buf-put-i32
+syn keyword tl_keyword contained buf-put-i64 buf-put-i8 buf-put-int buf-put-long
+syn keyword tl_keyword contained buf-put-short buf-put-u16 buf-put-u32 buf-put-u64
+syn keyword tl_keyword contained buf-put-u8 buf-put-uchar buf-put-uint buf-put-ulong
+syn keyword tl_keyword contained buf-put-ushort buf-set-length buf-str buf-trim
+syn keyword tl_keyword contained buf-uint bufp build build-list
+syn keyword tl_keyword contained buildn built-in-type-p butlast butlastn
+syn keyword tl_keyword contained caaaaar caaaadr caaaar caaadar
+syn keyword tl_keyword contained caaaddr caaadr caaar caadaar
+syn keyword tl_keyword contained caadadr caadar caaddar caadddr
+syn keyword tl_keyword contained caaddr caadr caar cadaaar
+syn keyword tl_keyword contained cadaadr cadaar cadadar cadaddr
+syn keyword tl_keyword contained cadadr cadar caddaar caddadr
+syn keyword tl_keyword contained caddar cadddar caddddr cadddr
+syn keyword tl_keyword contained caddr cadr call call-clobber-expander
+syn keyword tl_keyword contained call-delete-expander call-finalizers call-super-fun call-super-method
syn keyword tl_keyword contained call-update-expander callf car carray
syn keyword tl_keyword contained carray-blank carray-buf carray-buf-sync carray-cptr
syn keyword tl_keyword contained carray-dup carray-free carray-get carray-getz
@@ -120,67 +135,82 @@ syn keyword tl_keyword contained carray-put carray-putz carray-ref carray-refset
syn keyword tl_keyword contained carray-replace carray-set-length carray-sub carray-type
syn keyword tl_keyword contained carray-uint carray-vec carrayp caseq
syn keyword tl_keyword contained caseq* caseql caseql* casequal
-syn keyword tl_keyword contained casequal* cat-str cat-streams cat-vec
-syn keyword tl_keyword contained catch catch* catch** catenated-stream-p
-syn keyword tl_keyword contained catenated-stream-push cbaud cbaudex cdaaaar
-syn keyword tl_keyword contained cdaaadr cdaaar cdaadar cdaaddr
-syn keyword tl_keyword contained cdaadr cdaar cdadaar cdadadr
-syn keyword tl_keyword contained cdadar cdaddar cdadddr cdaddr
-syn keyword tl_keyword contained cdadr cdar cddaaar cddaadr
-syn keyword tl_keyword contained cddaar cddadar cddaddr cddadr
-syn keyword tl_keyword contained cddar cdddaar cdddadr cdddar
-syn keyword tl_keyword contained cddddar cdddddr cddddr cdddr
-syn keyword tl_keyword contained cddr cdr ceil ceil-rem
-syn keyword tl_keyword contained chain chand char chdir
-syn keyword tl_keyword contained chmod chmod-rec chown chown-rec
-syn keyword tl_keyword contained chr-digit chr-int chr-isalnum chr-isalpha
-syn keyword tl_keyword contained chr-isascii chr-isblank chr-iscntrl chr-isdigit
-syn keyword tl_keyword contained chr-isgraph chr-islower chr-isprint chr-ispunct
-syn keyword tl_keyword contained chr-isspace chr-isunisp chr-isupper chr-isxdigit
-syn keyword tl_keyword contained chr-num chr-str chr-str-set chr-tolower
-syn keyword tl_keyword contained chr-toupper chr-xdigit chrp clamp
-syn keyword tl_keyword contained clear-dirty clear-error clear-struct clearhash
+syn keyword tl_keyword contained casequal* cat-files cat-str cat-streams
+syn keyword tl_keyword contained cat-vec catch catch* catch**
+syn keyword tl_keyword contained catenated-stream-p catenated-stream-push cbaud cbaudex
+syn keyword tl_keyword contained cbrt cdaaaar cdaaadr cdaaar
+syn keyword tl_keyword contained cdaadar cdaaddr cdaadr cdaar
+syn keyword tl_keyword contained cdadaar cdadadr cdadar cdaddar
+syn keyword tl_keyword contained cdadddr cdaddr cdadr cdar
+syn keyword tl_keyword contained cddaaar cddaadr cddaar cddadar
+syn keyword tl_keyword contained cddaddr cddadr cddar cdddaar
+syn keyword tl_keyword contained cdddadr cdddar cddddar cdddddr
+syn keyword tl_keyword contained cddddr cdddr cddr cdr
+syn keyword tl_keyword contained ceil ceil-rem chain chand
+syn keyword tl_keyword contained char chdir chmod chmod-rec
+syn keyword tl_keyword contained chown chown-rec chr-digit chr-int
+syn keyword tl_keyword contained chr-isalnum chr-isalpha chr-isascii chr-isblank
+syn keyword tl_keyword contained chr-iscntrl chr-isdigit chr-isgraph chr-islower
+syn keyword tl_keyword contained chr-isprint chr-ispunct chr-isspace chr-isunisp
+syn keyword tl_keyword contained chr-isupper chr-isxdigit chr-num chr-str
+syn keyword tl_keyword contained chr-str-set chr-tolower chr-toupper chr-xdigit
+syn keyword tl_keyword contained chrp clamp clean-file clear-dirty
+syn keyword tl_keyword contained clear-error clear-mask clear-struct clearhash
syn keyword tl_keyword contained clocal clock-t clockid-t close
-syn keyword tl_keyword contained close-stream closelog closure cmp-str
-syn keyword tl_keyword contained cmspar coded-length collect-each collect-each*
-syn keyword tl_keyword contained comb command-get command-get-buf command-get-lines
-syn keyword tl_keyword contained command-get-string command-put command-put-buf command-put-lines
-syn keyword tl_keyword contained command-put-string compare-swap compile compile-defr-warning
-syn keyword tl_keyword contained compile-error compile-file compile-only compile-toplevel
-syn keyword tl_keyword contained compile-update-file compile-warning compl-span-str cond
-syn keyword tl_keyword contained conda condlet cons conses
-syn keyword tl_keyword contained conses* consp constantp copy
-syn keyword tl_keyword contained copy-alist copy-buf copy-carray copy-cons
-syn keyword tl_keyword contained copy-file copy-files copy-fun copy-hash
-syn keyword tl_keyword contained copy-list copy-path-rec copy-search-tree copy-str
-syn keyword tl_keyword contained copy-struct copy-tnode copy-tree copy-vec
-syn keyword tl_keyword contained cos cosh count-if count-until-match
-syn keyword tl_keyword contained countq countql countqual cptr
-syn keyword tl_keyword contained cptr-buf cptr-cast cptr-free cptr-int
-syn keyword tl_keyword contained cptr-null cptr-obj cptr-size-hint cptr-type
+syn keyword tl_keyword contained close-lazy-streams close-stream closedir closelog
+syn keyword tl_keyword contained closure cmp-str cmspar cnsort
+syn keyword tl_keyword contained coded-length collect-each collect-each* collect-each-prod
+syn keyword tl_keyword contained collect-each-prod* comb command-get command-get-buf
+syn keyword tl_keyword contained command-get-json command-get-jsons command-get-lines command-get-string
+syn keyword tl_keyword contained command-put command-put-buf command-put-json command-put-jsons
+syn keyword tl_keyword contained command-put-lines command-put-string compare-swap compile
+syn keyword tl_keyword contained compile-defr-warning compile-error compile-file compile-only
+syn keyword tl_keyword contained compile-toplevel compile-update-file compile-warning compiler-let
+syn keyword tl_keyword contained compl-span-str cond conda condlet
+syn keyword tl_keyword contained cons cons-count cons-find conses
+syn keyword tl_keyword contained conses* consp constantp contain[s]
+syn keyword tl_keyword contained copy copy-alist copy-buf copy-carray
+syn keyword tl_keyword contained copy-cons copy-cptr copy-file copy-files
+syn keyword tl_keyword contained copy-fun copy-hash copy-list copy-path-rec
+syn keyword tl_keyword contained copy-search-tree copy-str copy-struct copy-tnode
+syn keyword tl_keyword contained copy-tree copy-tree-iter copy-vec copysign
+syn keyword tl_keyword contained cos cosh count count-if
+syn keyword tl_keyword contained count-until-match countq countql countqual
+syn keyword tl_keyword contained cptr cptr-buf cptr-carray cptr-cast
+syn keyword tl_keyword contained cptr-free cptr-get cptr-int cptr-null
+syn keyword tl_keyword contained cptr-obj cptr-out cptr-size-hint cptr-type
syn keyword tl_keyword contained cptr-zap cptrp cr0 cr1
syn keyword tl_keyword contained cr2 cr3 crc32 crc32-stream
syn keyword tl_keyword contained crdly cread crtscts crypt
syn keyword tl_keyword contained cs5 cs6 cs7 cs8
-syn keyword tl_keyword contained csize cstopb cum-norm-dist daemon
-syn keyword tl_keyword contained dec defer-warning defex deffi
-syn keyword tl_keyword contained deffi-cb deffi-cb-unsafe deffi-sym deffi-type
+syn keyword tl_keyword contained csize csnsort csort csort-group
+syn keyword tl_keyword contained cssort cstopb cum-norm-dist cxr
+syn keyword tl_keyword contained cyr daemon dec defer-warning
+syn keyword tl_keyword contained defex deffi deffi-cb deffi-cb-unsafe
+syn keyword tl_keyword contained deffi-struct deffi-sym deffi-type deffi-union
syn keyword tl_keyword contained deffi-var define-accessor define-modify-macro define-option-struct
-syn keyword tl_keyword contained define-param-expander define-place-macro defmacro defmeth
-syn keyword tl_keyword contained defpackage defparm defparml defplace
-syn keyword tl_keyword contained defset defstruct defsymacro defun
+syn keyword tl_keyword contained define-param-expander define-place-macro define-struct-clause define-struct-prelude
+syn keyword tl_keyword contained defmacro defmatch defmeth defpackage
+syn keyword tl_keyword contained defparm defparml defplace defset
+syn keyword tl_keyword contained defstruct defsymacro defun defun-match
syn keyword tl_keyword contained defvar defvarl del delay
-syn keyword tl_keyword contained delete-package dev-t diff digits
-syn keyword tl_keyword contained digpow dir-name disassemble display-width
-syn keyword tl_keyword contained divides dlclose dlopen dlsym
-syn keyword tl_keyword contained dlsym-checked dlvsym dlvsym-checked do
-syn keyword tl_keyword contained dohash doloop doloop* dotimes
-syn keyword tl_keyword contained double downcase-str drop drop-until
-syn keyword tl_keyword contained drop-while dump-compiled-objects dump-deferred-warnings dup
+syn keyword tl_keyword contained delcons delete-package dev-t diff
+syn keyword tl_keyword contained digits digpow dir-name dirstat
+syn keyword tl_keyword contained disassemble display-width divides dlclose
+syn keyword tl_keyword contained dlopen dlsym dlsym-checked dlvsym
+syn keyword tl_keyword contained dlvsym-checked do doc dohash
+syn keyword tl_keyword contained doloop doloop* dotimes double
+syn keyword tl_keyword contained downcase-str drem drop drop-until
+syn keyword tl_keyword contained drop-while dt-blk dt-chr dt-dir
+syn keyword tl_keyword contained dt-fifo dt-lnk dt-reg dt-sock
+syn keyword tl_keyword contained dt-unknown dump-compiled-objects dump-deferred-warnings dup
syn keyword tl_keyword contained dupfd dwim e2big eacces
-syn keyword tl_keyword contained each each* eaddrinuse eaddrnotavail
-syn keyword tl_keyword contained eafnosupport eagain ealready ebadf
-syn keyword tl_keyword contained ebadmsg ebusy ecanceled echild
+syn keyword tl_keyword contained each each* each-false each-match
+syn keyword tl_keyword contained each-match-product each-prod each-prod* each-true
+syn keyword tl_keyword contained eaddrinuse eaddrnotavail eafnosupport eagain
+syn keyword tl_keyword contained ealready ebadf ebadmsg ebusy
+syn keyword tl_keyword contained ecanceled ecaseq ecaseq* ecaseql
+syn keyword tl_keyword contained ecaseql* ecasequal ecasequal* echild
syn keyword tl_keyword contained echo echoctl echoe echok
syn keyword tl_keyword contained echoke echonl echoprt econnaborted
syn keyword tl_keyword contained econnrefused econnreset edeadlk edestaddrreq
@@ -197,417 +227,530 @@ syn keyword tl_keyword contained enoexec enolck enolink enomem
syn keyword tl_keyword contained enomsg enoprotoopt enospc enosr
syn keyword tl_keyword contained enostr enosys enotconn enotdir
syn keyword tl_keyword contained enotempty enotrecoverable enotsock enotsup
-syn keyword tl_keyword contained enotty ensure-dir enum enumed
-syn keyword tl_keyword contained env env-fbind env-fbindings env-hash
-syn keyword tl_keyword contained env-next env-vbind env-vbindings enxio
-syn keyword tl_keyword contained eopnotsupp eoverflow eownerdead eperm
-syn keyword tl_keyword contained epipe eproto eprotonosupport eprototype
-syn keyword tl_keyword contained eq eql equal equot
-syn keyword tl_keyword contained erange erofs errno error
-syn keyword tl_keyword contained espipe esrch estale etime
-syn keyword tl_keyword contained etimedout etxtbsy eval eval-only
+syn keyword tl_keyword contained enotty ensure ensure-dir enum
+syn keyword tl_keyword contained enumed env env-fbind env-fbindings
+syn keyword tl_keyword contained env-hash env-next env-vbind env-vbindings
+syn keyword tl_keyword contained enxio eopnotsupp eoverflow eownerdead
+syn keyword tl_keyword contained eperm epipe eproto eprotonosupport
+syn keyword tl_keyword contained eprototype eq eql equal
+syn keyword tl_keyword contained equot erange erf erfc
+syn keyword tl_keyword contained erofs errno error espipe
+syn keyword tl_keyword contained esrch estale etime etimedout
+syn keyword tl_keyword contained etxtbsy etypecase eval eval-only
syn keyword tl_keyword contained evenp ewouldblock exception-subtype-map exception-subtype-p
syn keyword tl_keyword contained exdev exec exit exit*
-syn keyword tl_keyword contained exp expand expand* expand-left
-syn keyword tl_keyword contained expand-right expand-with-free-refs expt exptmod
+syn keyword tl_keyword contained exp exp10 exp2 expand
+syn keyword tl_keyword contained expand* expand-left expand-right expand-with-free-refs
+syn keyword tl_keyword contained expander-let expm1 expt exptmod
syn keyword tl_keyword contained extproc f$ f-dupfd f-dupfd-cloexec
syn keyword tl_keyword contained f-getfd f-getfl f-getlk f-rdlck
syn keyword tl_keyword contained f-setfd f-setfl f-setlk f-setlkw
syn keyword tl_keyword contained f-unlck f-wrlck f^ f^$
syn keyword tl_keyword contained false fboundp fcntl fd-cloexec
-syn keyword tl_keyword contained ff0 ff1 ffdly ffi
-syn keyword tl_keyword contained ffi-alignof ffi-arraysize ffi-call ffi-elemsize
-syn keyword tl_keyword contained ffi-elemtype ffi-get ffi-in ffi-make-call-desc
-syn keyword tl_keyword contained ffi-make-closure ffi-offsetof ffi-out ffi-put
-syn keyword tl_keyword contained ffi-put-into ffi-size ffi-type-compile ffi-type-operator-p
-syn keyword tl_keyword contained ffi-type-p ffi-typedef fifth file-append
-syn keyword tl_keyword contained file-append-buf file-append-lines file-append-string file-get
-syn keyword tl_keyword contained file-get-buf file-get-lines file-get-string file-place-buf
-syn keyword tl_keyword contained file-put file-put-buf file-put-lines file-put-string
-syn keyword tl_keyword contained fileno fill-buf fill-buf-adjust fill-carray
-syn keyword tl_keyword contained fill-obj filter-equal filter-string-tree finalize
-syn keyword tl_keyword contained find find-frame find-frames find-frames-by-mask
-syn keyword tl_keyword contained find-if find-max find-min find-package
-syn keyword tl_keyword contained find-struct-type find-symbol find-symbol-fb first
-syn keyword tl_keyword contained fixnum-max fixnum-min fixnump flatcar
-syn keyword tl_keyword contained flatcar* flatten flatten* flet
-syn keyword tl_keyword contained flip flipargs flo-dig flo-down
-syn keyword tl_keyword contained flo-epsilon flo-get-round-mode flo-int flo-max
-syn keyword tl_keyword contained flo-max-dig flo-min flo-near flo-set-round-mode
-syn keyword tl_keyword contained flo-str flo-up flo-zero float
-syn keyword tl_keyword contained floatp floor floor-rem flush-stream
-syn keyword tl_keyword contained flusho fmakunbound fmt fnm-casefold
-syn keyword tl_keyword contained fnm-extmatch fnm-leading-dir fnm-noescape fnm-pathname
-syn keyword tl_keyword contained fnm-period fnmatch for for*
-syn keyword tl_keyword contained force force-break fork format
-syn keyword tl_keyword contained fourth fr$ fr^ fr^$
-syn keyword tl_keyword contained from frr fsblkcnt-t fsfilcnt-t
-syn keyword tl_keyword contained fstat ftw ftw-actionretval ftw-chdir
-syn keyword tl_keyword contained ftw-continue ftw-d ftw-depth ftw-dnr
-syn keyword tl_keyword contained ftw-dp ftw-f ftw-mount ftw-ns
-syn keyword tl_keyword contained ftw-phys ftw-skip-siblings ftw-skip-subtree ftw-sl
-syn keyword tl_keyword contained ftw-sln ftw-stop fun fun-fixparam-count
-syn keyword tl_keyword contained fun-optparam-count fun-variadic func-get-env func-get-form
-syn keyword tl_keyword contained func-get-name func-set-env functionp gcd
-syn keyword tl_keyword contained gen gen-hash-seed generate gensym
-syn keyword tl_keyword contained gequal get-buf-from-stream get-byte get-char
-syn keyword tl_keyword contained get-clobber-expander get-delete-expander get-error get-error-str
-syn keyword tl_keyword contained get-frames get-hash-userdata get-indent get-indent-mode
-syn keyword tl_keyword contained get-line get-lines get-list-from-stream get-obj
-syn keyword tl_keyword contained get-sig-handler get-string get-string-from-stream get-update-expander
-syn keyword tl_keyword contained getaddrinfo getegid getenv geteuid
-syn keyword tl_keyword contained getgid getgrent getgrgid getgrnam
-syn keyword tl_keyword contained getgroups gethash getitimer getopts
-syn keyword tl_keyword contained getpid getppid getpwent getpwnam
-syn keyword tl_keyword contained getpwuid getresgid getresuid getuid
-syn keyword tl_keyword contained gid-t ginterate giterate glob
+syn keyword tl_keyword contained fdim ff0 ff1 ffdly
+syn keyword tl_keyword contained ffi ffi-alignof ffi-arraysize ffi-call
+syn keyword tl_keyword contained ffi-elemsize ffi-elemtype ffi-get ffi-in
+syn keyword tl_keyword contained ffi-make-call-desc ffi-make-closure ffi-offsetof ffi-out
+syn keyword tl_keyword contained ffi-put ffi-put-into ffi-size ffi-type-compile
+syn keyword tl_keyword contained ffi-type-operator-p ffi-type-p ffi-typedef fifth
+syn keyword tl_keyword contained file-append file-append-buf file-append-json file-append-jsons
+syn keyword tl_keyword contained file-append-lines file-append-objects file-append-string file-get
+syn keyword tl_keyword contained file-get-buf file-get-json file-get-jsons file-get-lines
+syn keyword tl_keyword contained file-get-objects file-get-string file-place-buf file-put
+syn keyword tl_keyword contained file-put-buf file-put-json file-put-jsons file-put-lines
+syn keyword tl_keyword contained file-put-objects file-put-string fileno fill-buf
+syn keyword tl_keyword contained fill-buf-adjust fill-carray fill-obj fill-vec
+syn keyword tl_keyword contained filter-equal filter-string-tree finalize find
+syn keyword tl_keyword contained find-frame find-frames find-frames-by-mask find-if
+syn keyword tl_keyword contained find-max find-max-key find-min find-min-key
+syn keyword tl_keyword contained find-package find-struct-type find-symbol find-symbol-fb
+syn keyword tl_keyword contained find-true first fixnum-max fixnum-min
+syn keyword tl_keyword contained fixnump flatcar flatcar* flatten
+syn keyword tl_keyword contained flatten* flet flip flipargs
+syn keyword tl_keyword contained flo-dig flo-down flo-epsilon flo-get-round-mode
+syn keyword tl_keyword contained flo-int flo-max flo-max-dig flo-min
+syn keyword tl_keyword contained flo-near flo-set-round-mode flo-str flo-up
+syn keyword tl_keyword contained flo-zero float floatp floor
+syn keyword tl_keyword contained floor-rem flow flush-stream flusho
+syn keyword tl_keyword contained fmakunbound fmax fmin fmt
+syn keyword tl_keyword contained fnm-casefold fnm-extmatch fnm-leading-dir fnm-noescape
+syn keyword tl_keyword contained fnm-pathname fnm-period fnmatch for
+syn keyword tl_keyword contained for* force force-break fork
+syn keyword tl_keyword contained format fourth fr$ fr^
+syn keyword tl_keyword contained fr^$ from frr fsblkcnt-t
+syn keyword tl_keyword contained fsfilcnt-t fstat ftw ftw-actionretval
+syn keyword tl_keyword contained ftw-chdir ftw-continue ftw-d ftw-depth
+syn keyword tl_keyword contained ftw-dnr ftw-dp ftw-f ftw-mount
+syn keyword tl_keyword contained ftw-ns ftw-phys ftw-skip-siblings ftw-skip-subtree
+syn keyword tl_keyword contained ftw-sl ftw-sln ftw-stop fun
+syn keyword tl_keyword contained fun-fixparam-count fun-optparam-count fun-variadic func-get-env
+syn keyword tl_keyword contained func-get-form func-get-name func-set-env functionp
+syn keyword tl_keyword contained gamma gcd gen gen-hash-seed
+syn keyword tl_keyword contained generate gensym gequal get-buf-from-stream
+syn keyword tl_keyword contained get-byte get-char get-clobber-expander get-delete-expander
+syn keyword tl_keyword contained get-error get-error-str get-frames get-hash-userdata
+syn keyword tl_keyword contained get-indent get-indent-mode get-json get-jsons
+syn keyword tl_keyword contained get-line get-line-as-buf get-lines get-list-from-stream
+syn keyword tl_keyword contained get-obj get-sig-handler get-stack-limit get-string
+syn keyword tl_keyword contained get-string-from-stream get-update-expander getaddrinfo getegid
+syn keyword tl_keyword contained getenv geteuid getgid getgrent
+syn keyword tl_keyword contained getgrgid getgrnam getgroups gethash
+syn keyword tl_keyword contained getitimer getopts getpid getppid
+syn keyword tl_keyword contained getpwent getpwnam getpwuid getresgid
+syn keyword tl_keyword contained getresuid getrlimit getuid gid-t
+syn keyword tl_keyword contained ginterate giterate glob glob*
syn keyword tl_keyword contained glob-altdirfunc glob-brace glob-err glob-mark
syn keyword tl_keyword contained glob-nocheck glob-noescape glob-nomagic glob-nosort
syn keyword tl_keyword contained glob-onlydir glob-period glob-tilde glob-tilde-check
-syn keyword tl_keyword contained go grade greater group-by
-syn keyword tl_keyword contained group-reduce gun handle handle*
-syn keyword tl_keyword contained handler-bind hash hash-alist hash-begin
-syn keyword tl_keyword contained hash-construct hash-count hash-diff hash-eql
-syn keyword tl_keyword contained hash-equal hash-from-alist hash-from-pairs hash-invert
-syn keyword tl_keyword contained hash-isec hash-keys hash-list hash-next
-syn keyword tl_keyword contained hash-pairs hash-peek hash-proper-subset hash-reset
-syn keyword tl_keyword contained hash-revget hash-subset hash-symdiff hash-uni
-syn keyword tl_keyword contained hash-update hash-update-1 hash-userdata hash-values
-syn keyword tl_keyword contained hash-zip hashp have hlet
+syn keyword tl_keyword contained glob-xnobrace go grade greater
+syn keyword tl_keyword contained group-by group-map group-reduce gun
+syn keyword tl_keyword contained handle handle* handler-bind hash
+syn keyword tl_keyword contained hash-alist hash-begin hash-construct hash-count
+syn keyword tl_keyword contained hash-diff hash-eql hash-equal hash-from-alist
+syn keyword tl_keyword contained hash-from-pairs hash-invert hash-isec hash-join
+syn keyword tl_keyword contained hash-keys hash-keys-of hash-list hash-map
+syn keyword tl_keyword contained hash-next hash-pairs hash-peek hash-proper-subset
+syn keyword tl_keyword contained hash-props hash-reset hash-revget hash-subset
+syn keyword tl_keyword contained hash-symdiff hash-uni hash-update hash-update-1
+syn keyword tl_keyword contained hash-userdata hash-values hash-zip hashp
+syn keyword tl_keyword contained have hist-sort hist-sort-by hlet
syn keyword tl_keyword contained hlet* html-decode html-encode html-encode*
-syn keyword tl_keyword contained hupcl iapply icanon icrnl
-syn keyword tl_keyword contained id-t identity identity* ido
-syn keyword tl_keyword contained iexten if ifa iff
-syn keyword tl_keyword contained iffi iflet ignbrk igncr
-syn keyword tl_keyword contained ignerr ignpar ignwarn imaxbel
-syn keyword tl_keyword contained improper-plist-to-alist in in-package in-range
-syn keyword tl_keyword contained in-range* in6addr-any in6addr-loopback inaddr-any
-syn keyword tl_keyword contained inaddr-loopback inc inc-indent indent-code
-syn keyword tl_keyword contained indent-data indent-foff indent-off inhash
-syn keyword tl_keyword contained inlcr ino-t inpck int
-syn keyword tl_keyword contained int-buf int-carray int-chr int-cptr
-syn keyword tl_keyword contained int-flo int-ptr-t int-str int16
-syn keyword tl_keyword contained int32 int64 int8 integerp
-syn keyword tl_keyword contained intern intern-fb interp-fun-p interpose
-syn keyword tl_keyword contained inv-cum-norm invoke-catch ip ipf
-syn keyword tl_keyword contained iread isec isig isqrt
-syn keyword tl_keyword contained istrip itimer-prov itimer-real itimer-virtual
-syn keyword tl_keyword contained iuclc iutf8 ixany ixoff
-syn keyword tl_keyword contained ixon juxt keep-if keep-if*
+syn keyword tl_keyword contained hupcl hypot iapply icanon
+syn keyword tl_keyword contained icrnl id-t identity identity*
+syn keyword tl_keyword contained ido iexten if if-match
+syn keyword tl_keyword contained ifa iff iffi iflet
+syn keyword tl_keyword contained ignbrk igncr ignerr ignore
+syn keyword tl_keyword contained ignpar ignwarn imaxbel improper-plist-to-alist
+syn keyword tl_keyword contained in in-package in-range in-range*
+syn keyword tl_keyword contained in6addr-any in6addr-loopback in6addr-str inaddr-any
+syn keyword tl_keyword contained inaddr-loopback inaddr-str inc inc-indent
+syn keyword tl_keyword contained inc-indent-abs indent-code indent-data indent-foff
+syn keyword tl_keyword contained indent-off inhash inlcr ino-t
+syn keyword tl_keyword contained inpck int int-buf int-carray
+syn keyword tl_keyword contained int-chr int-cptr int-flo int-ptr-t
+syn keyword tl_keyword contained int-str int16 int32 int64
+syn keyword tl_keyword contained int8 integerp intern intern-fb
+syn keyword tl_keyword contained interp-fun-p interpose intmax-t inv-cum-norm
+syn keyword tl_keyword contained invoke-catch ip ipf ipproto-ip
+syn keyword tl_keyword contained ipproto-ipv6 ipproto-tcp ipproto-udp ipv6-join-group
+syn keyword tl_keyword contained ipv6-leave-group ipv6-multicast-hops ipv6-multicast-if ipv6-multicast-loop
+syn keyword tl_keyword contained ipv6-unicast-hops ipv6-v6only iread isatty
+syn keyword tl_keyword contained isec isecp isig isqrt
+syn keyword tl_keyword contained istrip iter-begin iter-item iter-more
+syn keyword tl_keyword contained iter-reset iter-step iterable itimer-prof
+syn keyword tl_keyword contained itimer-real itimer-virtual iuclc iutf8
+syn keyword tl_keyword contained ixany ixoff ixon j0
+syn keyword tl_keyword contained j1 jmp-buf jn join
+syn keyword tl_keyword contained join-with json juxt keep-if
+syn keyword tl_keyword contained keep-if* keep-keys-if keep-match-products keep-matches
syn keyword tl_keyword contained keepq keepql keepqual key
syn keyword tl_keyword contained key-t keyword-package keywordp kill
-syn keyword tl_keyword contained labels lambda last lazy-str
-syn keyword tl_keyword contained lazy-str-force lazy-str-force-upto lazy-str-get-trailing-list lazy-stream-cons
-syn keyword tl_keyword contained lazy-stringp lchown lcm lcons
-syn keyword tl_keyword contained lcons-car lcons-cdr lcons-fun lconsp
-syn keyword tl_keyword contained ldiff ldo le-double le-float
-syn keyword tl_keyword contained le-int16 le-int32 le-int64 le-uint16
-syn keyword tl_keyword contained le-uint32 le-uint64 left len
-syn keyword tl_keyword contained length length-buf length-carray length-list
+syn keyword tl_keyword contained labels lambda lambda-match last
+syn keyword tl_keyword contained lazy-str lazy-str-force lazy-str-force-upto lazy-str-get-trailing-list
+syn keyword tl_keyword contained lazy-stream-cons lazy-stringp lchown lcm
+syn keyword tl_keyword contained lcons lcons-car lcons-cdr lcons-fun
+syn keyword tl_keyword contained lconsp ldexp ldiff ldo
+syn keyword tl_keyword contained le-double le-float le-int16 le-int32
+syn keyword tl_keyword contained le-int64 le-uint16 le-uint32 le-uint64
+syn keyword tl_keyword contained left len length length-<
+syn keyword tl_keyword contained length-buf length-carray length-list length-list-<
syn keyword tl_keyword contained length-str length-str-< length-str-<= length-str->
syn keyword tl_keyword contained length-str->= length-vec lequal less
-syn keyword tl_keyword contained let let* lexical-fun-p lexical-lisp1-binding
-syn keyword tl_keyword contained lexical-var-p lib-version link lisp-parse
-syn keyword tl_keyword contained list list* list-carray list-str
-syn keyword tl_keyword contained list-vec list-vector listp lnew
-syn keyword tl_keyword contained lnew* load load-for load-time
-syn keyword tl_keyword contained loff-t log log-alert log-auth
-syn keyword tl_keyword contained log-authpriv log-cons log-crit log-daemon
-syn keyword tl_keyword contained log-debug log-emerg log-err log-info
-syn keyword tl_keyword contained log-ndelay log-notice log-nowait log-odelay
-syn keyword tl_keyword contained log-perror log-pid log-user log-warning
-syn keyword tl_keyword contained log10 log2 logand logcount
+syn keyword tl_keyword contained let let* lexical-binding-kind lexical-fun-binding-kind
+syn keyword tl_keyword contained lexical-fun-p lexical-lisp1-binding lexical-macro-p lexical-symacro-p
+syn keyword tl_keyword contained lexical-var-p lflow lgamma lib-version
+syn keyword tl_keyword contained link lisp-parse list list*
+syn keyword tl_keyword contained list-carray list-seq list-str list-vec
+syn keyword tl_keyword contained list-vector listp lnew lnew*
+syn keyword tl_keyword contained load load-args-process load-args-recurse load-for
+syn keyword tl_keyword contained load-time loand loff-t log
+syn keyword tl_keyword contained log-alert log-auth log-authpriv log-cons
+syn keyword tl_keyword contained log-crit log-daemon log-debug log-emerg
+syn keyword tl_keyword contained log-err log-info log-ndelay log-notice
+syn keyword tl_keyword contained log-nowait log-odelay log-perror log-pid
+syn keyword tl_keyword contained log-user log-warning log10 log1p
+syn keyword tl_keyword contained log2 logand logb logcount
syn keyword tl_keyword contained logior lognot logtest logtrunc
-syn keyword tl_keyword contained logxor long longlong lop
+syn keyword tl_keyword contained logxor long long-suffix longjmp
+syn keyword tl_keyword contained longlong lop lopf lopip
syn keyword tl_keyword contained lset lstat lutimes m$
-syn keyword tl_keyword contained m^ m^$ mac-param-bind macro-ancestor
-syn keyword tl_keyword contained macro-form-p macro-time macroexpand macroexpand-1
-syn keyword tl_keyword contained macroexpand-1-lisp1 macroexpand-lisp1 macrolet major
-syn keyword tl_keyword contained make-buf make-buf-stream make-byte-input-stream make-catenated-stream
-syn keyword tl_keyword contained make-env make-hash make-lazy-cons make-lazy-struct
-syn keyword tl_keyword contained make-like make-package make-random-state make-similar-hash
-syn keyword tl_keyword contained make-string-byte-input-stream make-string-input-stream make-string-output-stream make-strlist-input-stream
-syn keyword tl_keyword contained make-strlist-output-stream make-struct make-struct-delegate-stream make-struct-type
-syn keyword tl_keyword contained make-sym make-time make-time-utc make-trie
-syn keyword tl_keyword contained make-union make-zstruct makedev makunbound
-syn keyword tl_keyword contained mapcar mapcar* mapdo mapf
-syn keyword tl_keyword contained maphash mappend mappend* maprend
-syn keyword tl_keyword contained maprod mask match-fun match-regex
-syn keyword tl_keyword contained match-regex-right match-regst match-regst-right match-str
-syn keyword tl_keyword contained match-str-tree max mboundp md5
-syn keyword tl_keyword contained md5-begin md5-end md5-hash md5-stream
-syn keyword tl_keyword contained member member-if memp memq
-syn keyword tl_keyword contained memql memqual meq meql
-syn keyword tl_keyword contained mequal merge merge-delete-package meth
-syn keyword tl_keyword contained method min minor minusp
-syn keyword tl_keyword contained mismatch mkdir mkfifo mknod
-syn keyword tl_keyword contained mkstring mlet mmakunbound mod
-syn keyword tl_keyword contained mode-t multi multi-sort n-choose-k
-syn keyword tl_keyword contained n-perm-k nconc neg neq
-syn keyword tl_keyword contained neql nequal new new*
-syn keyword tl_keyword contained nexpand-left nil nilf ninth
-syn keyword tl_keyword contained nl0 nl1 nldly nlink-t
-syn keyword tl_keyword contained noflsh none not notf
-syn keyword tl_keyword contained nreconc nreverse nth nthcdr
-syn keyword tl_keyword contained nthlast null nullify num-chr
-syn keyword tl_keyword contained num-str numberp nzerop o-accmode
-syn keyword tl_keyword contained o-append o-async o-cloexec o-creat
-syn keyword tl_keyword contained o-direct o-directory o-noatime o-noctty
-syn keyword tl_keyword contained o-nofollow o-nonblock o-path o-rdonly
-syn keyword tl_keyword contained o-rdwr o-sync o-trunc o-wronly
-syn keyword tl_keyword contained oand obtain obtain* obtain*-block
-syn keyword tl_keyword contained obtain-block ocrnl oddp ofdel
-syn keyword tl_keyword contained off-t offsetof ofill olcuc
-syn keyword tl_keyword contained onlcr onlret onocr op
-syn keyword tl_keyword contained open-command open-directory open-file open-fileno
-syn keyword tl_keyword contained open-files open-files* open-pipe open-process
-syn keyword tl_keyword contained open-socket open-socket-pair open-subprocess open-tail
-syn keyword tl_keyword contained openlog opip opost opt
-syn keyword tl_keyword contained opthelp or orf package-alist
+syn keyword tl_keyword contained m^ m^$ mac-env-param-bind mac-param-bind
+syn keyword tl_keyword contained macro-ancestor macro-form-p macro-time macroexpand
+syn keyword tl_keyword contained macroexpand-1 macroexpand-1-lisp1 macroexpand-1-place macroexpand-lisp1
+syn keyword tl_keyword contained macroexpand-match macroexpand-params macroexpand-place macroexpand-struct-clause
+syn keyword tl_keyword contained macrolet madv-dodump madv-dofork madv-dontdump
+syn keyword tl_keyword contained madv-dontfork madv-dontneed madv-free madv-hugepage
+syn keyword tl_keyword contained madv-hwpoison madv-keeponfork madv-mergeable madv-nohugepage
+syn keyword tl_keyword contained madv-normal madv-random madv-remove madv-sequential
+syn keyword tl_keyword contained madv-unmergeable madv-willneed madv-wipeonfork madvise
+syn keyword tl_keyword contained major make-buf make-buf-stream make-byte-input-stream
+syn keyword tl_keyword contained make-catenated-stream make-env make-hash make-lazy-cons
+syn keyword tl_keyword contained make-lazy-struct make-like make-package make-random-state
+syn keyword tl_keyword contained make-similar-hash make-similar-tree make-string-byte-input-stream make-string-input-stream
+syn keyword tl_keyword contained make-string-output-stream make-strlist-input-stream make-strlist-output-stream make-struct
+syn keyword tl_keyword contained make-struct-delegate-stream make-struct-type make-sym make-time
+syn keyword tl_keyword contained make-time-utc make-trie make-union make-zstruct
+syn keyword tl_keyword contained makedev makunbound map-anon map-fixed
+syn keyword tl_keyword contained map-growsdown map-huge-mask map-huge-shift map-hugetlb
+syn keyword tl_keyword contained map-locked map-nonblock map-noreserve map-populate
+syn keyword tl_keyword contained map-private map-shared map-stack mapcar
+syn keyword tl_keyword contained mapcar* mapdo mapf maphash
+syn keyword tl_keyword contained mappend mappend* maprend maprod
+syn keyword tl_keyword contained maprodo mask match match-case
+syn keyword tl_keyword contained match-cond match-ecase match-error match-fboundp
+syn keyword tl_keyword contained match-fun match-regex match-regex-right match-regst
+syn keyword tl_keyword contained match-regst-right match-str match-str-tree max
+syn keyword tl_keyword contained mboundp md5 md5-begin md5-end
+syn keyword tl_keyword contained md5-hash md5-stream member member-if
+syn keyword tl_keyword contained memp memq memql memqual
+syn keyword tl_keyword contained meq meql mequal merge
+syn keyword tl_keyword contained merge-delete-package meth method min
+syn keyword tl_keyword contained minor minusp mismatch mkdir
+syn keyword tl_keyword contained mkdtemp mkfifo mknod mkstemp
+syn keyword tl_keyword contained mkstring mlet mmakunbound mmap
+syn keyword tl_keyword contained mod mode-t mprotect mref
+syn keyword tl_keyword contained ms-async ms-invalidate ms-sync msync
+syn keyword tl_keyword contained mul-each mul-each* mul-each-prod mul-each-prod*
+syn keyword tl_keyword contained multi multi-sort munmap n-choose-k
+syn keyword tl_keyword contained n-perm-k nand nandf nconc
+syn keyword tl_keyword contained nearbyint neg neq neql
+syn keyword tl_keyword contained nequal nested-vec nested-vec-of new
+syn keyword tl_keyword contained new* nexpand-left nextafter nil
+syn keyword tl_keyword contained nilf ninth nl0 nl1
+syn keyword tl_keyword contained nldly nlink-t noflsh none
+syn keyword tl_keyword contained nor norf not notf
+syn keyword tl_keyword contained nreconc nreverse nrot nshuffle
+syn keyword tl_keyword contained nsort nth nthcdr nthlast
+syn keyword tl_keyword contained null nullify num-chr num-str
+syn keyword tl_keyword contained numberp nzerop o-accmode o-append
+syn keyword tl_keyword contained o-async o-cloexec o-creat o-direct
+syn keyword tl_keyword contained o-directory o-noatime o-noctty o-nofollow
+syn keyword tl_keyword contained o-nonblock o-path o-rdonly o-rdwr
+syn keyword tl_keyword contained o-sync o-trunc o-wronly oand
+syn keyword tl_keyword contained obtain obtain* obtain*-block obtain-block
+syn keyword tl_keyword contained ocrnl oddp ofdel off-t
+syn keyword tl_keyword contained offsetof ofill olcuc onlcr
+syn keyword tl_keyword contained onlret onocr op open-command
+syn keyword tl_keyword contained open-directory open-file open-fileno open-files
+syn keyword tl_keyword contained open-files* open-pipe open-process open-socket
+syn keyword tl_keyword contained open-socket-pair open-subprocess open-tail opendir
+syn keyword tl_keyword contained openlog opf opip opost
+syn keyword tl_keyword contained opt opthelp opthelp-conventions opthelp-types
+syn keyword tl_keyword contained or orf pack package-alist
syn keyword tl_keyword contained package-fallback-list package-foreign-symbols package-local-symbols package-name
-syn keyword tl_keyword contained package-symbols packagep pad parenb
-syn keyword tl_keyword contained parmrk parodd partition partition*
-syn keyword tl_keyword contained partition-by path-blkdev-p path-cat path-chrdev-p
-syn keyword tl_keyword contained path-dir-empty path-dir-p path-executable-to-me-p path-exists-p
-syn keyword tl_keyword contained path-file-p path-mine-p path-my-group-p path-newer
-syn keyword tl_keyword contained path-older path-pipe-p path-private-to-me-p path-read-writable-to-me-p
-syn keyword tl_keyword contained path-readable-to-me-p path-same-object path-sep-chars path-setgid-p
+syn keyword tl_keyword contained package-symbols packagep pad page-size
+syn keyword tl_keyword contained pairlis parenb parmrk parodd
+syn keyword tl_keyword contained parse-errors partition partition* partition-by
+syn keyword tl_keyword contained partition-if path-blkdev-p path-cat path-chrdev-p
+syn keyword tl_keyword contained path-components-safe path-dir-empty path-dir-p path-equal
+syn keyword tl_keyword contained path-executable-to-me-p path-exists-p path-file-p path-mine-p
+syn keyword tl_keyword contained path-my-group-p path-newer path-older path-pipe-p
+syn keyword tl_keyword contained path-private-to-me-p path-read-writable-to-me-p path-readable-to-me-p path-safe-sticky-dir
+syn keyword tl_keyword contained path-same-object path-search path-sep-chars path-setgid-p
syn keyword tl_keyword contained path-setuid-p path-sock-p path-sticky-p path-strictly-private-to-me-p
syn keyword tl_keyword contained path-symlink-p path-writable-to-me-p pdec pendin
-syn keyword tl_keyword contained perm pid-t pinc pipe
-syn keyword tl_keyword contained place-form-p placelet placelet* plist-to-alist
-syn keyword tl_keyword contained plusp poll poll-err poll-in
-syn keyword tl_keyword contained poll-nval poll-out poll-pri poll-rdband
-syn keyword tl_keyword contained poll-rdhup poll-wrband poly pop
-syn keyword tl_keyword contained pos pos-if pos-max pos-min
-syn keyword tl_keyword contained posq posql posqual pppred
-syn keyword tl_keyword contained ppred pprinl pprint pprof
-syn keyword tl_keyword contained pred prinl print prod
-syn keyword tl_keyword contained prof prog prog* prog1
-syn keyword tl_keyword contained progn promisep prop proper-list-p
-syn keyword tl_keyword contained proper-listp pset ptr ptr-in
-syn keyword tl_keyword contained ptr-in-d ptr-out ptr-out-d ptr-out-s
-syn keyword tl_keyword contained ptrdiff-t pub:txr-sym pure-rel-path-p purge-deferred-warning
-syn keyword tl_keyword contained push pushhash pushnew put-buf
-syn keyword tl_keyword contained put-byte put-carray put-char put-line
-syn keyword tl_keyword contained put-lines put-obj put-string put-strings
-syn keyword tl_keyword contained pwd qquote qref quote
-syn keyword tl_keyword contained r$ r^ r^$ raise
-syn keyword tl_keyword contained rand random random-fixnum random-float
+syn keyword tl_keyword contained perm pic pid-t pinc
+syn keyword tl_keyword contained pipe place-form-p placelet placelet*
+syn keyword tl_keyword contained plist-to-alist plusp poll poll-err
+syn keyword tl_keyword contained poll-in poll-nval poll-out poll-pri
+syn keyword tl_keyword contained poll-rdband poll-rdhup poll-wrband poly
+syn keyword tl_keyword contained pop pop-after-load portable-abs-path-p pos
+syn keyword tl_keyword contained pos-if pos-max pos-min posq
+syn keyword tl_keyword contained posql posqual pppred ppred
+syn keyword tl_keyword contained pprinl pprint pprof pred
+syn keyword tl_keyword contained prinl print prod prof
+syn keyword tl_keyword contained prog prog* prog1 prog2
+syn keyword tl_keyword contained progn progv promisep prop
+syn keyword tl_keyword contained proper-list-p proper-listp prot-exec prot-growsdown
+syn keyword tl_keyword contained prot-growsup prot-none prot-read prot-write
+syn keyword tl_keyword contained pset ptr ptr-in ptr-in-d
+syn keyword tl_keyword contained ptr-out ptr-out-d ptr-out-s ptrdiff-t
+syn keyword tl_keyword contained pub:txr-sym pure-rel-path-p purge-deferred-warning push
+syn keyword tl_keyword contained push-after-load pushhash pushnew put-buf
+syn keyword tl_keyword contained put-byte put-carray put-char put-json
+syn keyword tl_keyword contained put-jsonl put-jsons put-line put-lines
+syn keyword tl_keyword contained put-obj put-string put-strings pwd
+syn keyword tl_keyword contained qquote qref quantile quip
+syn keyword tl_keyword contained quote r$ r^ r^$
+syn keyword tl_keyword contained raise rand random random-buf
+syn keyword tl_keyword contained random-fixnum random-float random-float-incl random-sample
syn keyword tl_keyword contained random-state-get-vec random-state-p range range*
-syn keyword tl_keyword contained range-regex rangep rassoc rassq
-syn keyword tl_keyword contained rassql rcomb rcons read
-syn keyword tl_keyword contained read-until-match readlink real-time-stream-p realpath
+syn keyword tl_keyword contained range-regex rangep rangeref rassoc
+syn keyword tl_keyword contained rassq rassql rcomb rcons
+syn keyword tl_keyword contained read read-objects read-once read-until-match
+syn keyword tl_keyword contained readdir readlink real-time-stream-p realpath
syn keyword tl_keyword contained record-adapter reduce-left reduce-right ref
-syn keyword tl_keyword contained refset regex-compile regex-from-trie regex-parse
-syn keyword tl_keyword contained regex-prefix-match regex-source regexp register-exception-subtypes
-syn keyword tl_keyword contained register-tentative-def regsub rehome-sym relate
-syn keyword tl_keyword contained release-deferred-warnings remhash remove-if remove-if*
+syn keyword tl_keyword contained refset regex-compile regex-from-trie regex-optimize
+syn keyword tl_keyword contained regex-parse regex-prefix-match regex-source regexp
+syn keyword tl_keyword contained register-exception-subtypes register-tentative-def regsub rehome-sym
+syn keyword tl_keyword contained reject rel-path relate release-deferred-warnings
+syn keyword tl_keyword contained remainder remhash remove-if remove-if*
syn keyword tl_keyword contained remove-path remove-path-rec remq remq*
syn keyword tl_keyword contained remql remql* remqual remqual*
syn keyword tl_keyword contained rename-path repeat replace replace-buf
-syn keyword tl_keyword contained replace-list replace-str replace-struct replace-vec
-syn keyword tl_keyword contained reset-struct rest ret retf
-syn keyword tl_keyword contained return return* return-from revappend
-syn keyword tl_keyword contained reverse rfind rfind-if right
-syn keyword tl_keyword contained rlcp rlcp-tree rlet rlist
-syn keyword tl_keyword contained rlist* rmdir rmember rmember-if
-syn keyword tl_keyword contained rmemq rmemql rmemqual rmismatch
-syn keyword tl_keyword contained rotate round round-rem rperm
-syn keyword tl_keyword contained rplaca rplacd rpoly rpos
-syn keyword tl_keyword contained rpos-if rposq rposql rposqual
-syn keyword tl_keyword contained rr rra rsearch rslot
-syn keyword tl_keyword contained rtld-deepbind rtld-global rtld-lazy rtld-local
-syn keyword tl_keyword contained rtld-nodelete rtld-noload rtld-now run
-syn keyword tl_keyword contained s-ifblk s-ifchr s-ifdir s-ififo
-syn keyword tl_keyword contained s-iflnk s-ifmt s-ifreg s-ifsock
-syn keyword tl_keyword contained s-irgrp s-iroth s-irusr s-irwxg
-syn keyword tl_keyword contained s-irwxo s-irwxu s-isgid s-isuid
-syn keyword tl_keyword contained s-isvtx s-iwgrp s-iwoth s-iwusr
-syn keyword tl_keyword contained s-ixgrp s-ixoth s-ixusr save-exe
-syn keyword tl_keyword contained sbit scan-until-match search search-regex
-syn keyword tl_keyword contained search-regst search-str search-str-tree second
-syn keyword tl_keyword contained seek-cur seek-end seek-set seek-stream
-syn keyword tl_keyword contained select self-load-path self-path seq-begin
+syn keyword tl_keyword contained replace-env replace-list replace-str replace-struct
+syn keyword tl_keyword contained replace-tree-iter replace-vec reset-struct rest
+syn keyword tl_keyword contained ret retf return return*
+syn keyword tl_keyword contained return-from revappend reverse rfind
+syn keyword tl_keyword contained rfind-if right rint rlcp
+syn keyword tl_keyword contained rlcp-tree rlet rlim-infinity rlim-saved-cur
+syn keyword tl_keyword contained rlim-saved-max rlimit-as rlimit-core rlimit-cpu
+syn keyword tl_keyword contained rlimit-data rlimit-fsize rlimit-nofile rlimit-stack
+syn keyword tl_keyword contained rlink rlist rlist* rmdir
+syn keyword tl_keyword contained rmember rmember-if rmemq rmemql
+syn keyword tl_keyword contained rmemqual rmismatch rot rotate
+syn keyword tl_keyword contained round round-rem rperm rplaca
+syn keyword tl_keyword contained rplacd rpoly rpos rpos-if
+syn keyword tl_keyword contained rposq rposql rposqual rr
+syn keyword tl_keyword contained rra rsearch rslot rtld-deepbind
+syn keyword tl_keyword contained rtld-global rtld-lazy rtld-local rtld-nodelete
+syn keyword tl_keyword contained rtld-noload rtld-now run s-ifblk
+syn keyword tl_keyword contained s-ifchr s-ifdir s-ififo s-iflnk
+syn keyword tl_keyword contained s-ifmt s-ifreg s-ifsock s-irgrp
+syn keyword tl_keyword contained s-iroth s-irusr s-irwxg s-irwxo
+syn keyword tl_keyword contained s-irwxu s-isgid s-isuid s-isvtx
+syn keyword tl_keyword contained s-iwgrp s-iwoth s-iwusr s-ixgrp
+syn keyword tl_keyword contained s-ixoth s-ixusr save-exe sbit
+syn keyword tl_keyword contained scalb scalbln scan-until-match search
+syn keyword tl_keyword contained search-all search-regex search-regst search-str
+syn keyword tl_keyword contained search-str-tree second seek-cur seek-end
+syn keyword tl_keyword contained seek-set seek-stream select self-load-path
+syn keyword tl_keyword contained self-path separate separate-keys seq-begin
syn keyword tl_keyword contained seq-next seq-reset seqp set
syn keyword tl_keyword contained set-diff set-hash-userdata set-indent set-indent-mode
-syn keyword tl_keyword contained set-key set-left set-max-depth set-max-length
-syn keyword tl_keyword contained set-package-fallback-list set-right set-sig-handler setegid
-syn keyword tl_keyword contained setenv seteuid setgid setgrent
-syn keyword tl_keyword contained setgroups sethash setitimer setlogmask
-syn keyword tl_keyword contained setpwent setresgid setresuid setuid
-syn keyword tl_keyword contained seventh sh sha256 sha256-begin
-syn keyword tl_keyword contained sha256-end sha256-hash sha256-stream shift
-syn keyword tl_keyword contained short shuffle sig-abrt sig-alrm
-syn keyword tl_keyword contained sig-atomic-t sig-bus sig-check sig-chld
-syn keyword tl_keyword contained sig-cont sig-fpe sig-hup sig-ill
-syn keyword tl_keyword contained sig-int sig-io sig-iot sig-kill
-syn keyword tl_keyword contained sig-pipe sig-poll sig-prof sig-pwr
-syn keyword tl_keyword contained sig-quit sig-segv sig-stkflt sig-stop
-syn keyword tl_keyword contained sig-sys sig-term sig-trap sig-tstp
-syn keyword tl_keyword contained sig-ttin sig-ttou sig-urg sig-usr1
-syn keyword tl_keyword contained sig-usr2 sig-vtalrm sig-winch sig-xcpu
-syn keyword tl_keyword contained sig-xfsz sign-extend signum sin
-syn keyword tl_keyword contained sinh sixth size-t size-vec
-syn keyword tl_keyword contained sizeof slet slot slotp
-syn keyword tl_keyword contained slots slotset sock-accept sock-bind
-syn keyword tl_keyword contained sock-cloexec sock-connect sock-dgram sock-family
-syn keyword tl_keyword contained sock-listen sock-nonblock sock-peer sock-recv-timeout
-syn keyword tl_keyword contained sock-send-timeout sock-set-peer sock-shutdown sock-stream
-syn keyword tl_keyword contained sock-type some sort sort-group
-syn keyword tl_keyword contained source-loc source-loc-str span-str special-operator-p
-syn keyword tl_keyword contained special-var-p spl splice split
-syn keyword tl_keyword contained split* split-str split-str-set sqrt
-syn keyword tl_keyword contained square ssize-t sssucc ssucc
-syn keyword tl_keyword contained starts-with stat static-slot static-slot-ensure
-syn keyword tl_keyword contained static-slot-home static-slot-p static-slot-set stdlib
-syn keyword tl_keyword contained str str-buf str-d str-in6addr
-syn keyword tl_keyword contained str-in6addr-net str-inaddr str-inaddr-net str<
+syn keyword tl_keyword contained set-key set-left set-mask set-max-depth
+syn keyword tl_keyword contained set-max-length set-package-fallback-list set-right set-sig-handler
+syn keyword tl_keyword contained set-stack-limit setegid setenv seteuid
+syn keyword tl_keyword contained setgid setgrent setgroups sethash
+syn keyword tl_keyword contained setitimer setjmp setlogmask setpwent
+syn keyword tl_keyword contained setresgid setresuid setrlimit setuid
+syn keyword tl_keyword contained seventh sh sh-esc sh-esc-all
+syn keyword tl_keyword contained sh-esc-dq sh-esc-sq sha1 sha1-begin
+syn keyword tl_keyword contained sha1-end sha1-hash sha1-stream sha256
+syn keyword tl_keyword contained sha256-begin sha256-end sha256-hash sha256-stream
+syn keyword tl_keyword contained shift short short-suffix shuffle
+syn keyword tl_keyword contained shut-rd shut-rdwr shut-wr sig-abrt
+syn keyword tl_keyword contained sig-alrm sig-atomic-t sig-bus sig-check
+syn keyword tl_keyword contained sig-chld sig-cont sig-fpe sig-hup
+syn keyword tl_keyword contained sig-ill sig-int sig-io sig-iot
+syn keyword tl_keyword contained sig-kill sig-pipe sig-poll sig-prof
+syn keyword tl_keyword contained sig-pwr sig-quit sig-segv sig-stkflt
+syn keyword tl_keyword contained sig-stop sig-sys sig-term sig-trap
+syn keyword tl_keyword contained sig-tstp sig-ttin sig-ttou sig-urg
+syn keyword tl_keyword contained sig-usr1 sig-usr2 sig-vtalrm sig-winch
+syn keyword tl_keyword contained sig-xcpu sig-xfsz sign-extend significand
+syn keyword tl_keyword contained signum sin sinh sixth
+syn keyword tl_keyword contained size-t size-vec sizeof slet
+syn keyword tl_keyword contained slot slotp slots slotset
+syn keyword tl_keyword contained snsort so-acceptconn so-broadcast so-debug
+syn keyword tl_keyword contained so-dontroute so-error so-keepalive so-linger
+syn keyword tl_keyword contained so-oobinline so-rcvbuf so-rcvlowat so-rcvtimeo
+syn keyword tl_keyword contained so-reuseaddr so-sndbuf so-sndlowat so-sndtimeo
+syn keyword tl_keyword contained so-type sock-accept sock-bind sock-cloexec
+syn keyword tl_keyword contained sock-connect sock-dgram sock-family sock-listen
+syn keyword tl_keyword contained sock-nonblock sock-opt sock-peer sock-recv-timeout
+syn keyword tl_keyword contained sock-send-timeout sock-set-opt sock-set-peer sock-shutdown
+syn keyword tl_keyword contained sock-stream sock-type sockaddr-str socklen-t
+syn keyword tl_keyword contained sol-socket some some-false some-true
+syn keyword tl_keyword contained sort sort-group source-loc source-loc-str
+syn keyword tl_keyword contained span-str special-operator-p special-var-p spl
+syn keyword tl_keyword contained splice split split* split-str
+syn keyword tl_keyword contained split-str-set spln sqrt square
+syn keyword tl_keyword contained ssize-t ssort sspl sssucc
+syn keyword tl_keyword contained ssucc starts-with stat static-slot
+syn keyword tl_keyword contained static-slot-ensure static-slot-home static-slot-p static-slot-set
+syn keyword tl_keyword contained stdlib str str-buf str-d
+syn keyword tl_keyword contained str-esc str-in6addr str-in6addr-net str-inaddr
+syn keyword tl_keyword contained str-inaddr-net str-s str-seq str<
syn keyword tl_keyword contained str<= str= str> str>=
-syn keyword tl_keyword contained stream-get-prop stream-set-prop streamp string-extend
-syn keyword tl_keyword contained string-lt stringp struct struct-from-args
-syn keyword tl_keyword contained struct-from-plist struct-get-initfun struct-get-postinitfun struct-set-initfun
-syn keyword tl_keyword contained struct-set-postinitfun struct-type struct-type-name struct-type-p
-syn keyword tl_keyword contained structp sub sub-buf sub-list
-syn keyword tl_keyword contained sub-str sub-vec subtypep succ
-syn keyword tl_keyword contained sum super super-method suspend
-syn keyword tl_keyword contained swap symacrolet symbol-function symbol-macro
-syn keyword tl_keyword contained symbol-name symbol-package symbol-value symbolp
-syn keyword tl_keyword contained symdiff symlink sys:%backpatch-high16% sys:%backpatch-low16%
-syn keyword tl_keyword contained sys:%big-endian% sys:%bin-op% sys:%bin-ops% sys:%block-using-funs%
-syn keyword tl_keyword contained sys:%call-op% sys:%dbg-command-env% sys:%file-suff-rx% sys:%gcall-op%
-syn keyword tl_keyword contained sys:%imm-width% sys:%lev-bits% sys:%lev-size% sys:%max-lambda-fixed-args%
+syn keyword tl_keyword contained stream-get-prop stream-set-prop streamp strerror
+syn keyword tl_keyword contained string-extend string-finish string-get-code string-lt
+syn keyword tl_keyword contained string-set-code stringp strsignal struct
+syn keyword tl_keyword contained struct-from-args struct-from-plist struct-get-initfun struct-get-postinitfun
+syn keyword tl_keyword contained struct-set-initfun struct-set-postinitfun struct-type struct-type-name
+syn keyword tl_keyword contained struct-type-p structp sub sub-buf
+syn keyword tl_keyword contained sub-list sub-str sub-tree sub-vec
+syn keyword tl_keyword contained subq subql subqual subst
+syn keyword tl_keyword contained subtypep succ sum sum-each
+syn keyword tl_keyword contained sum-each* sum-each-prod sum-each-prod* super
+syn keyword tl_keyword contained super-method suspend swap symacrolet
+syn keyword tl_keyword contained symbol-function symbol-macro symbol-name symbol-package
+syn keyword tl_keyword contained symbol-value symbolp symdiff symlink
+syn keyword tl_keyword contained sys:%backpatch-high16% sys:%backpatch-low16% sys:%big-endian% sys:%bin-op%
+syn keyword tl_keyword contained sys:%bin-ops% sys:%block-using-funs% sys:%call-op% sys:%const-foldable%
+syn keyword tl_keyword contained sys:%const-foldable-funs% sys:%dbg-command-env% sys:%dbg-commands% sys:%effect-free%
+syn keyword tl_keyword contained sys:%effect-free-funs% sys:%eval-cache% sys:%functional% sys:%functional-funs%
+syn keyword tl_keyword contained sys:%gcall-op% sys:%lev-bits% sys:%lev-size% sys:%max-lambda-fixed-args%
syn keyword tl_keyword contained sys:%max-lev% sys:%max-lev-idx% sys:%max-sm-lev% sys:%max-sm-lev-idx%
syn keyword tl_keyword contained sys:%max-v-lev% sys:%nary-ops% sys:%oc-code% sys:%oc-hash%
-syn keyword tl_keyword contained sys:%oc-list-builder% sys:%package-manip% sys:%sm-lev-bits% sys:%sm-lev-size%
+syn keyword tl_keyword contained sys:%oc-list-builder% sys:%package-manip% sys:%param-info% sys:%quip-rand-state%
+syn keyword tl_keyword contained sys:%quips% sys:%shuffled-quips% sys:%sm-lev-bits% sys:%sm-lev-size%
syn keyword tl_keyword contained sys:%test-funs% sys:%test-funs-neg% sys:%test-funs-ops% sys:%test-funs-pos%
-syn keyword tl_keyword contained sys:%test-inv% sys:%test-opcode% sys:%tlo-ver% sys:*dedup*
-syn keyword tl_keyword contained sys:*emit* sys:*eval* sys:*load-recursive* sys:*op-ctx*
-syn keyword tl_keyword contained sys:*pl-env* sys:*pl-form* sys:*trace-hash* sys:*trace-level*
-syn keyword tl_keyword contained sys:abscond* sys:abscond-from sys:analyze-argtypes sys:analyze-params
-syn keyword tl_keyword contained sys:apply sys:asm-error sys:assumed-fun sys:awk%--rng
+syn keyword tl_keyword contained sys:%test-inv% sys:%test-opcode% sys:%tlo-ver% sys:%warning-syms%
+syn keyword tl_keyword contained sys:*dedup* sys:*emit* sys:*eval* sys:*in-compilation-unit*
+syn keyword tl_keyword contained sys:*lazy-streams* sys:*load-recursive* sys:*load-time* sys:*match-form*
+syn keyword tl_keyword contained sys:*op-ctx* sys:*pl-env* sys:*pl-form* sys:*struct-prelude*
+syn keyword tl_keyword contained sys:*struct-prelude-alists* sys:*top-level* sys:*trace-hash* sys:*trace-level*
+syn keyword tl_keyword contained sys:*unchecked-calls* sys:abscond* sys:abscond-from sys:add-neg-parens
+syn keyword tl_keyword contained sys:analyze-argtypes sys:analyze-params sys:apply sys:arith-each
+syn keyword tl_keyword contained sys:asm-error sys:assumed-fun sys:autoload-try-fun sys:awk%--rng
syn keyword tl_keyword contained sys:awk%--rng+ sys:awk%--rng- sys:awk%-rng+ sys:awk%rng+
-syn keyword tl_keyword contained sys:awk-code-move-check sys:awk-error sys:awk-expander sys:awk-fun-let
-syn keyword tl_keyword contained sys:awk-fun-shadowing-env sys:awk-mac-let sys:awk-redir sys:awk-test
-syn keyword tl_keyword contained sys:b* sys:b+ sys:b- sys:b/
-syn keyword tl_keyword contained sys:b< sys:b<= sys:b= sys:b=>
-syn keyword tl_keyword contained sys:b> sys:bad-slot-syntax sys:bind-mac-check sys:bind-mac-error
-syn keyword tl_keyword contained sys:bits sys:bits-to-obj sys:build-expander sys:build-key-list-expr
-syn keyword tl_keyword contained sys:call-delete-expander sys:capture-cont sys:catch sys:check-slot
-syn keyword tl_keyword contained sys:check-struct sys:circref sys:compat sys:compile-file-conditionally
-syn keyword tl_keyword contained sys:compiler-emit-warnings sys:conv sys:conv-expand sys:conv-let
-syn keyword tl_keyword contained sys:ctx-form sys:ctx-name sys:dbg-all sys:dbg-backtrace
-syn keyword tl_keyword contained sys:dbg-clear sys:dbg-enable sys:dbg-restore sys:dbg-set
-syn keyword tl_keyword contained sys:dbg-step sys:debugger sys:dedup sys:deffi-cb-expander
-syn keyword tl_keyword contained sys:define-method sys:defset-expander sys:defset-expander-simple sys:disassemble-cdf
-syn keyword tl_keyword contained sys:dlib-expr sys:do-conv sys:do-copy-obj sys:do-path-test
-syn keyword tl_keyword contained sys:do-tweak-obj sys:dump-to-tlo sys:dvbind sys:dwim-del
-syn keyword tl_keyword contained sys:dwim-set sys:dyn-size sys:each-op sys:enc-small-op
-syn keyword tl_keyword contained sys:ensure-op-arg sys:env-to-let sys:eval-err sys:expand-bind-mac-params
+syn keyword tl_keyword contained sys:awk-code-move-check sys:awk-error sys:awk-expander sys:awk-field-name-code
+syn keyword tl_keyword contained sys:awk-fun-let sys:awk-fun-shadowing-env sys:awk-mac-let sys:awk-mac-let-outer
+syn keyword tl_keyword contained sys:awk-redir sys:awk-symac-let sys:awk-test sys:b*
+syn keyword tl_keyword contained sys:b+ sys:b- sys:b/ sys:b<
+syn keyword tl_keyword contained sys:b<= sys:b= sys:b=> sys:b>
+syn keyword tl_keyword contained sys:bad-slot-syntax sys:bexp-expand sys:bexp-parse sys:bexp-parse-brace
+syn keyword tl_keyword contained sys:bind-mac-check sys:bind-mac-error sys:bindable-check sys:bits
+syn keyword tl_keyword contained sys:bits-to-obj sys:blk sys:brace-expand sys:build-expander
+syn keyword tl_keyword contained sys:cached-sort-body sys:can-inline-chain sys:capture-cont sys:careful-subst-preserve
+syn keyword tl_keyword contained sys:catch sys:check sys:check-slot sys:check-struct
+syn keyword tl_keyword contained sys:check-sym sys:circref sys:comma-positions sys:compat
+syn keyword tl_keyword contained sys:compile-and-match sys:compile-as-match sys:compile-atom-match sys:compile-cons-structure
+syn keyword tl_keyword contained sys:compile-exprs-match sys:compile-file-conditionally sys:compile-hash-match sys:compile-loop-match
+syn keyword tl_keyword contained sys:compile-match sys:compile-new-var-match sys:compile-not-match sys:compile-or-match
+syn keyword tl_keyword contained sys:compile-predicate-match sys:compile-range-match sys:compile-require-match sys:compile-scan-match
+syn keyword tl_keyword contained sys:compile-struct-match sys:compile-var-match sys:compile-vec-match sys:compile-with-match
+syn keyword tl_keyword contained sys:compiler-emit-warnings sys:conv sys:conv-expand sys:conv-expand-sym
+syn keyword tl_keyword contained sys:conv-let sys:ctx-form sys:ctx-name sys:dbg-all
+syn keyword tl_keyword contained sys:dbg-backtrace sys:dbg-clear sys:dbg-enable sys:dbg-restore
+syn keyword tl_keyword contained sys:dbg-set sys:dbg-step sys:debugger sys:debugger-help
+syn keyword tl_keyword contained sys:dedup sys:dedup-labels sys:deffi-cb-expander sys:define-method
+syn keyword tl_keyword contained sys:defset-expander sys:defset-expander-simple sys:detached-run sys:dig
+syn keyword tl_keyword contained sys:disassemble-cdf sys:dlib-expr sys:do-conv sys:do-copy-obj
+syn keyword tl_keyword contained sys:do-path-test sys:do-tweak-obj sys:dump-to-tlo sys:dvbind
+syn keyword tl_keyword contained sys:dwim-del sys:dwim-set sys:dyn-size sys:each-match-expander
+syn keyword tl_keyword contained sys:each-op sys:early-peephole sys:enc-small-op sys:ensure-op-arg
+syn keyword tl_keyword contained sys:env-to-let sys:eq-comparable sys:eql-comparable sys:eval-cache-emit-warnings
+syn keyword tl_keyword contained sys:eval-err sys:expand-and sys:expand-arith-each-prod sys:expand-bind-mac-params
syn keyword tl_keyword contained sys:expand-defmacro sys:expand-defsymacro sys:expand-defun sys:expand-defvarl
-syn keyword tl_keyword contained sys:expand-dohash sys:expand-doloop sys:expand-each sys:expand-handle
-syn keyword tl_keyword contained sys:expand-params sys:expand-quasi sys:expand-quasi-args sys:expand-quasi-mods
-syn keyword tl_keyword contained sys:expand-sym-ref sys:expr sys:extract-keys sys:extract-keys-p
-syn keyword tl_keyword contained sys:fbind sys:fmt-flex sys:fmt-join sys:fmt-simple
-syn keyword tl_keyword contained sys:for-op sys:gc sys:gc-set-delta sys:get-buf-common
-syn keyword tl_keyword contained sys:get-fun-getter-setter sys:get-mb sys:get-parser sys:get-place-macro
-syn keyword tl_keyword contained sys:get-vb sys:getopts-error sys:handle-bad-syntax sys:hlet-expand
-syn keyword tl_keyword contained sys:if-to-cond sys:in6addr-condensed-text sys:is-label sys:l1-setq
-syn keyword tl_keyword contained sys:l1-val sys:lambda-apply-transform sys:lambda-short-apply-list sys:lambda-too-few-args
+syn keyword tl_keyword contained sys:expand-dohash sys:expand-doloop sys:expand-each sys:expand-each-prod
+syn keyword tl_keyword contained sys:expand-each-prod* sys:expand-handle sys:expand-lambda-match sys:expand-neg-parens
+syn keyword tl_keyword contained sys:expand-param-macro sys:expand-params sys:expand-pic sys:expand-pic-align
+syn keyword tl_keyword contained sys:expand-pic-num sys:expand-pic-num-commas sys:expand-quasi sys:expand-quasi-args
+syn keyword tl_keyword contained sys:expand-quasi-match sys:expand-quasi-mods sys:expand-sym-ref sys:expr
+syn keyword tl_keyword contained sys:fbind sys:find-parent sys:fixed-point sys:flatten-or
+syn keyword tl_keyword contained sys:fmt-flex sys:fmt-join sys:fmt-simple sys:for-op
+syn keyword tl_keyword contained sys:gc sys:gc-set-delta sys:get-buf-common sys:get-fun-getter-setter
+syn keyword tl_keyword contained sys:get-mb sys:get-param-info sys:get-place-macro sys:get-var-list
+syn keyword tl_keyword contained sys:get-vars sys:get-vb sys:getopts-error sys:glob-xstar
+syn keyword tl_keyword contained sys:handle-bad-syntax sys:handle-mutated-var-args sys:hlet-expand sys:if-to-cond
+syn keyword tl_keyword contained sys:ign-notfound sys:in6addr-condensed-text sys:inline-chain sys:inline-chain-rec
+syn keyword tl_keyword contained sys:insert-commas sys:is-label sys:l1-setq sys:l1-val
+syn keyword tl_keyword contained sys:lambda-apply-transform sys:lambda-excess-apply-list sys:lambda-short-apply-list sys:lambda-too-few-args
syn keyword tl_keyword contained sys:lambda-too-many-args sys:lbind sys:lisp1-setq sys:lisp1-value
syn keyword tl_keyword contained sys:list-builder-flets sys:list-from-vm-desc sys:load-time-lit sys:loc
-syn keyword tl_keyword contained sys:mac-env-flatten sys:make-anon-package sys:make-copy-path-opts sys:make-struct-lit
-syn keyword tl_keyword contained sys:make-struct-type sys:mark-special sys:maybe-mov sys:misleading-ref-check
-syn keyword tl_keyword contained sys:name-str sys:new-expander sys:new-type sys:null-reg
-syn keyword tl_keyword contained sys:obtain-impl sys:op-alpha-rename sys:op-ensure-rec sys:op-expand
-syn keyword tl_keyword contained sys:op-meta-p sys:op-rec-p sys:open-compile-streams sys:operand-to-exp
-syn keyword tl_keyword contained sys:operand-to-sym sys:opip-expand sys:opt-dash sys:opt-err
-syn keyword tl_keyword contained sys:parse-compound-operand sys:parse-operand sys:parser-eof sys:parser-errors
-syn keyword tl_keyword contained sys:path-access sys:path-examine sys:path-test-mode sys:path-test-type
-syn keyword tl_keyword contained sys:pl-expand sys:placelet-1 sys:print-backtrace sys:propagate-ancestor
-syn keyword tl_keyword contained sys:prune-missing-inits sys:qquote sys:quasi sys:quasilist
-syn keyword tl_keyword contained sys:r-s-let-expander sys:reg-expand-nongreedy sys:reg-optimize sys:register-opcode
-syn keyword tl_keyword contained sys:register-simple-accessor sys:repl sys:rplaca sys:rplacd
-syn keyword tl_keyword contained sys:rslotset sys:rt-defmacro sys:rt-defsymacro sys:rt-defun
-syn keyword tl_keyword contained sys:rt-defvarl sys:rt-load-for sys:rt-pprof sys:set-hash-traversal-limit
-syn keyword tl_keyword contained sys:set-macro-ancestor sys:setq sys:setqf sys:shut-rd
-syn keyword tl_keyword contained sys:shut-rdwr sys:shut-wr sys:slot-types sys:small-op-p
-syn keyword tl_keyword contained sys:small-op-to-sym sys:splice sys:static-slot-types sys:str-inaddr-net-impl
-syn keyword tl_keyword contained sys:struct-lit sys:switch sys:sym-clobber-expander sys:sym-delete-expander
+syn keyword tl_keyword contained sys:loosen sys:mac-env-flatten sys:make-anon-package sys:make-command-env
+syn keyword tl_keyword contained sys:make-copy-path-opts sys:make-struct-lit sys:make-struct-type sys:mark-special
+syn keyword tl_keyword contained sys:match-case-to-casequal sys:match-pat-error sys:maybe-mov sys:meth-lambda
+syn keyword tl_keyword contained sys:misleading-ref-check sys:name-str sys:new-expander sys:new-type
+syn keyword tl_keyword contained sys:no-dvbind-eval sys:non-triv-pat-p sys:null-reg sys:obtain-impl
+syn keyword tl_keyword contained sys:op-alpha-rename sys:op-ensure-rec sys:op-expand sys:op-meta-p
+syn keyword tl_keyword contained sys:op-rec-p sys:open-compile-streams sys:open-url sys:operand-to-exp
+syn keyword tl_keyword contained sys:operand-to-sym sys:opip-expand sys:opip-let-p sys:opip-single-let-p
+syn keyword tl_keyword contained sys:opt-controlled-diag sys:opt-dash sys:opt-err sys:orig-form
+syn keyword tl_keyword contained sys:os-symbol sys:param-check sys:parse-compound-operand sys:parse-lambda-match-clause
+syn keyword tl_keyword contained sys:parse-operand sys:pat-len sys:path-access sys:path-examine
+syn keyword tl_keyword contained sys:path-simplify sys:path-split sys:path-test-mode sys:path-test-type
+syn keyword tl_keyword contained sys:path-volume sys:pic-join-opt sys:placelet-1 sys:print-backtrace
+syn keyword tl_keyword contained sys:propagate-ancestor sys:propagate-perms sys:prune-missing-inits sys:put-objects
+syn keyword tl_keyword contained sys:qquote sys:quasi sys:quasilist sys:r-s-let-expander
+syn keyword tl_keyword contained sys:reduce-constant sys:reduce-lisp sys:reduce-or sys:reg-expand-nongreedy
+syn keyword tl_keyword contained sys:register-opcode sys:register-simple-accessor sys:repl sys:rewrite
+syn keyword tl_keyword contained sys:rewrite-case sys:rplaca sys:rplacd sys:rslotset
+syn keyword tl_keyword contained sys:rt-assert-fail sys:rt-defmacro sys:rt-defsymacro sys:rt-defun
+syn keyword tl_keyword contained sys:rt-defv sys:rt-defvarl sys:rt-load-for sys:rt-pprof
+syn keyword tl_keyword contained sys:rt-progv sys:rt-setjmp sys:safe-abs-path sys:safe-const-eval
+syn keyword tl_keyword contained sys:safe-const-reduce sys:safe-constantp sys:set-hash-traversal-limit sys:set-macro-ancestor
+syn keyword tl_keyword contained sys:set-symbol-value sys:setq sys:setqf sys:simplify-or
+syn keyword tl_keyword contained sys:simplify-variadic-lambda sys:slot-types sys:small-op-p sys:small-op-to-sym
+syn keyword tl_keyword contained sys:splice sys:static-slot-types sys:str-inaddr-net-impl sys:struct-lit
+syn keyword tl_keyword contained sys:subst-preserve sys:switch sys:sym-clobber-expander sys:sym-delete-expander
syn keyword tl_keyword contained sys:sym-update-expander sys:system-symbol-p sys:top-fb sys:top-mb
syn keyword tl_keyword contained sys:top-vb sys:tr* sys:trace sys:trace-canonicalize-name
-syn keyword tl_keyword contained sys:trace-enter sys:trace-leave sys:trace-redefine-check sys:tree-construct
-syn keyword tl_keyword contained sys:trfm sys:try-load sys:txr-case-impl sys:unquote
-syn keyword tl_keyword contained sys:untrace sys:upenv sys:uw-block sys:uw-captured-block
-syn keyword tl_keyword contained sys:uw-catch sys:uw-cont-copy sys:uw-eval sys:uw-expand
-syn keyword tl_keyword contained sys:uw-fcall sys:uw-guard sys:uw-handle sys:uw-menv
-syn keyword tl_keyword contained sys:var sys:vm-closure-desc sys:vm-closure-entry sys:vm-desc-bytecode
-syn keyword tl_keyword contained sys:vm-desc-datavec sys:vm-desc-nlevels sys:vm-desc-nregs sys:vm-desc-symvec
-syn keyword tl_keyword contained sys:vm-execute-toplevel sys:vm-make-desc sys:wdwrap sys:with-dyn-lib-check
+syn keyword tl_keyword contained sys:trace-enter sys:trace-leave sys:trace-redefine-check sys:transform-qquote
+syn keyword tl_keyword contained sys:translate-hash-bang sys:tree-construct sys:trfm sys:true-const-p
+syn keyword tl_keyword contained sys:txr-case-impl sys:typecase-expander sys:unquote sys:untrace
+syn keyword tl_keyword contained sys:upenv sys:uw-block sys:uw-captured-block sys:uw-catch
+syn keyword tl_keyword contained sys:uw-cont-copy sys:uw-eval sys:uw-expand sys:uw-fcall
+syn keyword tl_keyword contained sys:uw-guard sys:uw-handle sys:uw-menv sys:var
+syn keyword tl_keyword contained sys:var-pat-p sys:vars-check sys:vm-closure-desc sys:vm-closure-entry
+syn keyword tl_keyword contained sys:vm-desc-bytecode sys:vm-desc-datavec sys:vm-desc-nlevels sys:vm-desc-nregs
+syn keyword tl_keyword contained sys:vm-desc-symvec sys:vm-execute-toplevel sys:vm-make-desc sys:wdwrap
+syn keyword tl_keyword contained sys:when-exprs-match sys:when-opt sys:with-disabled-debugging sys:with-dyn-lib-check
syn keyword tl_keyword contained syslog system-package t tab0
syn keyword tl_keyword contained tab1 tab2 tab3 tabdly
syn keyword tl_keyword contained tagbody tailp take take-until
-syn keyword tl_keyword contained take-while tan tanh tb
-syn keyword tl_keyword contained tc tcdrain tcflow tcflush
-syn keyword tl_keyword contained tcgetattr tciflush tcioff tcioflush
-syn keyword tl_keyword contained tcion tcoflush tcooff tcoon
-syn keyword tl_keyword contained tcsadrain tcsaflush tcsanow tcsendbreak
-syn keyword tl_keyword contained tcsetattr tentative-def-exists tenth test-clear
-syn keyword tl_keyword contained test-clear-dirty test-dec test-dirty test-inc
-syn keyword tl_keyword contained test-neq-set-indent-mode test-set test-set-indent-mode tf
-syn keyword tl_keyword contained third throw throwf time
-syn keyword tl_keyword contained time-fields-local time-fields-utc time-parse time-parse-local
-syn keyword tl_keyword contained time-parse-utc time-string-local time-string-utc time-struct-local
-syn keyword tl_keyword contained time-struct-utc time-t time-usec tnode
+syn keyword tl_keyword contained take-while tan tanh tap
+syn keyword tl_keyword contained tb tc tcdrain tcflow
+syn keyword tl_keyword contained tcflush tcgetattr tciflush tcioff
+syn keyword tl_keyword contained tcioflush tcion tcoflush tcooff
+syn keyword tl_keyword contained tcoon tcp-nodelay tcsadrain tcsaflush
+syn keyword tl_keyword contained tcsanow tcsendbreak tcsetattr tentative-def-exists
+syn keyword tl_keyword contained tenth test-clear test-clear-dirty test-dec
+syn keyword tl_keyword contained test-dirty test-inc test-neq-set-indent-mode test-set
+syn keyword tl_keyword contained test-set-indent-mode tf tgamma third
+syn keyword tl_keyword contained throw throwf time time-fields-local
+syn keyword tl_keyword contained time-fields-utc time-nsec time-parse time-parse-local
+syn keyword tl_keyword contained time-parse-utc time-str-local time-str-utc time-string-local
+syn keyword tl_keyword contained time-string-utc time-struct-local time-struct-utc time-t
+syn keyword tl_keyword contained time-usec tmpfile tnode tnodep
syn keyword tl_keyword contained to tofloat tofloatz toint
-syn keyword tl_keyword contained tointz tok tok-str tok-where
-syn keyword tl_keyword contained tostop tostring tostringp tprint
-syn keyword tl_keyword contained trace transpose tree tree-begin
-syn keyword tl_keyword contained tree-bind tree-case tree-clear tree-delete
-syn keyword tl_keyword contained tree-delete-node tree-find tree-insert tree-insert-node
-syn keyword tl_keyword contained tree-lookup tree-lookup-node tree-next tree-root
-syn keyword tl_keyword contained treep trie-add trie-compress trie-lookup-begin
-syn keyword tl_keyword contained trie-lookup-feed-char trie-value-at trim-str true
+syn keyword tl_keyword contained tointz tojson tok tok-str
+syn keyword tl_keyword contained tok-where tokn tostop tostring
+syn keyword tl_keyword contained tostringp touch tprint trace
+syn keyword tl_keyword contained transpose tree tree-begin tree-bind
+syn keyword tl_keyword contained tree-case tree-clear tree-count tree-del-min
+syn keyword tl_keyword contained tree-del-min-node tree-delete tree-delete-node tree-delete-specific-node
+syn keyword tl_keyword contained tree-find tree-insert tree-insert-node tree-lookup
+syn keyword tl_keyword contained tree-lookup-node tree-min tree-min-node tree-next
+syn keyword tl_keyword contained tree-peek tree-reset tree-root treep
+syn keyword tl_keyword contained trie-add trie-compress trie-lookup-begin trie-lookup-feed-char
+syn keyword tl_keyword contained trie-value-at trim-left trim-long-suffix trim-path-seps
+syn keyword tl_keyword contained trim-right trim-short-suffix trim-str true
syn keyword tl_keyword contained trunc trunc-rem truncate-stream tuples
-syn keyword tl_keyword contained txr-case txr-exe-path txr-if txr-path
-syn keyword tl_keyword contained txr-version txr-when typecase typedef
-syn keyword tl_keyword contained typeof typep ubit uchar
-syn keyword tl_keyword contained uid-t uint uint-buf uint-carray
-syn keyword tl_keyword contained uint-ptr-t uint16 uint32 uint64
-syn keyword tl_keyword contained uint8 ulong ulonglong umask
-syn keyword tl_keyword contained umeth umethod uname unget-byte
-syn keyword tl_keyword contained unget-char uni unintern union
-syn keyword tl_keyword contained union-get union-in union-members union-out
-syn keyword tl_keyword contained union-put uniq unique unless
-syn keyword tl_keyword contained unquote unsetenv until until*
-syn keyword tl_keyword contained untrace unuse-package unuse-sym unwind-protect
-syn keyword tl_keyword contained upcase-str upd update uref
-syn keyword tl_keyword contained url-decode url-encode use use-package
-syn keyword tl_keyword contained use-sym user-package ushort usl
+syn keyword tl_keyword contained tuples* txr-case txr-exe-path txr-if
+syn keyword tl_keyword contained txr-parse txr-path txr-version txr-when
+syn keyword tl_keyword contained typecase typedef typeof typep
+syn keyword tl_keyword contained ubit uchar uid-t uint
+syn keyword tl_keyword contained uint-buf uint-carray uint-ptr-t uint16
+syn keyword tl_keyword contained uint32 uint64 uint8 uintmax-t
+syn keyword tl_keyword contained ulong ulonglong umask umeth
+syn keyword tl_keyword contained umethod uname unget-byte unget-char
+syn keyword tl_keyword contained uni unintern union union-get
+syn keyword tl_keyword contained union-in union-members union-out union-put
+syn keyword tl_keyword contained uniq unique unless unquote
+syn keyword tl_keyword contained unsetenv until until* untrace
+syn keyword tl_keyword contained unuse-package unuse-sym unwind-protect upcase-str
+syn keyword tl_keyword contained upd update uref url-decode
+syn keyword tl_keyword contained url-encode use use-package use-sym
+syn keyword tl_keyword contained use-sym-as user-package ushort usl
syn keyword tl_keyword contained usleep uslot utimes val
syn keyword tl_keyword contained vdiscard vec vec-carray vec-list
-syn keyword tl_keyword contained vec-push vec-set-length vecref vector
-syn keyword tl_keyword contained vector-list vectorp veof veol
-syn keyword tl_keyword contained veol2 verase vintr vkill
-syn keyword tl_keyword contained vlnext vm-fun-p vmin void
-syn keyword tl_keyword contained vquit vreprint vstart vstop
-syn keyword tl_keyword contained vsusp vswtc vt0 vt1
-syn keyword tl_keyword contained vtdly vtime vwerase w-continued
-syn keyword tl_keyword contained w-coredump w-exitstatus w-ifcontinued w-ifexited
-syn keyword tl_keyword contained w-ifsignaled w-ifstopped w-nohang w-stopsig
-syn keyword tl_keyword contained w-termsig w-untraced wait wchar
-syn keyword tl_keyword contained weave when whena whenlet
-syn keyword tl_keyword contained where while while* whilet
-syn keyword tl_keyword contained width width-check window-map window-mapdo
-syn keyword tl_keyword contained window-mappend wint-t with-clobber-expander with-compilation-unit
-syn keyword tl_keyword contained with-delete-expander with-dyn-lib with-gensyms with-hash-iter
-syn keyword tl_keyword contained with-in-buf-stream with-in-string-byte-stream with-in-string-stream with-objects
-syn keyword tl_keyword contained with-out-buf-stream with-out-string-stream with-out-strlist-stream with-resources
-syn keyword tl_keyword contained with-slots with-stream with-update-expander wrap
-syn keyword tl_keyword contained wrap* wstr wstr-d xcase
-syn keyword tl_keyword contained yield yield-from zap zarray
-syn keyword tl_keyword contained zchar zero-fill zerop zip
-syn keyword tl_keyword contained znew
+syn keyword tl_keyword contained vec-push vec-seq vec-set-length vecref
+syn keyword tl_keyword contained vector vector-list vectorp veof
+syn keyword tl_keyword contained veol veol2 verase vintr
+syn keyword tl_keyword contained vkill vlnext vm-fun-p vmin
+syn keyword tl_keyword contained void vquit vreprint vstart
+syn keyword tl_keyword contained vstop vsusp vswtc vt0
+syn keyword tl_keyword contained vt1 vtdly vtime vwerase
+syn keyword tl_keyword contained w-continued w-coredump w-exitstatus w-ifcontinued
+syn keyword tl_keyword contained w-ifexited w-ifsignaled w-ifstopped w-nohang
+syn keyword tl_keyword contained w-stopsig w-termsig w-untraced wait
+syn keyword tl_keyword contained wchar weave when when-match
+syn keyword tl_keyword contained whena whenlet where while
+syn keyword tl_keyword contained while* while-match while-match-case while-true-match-case
+syn keyword tl_keyword contained whilet width width-check window-map
+syn keyword tl_keyword contained window-mapdo window-mappend wint-t with-clobber-expander
+syn keyword tl_keyword contained with-compilation-unit with-compile-opts with-delete-expander with-dyn-lib
+syn keyword tl_keyword contained with-gensyms with-hash-iter with-in-buf-stream with-in-string-byte-stream
+syn keyword tl_keyword contained with-in-string-stream with-objects with-out-buf-stream with-out-string-stream
+syn keyword tl_keyword contained with-out-strlist-stream with-resources with-slots with-stream
+syn keyword tl_keyword contained with-update-expander wrap wrap* wstr
+syn keyword tl_keyword contained wstr-d wstr-s xcase y0
+syn keyword tl_keyword contained y1 yield yield-from yn
+syn keyword tl_keyword contained zap zarray zchar zero-fill
+syn keyword tl_keyword contained zerop zip znew
syn keyword txr_keyword contained accept all and assert
syn keyword txr_keyword contained bind block call cases
@@ -621,31 +764,33 @@ syn keyword txr_keyword contained freeform fuzz gather if
syn keyword txr_keyword contained include last line load
syn keyword txr_keyword contained local maybe merge mod
syn keyword txr_keyword contained modlast name next none
-syn keyword txr_keyword contained or output rebind rep
-syn keyword txr_keyword contained repeat require set single
-syn keyword txr_keyword contained skip some text throw
-syn keyword txr_keyword contained trailer try until var
-syn match txr_error "\(@[ \t]*\)[*]\?[\t ]*."
-syn match txr_atat "\(@[ \t]*\)@"
-syn match txr_comment "\(@[ \t]*\)[#;].*"
-syn match txr_contin "\(@[ \t]*\)\\$"
-syn match txr_char "\(@[ \t]*\)\\."
-syn match txr_error "\(@[ \t]*\)\\[xo]"
-syn match txr_char "\(@[ \t]*\)\\x[0-9A-Fa-f]\+;\?"
-syn match txr_char "\(@[ \t]*\)\\[0-7]\+;\?"
-syn match txr_regdir "\(@[ \t]*\)/\(\\/\|[^/]\|\\\n\)*/"
+syn keyword txr_keyword contained or output push rebind
+syn keyword txr_keyword contained rep repeat require set
+syn keyword txr_keyword contained single skip some text
+syn keyword txr_keyword contained throw trailer try until
+syn keyword txr_keyword contained var
+syn match txr_at "\(@[ \t]*\)" nextgroup=txr_error,txr_atat,txr_comment,txr_contin,txr_char,txr_error,txr_char,txr_regdir,txr_variable,txr_splicevar,txr_metanum,txr_directive,txr_bracevar,txr_bracket
+syn match txr_error "[*]\?[\t ]*." contained
+syn match txr_atat "@" contained
+syn match txr_comment "[#;].*" contained
+syn match txr_contin "\\$" contained
+syn match txr_char "\\." contained
+syn match txr_error "\\[xo]" contained
+syn match txr_char "\\x[0-9A-Fa-f]\+;\?" contained
+syn match txr_char "\\[0-7]\+;\?" contained
+syn match txr_regdir "/\(\\/\|[^/]\|\\\n\)*/" contained
syn match txr_nested_error "[^\t ]\+" contained
-syn match txr_variable "\(@[ \t]*\)[*]\?[ \t]*[A-Za-z_][A-Za-z_0-9]*"
-syn match txr_splicevar "@[ \t,*@]*[A-Za-z_][A-Za-z_0-9]*" contained
-syn match txr_metanum "@\+[0-9]\+" contained
+syn match txr_variable "[*]\?[ \t]*[A-Za-z_][A-Za-z_0-9]*" contained
+syn match txr_splicevar "[ \t,*@]*[A-Za-z_][A-Za-z_0-9]*" contained
+syn match txr_metanum "\(@[ \t]*\)\+[0-9]\+" contained
syn match txr_badesc "\\." contained
syn match txr_escat "\\@" contained
-syn match txr_stresc "\\[abtnvfre\\ \n"`']" contained
+syn match txr_stresc "\\[abtnvfre\\ "`']" contained
syn match txr_numesc "\\x[0-9A-Fa-f]\+;\?" contained
syn match txr_numesc "\\[0-7]\+;\?" contained
-syn match txr_regesc "\\[abtnvfre\\ \n/sSdDwW()\|.*?+~&%\[\]\-]" contained
+syn match txr_regesc "\\[abtnvfre\\ /sSdDwW()\|.*?+~&%\[\]\-]" contained
-syn match txr_error "#[^HSR]" contained
+syn match tl_error "#[^HSRTN]" contained
syn match txr_chr "#\\x[0-9A-Fa-f]\+" contained
syn match txr_chr "#\\o[0-7]\+" contained
@@ -655,20 +800,21 @@ syn match txr_ncomment ";.*" contained
syn match txr_hashbang "\%^#!.*"
+syn match txr_qat "\(@[ \t]*\)" nextgroup=txr_splicevar,txr_metanum,txr_qbracevar,txr_list,txr_bracket,txr_escat,txr_stresc,txr_numesc,txr_badesc contained
syn match txr_dot "\." contained
syn match txr_ident "[A-Za-z_0-9!$%&*+\-<=>?\\_~]*[A-Za-z_!$%&*+\-<=>?\\_~^][A-Za-z_0-9!$%&*+\-<=>?\\_~^]*" contained
-syn match tl_ident "[:@][A-Za-z_0-9!$%&*+\-<=>?\\_~^/]\+" contained
-syn match txr_braced_ident "[:][A-Za-z_0-9!$%&*+\-<=>?\\_~^/]\+" contained
-syn match tl_ident "[A-Za-z_0-9!$%&*+\-<=>?\\_~/]\+[A-Za-z_0-9!$%&*+\-<=>?\\_~^/#]*" contained
-syn match txr_pnum "#[xob][+\-]\?[A-Za-z_0-9]\+" contains=txr_xnum,txr_bnum,txr_onum contained
-syn match txr_xnum "#x[+\-]\?[0-9A-Fa-f]\+" containedin=txr_pnum contained
-syn match txr_onum "#o[+\-]\?[0-7]\+" containedin=txr_pnum contained
-syn match txr_bnum "#b[+\-]\?[01]\+" containedin=txr_pnum contained
-syn match txr_num "[+\-]\?[0-9]\+\([^A-Za-z_0-9!$%&*+\-<=>?\\_~^/#]\|\n\)"me=e-1 contained
-syn match txr_badnum "[+\-]\?[0-9]*[.][0-9]\+\([eE][+\-]\?[0-9]\+\)\?[A-Za-z_!$%&*+\-<=>?\\_~^/#]\+" contained
-syn match txr_num "[+\-]\?[0-9]*[.][0-9]\+\([eE][+\-]\?[0-9]\+\)\?\([^A-Za-z_0-9!$%&*+\-<=>?\\_~^/#]\|\n\)"me=e-1 contained
-syn match txr_num "[+\-]\?[0-9]\+\([eE][+\-]\?[0-9]\+\)\([^A-Za-z_0-9!$%&*+\-<=>?\\_~^/#]\|\n\)"me=e-1 contained
-syn match tl_ident ":" contained
+syn match txr_braced_ident "\(#\?:\)\?[[A-Za-z_0-9!$%&*+\-<=>?\\_~^/]\+" contained
+syn match tl_ident "\(#\?:\)\?[A-Za-z_0-9!$%&*+\-<=>?\\_~/]\+[A-Za-z_0-9!$%&*+\-<=>?\\_~^/#]*" contained
+syn match txr_pnum "#[xob][+\-]\?[A-Za-z_0-9,]\+" contains=txr_xnum,txr_bnum,txr_onum contained
+syn match txr_xnum "#x[+\-]\?\([0-9A-Fa-f][,0-9A-Fa-f]*[0-9A-Fa-f]\|[0-9A-Fa-f]\)" containedin=txr_pnum contained
+syn match txr_onum "#o[+\-]\?\([0-7][,0-7]*[0-7]\|[0-7]\)" containedin=txr_pnum contained
+syn match txr_bnum "#b[+\-]\?\([01][,01]*[01]\|[01]\)" containedin=txr_pnum contained
+syn match txr_num "[+\-]\?\([0-9][,0-9]*[0-9]\|[0-9]\)" contained
+syn match txr_num "[+\-]\?\([0-9][,0-9]*[0-9]\|[0-9]\)\?[.]\([0-9][,0-9]*[0-9]\|[0-9]\)\([eE][+\-]\?[0-9]\+\)\?" contained
+syn match txr_num "[+\-]\?\([0-9][,0-9]*[0-9]\|[0-9]\)[.]\?\([eE][+\-]\?[0-9]\+\)" contained
+syn match txr_badnum "[+\-]\?\([0-9][,0-9]*[0-9]\|[0-9]\)\?[.]\([0-9][,0-9]*[0-9]\|[0-9]\)\([A-DF-Za-dfz_!$%&*+\-<=>?\\_~^/#]\|[eE][^+\-0-9]\|[eE][+/-]\?$\|[eE][+\-][^0-9]\)" contained
+syn match txr_badnum "[+\-]\?\([0-9][,0-9]*[0-9]\|[0-9]\)[.]\?\([A-DF-Za-dfz_!$%&*+\-<=>?\\_~^/#]\|[eE][^+\-0-9]\|[eE][+/-]\?$\|[eE][+\-][^0-9]\)" contained
+syn match tl_ident "#\?:" contained
syn match tl_splice "[ \t,]\|,[*]" contained
syn match txr_unquote "," contained
@@ -677,30 +823,53 @@ syn match txr_quote "'" contained
syn match txr_quote "\^" contained
syn match txr_dotdot "\.\." contained
syn match txr_metaat "@" contained
-syn match txr_circ "#[0-9]\+[#=]"
syn match txr_buf_error "[^']" contained
syn match txr_buf_interior "\([0-9A-Fa-f][\n\t ]*[0-9A-Fa-f]\|[\n\t ]\+\)" contained
-syn region txr_bracevar matchgroup=Delimiter start="@[ \t]*[*]\?{" matchgroup=Delimiter end="}" contains=txr_num,txr_pnum,tl_ident,tl_splice,tl_metanum,txr_metaat,txr_circ,txr_braced_ident,txr_dot,txr_dotdot,txr_string,txr_list,txr_bracket,txr_mlist,txr_mbracket,txr_regex,txr_quasilit,txr_chr,txr_nested_error
-syn region txr_directive matchgroup=Delimiter start="@[ \t]*(" matchgroup=Delimiter end=")" contains=txr_keyword,txr_string,txr_list,txr_bracket,txr_mlist,txr_mbracket,txr_quasilit,txr_num,txr_pnum,txr_badnum,tl_ident,tl_regex,txr_string,txr_chr,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_ncomment,txr_nested_error
-syn region txr_list contained matchgroup=Delimiter start="\(#[HSR]\?\)\?(" matchgroup=Delimiter end=")" contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign_par,txr_ign_bkt,txr_list,txr_bracket,txr_mlist,txr_mbracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_ncomment,txr_nested_error
-syn region txr_bracket contained matchgroup=Delimiter start="\[" matchgroup=Delimiter end="\]" contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign_par,txr_ign_bkt,txr_list,txr_bracket,txr_mlist,txr_mbracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_ncomment,txr_nested_error
-syn region txr_mlist contained matchgroup=Delimiter start="@[ \t^',]*(" matchgroup=Delimiter end=")" contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign_par,txr_ign_bkt,txr_list,txr_bracket,txr_mlist,txr_mbracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_ncomment,txr_nested_error
-syn region txr_mbracket matchgroup=Delimiter start="@[ \t^',]*\[" matchgroup=Delimiter end="\]" contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign_par,txr_ign_bkt,txr_list,txr_bracket,txr_mlist,txr_mbracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_ncomment,txr_nested_error
-syn region txr_string contained start=+#\?\*\?"+ end=+["\n]+ contains=txr_stresc,txr_numesc,txr_badesc
-syn region txr_quasilit contained start=+#\?\*\?`+ end=+[`\n]+ contains=txr_splicevar,txr_metanum,txr_bracevar,txr_mlist,txr_mbracket,txr_escat,txr_stresc,txr_numesc,txr_badesc
-syn region txr_regex contained start="/" end="[/\n]" contains=txr_regesc,txr_numesc,txr_badesc
-syn region tl_regex contained start="#/" end="[/\n]" contains=txr_regesc,txr_numesc,txr_badesc
+syn region txr_bracevar contained matchgroup=Delimiter start="[*]\?{" matchgroup=Delimiter end="}" contains=txr_num,txr_pnum,tl_ident,tl_splice,tl_metanum,txr_metaat,txr_circ,txr_braced_ident,txr_dot,txr_dotdot,txr_string,txr_list,txr_bracket,txr_regex,tl_regex,txr_quasilit,txr_chr,txr_nested_error
+syn region txr_qbracevar contained matchgroup=Delimiter start="[*]\?{" matchgroup=Delimiter end="}" contains=txr_num,txr_pnum,tl_ident,tl_splice,tl_metanum,txr_metaat,txr_circ,txr_braced_ident,txr_dot,txr_dotdot,txr_string,txr_list,txr_bracket,txr_regex,tl_regex,txr_quasilit,txr_chr,txr_nested_error
+syn region txr_directive contained matchgroup=Delimiter start="(" matchgroup=Delimiter end=")" contains=txr_keyword,txr_string,txr_list,txr_bracket,txr_quasilit,txr_num,txr_pnum,txr_badnum,tl_ident,tl_regex,txr_string,txr_chr,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_ncomment,txr_nested_error
+syn region txr_list contained matchgroup=Delimiter start="\(#[HSRTN]\?\)\?(" matchgroup=Delimiter end=")" contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign,txr_ign_json,txr_list,txr_bracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_jhash,txr_jarray,txr_jatom,txr_ncomment,tl_error,txr_nested_error
+syn region txr_bracket contained matchgroup=Delimiter start="\[" matchgroup=Delimiter end="\]" contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign,txr_ign_json,txr_list,txr_bracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_jhash,txr_jarray,txr_jatom,txr_ncomment,tl_error,txr_nested_error
+syn region txr_string contained start=+#\?\*\?"+ skip=+\\\n+ end=+["\n]+ contains=txr_stresc,txr_numesc,txr_badesc
+syn region txr_quasilit contained start=+#\?\*\?`+ skip=+\\\n+ end=+[`\n]+ contains=txr_qat,txr_stresc,txr_numesc,txr_badesc
+syn region txr_regex contained start="/" skip=+\\\n+ end="[/\n]" contains=txr_regesc,txr_numesc,txr_badesc
+syn region tl_regex contained start="#/" skip=+\\\n+ end="[/\n]" contains=txr_regesc,txr_numesc,txr_badesc
syn region txr_buf contained matchgroup=txr_buf start="#b'" end="'" contains=txr_buf_interior,txr_buf_error
-syn region txr_ign_par contained matchgroup=Comment start="#;[ \t',]*\(#[HSR]\?\)\?(" matchgroup=Comment end=")" contains=txr_ign_par_interior,txr_ign_bkt_interior
-syn region txr_ign_bkt contained matchgroup=Comment start="#;[ \t',]*\(#[HSR]\?\)\?\[" matchgroup=Comment end="\]" contains=txr_ign_par_interior,txr_ign_bkt_interior
-syn region txr_ign_par_interior contained matchgroup=Comment start="(" matchgroup=Comment end=")" contains=txr_ign_par_interior,txr_ign_bkt_interior
-syn region txr_ign_bkt_interior contained matchgroup=Comment start="\[" matchgroup=Comment end="\]" contains=txr_ign_par_interior,txr_ign_bkt_interior
+syn region txr_ign contained matchgroup=Comment start="#;" end="[ \(\)\[\]]"me=e contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign,txr_ign_json,txr_list,txr_bracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_jhash,txr_jarray,txr_jatom,txr_ncomment,tl_error,txr_nested_error
+syn region txr_ign contained matchgroup=Comment start="#;[ \t',^@]*\(#[HSRTN]\?\)\?(" matchgroup=Comment end=")" contains=txr_ign_interior
+syn region txr_ign contained matchgroup=Comment start="#;[ \t',^@]*\(#[HSRTNJ]\?\)\?\[" matchgroup=Comment end="\]" contains=txr_ign_interior
+syn region txr_ign_json contained matchgroup=Comment start="#;[ \t',^@]*#J[~^]*{" matchgroup=Comment end="}" contains=txr_ign_interior
+syn region txr_ign_json contained matchgroup=Comment start="#;[ \t',^@]*#J[~^]*\[" matchgroup=Comment end="\]" contains=txr_ign_interior
+syn region txr_ign_json contained matchgroup=Comment start="#;[ \t',^@]*#J[~^]*(" matchgroup=Comment end=")" contains=txr_ign_interior
+syn region txr_ign_interior contained matchgroup=Comment start="(" matchgroup=Comment end=")" contains=txr_ign_interior
+syn region txr_ign_interior contained matchgroup=Comment start="\[" matchgroup=Comment end="\]" contains=txr_ign_interior
+syn region txr_ign_interior contained matchgroup=Comment start="{" matchgroup=Comment end="}" contains=txr_ign_interior
+
+syn match txr_jerr "." contained
+syn match txr_jpunc "[,: \t\n]" contained
+syn match txr_jesc "\\[bfnrt"\\/]" contained
+syn match txr_juesc "\\u[0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f]" contained
+syn match txr_jnum "-\?\(0\|[1-9][0-9]*\)\([.][0-9]\+\)\?\([Ee][+-]\?[0-9]\+\)\?" contained
+syn match txr_jkeyword "true\|false\|null" contained
+
+syn region txr_jatom contained matchgroup=Delimiter start="#J\^\?[\t\n ]*"rs=e end="[\t\n ]\|[\])}]"re=e-1 contains=txr_jarray_in,txr_jhash_in,txr_jkeyword,txr_jstring,txr_jnum,txr_jpunc,txr_junqlist,txr_junqbkt,txr_junqtok,txr_circ,txr_jerr
+syn region txr_junqtok contained matchgroup=Delimiter start="\~" end="[ \(\)\[\]{}]"re=s contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign,txr_ign_json,txr_list,txr_bracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_jhash,txr_jarray,txr_jatom,txr_ncomment,tl_error,txr_nested_error
+syn region txr_junqlist contained matchgroup=Delimiter start="\~\*\?#\?(" end=")" contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign,txr_ign_json,txr_list,txr_bracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_jhash,txr_jarray,txr_jatom,txr_ncomment,tl_error,txr_nested_error
+syn region txr_junqbkt contained matchgroup=Delimiter start="\~\*\?\[" end="\]" contains=tl_keyword,txr_string,tl_regex,txr_num,txr_pnum,txr_badnum,tl_ident,txr_metanum,txr_ign,txr_ign_json,txr_list,txr_bracket,txr_quasilit,txr_chr,txr_buf,txr_quote,txr_unquote,txr_splice,txr_dot,txr_dotdot,txr_metaat,txr_circ,txr_jhash,txr_jarray,txr_jatom,txr_ncomment,tl_error,txr_nested_error
+syn region txr_jstring contained matchgroup=Delimiter start=+"+ end=+["\n]+ contains=txr_jesc,txr_juesc,txr_badesc
+syn region txr_jarray contained matchgroup=Delimiter start="#J\^\?[\t\n ]*\[" matchgroup=Delimiter end="\]" contains=txr_jarray_in,txr_jhash_in,txr_jkeyword,txr_jstring,txr_jnum,txr_jpunc,txr_junqlist,txr_junqbkt,txr_junqtok,txr_circ,txr_jerr
+syn region txr_jhash contained matchgroup=Delimiter start="#J\^\?[\t\n ]*{" matchgroup=Delimiter end="}" contains=txr_jarray_in,txr_jhash_in,txr_jkeyword,txr_jstring,txr_jnum,txr_jpunc,txr_junqlist,txr_junqbkt,txr_junqtok,txr_circ,txr_jerr
+syn region txr_jarray_in contained matchgroup=Delimiter start="\[" end="\]" contains=txr_jarray_in,txr_jhash_in,txr_jkeyword,txr_jstring,txr_jnum,txr_jpunc,txr_junqlist,txr_junqbkt,txr_junqtok,txr_circ,txr_jerr
+syn region txr_jhash_in contained matchgroup=Delimiter start="{" end="}" contains=txr_jarray_in,txr_jhash_in,txr_jkeyword,txr_jstring,txr_jnum,txr_jpunc,txr_junqlist,txr_junqbkt,txr_junqtok,txr_circ,txr_jerr
+
+syn match txr_circ "#[0-9]\+[#=]" contained
hi def link txr_at Special
hi def link txr_atstar Special
hi def link txr_atat Special
+hi def link txr_qat Special
hi def link txr_comment Comment
hi def link txr_ncomment Comment
hi def link txr_hashbang Preproc
@@ -740,16 +909,24 @@ hi def link txr_circ Special
hi def link txr_munqspl Special
hi def link tl_splice Special
hi def link txr_error Error
+hi def link tl_error Error
hi def link txr_nested_error Error
hi def link txr_buf String
hi def link txr_buf_interior String
hi def link txr_buf_error Error
-hi def link txr_ign_par Comment
-hi def link txr_ign_bkt_interior Comment
-hi def link txr_ign_par_interior Comment
-hi def link txr_ign_bkt Comment
+hi def link txr_ign_interior Comment
+hi def link txr_ign Comment
+hi def link txr_ign_json Comment
+
+hi def link txr_jkeyword Type
+hi def link txr_jnum Number
+hi def link txr_jstring String
+hi def link txr_jesc Special
+hi def link txr_juesc Special
+hi def link txr_jpunc Special
+hi def link txr_jerr Error
let b:current_syntax = "lisp"
-set lispwords=ado,alet,align,alignof,ap,append-each,append-each*,aret,array,arraysize,awk,bit,block,block*,bool,buf,buf-d,build,buildn,carray,caseq,caseq*,caseql,caseql*,casequal,casequal*,catch,catch*,catch**,collect-each,collect-each*,compare-swap,compile-only,cond,conda,condlet,cptr,dec,defex,deffi,deffi-cb,deffi-cb-unsafe,deffi-sym,deffi-type,deffi-var,define-accessor,define-modify-macro,define-option-struct,define-param-expander,define-place-macro,defmacro,defmeth,defpackage,defparm,defparml,defplace,defset,defstruct,defsymacro,defun,defvar,defvarl,del,delay,do,dohash,doloop,doloop*,dotimes,each,each*,elemsize,elemtype,enum,enumed,equot,eval-only,ffi,flet,flip,for,for*,fun,gen,go,gun,handle,handle*,handler-bind,hlet,hlet*,ido,if,ifa,iflet,ignerr,ignwarn,in-package,ip,labels,lambda,lcons,ldo,let,let*,lnew*,load-for,load-time,lop,lset,mac-param-bind,macro-time,macrolet,mlet,new*,obtain,obtain*,obtain*-block,obtain-block,offsetof,op,pdec,pinc,placelet,placelet*,pop,pprof,prof,prog,prog*,prog1,progn,ptr,ptr-in,ptr-in-d,ptr-out,ptr-out-d,ptr-out-s,push,pushnew,ret,return,return-from,rlet,rslot,sbit,sizeof,slet,splice,struct,suspend,symacrolet,sys:abscond-from,sys:awk-fun-let,sys:awk-mac-let,sys:awk-redir,sys:catch,sys:conv,sys:dlib-expr,sys:dvbind,sys:each-op,sys:expr,sys:fbind,sys:for-op,sys:l1-val,sys:lbind,sys:lisp1-value,sys:load-time-lit,sys:path-examine,sys:placelet-1,sys:splice,sys:struct-lit,sys:switch,sys:txr-case-impl,sys:unquote,sys:upenv,sys:var,tagbody,tb,tc,test-clear,test-dec,test-inc,test-set,trace,tree-bind,tree-case,txr-case,txr-if,txr-when,typecase,typedef,ubit,union,unless,unquote,until,until*,untrace,unwind-protect,upd,uref,when,whena,whenlet,while,while*,whilet,with-clobber-expander,with-compilation-unit,with-delete-expander,with-dyn-lib,with-gensyms,with-hash-iter,with-in-buf-stream,with-in-string-byte-stream,with-in-string-stream,with-objects,with-out-buf-stream,with-out-string-stream,with-out-strlist-stream,with-resources,with-slots,with-stream,with-update-expander,yield,yield-from,zap,zarray,znew,:method,:function,:init,:postinit,:fini
+set lispwords=ado,alet,align,alignof,ap,append-each,append-each*,append-each-prod,append-each-prod*,append-match-products,append-matches,aret,array,arraysize,assert,awk,bit,block,block*,bool,buf,buf-d,build,buildn,carray,caseq,caseq*,caseql,caseql*,casequal,casequal*,catch,catch*,catch**,clear-mask,close-lazy-streams,collect-each,collect-each*,collect-each-prod,collect-each-prod*,compare-swap,compile-only,compiler-let,cond,conda,condlet,cptr,dec,defex,deffi,deffi-cb,deffi-cb-unsafe,deffi-struct,deffi-sym,deffi-type,deffi-union,deffi-var,define-accessor,define-modify-macro,define-option-struct,define-param-expander,define-place-macro,define-struct-clause,define-struct-prelude,defmacro,defmatch,defmeth,defpackage,defparm,defparml,defplace,defset,defstruct,defsymacro,defun,defun-match,defvar,defvarl,del,delay,do,dohash,doloop,doloop*,dotimes,each,each*,each-false,each-match,each-match-product,each-prod,each-prod*,each-true,ecaseq,ecaseq*,ecaseql,ecaseql*,ecasequal,ecasequal*,elemsize,elemtype,ensure,enum,enumed,equot,etypecase,eval-only,expander-let,ffi,flet,flip,flow,for,for*,fun,gen,go,gun,handle,handle*,handler-bind,hlet,hlet*,ido,if,if-match,ifa,iflet,ignerr,ignwarn,in-package,ip,json,keep-match-products,keep-matches,labels,lambda,lambda-match,lcons,ldo,let,let*,lflow,lnew*,load-for,load-time,loand,lop,lopf,lopip,lset,mac-env-param-bind,mac-param-bind,macro-time,macrolet,match,match-case,match-cond,match-ecase,mlet,mul-each,mul-each*,mul-each-prod,mul-each-prod*,nand,new*,nor,obtain,obtain*,obtain*-block,obtain-block,offsetof,op,opf,pack,pdec,pic,pinc,placelet,placelet*,pop,pop-after-load,pprof,prof,prog,prog*,prog1,prog2,progn,progv,ptr,ptr-in,ptr-in-d,ptr-out,ptr-out-d,ptr-out-s,push,push-after-load,pushnew,ret,return,return-from,rlet,rslot,sbit,set-mask,setjmp,sizeof,slet,some-false,some-true,splice,struct,sum-each,sum-each*,sum-each-prod,sum-each-prod*,suspend,symacrolet,sys:abscond-from,sys:arith-each,sys:awk-fun-let,sys:awk-mac-let,sys:awk-mac-let-outer,sys:awk-redir,sys:awk-symac-let,sys:blk,sys:cached-sort-body,sys:catch,sys:conv,sys:conv-expand-sym,sys:dlib-expr,sys:dvbind,sys:each-op,sys:expr,sys:fbind,sys:fixed-point,sys:for-op,sys:ign-notfound,sys:l1-val,sys:lbind,sys:lisp1-value,sys:load-time-lit,sys:meth-lambda,sys:path-examine,sys:placelet-1,sys:rewrite-case,sys:splice,sys:struct-lit,sys:switch,sys:txr-case-impl,sys:unquote,sys:upenv,sys:var,sys:when-exprs-match,sys:when-opt,sys:with-disabled-debugging,tagbody,tap,tb,tc,test-clear,test-dec,test-inc,test-set,trace,tree-bind,tree-case,txr-case,txr-if,txr-when,typecase,typedef,ubit,union,unless,unquote,until,until*,untrace,unwind-protect,upd,uref,when,when-match,whena,whenlet,while,while*,while-match,while-match-case,while-true-match-case,whilet,with-clobber-expander,with-compilation-unit,with-compile-opts,with-delete-expander,with-dyn-lib,with-gensyms,with-hash-iter,with-in-buf-stream,with-in-string-byte-stream,with-in-string-stream,with-objects,with-out-buf-stream,with-out-string-stream,with-out-strlist-stream,with-resources,with-slots,with-stream,with-update-expander,yield,yield-from,zap,zarray,znew,:method,:function,:init,:postinit,:fini
set comments=:@\;\;\;,:@\;\;,:@\;
diff --git a/txrtags.tl b/txrtags.tl
new file mode 100755
index 00000000..8e13f120
--- /dev/null
+++ b/txrtags.tl
@@ -0,0 +1,422 @@
+#!/usr/bin/env txr
+
+(defvar *tags-lib*)
+
+;; The etags format is described here:
+;; https://git.savannah.gnu.org/cgit/emacs.git/tree/etc/ETAGS.EBNF.
+;;
+;; Unmentioned in the document is that the line number is 1-based and
+;; the byte offset 0-based.
+(defparml etag-sec-start #\x0c)
+(defparml etag-pat-end #\x7f)
+(defparml etag-name-end #\x01)
+(defparml etag-nonname-chars " \f\t\n\r()=,;'")
+
+(define-option-struct tags-opts nil
+ (nil help :bool "List this help text and exit.")
+ (o output :text "Act on the tags file named TEXT.")
+ (a append :bool "Append to existing tags file, without sorting.")
+ (m merge :bool "Merge with existing tags file, sorting combined content.")
+ (nil exclude (cumul :text) "Skip paths matching glob pattern given \ \
+ in TEXT. Multiple patterns can be specified.")
+ (e emacs :bool "Write the tags file in Emacs's etags format.")
+ (q qual :bool "Also generate struct:slot tags for each slot."))
+
+(defun escape (str)
+ (mappend (do caseql @1
+ ((#\^ #\$ #\/ #\\) (list #\\ @1))
+ (t (list @1)))
+ str))
+
+(defstruct tag ()
+ ident
+ path
+ linum
+ byte
+ line
+ (type "?")
+
+ (:postinit (me)
+ (upd me.ident tostringp))
+
+ (:method text (me)
+ `@{me.ident}\t@{me.path}\t/^@(escape me.line)$/;"\t@{me.type}`)
+
+ (:method etext (me)
+ `@{me.line}@{etag-pat-end} \
+ @{me.ident}@{etag-name-end} \
+ @{me.linum},@{me.byte}`))
+
+(defstruct file-tag tag
+ (type "F")
+ (:postinit (me)
+ (set me.ident (base-name me.path)))
+ (:method text (me)
+ `@{me.ident}\t@{me.path}\t;"\t@{me.type}`))
+
+(defstruct fun-tag tag
+ (type "f"))
+
+(defstruct var-tag tag
+ (type "v"))
+
+(defstruct struct-tag tag
+ (type "s"))
+
+(defstruct type-tag tag
+ (type "t"))
+
+(defstruct slot-tag tag
+ (type "m")
+ parent
+ expattern
+ (:method text (me)
+ `@{me.ident}\t@{me.path}\t/^@(escape me.line)$/@(if me.expattern `\x3b/@(escape me.ident)/`)\x3b"\t@{me.type}\tstruct:@{me.parent}`)
+ (:method make-qual-tag (me)
+ (if me.parent
+ (let ((qt (copy me)))
+ (set qt.ident `@{me.parent}:@{me.ident}`)
+ qt))))
+
+(defstruct orig-tag tag
+ ;; We reuse the line slot as the already-escaped ctag pattern.
+ orig-fields
+ (:method text (me)
+ `@{me.ident}\t@{me.path}\t@{me.line} \
+ @(if me.orig-fields `\t@(cat-str me.orig-fields #\tab)`)`))
+
+(defvarl err-ret (gensym))
+
+(defvar *fake-load-path*)
+
+(defun get-pos-line (lines form)
+ (tree-case (source-loc form)
+ ((line . file)
+ ;; The file-get-string function keeps carriage returns, so the byte
+ ;; offset is correct even with \r\n line separators.
+ (let ((byte (+ line ; Count the newlines.
+ -1 ; Adjust the byte offset to be 0-based.
+ [sum (take line lines) coded-length])))
+ (cons (cons line byte) [lines line])))))
+
+(defmacro in-anon-package (. body)
+ (with-gensyms (pkg)
+ ^(let* ((*package-alist* *package-alist*)
+ (,pkg (sys:make-anon-package t))
+ (*package* ,pkg))
+ (set-package-fallback-list *package* '(:usr))
+ ,*body)))
+
+(defmacro with-tag-shorthand-macro ((name-sym path-var lines-var obj-var)
+ . body)
+ ^(macrolet ((,name-sym (type ident : parent pattern-obj)
+ (with-gensyms (linum byte line)
+ ^(tree-case ,(if pattern-obj
+ ^(get-pos-line ,',lines-var ,pattern-obj)
+ ^(get-pos-line ,',lines-var ,',obj-var))
+ (((,linum . ,byte) . ,line)
+ (new ,type ident ,ident
+ path ,',path-var
+ linum ,linum
+ byte ,byte
+ line ,line
+ ,*(if parent ^(parent ,parent))
+ ,*(if pattern-obj ^(expattern t))))))))
+ ,*body))
+
+(defun process-package-influencing-form (form)
+ (caseq (car form)
+ (load (fake-load (cadr form)))
+ (load-for (each ((clause (cdr form)))
+ (tree-bind (kind sym arg) clause
+ (when (and (eq kind 'pkg)
+ (not (find-package sym)))
+ (fake-load (caddr clause))))))
+ (defpackage (make-package (symbol-name (cadr form))))))
+
+(defun fake-load (path)
+ (unless (abs-path-p path)
+ (set path (path-cat (dir-name *fake-load-path*) path))
+ (let ((*fake-load-path* path)
+ (stream (if (ends-with ".tl" path)
+ (open-file path)
+ (or (ignerr (open-file `@path.tl`))
+ (open-file path)))))
+ (whilet ((obj (read stream *stderr* err-ret path))
+ ((neq obj err-ret)))
+ (when (consp obj)
+ (process-package-influencing-form obj))))))
+
+(defun process-form (path lines obj)
+ (build
+ (with-tag-shorthand-macro (ntag path lines obj)
+ (when (consp obj)
+ (process-package-influencing-form obj)
+ (caseq (car obj)
+ ((progn eval-only compile-only with-dyn-lib macro-time)
+ (pend [mappend (op process-form path lines) (cdr obj)]))
+ ((defun defmacro define-place-macro defmatch deffi deffi-cb)
+ (add (ntag fun-tag (cadr obj))))
+ ((defvar defvarl defparm defparml defsymacro)
+ (add (ntag var-tag (cadr obj))))
+ ((defmeth)
+ (add (ntag slot-tag (caddr obj) (cadr obj))))
+ ((defplace)
+ (tree-bind (op (name . args) . body) obj
+ (add (ntag fun-tag name))))
+ ((typedef)
+ (add (ntag type-tag (cadr obj))))
+ ((defpackage)
+ (add (ntag struct-tag (cadr obj))))
+ ((define-option-struct)
+ (let ((struct-name (cadr obj)))
+ (add (ntag struct-tag struct-name))
+ (each ((obj (cdddr obj)))
+ (tree-bind (short long . rest) obj
+ (cond
+ (long (add (ntag slot-tag long struct-name)))
+ (short (add (ntag slot-tag short struct-name))))))))
+ ((defstruct deffi-struct)
+ (let ((struct-obj obj)
+ (struct-name (tree-case (cadr obj)
+ ((atom . rest) atom)
+ (atom atom))))
+ (add (ntag struct-tag struct-name))
+ (each ((obj (cdddr obj)))
+ (tree-case obj
+ ((word name . rest)
+ (caseq word
+ ((:method :function :static :instance)
+ (add (ntag slot-tag name struct-name)))
+ (t :)))
+ ((word (arg) . body)
+ (caseq word
+ ((:init :postinit :fini :postfini))
+ (t :)))
+ ((name . rest)
+ (unless (keywordp name)
+ (add (ntag slot-tag name struct-name))))
+ (name
+ (add (ntag slot-tag name struct-name struct-obj))))))))))))
+
+(defun unexpand (form)
+ (whilet ((anc (macro-ancestor form)))
+ (set form anc))
+ form)
+
+(defun process-clause (path lines clause)
+ (when (consp clause)
+ (let ((elem (car clause)))
+ (build
+ (with-tag-shorthand-macro (ntag path lines elem)
+ (when (consp elem)
+ (caseq (car elem)
+ (define (let ((args (if (eq t (cadr elem))
+ (cadddr elem)
+ (cadr elem))))
+ (add (ntag fun-tag (car args)))))
+ (bind (let ((syms (flatcar (cadr elem))))
+ (each ((sym syms))
+ (add (ntag var-tag sym)))))
+ (do (let ((forms [mapcar unexpand (cdr elem)]))
+ (each ((form forms))
+ (pend (process-form path lines form))))))))))))
+
+(defun collect-tags-tl (path)
+ (let* ((text (file-get-string path))
+ (text (if (starts-with "#!" text) `;@text` text))
+ ;; Make line numbers and byte offsets 1-based.
+ (lines (cons "" (spl #\newline text)))
+ (stream (make-string-byte-input-stream text))
+ (*rec-source-loc* t)
+ (*fake-load-path* path))
+ (build
+ (add (new file-tag
+ path path))
+ (in-anon-package
+ (whilet ((obj (read stream *stderr* err-ret path))
+ ((neq obj err-ret)))
+ (pend (process-form path lines obj)))))))
+
+(defun collect-tags-txr (path)
+ (let* ((text (file-get-string path))
+ (text (if (starts-with "#!" text) `\@;@text` text))
+ ;; Make line numbers and byte offsets 1-based.
+ (lines (cons "" (spl #\newline text)))
+ (stream (make-string-byte-input-stream text))
+ (*rec-source-loc* t)
+ (syntax (in-anon-package (txr-parse stream *stderr* nil path))))
+ (build
+ (each ((clause syntax))
+ (pend (process-clause path lines clause))))))
+
+(defun collect-tags-guess (path)
+ (with-stream (s (open-file path))
+ (iflet ((line (get-line s)))
+ (if (and (starts-with "#!" line)
+ (search-str line "txr"))
+ (if (search-str line "--lisp")
+ (collect-tags-tl path)
+ (collect-tags-txr path))
+ (progn
+ (put-line `@path: unable to determine file type` *stderr*)
+ nil)))))
+
+ (defun parse-etag-path (stream)
+ (let ((line (get-line stream)))
+ (unless line
+ (throw 'syntax-error "trailing etag section starter"))
+ (match-case line
+ (`@{path #/[^,]+/},@{size #/\d+/}` path)
+ (@otherwise
+ (throwf 'syntax-error "bad etag path line: ~s" line)))))
+
+ (defun get-etag-name (line)
+ (let ((etag-pat-end etag-pat-end)
+ (etag-name-end etag-name-end))
+ (match-case line
+ (`@pat@{etag-pat-end}@ident@{etag-name-end}@rest` ident)
+ (`@pat@{etag-pat-end}@rest`
+ (labels ((nonname-char-p (ch) (in etag-nonname-chars ch)))
+ (when (nonname-char-p [pat -1])
+ (set pat [pat 0..-1]))
+ (let ((pos [rpos-if nonname-char-p pat]))
+ (when pos (inc pos))
+ [pat pos..:])))
+ (@otherwise
+ (throwf 'syntax-error "bad etag line: ~s" line)))))
+
+ ;; Does not support include sections.
+ ;; Does not support file properties.
+ (defun read-etagfile (path)
+ (with-stream (stream (open-file path))
+ (let ((line (get-line stream)))
+ (unless line (return nil))
+ (unless (equal line (tostringp etag-sec-start))
+ (throwf 'syntax-error "bad etag section starter: ~s" line)))
+ (let ((all-tags ()))
+ (whilet ((path (parse-etag-path stream))
+ (tags ())
+ (t))
+ (whilet ((line (get-line stream))
+ (next (equal line (tostringp etag-sec-start)))
+ (t))
+ (when (or (not line) next)
+ (push (cons path tags) all-tags)
+ (if next
+ (return)
+ (return-from read-etagfile all-tags)))
+ (push (new orig-tag
+ ident (get-etag-name line)
+ orig-line line)
+ tags))))))
+
+(defun read-tagfile (path)
+ (catch (let ((lines (file-get-lines path)))
+ (collect-each ((line lines))
+ (tree-bind (ident path pat . fields) (split-str line #\tab)
+ (new orig-tag
+ ident ident
+ path path
+ line pat
+ orig-fields fields))))
+ (path-not-found (_))))
+
+(defun write-tagfile (tags o)
+ (when o.merge
+ (whenlet ((orig-tags (read-tagfile o.output)))
+ (set tags (merge tags orig-tags : .ident))))
+ (with-stream (stream (open-file o.output (if o.append "a" "w")))
+ (each ((tag tags))
+ (put-line tag.(text) stream))))
+
+(defun write-etagfile (grouped-etags o)
+ (with-stream (stream (open-file o.output (if o.append "a" "w")))
+ (each ((pair grouped-etags))
+ (tree-bind (path . etags) pair
+ (let ((str (with-out-string-stream (s)
+ (each ((etag etags))
+ (put-line etag.(etext) s)))))
+ (put-string `@{etag-sec-start}\n@{path},@(len str)\n@{str}`
+ stream))))))
+
+(defvarl ftw-actionretval 0)
+(defvarl ftw-continue 0)
+(defvarl ftw-skip-subtree 0)
+
+(defmacro static-when (expr . body)
+ (when (eval expr) ^(progn ,*body)))
+
+(compile-only
+ (unless *tags-lib*
+ (let ((o (new tags-opts)))
+ o.(getopts *args*)
+ (when o.help
+ (put-line "\nUsage:\n")
+ (put-line ` @{*load-path*} [options] {file|dir}*\n`)
+ (put-line "Directory arguments are recursively searched for .tl and .txr files.")
+ (put-line "If no arguments are given, the current directory is searched.")
+ o.(opthelp)
+ (exit t))
+
+ (unless o.out-args
+ (push "." o.out-args))
+
+ (unless (plusp (len o.output))
+ (set o.output (if o.emacs "TAGS" "tags")))
+
+ (when (and o.merge (or o.append o.emacs))
+ ;; The --merge option (without --emacs) currently results in
+ ;; duplicate tags if a file is retagged (e.g., "txr tags.tl foo.tl
+ ;; && txr tags.tl --merge foo.tl").
+ ;; We could have --merge replace all existing tags of a retagged
+ ;; file with the latest ones, with and without --emacs, but for
+ ;; now don't bother (and therefore forbid combining --emacs with
+ ;; --merge).
+ (put-line `@{*load-path*}: @(if o.append `--append` `--emacs`)\ \
+ and --merge are mutually exclusive`)
+ (exit nil))
+
+ (let* ((excf [apply orf (mapcar (do op fnmatch @@1) o.exclude)])
+ (skips ())
+ (*read-unknown-structs* t)
+ (tags (build
+ (ftw o.out-args
+ (lambda (path type stat . rest)
+ (caseql* type
+ (ftw-f (when (and (not [excf path])
+ (not [excf (base-name path)])
+ (not (some skips (op starts-with @1 path))))
+ (cond
+ ((ends-with ".tl" path)
+ (pend (ignerr (collect-tags-tl path))))
+ ((ends-with ".txr" path)
+ (pend (ignerr (collect-tags-txr path))))
+ ((member path o.out-args)
+ (pend (ignerr (collect-tags-guess path))))
+ (t ftw-continue))))
+ (ftw-d (while (and skips (starts-with path (car skips)))
+ (pop skips))
+ (cond
+ ((or [excf path] [excf (base-name path)])
+ (static-when (zerop ftw-actionretval)
+ (push `@path/` skips))
+ ftw-skip-subtree)))
+ (t ftw-continue)))
+ (logior ftw-phys ftw-actionretval)))))
+ (if o.qual
+ (set tags (build
+ (pend tags)
+ (each ((tg tags))
+ (if (typep tg 'slot-tag)
+ (iflet ((qt tg.(make-qual-tag)))
+ (add qt)))))))
+ (if o.emacs
+ (write-etagfile (flow tags
+ (remove-if (op equal @1.type "F"))
+ (nsort @1 : .linum)
+ (group-by .path)
+ (hash-alist)
+ (nsort @1 : car))
+ o)
+ (write-tagfile (nsort tags : .ident) o))))))
diff --git a/unwind.c b/unwind.c
index 0f9ffe63..4a2ba678 100644
--- a/unwind.c
+++ b/unwind.c
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stddef.h>
@@ -32,6 +33,7 @@
#include <assert.h>
#include <stdarg.h>
#include <signal.h>
+#include <errno.h>
#include "config.h"
#if HAVE_VALGRIND
#include <valgrind/memcheck.h>
@@ -46,7 +48,6 @@
#include "struct.h"
#include "cadr.h"
#include "alloca.h"
-#include "arith.h"
#include "unwind.h"
#include "debug.h"
@@ -66,15 +67,23 @@ static val args_s, form_s;
static val sys_cont_s, sys_cont_poison_s;
static val sys_cont_free_s, sys_capture_cont_s;
+val catch_frame_s;
+
static val frame_type, catch_frame_type, handle_frame_type;
+#if CONFIG_DEBUG_SUPPORT
static val fcall_frame_type, eval_frame_type, expand_frame_type;
+#endif
static val deferred_warnings, tentative_defs;
+static struct cobj_class *sys_cont_cls;
+
#if CONFIG_EXTRA_DEBUGGING
static int uw_break_on_error;
#endif
+static int reentry_count;
+
static void uw_unwind_to_exit_point(void)
{
uw_frame_t *orig_stack = uw_stack;
@@ -109,7 +118,8 @@ static void uw_unwind_to_exit_point(void)
case UW_GUARD:
if (uw_stack->gu.uw_ok)
break;
- format(std_error, lit("~a: cannot unwind across foreign stack frames\n"),
+ ++reentry_count;
+ format(top_stderr, lit("~a: cannot unwind across foreign stack frames\n"),
prog_string, nao);
abort();
default:
@@ -121,15 +131,20 @@ static void uw_unwind_to_exit_point(void)
val sym = unhandled_ex.ca.sym;
val args = unhandled_ex.ca.args;
+ gc_stack_limit = 0;
+ ++reentry_count;
+
+ dyn_env = nil;
+
if (opt_loglevel >= 1) {
- val prefix = format(nil, lit("~a:"), prog_string, nao);
+ val prefix = scat2(prog_string, lit(":"));
flush_stream(std_output);
- format(std_error, lit("~a unhandled exception of type ~a:\n"),
+ format(top_stderr, lit("~a unhandled exception of type ~a:\n"),
prefix, sym, nao);
uw_stack = orig_stack;
- error_trace(sym, args, std_error, prefix);
+ error_trace(sym, args, top_stderr, prefix);
}
if (uw_exception_subtype_p(sym, query_error_s) ||
uw_exception_subtype_p(sym, file_error_s)) {
@@ -187,6 +202,22 @@ static void uw_abscond_to_exit_point(void)
}
}
+uw_snapshot_t uw_snapshot(void)
+{
+ uw_snapshot_t snap = {
+ dyn_env, uw_stack, uw_menv_stack
+ };
+
+ return snap;
+}
+
+void uw_restore(const uw_snapshot_t *psnap)
+{
+ dyn_env = psnap->de;
+ uw_stack = psnap->stack;
+ uw_menv_stack = psnap->menv_stack;
+}
+
void uw_push_block(uw_frame_t *fr, val tag)
{
memset(fr, 0, sizeof *fr);
@@ -394,7 +425,8 @@ val uw_find_frames(val extype, val frtype)
val uw_find_frames_by_mask(val mask_in)
{
- ucnum mask = c_unum(mask_in);
+ val self = lit("find-frames-by-mask");
+ ucnum mask = c_unum(mask_in, self);
list_collect_decl (out, ptail);
uw_frame_t *fr;
@@ -420,7 +452,7 @@ val uw_find_frames_by_mask(val mask_in)
}
case UW_FCALL:
{
- struct args *frargs = fr->fc.args;
+ varg frargs = fr->fc.args;
args_decl(acopy, frargs->argc);
args_copy(acopy, frargs);
frame = allocate_struct(fcall_frame_type);
@@ -472,7 +504,7 @@ val uw_last_form_expanded(void)
#endif
-val uw_invoke_catch(val catch_frame, val sym, struct args *args)
+val uw_invoke_catch(val catch_frame, val sym, varg args)
{
uw_frame_t *ex, *ex_point;
@@ -497,14 +529,14 @@ val uw_invoke_catch(val catch_frame, val sym, struct args *args)
abort();
}
-val uw_muffle_warning(val exc, struct args *args)
+val uw_muffle_warning(val exc, varg args)
{
(void) exc;
(void) args;
- uw_throw(continue_s, nil);
+ return uw_rthrow(continue_s, nil);
}
-val uw_trace_error(val ctx, val exc, struct args *args)
+val uw_trace_error(val ctx, val exc, varg args)
{
cons_bind (stream, prefix, ctx);
error_trace(exc, args_get_list(args), stream, prefix);
@@ -512,7 +544,7 @@ val uw_trace_error(val ctx, val exc, struct args *args)
}
void uw_push_cont_copy(uw_frame_t *fr, mem_t *ptr,
- void (*copy)(mem_t *ptr, int parent))
+ void (*copy)(mem_t *ptr))
{
memset(fr, 0, sizeof *fr);
fr->cp.type = UW_CONT_COPY;
@@ -591,7 +623,7 @@ void uw_push_handler(uw_frame_t *fr, val matches, val fun)
#if CONFIG_DEBUG_SUPPORT
-void uw_push_fcall(uw_frame_t *fr, val fun, struct args *args)
+void uw_push_fcall(uw_frame_t *fr, val fun, varg args)
{
memset(fr, 0, sizeof *fr);
fr->fc.type = UW_FCALL;
@@ -635,18 +667,21 @@ val uw_exception_subtype_p(val sub, val sup)
}
}
-static void invoke_handler(uw_frame_t *fr, struct args *args)
+static void invoke_handler(uw_frame_t *fr, varg args)
{
val saved_dyn_env = dyn_env;
+ val cur_pkg_alist = deref(cur_package_alist_loc);
+ val cur_pkg = cur_package;
fr->ha.visible = 0;
uw_simple_catch_begin;
- dyn_env = make_env(nil, nil, dyn_env);
-
- env_vbind(dyn_env, package_s, fr->ha.package);
- env_vbind(dyn_env, package_alist_s, fr->ha.package_alist);
+ if (cur_pkg_alist != fr->ha.package_alist || cur_pkg != fr->ha.package) {
+ dyn_env = make_env(nil, nil, dyn_env);
+ env_vbind(dyn_env, package_s, fr->ha.package);
+ env_vbind(dyn_env, package_alist_s, fr->ha.package_alist);
+ }
generic_funcall(fr->ha.fun, args);
@@ -658,18 +693,18 @@ static void invoke_handler(uw_frame_t *fr, struct args *args)
uw_catch_end;
}
-val uw_throw(val sym, val args)
+val uw_rthrow(val sym, val args)
{
uw_frame_t *ex;
- static int reentry_count = 0;
+ val errorp = uw_exception_subtype_p(sym, error_s);
- if (++reentry_count > 1) {
+ if (++reentry_count > 1 && errorp) {
fprintf(stderr, "txr: invalid re-entry of exception handling logic\n");
abort();
}
#if CONFIG_EXTRA_DEBUGGING
- if (uw_break_on_error && uw_exception_subtype_p(sym, error_s))
+ if (uw_break_on_error && errorp)
breakpt();
#endif
@@ -705,18 +740,28 @@ val uw_throw(val sym, val args)
}
if (ex == 0) {
- if (std_error == 0) {
- fprintf(stderr, "txr: unhandled exception in early initialization\n");
- abort();
- }
-
if (uw_exception_subtype_p(sym, warning_s)) {
--reentry_count;
if (uw_exception_subtype_p(sym, defr_warning_s))
uw_defer_warning(args);
- else
- format(std_error, lit("warning: ~a\n"), car(args), nao);
+ else if (top_stderr != 0)
+ format(top_stderr, lit("~a\n"), car(args), nao);
+ if (!opt_compat || opt_compat >= 234) {
+ uw_rthrow(continue_s, nil);
+ return nil;
+ }
uw_throw(continue_s, nil);
+ }
+
+ if (!opt_compat || opt_compat >= 234) {
+ if (!errorp) {
+ --reentry_count;
+ return nil;
+ }
+ }
+
+ if (top_stderr == 0) {
+ fprintf(stderr, "txr: unhandled exception in early initialization\n");
abort();
}
@@ -730,8 +775,8 @@ val uw_throw(val sym, val args)
if (functionp(fun))
funcall3(fun, sym, args, last_form_evaled);
else
- format(std_error, lit("~a: *unhandled-hook* ~s isn't a function\n"),
- prog_string, fun, nao);
+ format(top_stderr, lit("~a: *unhandled-hook* ~s isn't a function\n"),
+ prog_string, fun, nao);
}
}
@@ -746,9 +791,23 @@ val uw_throw(val sym, val args)
abort();
}
-val uw_throwv(val sym, struct args *arglist)
+val uw_rthrowv(val sym, varg arglist)
{
- uw_throw(sym, args_get_list(arglist));
+ return uw_rthrow(sym, args_get_list(arglist));
+}
+
+val uw_rthrowfv(val sym, val fmt, varg args)
+{
+ val stream = make_string_output_stream();
+ (void) formatv(stream, fmt, args);
+ return uw_rthrow(sym, get_string_from_stream(stream));
+ abort();
+}
+
+val uw_throw(val sym, val args)
+{
+ uw_rthrow(sym, args);
+ abort();
}
val uw_throwf(val sym, val fmt, ...)
@@ -764,28 +823,21 @@ val uw_throwf(val sym, val fmt, ...)
abort();
}
-val uw_throwfv(val sym, val fmt, struct args *args)
-{
- val stream = make_string_output_stream();
- (void) formatv(stream, fmt, args);
- uw_throw(sym, get_string_from_stream(stream));
- abort();
-}
-
-val uw_errorf(val fmt, ...)
+val uw_ethrowf(val sym, val fmt, ...)
{
va_list vl;
+ val eno = num(errno);
val stream = make_string_output_stream();
va_start (vl, fmt);
(void) vformat(stream, fmt, vl);
va_end (vl);
- uw_throw(error_s, get_string_from_stream(stream));
+ uw_throw(sym, string_set_code(get_string_from_stream(stream), eno));
abort();
}
-val uw_errorfv(val fmt, struct args *args)
+val uw_errorfv(val fmt, varg args)
{
val stream = make_string_output_stream();
(void) formatv(stream, fmt, args);
@@ -799,6 +851,7 @@ val uw_warningf(val fmt, ...)
val stream = make_string_output_stream();
va_start (vl, fmt);
+ put_string(lit("warning: "), stream);
(void) vformat(stream, fmt, vl);
va_end (vl);
@@ -828,6 +881,17 @@ val type_mismatch(val fmt, ...)
abort();
}
+NORETURN void invalid_ops(val self, val obj1, val obj2)
+{
+ uw_throwf(type_error_s, lit("~a: invalid operands ~s ~s"), self,
+ obj1, obj2, nao);
+}
+
+NORETURN void invalid_op(val self, val obj)
+{
+ uw_throwf(type_error_s, lit("~a: invalid operand ~s"), self, obj, nao);
+}
+
val uw_defer_warning(val args)
{
val msg = car(args);
@@ -860,7 +924,7 @@ val uw_dump_deferred_warnings(val stream)
for (; wl; wl = cdr(wl)) {
val args = car(wl);
- format(stream, lit("warning: ~a\n"), car(args), nao);
+ format(stream, lit("~a\n"), car(args), nao);
}
return nil;
@@ -874,7 +938,7 @@ val uw_release_deferred_warnings(void)
uw_catch_begin (cons(continue_s, nil), exsym, exvals);
- uw_throw(warning_s, caar(wl));
+ uw_rthrow(warning_s, caar(wl));
uw_catch(exsym, exvals) { (void) exsym; (void) exvals; }
@@ -940,7 +1004,7 @@ val uw_register_subtype(val sub, val sup)
return sup;
}
-static val register_exception_subtypes(struct args *args)
+static val register_exception_subtypes(varg args)
{
val types = args_copy_to_list(args);
reduce_left(func_n2(uw_register_subtype), types, nil, nil);
@@ -951,6 +1015,8 @@ static val me_defex(val form, val menv)
{
val types = cdr(form);
+ (void) menv;
+
if (!all_satisfy(types, func_n1(symbolp), nil))
eval_error(form, lit("defex: arguments must all be symbols"), nao);
@@ -998,20 +1064,20 @@ static struct cobj_ops cont_ops = cobj_ops_init(eq,
cont_mark,
cobj_eq_hash_op);
-static void call_copy_handlers(uw_frame_t *upto, int parent)
+static void call_copy_handlers(uw_frame_t *upto)
{
uw_frame_t *fr;
for (fr = uw_stack; fr != 0 && fr != upto; fr = fr->uw.up) {
if (fr->uw.type == UW_CONT_COPY)
- fr->cp.copy(fr->cp.ptr, parent);
+ fr->cp.copy(fr->cp.ptr);
}
}
static val revive_cont(val dc, val arg)
{
val self = lit("revive-cont");
- struct cont *cont = coerce(struct cont *, cobj_handle(self, dc, sys_cont_s));
+ struct cont *cont = coerce(struct cont *, cobj_handle(self, dc, sys_cont_cls));
if (arg == sys_cont_free_s) {
free(cont->stack);
@@ -1025,6 +1091,7 @@ static val revive_cont(val dc, val arg)
mem_t *ptr;
uw_frame_t *new_uw_stack = coerce(uw_frame_t *, space + UW_CONT_FRAME_BEFORE), *fr;
int env_set = 0;
+ val result = nil;
memcpy(space, cont->stack, cont->size);
@@ -1045,7 +1112,7 @@ static val revive_cont(val dc, val arg)
if (word >= orig_start - UW_CONT_FRAME_BEFORE &&
word <= orig_end && is_ptr(coerce(val, word)))
{
- *wordptr = word + delta;
+ *wordptr = word + convert(uint_ptr_t, delta);
}
#if HAVE_VALGRIND
@@ -1054,7 +1121,7 @@ static val revive_cont(val dc, val arg)
#endif
}
- uw_block_begin (cont->tag, result);
+ uw_block_beg (cont->tag, result);
for (fr = new_uw_stack; ; fr = fr->uw.up) {
if (!env_set && fr->uw.type == UW_MENV) {
@@ -1074,7 +1141,7 @@ static val revive_cont(val dc, val arg)
bug_unless (uw_stack->uw.type == UW_BLOCK);
if (arg != sys_cont_poison_s)
- call_copy_handlers(&uw_blk, 0);
+ call_copy_handlers(&uw_blk);
uw_stack->bl.result = arg;
uw_exit_point = if3(arg == sys_cont_poison_s, &uw_blk, uw_stack);
@@ -1119,7 +1186,7 @@ static val capture_cont(val tag, val fun, uw_frame_t *block)
blcopy->uw.up = 0;
blcopy->uw.type = UW_CAPTURED_BLOCK;
- cont_obj = cobj(coerce(mem_t *, cont), sys_cont_s, &cont_ops);
+ cont_obj = cobj(coerce(mem_t *, cont), sys_cont_cls, &cont_ops);
cont->tag = tag;
@@ -1129,7 +1196,7 @@ static val capture_cont(val tag, val fun, uw_frame_t *block)
uw_block_end;
if (cont_obj) {
- call_copy_handlers(block, 0);
+ call_copy_handlers(block);
result = funcall1(fun, func_f1(cont_obj, revive_cont));
}
@@ -1196,7 +1263,6 @@ void extjmp_restore(extended_jmp_buf *ejb)
gc_prot_top = ejb->gc_pt;
#if HAVE_POSIX_SIGS
async_sig_enabled = ejb->se;
- ejb->blocked.set = sig_blocked_cache.set;
sig_mask(SIG_SETMASK,
strip_qual(small_sigset_t *, &ejb->blocked), 0);
@@ -1222,6 +1288,7 @@ void uw_init(void)
uw_register_subtype(process_error_s, error_s);
uw_register_subtype(system_error_s, error_s);
uw_register_subtype(alloc_error_s, error_s);
+ uw_register_subtype(stack_overflow_s, error_s);
uw_register_subtype(timeout_error_s, error_s);
uw_register_subtype(assert_s, error_s);
uw_register_subtype(syntax_error_s, error_s);
@@ -1249,10 +1316,13 @@ void uw_late_init(void)
sys_cont_s = intern(lit("cont"), system_package);
sys_cont_poison_s = intern(lit("cont-poison"), system_package);
sys_cont_free_s = intern(lit("cont-free"), system_package);
+ catch_frame_s = intern(lit("catch-frame"), user_package);
+
+ sys_cont_cls = cobj_register(sys_cont_s);
+
frame_type = make_struct_type(intern(lit("frame"), user_package),
nil, nil, nil, nil, nil, nil, nil);
- catch_frame_type = make_struct_type(intern(lit("catch-frame"),
- user_package),
+ catch_frame_type = make_struct_type(catch_frame_s,
frame_type, nil,
list(types_s, desc_s, jump_s, nao),
nil, nil, nil, nil);
@@ -1278,8 +1348,8 @@ void uw_late_init(void)
reg_mac(intern(lit("defex"), user_package), func_n2(me_defex));
reg_var(unhandled_hook_s = intern(lit("*unhandled-hook*"),
user_package), nil);
- reg_fun(throw_s, func_n1v(uw_throwv));
- reg_fun(intern(lit("throwf"), user_package), func_n2v(uw_throwfv));
+ reg_fun(throw_s, func_n1v(uw_rthrowv));
+ reg_fun(intern(lit("throwf"), user_package), func_n2v(uw_rthrowfv));
reg_fun(error_s, func_n1v(uw_errorfv));
reg_fun(intern(lit("purge-deferred-warning"), user_package),
func_n1(uw_purge_deferred_warning));
diff --git a/unwind.h b/unwind.h
index 7f195f47..350e6aa0 100644
--- a/unwind.h
+++ b/unwind.h
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#if __i386__
@@ -85,7 +86,16 @@ struct jmp {
#elif __PPC64__
-struct jmp {
+#if __ALTIVEC__
+#define UW_JMP_ALIGN __attribute__ ((aligned (32)))
+#else
+#define UW_JMP_ALIGN
+#endif
+
+struct UW_JMP_ALIGN jmp {
+#if __ALTIVEC__
+ unsigned long vr31[4];
+#endif
unsigned long r1;
unsigned long r2;
unsigned long r11;
@@ -141,6 +151,83 @@ struct jmp {
x19-x28, x29(fp), x30(lr), (x31)sp, d8-d15. Other registers are not
saved. */
+#elif __mips__
+
+struct jmp {
+ unsigned long s0; /* $16 */
+ unsigned long s1; /* ... */
+ unsigned long s2;
+ unsigned long s3;
+ unsigned long s4;
+ unsigned long s5;
+ unsigned long s6; /* ... */
+ unsigned long s8; /* $23 */
+ unsigned long gp; /* $28 */
+ unsigned long sp; /* $29 */
+ unsigned long fp; /* $30 */
+ unsigned long ra; /* $31 */
+};
+
+#elif __riscv
+
+struct jmp {
+ unsigned long ra; /* x1 */
+ unsigned long sp; /* x2 */
+ unsigned long fp; /* x8 */
+ unsigned long s1; /* x9 */
+ unsigned long s2; /* x18 */
+ unsigned long s3; /* x19 */
+ unsigned long s4; /* x20 */
+ unsigned long s5; /* x21 */
+ unsigned long s6; /* x22 */
+ unsigned long s7; /* x23 */
+ unsigned long s8; /* x24 */
+ unsigned long s9; /* x25 */
+ unsigned long s10; /* x26 */
+ unsigned long s11; /* x27 */
+#if 0 && !__riscv_float_abi_soft
+ double fs0; /* f8 */
+ double fs1; /* f9 */
+ double fs2; /* f18 */
+ double fs3; /* f19 */
+ double fs4; /* f20 */
+ double fs5; /* f21 */
+ double fs6; /* f22 */
+ double fs7; /* f23 */
+ double fs8; /* f24 */
+ double fs9; /* f25 */
+ double fs10; /* f26 */
+ double fs11; /* f27 */
+#endif
+};
+
+#elif __loongarch64
+
+struct jmp {
+ unsigned long ra;
+ unsigned long sp;
+ unsigned long fp;
+ unsigned long s0;
+ unsigned long s1;
+ unsigned long s2;
+ unsigned long s3;
+ unsigned long s4;
+ unsigned long s5;
+ unsigned long s6;
+ unsigned long s7;
+ unsigned long s8;
+#if 0 && !__loongarch64_soft_float
+ double fs0;
+ double fs1;
+ double fs2;
+ double fs3;
+ double fs4;
+ double fs5;
+ double fs6;
+ double fs7;
+#endif
+};
+
#else
#error port me!
#endif
@@ -150,7 +237,7 @@ extern "C" {
#endif
int jmp_save(struct jmp *);
-void jmp_restore(struct jmp *, int);
+NORETURN void jmp_restore(struct jmp *, int);
#ifdef __cplusplus
}
@@ -258,7 +345,7 @@ struct uw_cont_copy {
uw_frame_t *up;
uw_frtype_t type;
mem_t *ptr;
- void (*copy)(mem_t *ptr, int parent);
+ void (*copy)(mem_t *ptr);
};
struct uw_guard {
@@ -285,7 +372,7 @@ struct uw_eval {
#endif
-#if __aarch64__
+#if __aarch64__ || (__clang__ && __amd64__)
#define UW_FRAME_ALIGN __attribute__ ((aligned (16)))
#else
#define UW_FRAME_ALIGN
@@ -305,6 +392,16 @@ union uw_frame {
#endif
} UW_FRAME_ALIGN;
+typedef struct {
+ val de;
+ uw_frame_t *stack;
+ uw_frame_t *menv_stack;
+} uw_snapshot_t;
+
+extern val catch_frame_s;
+
+uw_snapshot_t uw_snapshot(void);
+void uw_restore(const uw_snapshot_t *);
void uw_push_block(uw_frame_t *, val tag);
void uw_push_match_env(uw_frame_t *);
val uw_get_func(val sym);
@@ -324,12 +421,13 @@ void uw_push_fcall(uw_frame_t *, val fun, struct args *args);
void uw_push_eval(uw_frame_t *, val form, val env);
void uw_push_expand(uw_frame_t *, val form, val env);
#endif
-noreturn val uw_throw(val sym, val exception);
-noreturn val uw_throwv(val sym, struct args *);
-noreturn val uw_throwf(val sym, val fmt, ...);
-noreturn val uw_throwfv(val sym, val fmt, struct args *);
-noreturn val uw_errorf(val fmt, ...);
-noreturn val uw_errorfv(val fmt, struct args *args);
+val uw_rthrow(val sym, val exception);
+val uw_rthrowv(val sym, struct args *);
+val uw_rthrowfv(val sym, val fmt, struct args *);
+NORETURN val uw_throw(val sym, val exception);
+NORETURN val uw_throwf(val sym, val fmt, ...);
+NORETURN val uw_ethrowf(val sym, val fmt, ...);
+NORETURN val uw_errorfv(val fmt, struct args *args);
val uw_warningf(val fmt, ...);
val uw_defer_warning(val args);
val uw_warning_exists(val tag);
@@ -354,18 +452,20 @@ val uw_find_frames(val extype, val frtype);
val uw_find_frames_by_mask(val mask);
val uw_last_form_expanded(void);
#else
-define uw_last_form_expanded() ((void) 0)
+#define uw_last_form_expanded() nil
#endif
val uw_invoke_catch(val catch_frame, val sym, struct args *);
val uw_muffle_warning(val exc, struct args *);
val uw_trace_error(val ctx, val exc, struct args *);
val uw_capture_cont(val tag, val fun, val ctx_form);
void uw_push_cont_copy(uw_frame_t *, mem_t *ptr,
- void (*copy)(mem_t *ptr, int parent));
+ void (*copy)(mem_t *ptr));
void uw_init(void);
void uw_late_init(void);
-noreturn val type_mismatch(val, ...);
+NORETURN val type_mismatch(val, ...);
+NORETURN void invalid_ops(val self, val obj1, val obj2);
+NORETURN void invalid_op(val self, val obj);
#define uw_mark_frame \
uw_frame_t *uw_top = uw_current_frame()
@@ -376,6 +476,16 @@ noreturn val type_mismatch(val, ...);
return VAL; \
} while (0)
+#define uw_block_beg(TAG, RESULTVAR) \
+ do { \
+ uw_frame_t uw_blk; \
+ obj_t **uw_rslt = &RESULTVAR; \
+ uw_push_block(&uw_blk, TAG); \
+ if (extended_setjmp(uw_blk.bl.jb)) { \
+ RESULTVAR = uw_blk.bl.result; \
+ } else { \
+ enum { dummy ## __LINE__ }
+
#define uw_block_begin(TAG, RESULTVAR) \
obj_t *RESULTVAR = nil; \
do { \
@@ -385,7 +495,7 @@ noreturn val type_mismatch(val, ...);
if (extended_setjmp(uw_blk.bl.jb)) { \
RESULTVAR = uw_blk.bl.result; \
} else { \
- do { } while (0)
+ enum { dummy ## __LINE__ }
#define uw_block_end \
} \
@@ -395,9 +505,12 @@ noreturn val type_mismatch(val, ...);
#define uw_match_env_begin \
do { \
uw_frame_t uw_env; \
- uw_push_match_env(&uw_env)
+ uw_push_match_env(&uw_env); \
+ { \
+ enum { dummy ## __LINE__ }
#define uw_match_env_end \
+ } \
uw_pop_frame(&uw_env); \
} while (0)
diff --git a/utf8.c b/utf8.c
index 8afae187..6a5e894a 100644
--- a/utf8.c
+++ b/utf8.c
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,31 +6,33 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
-#include <stddef.h>
+#define UTF8_DECL_OPENDIR
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <wchar.h>
#include <signal.h>
+#include <dirent.h>
#include "config.h"
#include "lib.h"
#include "signal.h"
@@ -53,10 +55,10 @@ size_t utf8_from_buf(wchar_t *wdst, const unsigned char *src, size_t nbytes)
{
size_t nchar = 1;
enum utf8_state state = utf8_init;
- const unsigned char *backtrack = 0;
+ const unsigned char *backtrack = 0, *end = src + nbytes;
wchar_t wch = 0, wch_min = 0;
- while (nbytes-- > 0) {
+ while (src < end) {
int ch = *src++;
switch (state) {
@@ -83,24 +85,24 @@ size_t utf8_from_buf(wchar_t *wdst, const unsigned char *src, size_t nbytes)
wch_min = 0x800;
break;
case 0xF:
-#ifdef FULL_UNICODE
if (ch < 0xF5) {
+#ifdef FULL_UNICODE
state = utf8_more3;
wch = (ch & 0x7);
wch_min = 0x10000;
break;
- }
- /* fallthrough */
#else
conversion_error();
#endif
+ }
+ /* fallthrough */
default:
if (wdst)
*wdst++ = 0xDC00 | ch;
nchar++;
break;
}
- backtrack = src;
+ backtrack = src - 1;
break;
case utf8_more1:
case utf8_more2:
@@ -117,6 +119,7 @@ size_t utf8_from_buf(wchar_t *wdst, const unsigned char *src, size_t nbytes)
src = backtrack;
if (wdst)
*wdst++ = 0xDC00 | *src;
+ src++;
} else {
if (wdst)
*wdst++ = wch;
@@ -127,6 +130,7 @@ size_t utf8_from_buf(wchar_t *wdst, const unsigned char *src, size_t nbytes)
src = backtrack;
if (wdst)
*wdst++ = 0xDC00 | *src;
+ src++;
nchar++;
state = utf8_init;
}
@@ -134,8 +138,18 @@ size_t utf8_from_buf(wchar_t *wdst, const unsigned char *src, size_t nbytes)
}
}
+ if (state != utf8_init) {
+ while (backtrack != src) {
+ if (wdst)
+ *wdst++ = 0xDC00 | *backtrack;
+ nchar++;
+ backtrack++;
+ }
+ }
+
if (wdst)
*wdst++ = 0;
+
return nchar;
}
@@ -314,17 +328,17 @@ wint_t utf8_decode(utf8_decoder_t *ud, int (*get)(mem_t *ctx), mem_t *ctx)
ud->wch_min = 0x800;
break;
case 0xF:
-#ifdef FULL_UNICODE
if (ch < 0xF5) {
+#ifdef FULL_UNICODE
ud->state = utf8_more3;
ud->wch = (ch & 0x7);
ud->wch_min = 0x10000;
break;
- }
- /* fallthrough */
#else
conversion_error();
#endif
+ }
+ /* fallthrough */
default:
ud->back = ud->tail;
return 0xDC00 | ch;
@@ -371,26 +385,6 @@ FILE *w_fopen(const wchar_t *wname, const wchar_t *wmode)
return f;
}
-FILE *w_popen(const wchar_t *wcmd, const wchar_t *wmode)
-{
- char *cmd = utf8_dup_to(wcmd);
- char *mode = utf8_dup_to(wmode);
- FILE *f = popen(cmd, mode);
- free(cmd);
- free(mode);
- return f;
-}
-
-FILE *w_freopen(const wchar_t *wname, const wchar_t *wmode, FILE *fold)
-{
- char *name = utf8_dup_to(wname);
- char *mode = utf8_dup_to(wmode);
- FILE *f = fold ? freopen(name, mode, fold) : fopen(name, mode);
- free(name);
- free(mode);
- return f;
-}
-
FILE *w_fdopen(int fd, const wchar_t *wmode)
{
char *mode = utf8_dup_to(wmode);
@@ -416,3 +410,11 @@ int w_rename(const wchar_t *wfrom, const wchar_t *wto)
free(from);
return err;
}
+
+DIR *w_opendir(const wchar_t *wname)
+{
+ char *name = utf8_dup_to(wname);
+ DIR *d = opendir(name);
+ free(name);
+ return d;
+}
diff --git a/utf8.h b/utf8.h
index a8c48757..8d54166d 100644
--- a/utf8.h
+++ b/utf8.h
@@ -1,4 +1,4 @@
-/* Copyright 2009-2020
+/* Copyright 2009-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
size_t utf8_from_buf(wchar_t *, const unsigned char *, size_t nbytes);
@@ -51,8 +52,10 @@ void utf8_decoder_init(utf8_decoder_t *);
wint_t utf8_decode(utf8_decoder_t *,int (*get)(mem_t *ctx), mem_t *ctx);
FILE *w_fopen(const wchar_t *, const wchar_t *);
-FILE *w_popen(const wchar_t *, const wchar_t *);
FILE *w_freopen(const wchar_t *, const wchar_t *, FILE *);
FILE *w_fdopen(int, const wchar_t *);
int w_remove(const wchar_t *);
int w_rename(const wchar_t *, const wchar_t *);
+#ifdef UTF8_DECL_OPENDIR
+DIR *w_opendir(const wchar_t *wname);
+#endif
diff --git a/vm.c b/vm.c
index 9c8e270c..b0c3e597 100644
--- a/vm.c
+++ b/vm.c
@@ -1,4 +1,4 @@
-/* Copyright 2018-2020
+/* Copyright 2018-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,29 +6,28 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
#include <stddef.h>
-#include <stdio.h>
#include <string.h>
-#include <stdarg.h>
#include <stdlib.h>
#include <limits.h>
#include <signal.h>
@@ -43,7 +42,6 @@
#include "args.h"
#include "itypes.h"
#include "buf.h"
-#include "arith.h"
#include "vmop.h"
#include "vm.h"
@@ -94,13 +92,17 @@ struct vm {
struct vm_closure {
struct vm_desc *vd;
int frsz;
+ int nreg;
int nlvl;
unsigned ip;
- struct vm_env dspl[1];
+ struct vm_env dspl[FLEX_ARRAY];
};
val vm_desc_s, vm_closure_s;
+struct cobj_class *vm_desc_cls;
+static struct cobj_class *vm_closure_cls;
+
static_forward(struct cobj_ops vm_desc_ops);
static_forward(struct cobj_ops vm_closure_ops);
@@ -111,7 +113,7 @@ static struct vm_desc_links vmd_list = {
static struct vm_desc *vm_desc_struct(val self, val obj)
{
- return coerce(struct vm_desc *, cobj_handle(self, obj, vm_desc_s));
+ return coerce(struct vm_desc *, cobj_handle(self, obj, vm_desc_cls));
}
val vm_make_desc(val nlevels, val nregs, val bytecode,
@@ -120,18 +122,18 @@ val vm_make_desc(val nlevels, val nregs, val bytecode,
val self = lit("sys:vm-make-desc");
int nlvl = c_int(nlevels, self), nreg = c_int(nregs, self);
- if (nlvl < 2 || nlvl > 256)
- uw_throwf(error_s, lit("~a: nlevels must be 2 to 256; ~s given"),
- self, nlevels, nao);
+ if (nlvl < 2 || nlvl > VM_MAX_LEV)
+ uw_throwf(error_s, lit("~a: nlevels must be 2 to ~s; ~s given"),
+ self, num(VM_MAX_LEV), nlevels, nao);
- if (nreg < 1 || nreg > 256)
- uw_throwf(error_s, lit("~a: nregs must be 1 to 256; ~s given"),
- self, nregs, nao);
+ if (nreg < 1 || nreg > VM_LEV_SIZE)
+ uw_throwf(error_s, lit("~a: nregs must be 1 to ~s; ~s given"),
+ self, num(VM_LEV_SIZE), nregs, nao);
{
mem_t *code = buf_get(bytecode, self);
val dvl = length_vec(datavec);
- cnum stsz = c_num(length_vec(symvec));
+ cnum stsz = c_num(length_vec(symvec), self);
loc data_loc = if3(dvl != zero, vecref_l(datavec, zero), nulloc);
struct vm_desc *vd = coerce(struct vm_desc *, chk_malloc(sizeof *vd));
struct vm_desc *vtail = vmd_list.prev, *vnull = vtail->lnk.next;
@@ -160,7 +162,7 @@ val vm_make_desc(val nlevels, val nregs, val bytecode,
vnull->lnk.prev = vd;
vtail->lnk.next = vd;
- desc = cobj(coerce(mem_t *, vd), vm_desc_s, &vm_desc_ops);
+ desc = cobj(coerce(mem_t *, vd), vm_desc_cls, &vm_desc_ops);
vd->bytecode = bytecode;
vd->datavec = datavec;
@@ -173,7 +175,7 @@ val vm_make_desc(val nlevels, val nregs, val bytecode,
static val vm_desc_nlevels(val desc)
{
- val self = lit("vm_desc_nlevels");
+ val self = lit("vm-desc-nlevels");
struct vm_desc *vd = vm_desc_struct(self, desc);
return num(vd->nlvl);
}
@@ -232,11 +234,12 @@ static void vm_desc_mark(val obj)
static struct vm_closure *vm_closure_struct(val self, val obj)
{
- return coerce(struct vm_closure *, cobj_handle(self, obj, vm_closure_s));
+ return coerce(struct vm_closure *, cobj_handle(self, obj, vm_closure_cls));
}
-static val vm_make_closure(struct vm *vm, int frsz)
+static val vm_make_closure(struct vm *vm, int frsz, int nreg)
{
+ val self = lit("vm");
size_t dspl_sz = vm->nlvl * sizeof (struct vm_env);
struct vm_closure *vc = coerce(struct vm_closure *,
chk_malloc(offsetof (struct vm_closure, dspl)
@@ -247,13 +250,14 @@ static val vm_make_closure(struct vm *vm, int frsz)
vc->frsz = frsz;
vc->ip = vm->ip;
vc->nlvl = vm->lev + 1;
+ vc->nreg = nreg;
vc->vd = vm->vd;
memset(vc->dspl, 0, dspl_sz);
assert (vc->nlvl <= vm->nlvl);
- closure = cobj(coerce(mem_t *, vc), vm_closure_s, &vm_closure_ops);
+ closure = cobj(coerce(mem_t *, vc), vm_closure_cls, &vm_closure_ops);
for (i = 2; i < vc->nlvl; i++) {
struct vm_env *sdi = &vm->dspl[i];
@@ -269,7 +273,7 @@ static val vm_make_closure(struct vm *vm, int frsz)
case NUM:
{
val heap_vec = vector(vec, nil);
- size_t size = sizeof *cdi->mem * c_num(vec);
+ size_t size = sizeof *cdi->mem * c_num(vec, self);
cdi->vec = heap_vec;
cdi->mem = heap_vec->v.vec;
memcpy(cdi->mem, mem, size);
@@ -302,7 +306,7 @@ val vm_copy_closure(val oclosure)
memcpy(nvc, ovc, hdr_sz + dspl_sz);
- nclosure = cobj(coerce(mem_t *, nvc), vm_closure_s, &vm_closure_ops);
+ nclosure = cobj(coerce(mem_t *, nvc), vm_closure_cls, &vm_closure_ops);
for (i = 2; i < nvc->nlvl; i++) {
struct vm_env *ndi = &nvc->dspl[i];
@@ -313,6 +317,8 @@ val vm_copy_closure(val oclosure)
}
}
+ gc_hint(oclosure);
+
return nclosure;
}
@@ -345,10 +351,6 @@ static void vm_reset(struct vm *vm, struct vm_desc *vd,
#define vm_insn_bigop(insn) (((insn) & 0x3FFFFFFU))
#define vm_arg_operand_lo(arg) ((arg) & 0xFFFFU)
#define vm_arg_operand_hi(arg) ((arg) >> 16)
-#define VM_LEV_BITS 10
-#define VM_LEV_MASK 0x3FF
-#define VM_SM_LEV_BITS 6
-#define VM_SM_LEV_MASK 0x3F
#define vm_lev(arg) ((arg) >> VM_LEV_BITS)
#define vm_idx(arg) ((arg) & VM_LEV_MASK)
#define vm_sm_lev(arg) ((arg) >> VM_SM_LEV_BITS)
@@ -365,7 +367,7 @@ INLINE val vm_getz(struct vm_env *dspl, unsigned ref)
{
unsigned lev = vm_lev(ref);
val *addr = &dspl[lev].mem[vm_idx(ref)];
- return (lev == 0) ? z(*addr) : *addr;
+ return *addr;
}
INLINE val vm_sm_get(struct vm_env *dspl, unsigned ref)
@@ -462,38 +464,76 @@ NOINLINE static val vm_end(struct vm *vm, vm_word_t insn)
return vm_get(vm->dspl, vm_insn_operand(insn));
}
-NOINLINE static val vm_fin(struct vm *vm, vm_word_t insn)
-{
- vm->ip--;
- return vm_get(vm->dspl, vm_insn_operand(insn));
-}
-
NOINLINE static void vm_call(struct vm *vm, vm_word_t insn)
{
unsigned nargs = vm_insn_extra(insn);
unsigned dest = vm_insn_operand(insn);
vm_word_t argw = vm->code[vm->ip++];
- unsigned fun = vm_arg_operand_lo(argw);
+ unsigned funidx = vm_arg_operand_lo(argw);
+ val fun = vm_getz(vm->dspl, funidx);
val result;
- args_decl (args, max(nargs, ARGS_MIN));
- if (nargs--) {
- args_add(args, vm_get(vm->dspl, vm_arg_operand_hi(argw)));
-
- while (nargs >= 2) {
- nargs -= 2;
- argw = vm->code[vm->ip++];
- args_add(args, vm_getz(vm->dspl, vm_arg_operand_lo(argw)));
- args_add(args, vm_getz(vm->dspl, vm_arg_operand_hi(argw)));
+ switch (nargs) {
+ case 0:
+ result = funcall(fun);
+ break;
+ case 1:
+ {
+ val arg1 = vm_getz(vm->dspl, vm_arg_operand_hi(argw));
+ result = funcall1(fun, z(arg1));
+ }
+ break;
+ case 2:
+ {
+ vm_word_t argx = vm->code[vm->ip++];
+ val arg1 = vm_getz(vm->dspl, vm_arg_operand_hi(argw));
+ val arg2 = vm_getz(vm->dspl, vm_arg_operand_lo(argx));
+ result = funcall2(fun, z(arg1), z(arg2));
+ }
+ break;
+ case 3:
+ {
+ vm_word_t argx = vm->code[vm->ip++];
+ val arg1 = vm_getz(vm->dspl, vm_arg_operand_hi(argw));
+ val arg2 = vm_getz(vm->dspl, vm_arg_operand_lo(argx));
+ val arg3 = vm_getz(vm->dspl, vm_arg_operand_hi(argx));
+ result = funcall3(fun, z(arg1), z(arg2), z(arg3));
+ }
+ break;
+ case 4:
+ {
+ vm_word_t argx = vm->code[vm->ip++];
+ vm_word_t argy = vm->code[vm->ip++];
+ val arg1 = vm_getz(vm->dspl, vm_arg_operand_hi(argw));
+ val arg2 = vm_getz(vm->dspl, vm_arg_operand_lo(argx));
+ val arg3 = vm_getz(vm->dspl, vm_arg_operand_hi(argx));
+ val arg4 = vm_getz(vm->dspl, vm_arg_operand_lo(argy));
+ result = funcall4(fun, z(arg1), z(arg2), z(arg3), z(arg4));
}
+ break;
+ default:
+ {
+ args_decl (args, max(nargs, ARGS_MIN));
+ args_add(args, vm_getz(vm->dspl, vm_arg_operand_hi(argw)));
+ nargs--;
- if (nargs) {
- argw = vm->code[vm->ip++];
- args_add(args, vm_getz(vm->dspl, vm_arg_operand_lo(argw)));
+ while (nargs >= 2) {
+ nargs -= 2;
+ argw = vm->code[vm->ip++];
+ args_add(args, vm_getz(vm->dspl, vm_arg_operand_lo(argw)));
+ args_add(args, vm_getz(vm->dspl, vm_arg_operand_hi(argw)));
+ }
+
+ if (nargs) {
+ argw = vm->code[vm->ip++];
+ args_add(args, vm_getz(vm->dspl, vm_arg_operand_lo(argw)));
+ }
+
+ result = generic_funcall(fun, args);
}
+ break;
}
- result = generic_funcall(vm_getz(vm->dspl, fun), args);
vm_set(vm->dspl, dest, result);
}
@@ -528,13 +568,13 @@ NOINLINE static void vm_apply(struct vm *vm, vm_word_t insn)
NOINLINE static loc vm_stab_slowpath(struct vm *vm, unsigned fun,
- val (*lookup_fn)(val env, val sym),
+ val (*lookup_fn)(val sym),
val kind_str)
{
struct vm_desc *vd = vm->vd;
struct vm_stent *fe = &vd->stab[fun];
- if (nilp(fe->bind = lookup_fn(nil, vecref(vd->symvec, num_fast(fun)))))
+ if (nilp(fe->bind = lookup_fn(vecref(vd->symvec, num_fast(fun)))))
eval_error(vd->bytecode,
lit("~a ~s is not defined"), kind_str,
vecref(vd->symvec, num(fun)), nao);
@@ -544,7 +584,7 @@ NOINLINE static loc vm_stab_slowpath(struct vm *vm, unsigned fun,
}
INLINE loc vm_stab(struct vm *vm, unsigned fun,
- val (*lookup_fn)(val env, val sym), val kind_str)
+ val (*lookup_fn)(val sym), val kind_str)
{
struct vm_desc *vd = vm->vd;
struct vm_stent *fe = &vd->stab[fun];
@@ -562,7 +602,8 @@ NOINLINE static void vm_gcall(struct vm *vm, vm_word_t insn)
unsigned dest = vm_insn_operand(insn);
vm_word_t argw = vm->code[vm->ip++];
unsigned funidx = vm_arg_operand_lo(argw);
- val fun = deref(vm_stab(vm, funidx, lookup_fun, lit("function")));
+ val fun = deref(vm_stab(vm, funidx,
+ lookup_global_fun, lit("function")));
val result;
switch (nargs) {
@@ -654,7 +695,7 @@ NOINLINE static void vm_gapply(struct vm *vm, vm_word_t insn)
}
}
- result = applyv(deref(vm_stab(vm, fun, lookup_fun,
+ result = applyv(deref(vm_stab(vm, fun, lookup_global_fun,
lit("function"))), args);
vm_set(vm->dspl, dest, result);
}
@@ -678,45 +719,12 @@ NOINLINE static void vm_movrr(struct vm *vm, vm_word_t insn)
vm_set(vm->dspl, vm_insn_operand(insn), datum);
}
-NOINLINE static void vm_movrsi(struct vm *vm, vm_word_t insn)
-{
- unsigned dst = vm_insn_operand(insn);
- ucnum negmask = ~convert(ucnum, 0x3FF);
- ucnum imm = vm_insn_extra(insn);
-
- if ((imm & TAG_MASK) == NUM && (imm & 0x200))
- imm |= negmask;
-
- vm_set(vm->dspl, dst, coerce(val, imm));
-}
-
-NOINLINE static void vm_movsmi(struct vm *vm, vm_word_t insn)
-{
- unsigned dst = vm_insn_extra(insn);
- ucnum negmask = ~convert(ucnum, 0xFFFF);
- ucnum imm = vm_insn_operand(insn);
-
- if ((imm & TAG_MASK) == NUM && (imm & 0x8000))
- imm |= negmask;
-
- vm_sm_set(vm->dspl, dst, coerce(val, imm));
-}
-
-NOINLINE static void vm_movrbi(struct vm *vm, vm_word_t insn)
-{
- unsigned dst = vm_insn_operand(insn);
- ucnum negmask = ~convert(ucnum, 0xFFFFFFFF);
- ucnum imm = vm->code[vm->ip++];
-
- if ((imm & TAG_MASK) == NUM && (imm & 0x80000000))
- imm |= negmask;
-
- vm_set(vm->dspl, dst, coerce(val, imm));
-}
-
static void vm_jmp(struct vm *vm, vm_word_t insn)
{
- vm->ip = vm_insn_bigop(insn);
+ unsigned ip = vm_insn_bigop(insn);
+ if (ip < vm->ip)
+ sig_check_fast();
+ vm->ip = ip;
}
NOINLINE static void vm_if(struct vm *vm, vm_word_t insn)
@@ -753,8 +761,9 @@ NOINLINE static void vm_ifql(struct vm *vm, vm_word_t insn)
NOINLINE static void vm_swtch(struct vm *vm, vm_word_t insn)
{
+ val self = lit("vm");
unsigned tblsz = vm_insn_extra(insn);
- ucnum idx = c_unum(vm_get(vm->dspl, vm_insn_operand(insn)));
+ ucnum idx = c_unum(vm_get(vm->dspl, vm_insn_operand(insn)), self);
if (idx < tblsz) {
vm_word_t tgt = vm->code[vm->ip + idx / 2];
@@ -813,7 +822,7 @@ NOINLINE static void vm_no_block_err(struct vm *vm, val name)
else
eval_error(vm->vd->bytecode,
lit("return: no anonymous block is visible"),
- name, nao);
+ nao);
}
NOINLINE static void vm_retsr(struct vm *vm, vm_word_t insn)
@@ -898,11 +907,11 @@ NOINLINE static void vm_handle(struct vm *vm, vm_word_t insn)
}
static val vm_get_binding(struct vm *vm, vm_word_t insn,
- val (*lookup_fn)(val env, val sym),
+ val (*lookup_fn)(val sym),
val kind_str)
{
val sym = vm_sm_get(vm->dspl, vm_insn_extra(insn));
- val binding = lookup_fn(nil, sym);
+ val binding = lookup_fn(sym);
if (nilp(binding))
eval_error(vm->vd->bytecode, lit("unbound ~a ~s"), kind_str, sym, nao);
@@ -911,7 +920,7 @@ static val vm_get_binding(struct vm *vm, vm_word_t insn,
}
NOINLINE static void vm_getsym(struct vm *vm, vm_word_t insn,
- val (*lookup_fn)(val env, val sym),
+ val (*lookup_fn)(val sym),
val kind_str)
{
val binding = vm_get_binding(vm, insn, lookup_fn, kind_str);
@@ -920,7 +929,7 @@ NOINLINE static void vm_getsym(struct vm *vm, vm_word_t insn,
}
NOINLINE static void vm_getbind(struct vm *vm, vm_word_t insn,
- val (*lookup_fn)(val env, val sym),
+ val (*lookup_fn)(val sym),
val kind_str)
{
val binding = vm_get_binding(vm, insn, lookup_fn, kind_str);
@@ -929,7 +938,7 @@ NOINLINE static void vm_getbind(struct vm *vm, vm_word_t insn,
}
NOINLINE static void vm_setsym(struct vm *vm, vm_word_t insn,
- val (*lookup_fn)(val env, val sym),
+ val (*lookup_fn)(val sym),
val kind_str)
{
val binding = vm_get_binding(vm, insn, lookup_fn, kind_str);
@@ -950,7 +959,7 @@ NOINLINE static void vm_bindv(struct vm *vm, vm_word_t insn)
}
NOINLINE static void vm_gettab(struct vm *vm, vm_word_t insn,
- val (*lookup_fn)(val env, val sym),
+ val (*lookup_fn)(val sym),
val kind_str)
{
unsigned idx = vm_insn_operand(insn);
@@ -959,7 +968,7 @@ NOINLINE static void vm_gettab(struct vm *vm, vm_word_t insn,
}
NOINLINE static void vm_settab(struct vm *vm, vm_word_t insn,
- val (*lookup_fn)(val env, val sym),
+ val (*lookup_fn)(val sym),
val kind_str)
{
unsigned idx = vm_insn_operand(insn);
@@ -972,13 +981,15 @@ NOINLINE static void vm_close(struct vm *vm, vm_word_t insn)
unsigned dst = vm_insn_bigop(insn);
vm_word_t arg1 = vm->code[vm->ip++];
vm_word_t arg2 = vm->code[vm->ip++];
+ vm_word_t arg3 = vm->code[vm->ip++];
unsigned vari_fr = vm_arg_operand_hi(arg1);
int variadic = vari_fr & (1 << VM_LEV_BITS);
int frsz = vari_fr & VM_LEV_MASK;
unsigned reg = vm_arg_operand_lo(arg1);
int reqargs = vm_arg_operand_hi(arg2);
int fixparam = vm_arg_operand_lo(arg2);
- val closure = vm_make_closure(vm, frsz);
+ int ntregs = vm_arg_operand_lo(arg3);
+ val closure = vm_make_closure(vm, frsz, ntregs);
val vf = func_vm(closure, vm->vd->self, fixparam, reqargs, variadic);
vm_set(vm->dspl, reg, vf);
@@ -987,6 +998,8 @@ NOINLINE static void vm_close(struct vm *vm, vm_word_t insn)
NOINLINE static val vm_execute(struct vm *vm)
{
+ sig_check_fast();
+
for (;;) {
vm_word_t insn = vm->code[vm->ip++];
vm_op_t opcode = vm_insn_opcode(insn);
@@ -1005,8 +1018,6 @@ NOINLINE static val vm_execute(struct vm *vm)
break;
case END:
return vm_end(vm, insn);
- case FIN:
- return vm_fin(vm, insn);
case PROF:
vm_prof(vm, insn);
break;
@@ -1031,15 +1042,6 @@ NOINLINE static val vm_execute(struct vm *vm)
case MOVRR:
vm_movrr(vm, insn);
break;
- case MOVRSI:
- vm_movrsi(vm, insn);
- break;
- case MOVSMI:
- vm_movsmi(vm, insn);
- break;
- case MOVRBI:
- vm_movrbi(vm, insn);
- break;
case JMP:
vm_jmp(vm, insn);
break;
@@ -1080,28 +1082,28 @@ NOINLINE static val vm_execute(struct vm *vm)
vm_handle(vm, insn);
break;
case GETV:
- vm_getsym(vm, insn, lookup_var, lit("variable"));
+ vm_getsym(vm, insn, lookup_dynamic_var, lit("variable"));
break;
case OLDGETF:
- vm_getsym(vm, insn, lookup_fun, lit("function"));
+ vm_getsym(vm, insn, lookup_global_fun, lit("function"));
break;
case GETL1:
- vm_getsym(vm, insn, lookup_sym_lisp1, lit("variable/function"));
+ vm_getsym(vm, insn, lookup_dynamic_sym_lisp1, lit("variable/function"));
break;
case GETVB:
- vm_getbind(vm, insn, lookup_var, lit("variable"));
+ vm_getbind(vm, insn, lookup_dynamic_var, lit("variable"));
break;
case GETFB:
- vm_getbind(vm, insn, lookup_fun, lit("function"));
+ vm_getbind(vm, insn, lookup_global_fun, lit("function"));
break;
case GETL1B:
- vm_getbind(vm, insn, lookup_sym_lisp1, lit("variable/function"));
+ vm_getbind(vm, insn, lookup_dynamic_sym_lisp1, lit("variable/function"));
break;
case SETV:
- vm_setsym(vm, insn, lookup_var, lit("variable"));
+ vm_setsym(vm, insn, lookup_dynamic_var, lit("variable"));
break;
case SETL1:
- vm_setsym(vm, insn, lookup_sym_lisp1, lit("variable/function"));
+ vm_setsym(vm, insn, lookup_dynamic_sym_lisp1, lit("variable/function"));
break;
case BINDV:
vm_bindv(vm, insn);
@@ -1110,13 +1112,13 @@ NOINLINE static val vm_execute(struct vm *vm)
vm_close(vm, insn);
break;
case GETLX:
- vm_gettab(vm, insn, lookup_var, lit("variable"));
+ vm_gettab(vm, insn, lookup_global_var, lit("variable"));
break;
case SETLX:
- vm_settab(vm, insn, lookup_var, lit("variable"));
+ vm_settab(vm, insn, lookup_global_var, lit("variable"));
break;
case GETF:
- vm_gettab(vm, insn, lookup_fun, lit("function"));
+ vm_gettab(vm, insn, lookup_global_fun, lit("function"));
break;
default:
uw_throwf(error_s, lit("invalid opcode ~s"), num_fast(opcode), nao);
@@ -1129,7 +1131,7 @@ val vm_execute_toplevel(val desc)
val self = lit("vm-execute-toplevel");
struct vm_desc *vd = vm_desc_struct(self, desc);
struct vm vm;
- val *frame = coerce(val *, alloca(sizeof *frame * vd->frsz));
+ val *frame = coerce(val *, zalloca(sizeof *frame * vd->frsz));
struct vm_env *dspl = coerce(struct vm_env *, frame + vd->nreg);
vm_reset(&vm, vd, dspl, 1, 0);
@@ -1147,7 +1149,7 @@ val vm_execute_toplevel(val desc)
return vm_execute(&vm);
}
-val vm_execute_closure(val fun, struct args *args)
+val vm_execute_closure(val fun, varg args)
{
val self = lit("vm-execute-closure");
val closure = fun->f.env;
@@ -1157,15 +1159,18 @@ val vm_execute_closure(val fun, struct args *args)
struct vm_desc *vd = vm_desc_struct(self, desc);
struct vm_closure *vc = coerce(struct vm_closure *, closure->co.handle);
struct vm vm;
- val *frame = coerce(val *, alloca(sizeof *frame * vd->frsz));
- struct vm_env *dspl = coerce(struct vm_env *, frame + vd->nreg);
+ int frsz = vd->nlvl * 2 + vc->nreg;
+ val *frame = coerce(val *, zalloca(sizeof *frame * frsz));
+ struct vm_env *dspl = coerce(struct vm_env *, frame + vc->nreg);
val vargs = if3(variadic, args_get_rest(args, fixparam), nil);
cnum ix = 0;
vm_word_t argw = 0;
+ gc_stack_check();
+
vm_reset(&vm, vd, dspl, vc->nlvl - 1, vc->ip);
- vm.dspl = coerce(struct vm_env *, frame + vd->nreg);
+ vm.dspl = coerce(struct vm_env *, frame + vc->nreg);
frame[0] = nil;
@@ -1184,18 +1189,20 @@ val vm_execute_closure(val fun, struct args *args)
}
while (fixparam >= 2) {
- fixparam -= 2;
- argw = vm.code[vm.ip++];
- unsigned xreg = vm_arg_operand_lo(argw);
- unsigned yreg = vm_arg_operand_hi(argw);
+ vm_word_t aw = vm.code[vm.ip++];
+ unsigned xreg = vm_arg_operand_lo(aw);
+ unsigned yreg = vm_arg_operand_hi(aw);
vm_set(dspl, xreg, args_get(args, &ix));
vm_set(dspl, yreg, args_get(args, &ix));
+ fixparam -= 2;
+ argw = aw;
}
if (fixparam) {
- argw = vm.code[vm.ip++];
- unsigned xreg = vm_arg_operand_lo(argw);
+ vm_word_t aw = vm.code[vm.ip++];
+ unsigned xreg = vm_arg_operand_lo(aw);
vm_set(dspl, xreg, args_get(args, &ix));
+ argw = aw;
}
if (variadic) {
@@ -1219,10 +1226,12 @@ val vm_execute_closure(val fun, struct args *args)
struct vm_desc *vd = vm_desc_struct(self, desc); \
struct vm_closure *vc = coerce(struct vm_closure *, closure->co.handle); \
struct vm vm; \
- val *frame = coerce(val *, alloca(sizeof *frame * vd->frsz)); \
- struct vm_env *dspl = coerce(struct vm_env *, frame + vd->nreg); \
+ int frsz = vd->nlvl * 2 + vc->nreg; \
+ val *frame = coerce(val *, zalloca(sizeof *frame * frsz)); \
+ struct vm_env *dspl = coerce(struct vm_env *, frame + vc->nreg); \
+ gc_stack_check(); \
vm_reset(&vm, vd, dspl, vc->nlvl - 1, vc->ip); \
- vm.dspl = coerce(struct vm_env *, frame + vd->nreg); \
+ vm.dspl = coerce(struct vm_env *, frame + vc->nreg); \
frame[0] = nil; \
vm.dspl[0].mem = frame; \
vm.dspl[0].vec = nil; \
@@ -1361,6 +1370,8 @@ void vm_init(void)
{
vm_desc_s = intern(lit("vm-desc"), system_package);
vm_closure_s = intern(lit("vm-closure"), system_package);
+ vm_desc_cls = cobj_register(vm_desc_s);
+ vm_closure_cls = cobj_register(vm_closure_s);
reg_fun(intern(lit("vm-make-desc"), system_package), func_n5(vm_make_desc));
reg_fun(intern(lit("vm-desc-nlevels"), system_package), func_n1(vm_desc_nlevels));
reg_fun(intern(lit("vm-desc-nregs"), system_package), func_n1(vm_desc_nregs));
diff --git a/vm.h b/vm.h
index 427ffe65..841daa4e 100644
--- a/vm.h
+++ b/vm.h
@@ -1,4 +1,4 @@
-/* Copyright 2018-2020
+/* Copyright 2018-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,32 +6,35 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
extern val vm_desc_s, vm_closure_s;
+extern struct cobj_class *vm_desc_cls;
+
val vm_make_desc(val nlevels, val nregs, val bytecode,
val datavec, val funvec);
val vm_execute_toplevel(val desc);
val vm_copy_closure(val closure);
-val vm_execute_closure(val fun, struct args *);
+val vm_execute_closure(val fun, varg);
val vm_funcall(val fun);
val vm_funcall1(val fun, val arg);
val vm_funcall2(val fun, val arg1, val arg2);
diff --git a/vmop.h b/vmop.h
index 7c2e6185..a972efc6 100644
--- a/vmop.h
+++ b/vmop.h
@@ -1,4 +1,4 @@
-/* Copyright 2018-2020
+/* Copyright 2018-2024
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
@@ -6,23 +6,24 @@
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
- * 1. Redistributions of source code must retain the above copyright notice, this
- * list of conditions and the following disclaimer.
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
*/
typedef enum vm_op {
@@ -31,42 +32,46 @@ typedef enum vm_op {
SFRAME = 2,
DFRAME = 3,
END = 4,
- FIN = 5,
- PROF = 6,
- CALL = 7,
- APPLY = 8,
- GCALL = 9,
- GAPPLY = 10,
- MOVRS = 11,
- MOVSR = 12,
- MOVRR = 13,
- MOVRSI = 14,
- MOVSMI = 15,
- MOVRBI = 16,
- JMP = 17,
- IF = 18,
- IFQ = 19,
- IFQL = 20,
- SWTCH = 21,
- UWPROT = 22,
- BLOCK = 23,
- RETSR = 24,
- RETRS = 25,
- RETRR = 26,
- ABSCSR = 27,
- CATCH = 28,
- HANDLE = 29,
- GETV = 30,
- OLDGETF = 31,
- GETL1 = 32,
- GETVB = 33,
- GETFB = 34,
- GETL1B = 35,
- SETV = 36,
- SETL1 = 37,
- BINDV = 38,
- CLOSE = 39,
- GETLX = 40,
- SETLX = 41,
- GETF = 42,
+ PROF = 5,
+ CALL = 6,
+ APPLY = 7,
+ GCALL = 8,
+ GAPPLY = 9,
+ MOVRS = 10,
+ MOVSR = 11,
+ MOVRR = 12,
+ JMP = 13,
+ IF = 14,
+ IFQ = 15,
+ IFQL = 16,
+ SWTCH = 17,
+ UWPROT = 18,
+ BLOCK = 19,
+ RETSR = 20,
+ RETRS = 21,
+ RETRR = 22,
+ ABSCSR = 23,
+ CATCH = 24,
+ HANDLE = 25,
+ GETV = 26,
+ OLDGETF = 27,
+ GETL1 = 28,
+ GETVB = 29,
+ GETFB = 30,
+ GETL1B = 31,
+ SETV = 32,
+ SETL1 = 33,
+ BINDV = 34,
+ CLOSE = 35,
+ GETLX = 36,
+ SETLX = 37,
+ GETF = 38,
} vm_op_t;
+
+#define VM_LEV_BITS 10
+#define VM_LEV_MASK 0x3FF
+#define VM_SM_LEV_BITS 6
+#define VM_SM_LEV_MASK 0x3F
+#define VM_MAX_LEV 63
+#define VM_MAX_V_LEV 61
+#define VM_LEV_SIZE 1024
diff --git a/win/cleansvg.txr b/win/cleansvg.txr
index 4ff50d32..7278f9a6 100755
--- a/win/cleansvg.txr
+++ b/win/cleansvg.txr
@@ -26,7 +26,7 @@
<?xml version="1.0" encoding="UTF-8" standalone="no"?>
<!-- TXR Logo
- Copyright 2017-2020 Kaz Kylheku <kaz@@kylheku.com> -->
+ Copyright 2017-2024 Kaz Kylheku <kaz@@kylheku.com> -->
<svg xmlns="@xmlns"
viewBox="0 0 @width @height"
diff --git a/y.tab.c.patch b/y.tab.c.patch
new file mode 100644
index 00000000..d5de8485
--- /dev/null
+++ b/y.tab.c.patch
@@ -0,0 +1,28 @@
+--- y.tab.c.shipped 2023-12-28 00:00:00.000000000 -0800
++++ y.tab.c.shipped 2023-12-28 00:00:00.000000000 -0800
+@@ -2975,9 +2975,6 @@
+ /* The semantic value of the lookahead symbol. */
+ YYSTYPE yylval;
+
+- /* Number of syntax errors so far. */
+- int yynerrs;
+-
+ int yystate;
+ /* Number of tokens to shift before error messages enabled. */
+ int yyerrstatus;
+@@ -3031,7 +3028,6 @@
+
+ yystate = 0;
+ yyerrstatus = 0;
+- yynerrs = 0;
+ yychar = YYEMPTY; /* Cause a token to be read. */
+
+ /* Initialize stack pointers.
+@@ -7047,7 +7043,6 @@
+ /* If not already recovering from an error, report this error. */
+ if (!yyerrstatus)
+ {
+- ++yynerrs;
+ #if ! YYERROR_VERBOSE
+ yyerror (scnr, parser, YY_("syntax error"));
+ #else
diff --git a/y.tab.c.shipped b/y.tab.c.shipped
new file mode 100644
index 00000000..b9156ccc
--- /dev/null
+++ b/y.tab.c.shipped
@@ -0,0 +1,7997 @@
+/* A Bison parser, made by GNU Bison 2.5. */
+
+/* C LALR(1) parser skeleton written by Richard Stallman, by
+ simplifying the original so-called "semantic" parser. */
+
+/* All symbols defined below should begin with yy or YY, to avoid
+ infringing on user name space. This should be done even for local
+ variables, as they might otherwise be expanded by user macros.
+ There are some unavoidable exceptions within include files to
+ define necessary library symbols; they are noted "INFRINGES ON
+ USER NAME SPACE" below. */
+
+/* Identify Bison output. */
+#define YYBISON 1
+
+/* Bison version. */
+#define YYBISON_VERSION "2.5"
+
+/* Skeleton name. */
+#define YYSKELETON_NAME "yacc.c"
+
+/* Pure parsers. */
+#define YYPURE 1
+
+/* Push parsers. */
+#define YYPUSH 0
+
+/* Pull parsers. */
+#define YYPULL 1
+
+/* Using locations. */
+#define YYLSP_NEEDED 0
+
+
+
+/* Copy the first part of user declarations. */
+
+/* Line 268 of yacc.c */
+#line 1 "parser.y"
+
+
+/* Copyright 2009-2024
+ * Kaz Kylheku <kaz@kylheku.com>
+ * Vancouver, Canada
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ */
+
+#include <stddef.h>
+#include <stdio.h>
+#include <assert.h>
+#include <limits.h>
+#include <stdlib.h>
+#include <wchar.h>
+#include <signal.h>
+#include "config.h"
+#include "alloca.h"
+#include "lib.h"
+#include "signal.h"
+#include "unwind.h"
+#include "regex.h"
+#include "match.h"
+#include "filter.h"
+#include "hash.h"
+#include "struct.h"
+#include "eval.h"
+#include "tree.h"
+#include "y.tab.h"
+#include "debug.h"
+#include "txr.h"
+#include "itypes.h"
+#include "buf.h"
+#include "parser.h"
+
+static void set_syntax_tree(parser_t *parser, val tree);
+static val sym_helper(parser_t *parser, wchar_t *lexeme, val meta_allowed);
+static val repeat_rep_helper(val sym, val args, val main, val parts);
+static void process_catch_exprs(val exprs);
+static val define_transform(parser_t *parser, val define_form);
+static val optimize_text(val text_form);
+static val rlrec(parser_t *, val form, val line);
+static val rlcp_parser(parser_t *parser, val to, val from);
+static wchar_t char_from_name(const wchar_t *name);
+static val make_expr(parser_t *, val sym, val rest, val lineno);
+static val check_parse_time_action(val spec_rev);
+static val uref_helper(parser_t *, val expr);
+static val uoref_helper(parser_t *, val expr);
+static val qref_helper(parser_t *, val lexpr, val rexpr);
+static val fname_helper(parser_t *, val name);
+static val output_helper(parser_t *, val sym, val exprs, val clauses);
+
+#if YYBISON
+union YYSTYPE;
+int yylex(union YYSTYPE *, yyscan_t scanner);
+int yyparse(scanner_t *, parser_t *);
+#endif
+
+#define rl(form, line) rlrec(parser, form, line)
+#define rlc(to, from) rlcp_parser(parser, to, from)
+#define mkexp(sym, rest, lineno) make_expr(parser, sym, rest, lineno)
+#define symhlpr(lexeme, meta_allowed) sym_helper(parser, lexeme, meta_allowed)
+#define yyerr(msg) yyerror(scnr, parser, msg)
+#define yybadtok(tok, context) yybadtoken(parser, tok, context)
+#define ifnign(expr) (parser->ignore ? nil : (expr))
+
+INLINE val expand_forms_ver(val forms, int ver)
+{
+ if (!opt_compat || opt_compat >= ver)
+ return expand_forms(forms, nil);
+ return forms;
+}
+
+INLINE val expand_form_ver(val form, int ver)
+{
+ if (!opt_compat || opt_compat >= ver)
+ return expand(form, nil);
+ return form;
+}
+
+
+
+/* Line 268 of yacc.c */
+#line 175 "y.tab.c"
+
+/* Enabling traces. */
+#ifndef YYDEBUG
+# define YYDEBUG 0
+#endif
+
+/* Enabling verbose error messages. */
+#ifdef YYERROR_VERBOSE
+# undef YYERROR_VERBOSE
+# define YYERROR_VERBOSE 1
+#else
+# define YYERROR_VERBOSE 0
+#endif
+
+/* Enabling the token table. */
+#ifndef YYTOKEN_TABLE
+# define YYTOKEN_TABLE 0
+#endif
+
+
+/* Tokens. */
+#ifndef YYTOKENTYPE
+# define YYTOKENTYPE
+ /* Put the tokens into the symbol table, so that GDB and other debuggers
+ know about them. */
+ enum yytokentype {
+ SPACE = 258,
+ TEXT = 259,
+ SYMTOK = 260,
+ ALL = 261,
+ SOME = 262,
+ NONE = 263,
+ MAYBE = 264,
+ CASES = 265,
+ BLOCK = 266,
+ CHOOSE = 267,
+ GATHER = 268,
+ AND = 269,
+ OR = 270,
+ END = 271,
+ COLLECT = 272,
+ UNTIL = 273,
+ COLL = 274,
+ OUTPUT = 275,
+ REPEAT = 276,
+ PUSH = 277,
+ REP = 278,
+ SINGLE = 279,
+ FIRST = 280,
+ LAST = 281,
+ EMPTY = 282,
+ MOD = 283,
+ MODLAST = 284,
+ DEFINE = 285,
+ TRY = 286,
+ CATCH = 287,
+ FINALLY = 288,
+ IF = 289,
+ ERRTOK = 290,
+ HASH_BACKSLASH = 291,
+ HASH_SLASH = 292,
+ DOTDOT = 293,
+ HASH_H = 294,
+ HASH_S = 295,
+ HASH_R = 296,
+ HASH_J = 297,
+ HASH_SEMI = 298,
+ HASH_B_QUOTE = 299,
+ HASH_N = 300,
+ HASH_T = 301,
+ WORDS = 302,
+ WSPLICE = 303,
+ QWORDS = 304,
+ QWSPLICE = 305,
+ SECRET_ESCAPE_R = 306,
+ SECRET_ESCAPE_E = 307,
+ SECRET_ESCAPE_I = 308,
+ SECRET_ESCAPE_J = 309,
+ OLD_DOTDOT = 310,
+ NUMBER = 311,
+ METANUM = 312,
+ JSKW = 313,
+ HASH_N_EQUALS = 314,
+ HASH_N_HASH = 315,
+ REGCHAR = 316,
+ REGTOKEN = 317,
+ LITCHAR = 318,
+ SPLICE = 319,
+ JSPLICE = 320,
+ OLD_AT = 321,
+ CONSDOT = 322,
+ LAMBDOT = 323,
+ UREFDOT = 324,
+ OREFDOT = 325,
+ UOREFDOT = 326,
+ LOW = 327,
+ ELSE = 328,
+ ELIF = 329
+ };
+#endif
+/* Tokens. */
+#define SPACE 258
+#define TEXT 259
+#define SYMTOK 260
+#define ALL 261
+#define SOME 262
+#define NONE 263
+#define MAYBE 264
+#define CASES 265
+#define BLOCK 266
+#define CHOOSE 267
+#define GATHER 268
+#define AND 269
+#define OR 270
+#define END 271
+#define COLLECT 272
+#define UNTIL 273
+#define COLL 274
+#define OUTPUT 275
+#define REPEAT 276
+#define PUSH 277
+#define REP 278
+#define SINGLE 279
+#define FIRST 280
+#define LAST 281
+#define EMPTY 282
+#define MOD 283
+#define MODLAST 284
+#define DEFINE 285
+#define TRY 286
+#define CATCH 287
+#define FINALLY 288
+#define IF 289
+#define ERRTOK 290
+#define HASH_BACKSLASH 291
+#define HASH_SLASH 292
+#define DOTDOT 293
+#define HASH_H 294
+#define HASH_S 295
+#define HASH_R 296
+#define HASH_J 297
+#define HASH_SEMI 298
+#define HASH_B_QUOTE 299
+#define HASH_N 300
+#define HASH_T 301
+#define WORDS 302
+#define WSPLICE 303
+#define QWORDS 304
+#define QWSPLICE 305
+#define SECRET_ESCAPE_R 306
+#define SECRET_ESCAPE_E 307
+#define SECRET_ESCAPE_I 308
+#define SECRET_ESCAPE_J 309
+#define OLD_DOTDOT 310
+#define NUMBER 311
+#define METANUM 312
+#define JSKW 313
+#define HASH_N_EQUALS 314
+#define HASH_N_HASH 315
+#define REGCHAR 316
+#define REGTOKEN 317
+#define LITCHAR 318
+#define SPLICE 319
+#define JSPLICE 320
+#define OLD_AT 321
+#define CONSDOT 322
+#define LAMBDOT 323
+#define UREFDOT 324
+#define OREFDOT 325
+#define UOREFDOT 326
+#define LOW 327
+#define ELSE 328
+#define ELIF 329
+
+
+
+
+#if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED
+typedef union YYSTYPE
+{
+
+/* Line 293 of yacc.c */
+#line 109 "parser.y"
+
+ wchar_t *lexeme;
+ union obj *val;
+ wchar_t chr;
+ cnum lineno;
+
+
+
+/* Line 293 of yacc.c */
+#line 368 "y.tab.c"
+} YYSTYPE;
+# define YYSTYPE_IS_TRIVIAL 1
+# define yystype YYSTYPE /* obsolescent; will be withdrawn */
+# define YYSTYPE_IS_DECLARED 1
+#endif
+
+
+/* Copy the second part of user declarations. */
+
+
+/* Line 343 of yacc.c */
+#line 380 "y.tab.c"
+
+#ifdef short
+# undef short
+#endif
+
+#ifdef YYTYPE_UINT8
+typedef YYTYPE_UINT8 yytype_uint8;
+#else
+typedef unsigned char yytype_uint8;
+#endif
+
+#ifdef YYTYPE_INT8
+typedef YYTYPE_INT8 yytype_int8;
+#elif (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+typedef signed char yytype_int8;
+#else
+typedef short int yytype_int8;
+#endif
+
+#ifdef YYTYPE_UINT16
+typedef YYTYPE_UINT16 yytype_uint16;
+#else
+typedef unsigned short int yytype_uint16;
+#endif
+
+#ifdef YYTYPE_INT16
+typedef YYTYPE_INT16 yytype_int16;
+#else
+typedef short int yytype_int16;
+#endif
+
+#ifndef YYSIZE_T
+# ifdef __SIZE_TYPE__
+# define YYSIZE_T __SIZE_TYPE__
+# elif defined size_t
+# define YYSIZE_T size_t
+# elif ! defined YYSIZE_T && (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+# include <stddef.h> /* INFRINGES ON USER NAME SPACE */
+# define YYSIZE_T size_t
+# else
+# define YYSIZE_T unsigned int
+# endif
+#endif
+
+#define YYSIZE_MAXIMUM ((YYSIZE_T) -1)
+
+#ifndef YY_
+# if defined YYENABLE_NLS && YYENABLE_NLS
+# if ENABLE_NLS
+# include <libintl.h> /* INFRINGES ON USER NAME SPACE */
+# define YY_(msgid) dgettext ("bison-runtime", msgid)
+# endif
+# endif
+# ifndef YY_
+# define YY_(msgid) msgid
+# endif
+#endif
+
+/* Suppress unused-variable warnings by "using" E. */
+#if ! defined lint || defined __GNUC__
+# define YYUSE(e) ((void) (e))
+#else
+# define YYUSE(e) /* empty */
+#endif
+
+/* Identity function, used to suppress warnings about constant conditions. */
+#ifndef lint
+# define YYID(n) (n)
+#else
+#if (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+static int
+YYID (int yyi)
+#else
+static int
+YYID (yyi)
+ int yyi;
+#endif
+{
+ return yyi;
+}
+#endif
+
+#if ! defined yyoverflow || YYERROR_VERBOSE
+
+/* The parser invokes alloca or malloc; define the necessary symbols. */
+
+# ifdef YYSTACK_USE_ALLOCA
+# if YYSTACK_USE_ALLOCA
+# ifdef __GNUC__
+# define YYSTACK_ALLOC __builtin_alloca
+# elif defined __BUILTIN_VA_ARG_INCR
+# include <alloca.h> /* INFRINGES ON USER NAME SPACE */
+# elif defined _AIX
+# define YYSTACK_ALLOC __alloca
+# elif defined _MSC_VER
+# include <malloc.h> /* INFRINGES ON USER NAME SPACE */
+# define alloca _alloca
+# else
+# define YYSTACK_ALLOC alloca
+# if ! defined _ALLOCA_H && ! defined EXIT_SUCCESS && (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+# include <stdlib.h> /* INFRINGES ON USER NAME SPACE */
+# ifndef EXIT_SUCCESS
+# define EXIT_SUCCESS 0
+# endif
+# endif
+# endif
+# endif
+# endif
+
+# ifdef YYSTACK_ALLOC
+ /* Pacify GCC's `empty if-body' warning. */
+# define YYSTACK_FREE(Ptr) do { /* empty */; } while (YYID (0))
+# ifndef YYSTACK_ALLOC_MAXIMUM
+ /* The OS might guarantee only one guard page at the bottom of the stack,
+ and a page size can be as small as 4096 bytes. So we cannot safely
+ invoke alloca (N) if N exceeds 4096. Use a slightly smaller number
+ to allow for a few compiler-allocated temporary stack slots. */
+# define YYSTACK_ALLOC_MAXIMUM 4032 /* reasonable circa 2006 */
+# endif
+# else
+# define YYSTACK_ALLOC YYMALLOC
+# define YYSTACK_FREE YYFREE
+# ifndef YYSTACK_ALLOC_MAXIMUM
+# define YYSTACK_ALLOC_MAXIMUM YYSIZE_MAXIMUM
+# endif
+# if (defined __cplusplus && ! defined EXIT_SUCCESS \
+ && ! ((defined YYMALLOC || defined malloc) \
+ && (defined YYFREE || defined free)))
+# include <stdlib.h> /* INFRINGES ON USER NAME SPACE */
+# ifndef EXIT_SUCCESS
+# define EXIT_SUCCESS 0
+# endif
+# endif
+# ifndef YYMALLOC
+# define YYMALLOC malloc
+# if ! defined malloc && ! defined EXIT_SUCCESS && (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+void *malloc (YYSIZE_T); /* INFRINGES ON USER NAME SPACE */
+# endif
+# endif
+# ifndef YYFREE
+# define YYFREE free
+# if ! defined free && ! defined EXIT_SUCCESS && (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+void free (void *); /* INFRINGES ON USER NAME SPACE */
+# endif
+# endif
+# endif
+#endif /* ! defined yyoverflow || YYERROR_VERBOSE */
+
+
+#if (! defined yyoverflow \
+ && (! defined __cplusplus \
+ || (defined YYSTYPE_IS_TRIVIAL && YYSTYPE_IS_TRIVIAL)))
+
+/* A type that is properly aligned for any stack member. */
+union yyalloc
+{
+ yytype_int16 yyss_alloc;
+ YYSTYPE yyvs_alloc;
+};
+
+/* The size of the maximum gap between one aligned stack and the next. */
+# define YYSTACK_GAP_MAXIMUM (sizeof (union yyalloc) - 1)
+
+/* The size of an array large to enough to hold all stacks, each with
+ N elements. */
+# define YYSTACK_BYTES(N) \
+ ((N) * (sizeof (yytype_int16) + sizeof (YYSTYPE)) \
+ + YYSTACK_GAP_MAXIMUM)
+
+# define YYCOPY_NEEDED 1
+
+/* Relocate STACK from its old location to the new one. The
+ local variables YYSIZE and YYSTACKSIZE give the old and new number of
+ elements in the stack, and YYPTR gives the new location of the
+ stack. Advance YYPTR to a properly aligned location for the next
+ stack. */
+# define YYSTACK_RELOCATE(Stack_alloc, Stack) \
+ do \
+ { \
+ YYSIZE_T yynewbytes; \
+ YYCOPY (&yyptr->Stack_alloc, Stack, yysize); \
+ Stack = &yyptr->Stack_alloc; \
+ yynewbytes = yystacksize * sizeof (*Stack) + YYSTACK_GAP_MAXIMUM; \
+ yyptr += yynewbytes / sizeof (*yyptr); \
+ } \
+ while (YYID (0))
+
+#endif
+
+#if defined YYCOPY_NEEDED && YYCOPY_NEEDED
+/* Copy COUNT objects from FROM to TO. The source and destination do
+ not overlap. */
+# ifndef YYCOPY
+# if defined __GNUC__ && 1 < __GNUC__
+# define YYCOPY(To, From, Count) \
+ __builtin_memcpy (To, From, (Count) * sizeof (*(From)))
+# else
+# define YYCOPY(To, From, Count) \
+ do \
+ { \
+ YYSIZE_T yyi; \
+ for (yyi = 0; yyi < (Count); yyi++) \
+ (To)[yyi] = (From)[yyi]; \
+ } \
+ while (YYID (0))
+# endif
+# endif
+#endif /* !YYCOPY_NEEDED */
+
+/* YYFINAL -- State number of the termination state. */
+#define YYFINAL 213
+/* YYLAST -- Last index in YYTABLE. */
+#define YYLAST 4920
+
+/* YYNTOKENS -- Number of terminals. */
+#define YYNTOKENS 101
+/* YYNNTS -- Number of nonterminals. */
+#define YYNNTS 132
+/* YYNRULES -- Number of rules. */
+#define YYNRULES 473
+/* YYNRULES -- Number of states. */
+#define YYNSTATES 840
+
+/* YYTRANSLATE(YYLEX) -- Bison symbol number corresponding to YYLEX. */
+#define YYUNDEFTOK 2
+#define YYMAXUTOK 329
+
+#define YYTRANSLATE(YYX) \
+ ((unsigned int) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK)
+
+/* YYTRANSLATE[YYLEX] -- Bison symbol number corresponding to YYLEX. */
+static const yytype_uint8 yytranslate[] =
+{
+ 0, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 95, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 100, 2, 97, 96, 2, 93, 88, 84,
+ 72, 81, 90, 92, 83, 82, 94, 87, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 98, 2,
+ 2, 2, 2, 91, 74, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 73, 2, 80, 85, 2, 99, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 76, 86, 77, 89, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 1, 2, 3, 4,
+ 5, 6, 7, 8, 9, 10, 11, 12, 13, 14,
+ 15, 16, 17, 18, 19, 20, 21, 22, 23, 24,
+ 25, 26, 27, 28, 29, 30, 31, 32, 33, 34,
+ 35, 36, 37, 38, 39, 40, 41, 42, 43, 44,
+ 45, 46, 47, 48, 49, 50, 51, 52, 53, 54,
+ 55, 56, 57, 58, 59, 60, 61, 62, 63, 64,
+ 65, 66, 67, 68, 69, 70, 71, 75, 78, 79
+};
+
+#if YYDEBUG
+/* YYPRHS[YYN] -- Index of the first RHS symbol of rule number YYN in
+ YYRHS. */
+static const yytype_uint16 yyprhs[] =
+{
+ 0, 0, 3, 5, 8, 9, 14, 15, 20, 22,
+ 24, 25, 30, 32, 35, 36, 40, 41, 46, 47,
+ 52, 54, 57, 60, 61, 65, 66, 71, 72, 77,
+ 79, 82, 85, 87, 89, 90, 92, 95, 97, 98,
+ 100, 102, 104, 106, 108, 110, 112, 114, 116, 118,
+ 120, 122, 124, 126, 130, 134, 140, 146, 150, 154,
+ 158, 162, 166, 170, 178, 184, 190, 196, 204, 217,
+ 223, 226, 230, 234, 235, 243, 256, 262, 264, 266,
+ 268, 270, 273, 276, 280, 284, 294, 300, 307, 308,
+ 312, 313, 316, 318, 319, 321, 324, 326, 328, 330,
+ 332, 334, 337, 339, 341, 343, 349, 359, 365, 375,
+ 381, 384, 387, 390, 393, 398, 401, 404, 407, 412,
+ 418, 421, 423, 426, 429, 437, 444, 447, 453, 458,
+ 465, 469, 475, 482, 486, 487, 492, 498, 502, 510,
+ 516, 523, 531, 540, 543, 549, 554, 561, 567, 569,
+ 571, 573, 576, 578, 580, 582, 591, 595, 600, 605,
+ 612, 617, 624, 631, 632, 642, 645, 651, 658, 659,
+ 663, 664, 666, 667, 670, 672, 673, 675, 678, 680,
+ 683, 685, 687, 689, 691, 693, 700, 703, 707, 711,
+ 717, 721, 727, 733, 734, 736, 740, 745, 748, 753,
+ 759, 765, 768, 771, 773, 775, 777, 779, 781, 783,
+ 788, 791, 797, 801, 804, 807, 810, 813, 816, 819,
+ 822, 825, 828, 831, 834, 837, 840, 841, 846, 848,
+ 850, 853, 857, 860, 865, 868, 873, 874, 878, 879,
+ 883, 884, 888, 890, 893, 896, 899, 901, 902, 904,
+ 908, 911, 914, 918, 924, 927, 931, 934, 936, 938,
+ 942, 947, 950, 955, 960, 963, 966, 969, 972, 975,
+ 980, 984, 987, 992, 997, 1000, 1002, 1004, 1006, 1008,
+ 1010, 1011, 1013, 1017, 1019, 1020, 1024, 1025, 1030, 1031,
+ 1036, 1037, 1043, 1046, 1049, 1053, 1056, 1060, 1062, 1064,
+ 1066, 1068, 1070, 1072, 1074, 1076, 1078, 1080, 1082, 1084,
+ 1086, 1088, 1090, 1093, 1096, 1098, 1101, 1102, 1106, 1107,
+ 1111, 1112, 1116, 1117, 1121, 1123, 1126, 1128, 1130, 1132,
+ 1134, 1136, 1138, 1140, 1142, 1144, 1146, 1148, 1150, 1152,
+ 1154, 1156, 1158, 1161, 1164, 1166, 1169, 1170, 1174, 1175,
+ 1179, 1180, 1184, 1188, 1193, 1197, 1202, 1206, 1210, 1213,
+ 1216, 1217, 1221, 1223, 1225, 1226, 1229, 1232, 1234, 1238,
+ 1241, 1245, 1248, 1250, 1254, 1258, 1261, 1262, 1264, 1267,
+ 1271, 1274, 1277, 1280, 1284, 1288, 1291, 1294, 1296, 1298,
+ 1300, 1302, 1304, 1306, 1310, 1313, 1315, 1318, 1320, 1322,
+ 1324, 1328, 1330, 1332, 1334, 1336, 1338, 1340, 1342, 1344,
+ 1346, 1348, 1350, 1352, 1354, 1356, 1359, 1362, 1366, 1369,
+ 1372, 1375, 1378, 1381, 1384, 1388, 1391, 1393, 1396, 1398,
+ 1400, 1402, 1405, 1407, 1410, 1412, 1415, 1417, 1420, 1422,
+ 1425, 1427, 1430, 1433, 1435, 1437, 1440, 1443, 1447, 1450,
+ 1454, 1457, 1460, 1462, 1465, 1468, 1470, 1472, 1474, 1476,
+ 1478, 1480, 1482, 1484, 1486, 1490, 1494, 1498, 1502, 1506,
+ 1510, 1514, 1520, 1524
+};
+
+/* YYRHS -- A `-1'-separated list of the rules' RHS. */
+static const yytype_int16 yyrhs[] =
+{
+ 102, 0, -1, 116, -1, 51, 211, -1, -1, 52,
+ 106, 103, 114, -1, -1, 53, 110, 104, 114, -1,
+ 52, -1, 53, -1, -1, 54, 176, 105, 114, -1,
+ 54, -1, 1, 95, -1, -1, 43, 107, 202, -1,
+ -1, 43, 94, 108, 202, -1, -1, 43, 70, 109,
+ 202, -1, 202, -1, 94, 202, -1, 70, 202, -1,
+ -1, 43, 111, 196, -1, -1, 43, 94, 112, 196,
+ -1, -1, 43, 70, 113, 196, -1, 196, -1, 94,
+ 196, -1, 70, 196, -1, 202, -1, 43, -1, -1,
+ 117, -1, 115, 117, -1, 115, -1, -1, 118, -1,
+ 119, -1, 120, -1, 121, -1, 122, -1, 123, -1,
+ 124, -1, 128, -1, 125, -1, 144, -1, 145, -1,
+ 133, -1, 147, -1, 136, -1, 6, 219, 131, -1,
+ 6, 219, 1, -1, 7, 189, 81, 219, 131, -1,
+ 7, 189, 81, 219, 1, -1, 8, 219, 131, -1,
+ 8, 219, 1, -1, 9, 219, 131, -1, 9, 219,
+ 1, -1, 10, 219, 131, -1, 10, 219, 1, -1,
+ 11, 189, 81, 219, 116, 16, 219, -1, 11, 189,
+ 81, 219, 1, -1, 12, 189, 81, 219, 131, -1,
+ 12, 189, 81, 219, 1, -1, 13, 189, 81, 219,
+ 126, 16, 219, -1, 13, 189, 81, 219, 126, 130,
+ 189, 81, 219, 116, 16, 219, -1, 13, 189, 81,
+ 219, 1, -1, 116, 127, -1, 14, 219, 126, -1,
+ 15, 219, 126, -1, -1, 129, 189, 81, 219, 116,
+ 16, 219, -1, 129, 189, 81, 219, 116, 130, 189,
+ 81, 219, 116, 16, 219, -1, 129, 189, 81, 219,
+ 1, -1, 17, -1, 21, -1, 18, -1, 26, -1,
+ 116, 132, -1, 16, 219, -1, 14, 219, 131, -1,
+ 15, 219, 131, -1, 34, 207, 81, 219, 116, 134,
+ 135, 16, 219, -1, 34, 207, 81, 219, 1, -1,
+ 79, 207, 81, 219, 116, 134, -1, -1, 78, 219,
+ 116, -1, -1, 137, 95, -1, 138, -1, -1, 141,
+ -1, 141, 138, -1, 4, -1, 3, -1, 209, -1,
+ 27, -1, 139, -1, 139, 140, -1, 140, -1, 163,
+ -1, 184, -1, 19, 189, 81, 137, 16, -1, 19,
+ 189, 81, 137, 130, 189, 81, 137, 16, -1, 23,
+ 189, 81, 138, 16, -1, 23, 189, 81, 138, 130,
+ 189, 81, 138, 16, -1, 11, 189, 81, 138, 16,
+ -1, 19, 1, -1, 23, 1, -1, 11, 1, -1,
+ 6, 142, -1, 7, 189, 81, 142, -1, 8, 142,
+ -1, 9, 142, -1, 10, 142, -1, 12, 189, 81,
+ 142, -1, 30, 188, 81, 138, 16, -1, 137, 143,
+ -1, 16, -1, 14, 142, -1, 15, 142, -1, 30,
+ 188, 81, 219, 116, 16, 219, -1, 30, 81, 219,
+ 116, 16, 219, -1, 30, 1, -1, 30, 188, 81,
+ 219, 1, -1, 30, 81, 219, 1, -1, 31, 219,
+ 116, 146, 16, 219, -1, 31, 219, 1, -1, 32,
+ 81, 219, 116, 146, -1, 32, 188, 81, 219, 116,
+ 146, -1, 33, 219, 116, -1, -1, 32, 81, 219,
+ 1, -1, 32, 188, 81, 219, 1, -1, 33, 219,
+ 1, -1, 148, 81, 159, 95, 149, 16, 219, -1,
+ 148, 81, 219, 16, 219, -1, 148, 81, 219, 149,
+ 16, 219, -1, 148, 188, 81, 219, 149, 16, 219,
+ -1, 148, 188, 81, 159, 95, 149, 16, 219, -1,
+ 148, 1, -1, 148, 81, 159, 95, 1, -1, 148,
+ 81, 219, 1, -1, 148, 188, 81, 159, 95, 1,
+ -1, 148, 188, 81, 219, 1, -1, 20, -1, 22,
+ -1, 150, -1, 150, 149, -1, 151, -1, 153, -1,
+ 157, -1, 21, 207, 81, 219, 156, 152, 16, 219,
+ -1, 21, 219, 1, -1, 24, 219, 156, 152, -1,
+ 25, 219, 156, 152, -1, 26, 189, 81, 219, 156,
+ 152, -1, 27, 219, 156, 152, -1, 28, 189, 81,
+ 219, 156, 152, -1, 29, 189, 81, 219, 156, 152,
+ -1, -1, 34, 202, 81, 219, 156, 154, 155, 16,
+ 219, -1, 34, 81, -1, 34, 202, 81, 219, 1,
+ -1, 79, 207, 81, 219, 156, 154, -1, -1, 78,
+ 219, 156, -1, -1, 149, -1, -1, 158, 95, -1,
+ 159, -1, -1, 160, -1, 160, 159, -1, 232, -1,
+ 232, 159, -1, 4, -1, 3, -1, 166, -1, 187,
+ -1, 161, -1, 23, 207, 81, 158, 162, 16, -1,
+ 23, 1, -1, 24, 158, 162, -1, 25, 158, 162,
+ -1, 26, 189, 81, 158, 162, -1, 27, 158, 162,
+ -1, 28, 189, 81, 158, 162, -1, 29, 189, 81,
+ 158, 162, -1, -1, 5, -1, 76, 5, 77, -1,
+ 76, 5, 165, 77, -1, 164, 5, -1, 164, 76,
+ 5, 77, -1, 164, 76, 5, 209, 77, -1, 164,
+ 76, 5, 56, 77, -1, 5, 1, -1, 164, 1,
+ -1, 90, -1, 56, -1, 209, -1, 187, -1, 5,
+ -1, 5, -1, 76, 202, 207, 77, -1, 5, 1,
+ -1, 74, 76, 202, 207, 77, -1, 74, 76, 1,
+ -1, 96, 184, -1, 96, 1, -1, 39, 184, -1,
+ 39, 1, -1, 40, 184, -1, 40, 1, -1, 41,
+ 184, -1, 41, 1, -1, 45, 184, -1, 45, 1,
+ -1, 46, 184, -1, 46, 1, -1, 42, 176, -1,
+ -1, 42, 85, 175, 176, -1, 56, -1, 58, -1,
+ 97, 97, -1, 97, 225, 97, -1, 73, 80, -1,
+ 73, 181, 180, 80, -1, 76, 77, -1, 76, 182,
+ 180, 77, -1, -1, 89, 177, 208, -1, -1, 65,
+ 178, 208, -1, -1, 59, 179, 176, -1, 60, -1,
+ 97, 1, -1, 73, 1, -1, 76, 1, -1, 83,
+ -1, -1, 176, -1, 181, 83, 176, -1, 181, 176,
+ -1, 181, 1, -1, 176, 183, 176, -1, 182, 83,
+ 176, 183, 176, -1, 176, 176, -1, 182, 176, 1,
+ -1, 176, 1, -1, 5, -1, 98, -1, 72, 190,
+ 81, -1, 72, 94, 190, 81, -1, 72, 81, -1,
+ 72, 68, 202, 81, -1, 72, 67, 202, 81, -1,
+ 72, 1, -1, 74, 202, -1, 74, 1, -1, 66,
+ 202, -1, 66, 1, -1, 73, 94, 190, 80, -1,
+ 73, 190, 80, -1, 73, 80, -1, 73, 68, 202,
+ 80, -1, 73, 67, 202, 80, -1, 73, 1, -1,
+ 184, -1, 186, -1, 185, -1, 190, -1, 188, -1,
+ -1, 191, -1, 191, 67, 202, -1, 202, -1, -1,
+ 43, 192, 202, -1, -1, 43, 94, 193, 202, -1,
+ -1, 191, 43, 194, 202, -1, -1, 191, 43, 94,
+ 195, 202, -1, 191, 202, -1, 48, 227, -1, 191,
+ 48, 227, -1, 50, 228, -1, 191, 50, 228, -1,
+ 5, -1, 57, -1, 56, -1, 187, -1, 168, -1,
+ 169, -1, 170, -1, 171, -1, 172, -1, 173, -1,
+ 174, -1, 210, -1, 221, -1, 220, -1, 222, -1,
+ 47, 227, -1, 49, 228, -1, 229, -1, 84, 201,
+ -1, -1, 85, 197, 201, -1, -1, 83, 198, 201,
+ -1, -1, 64, 199, 201, -1, -1, 59, 200, 201,
+ -1, 60, -1, 94, 196, -1, 196, -1, 5, -1,
+ 57, -1, 56, -1, 187, -1, 168, -1, 169, -1,
+ 170, -1, 171, -1, 172, -1, 173, -1, 174, -1,
+ 210, -1, 221, -1, 220, -1, 222, -1, 47, 227,
+ -1, 49, 228, -1, 229, -1, 84, 208, -1, -1,
+ 85, 203, 208, -1, -1, 83, 204, 208, -1, -1,
+ 64, 205, 208, -1, 202, 38, 202, -1, 202, 38,
+ 94, 202, -1, 202, 55, 202, -1, 202, 55, 94,
+ 202, -1, 202, 94, 202, -1, 202, 70, 202, -1,
+ 69, 202, -1, 71, 202, -1, -1, 59, 206, 208,
+ -1, 60, -1, 190, -1, -1, 94, 202, -1, 70,
+ 202, -1, 202, -1, 87, 211, 87, -1, 87, 1,
+ -1, 37, 211, 87, -1, 37, 1, -1, 212, -1,
+ 211, 86, 211, -1, 211, 88, 211, -1, 89, 211,
+ -1, -1, 213, -1, 213, 212, -1, 213, 89, 211,
+ -1, 213, 90, -1, 213, 92, -1, 213, 91, -1,
+ 213, 93, 211, -1, 73, 214, 80, -1, 73, 80,
+ -1, 73, 1, -1, 94, -1, 80, -1, 82, -1,
+ 61, -1, 218, -1, 4, -1, 72, 211, 81, -1,
+ 72, 1, -1, 215, -1, 215, 214, -1, 216, -1,
+ 217, -1, 218, -1, 217, 82, 217, -1, 91, -1,
+ 94, -1, 90, -1, 92, -1, 72, -1, 81, -1,
+ 86, -1, 89, -1, 88, -1, 93, -1, 87, -1,
+ 61, -1, 62, -1, 95, -1, 1, 95, -1, 97,
+ 97, -1, 97, 225, 97, -1, 97, 1, -1, 36,
+ 5, -1, 36, 63, -1, 36, 4, -1, 36, 1,
+ -1, 99, 99, -1, 99, 223, 99, -1, 99, 1,
+ -1, 224, -1, 224, 223, -1, 225, -1, 167, -1,
+ 57, -1, 74, 202, -1, 63, -1, 63, 226, -1,
+ 4, -1, 4, 226, -1, 63, -1, 226, 63, -1,
+ 4, -1, 226, 4, -1, 97, -1, 100, 227, -1,
+ 225, 227, -1, 1, -1, 99, -1, 100, 228, -1,
+ 223, 99, -1, 223, 100, 228, -1, 44, 84, -1,
+ 44, 230, 84, -1, 44, 1, -1, 230, 231, -1,
+ 231, -1, 63, 63, -1, 63, 1, -1, 6, -1,
+ 7, -1, 8, -1, 9, -1, 10, -1, 14, -1,
+ 15, -1, 31, -1, 33, -1, 11, 189, 81, -1,
+ 12, 189, 81, -1, 17, 189, 81, -1, 19, 189,
+ 81, -1, 13, 189, 81, -1, 30, 189, 81, -1,
+ 32, 189, 81, -1, 34, 202, 202, 189, 81, -1,
+ 20, 189, 81, -1, 22, 189, 81, -1
+};
+
+/* YYRLINE[YYN] -- source line where rule number YYN was defined. */
+static const yytype_uint16 yyrline[] =
+{
+ 0, 177, 177, 178, 181, 180, 184, 183, 186, 193,
+ 200, 200, 203, 210, 219, 219, 222, 222, 225, 225,
+ 228, 229, 230, 233, 233, 236, 236, 239, 239, 242,
+ 243, 244, 249, 250, 251, 254, 255, 258, 259, 262,
+ 263, 264, 265, 266, 267, 268, 269, 270, 271, 274,
+ 275, 276, 277, 280, 282, 286, 289, 295, 297, 301,
+ 303, 307, 309, 313, 324, 329, 332, 337, 346, 358,
+ 363, 367, 368, 369, 372, 378, 390, 395, 396, 399,
+ 400, 403, 406, 407, 408, 411, 434, 438, 451, 454,
+ 459, 462, 465, 466, 469, 471, 476, 477, 485, 487,
+ 490, 491, 494, 496, 498, 509, 512, 520, 523, 532,
+ 535, 537, 539, 541, 542, 544, 545, 546, 547, 550,
+ 556, 559, 560, 561, 564, 569, 573, 575, 577, 582,
+ 590, 595, 600, 606, 611, 612, 615, 618, 624, 629,
+ 631, 634, 638, 643, 645, 648, 651, 654, 659, 660,
+ 663, 664, 667, 668, 669, 672, 678, 683, 687, 691,
+ 700, 704, 711, 718, 721, 733, 736, 740, 751, 754,
+ 757, 760, 761, 763, 766, 768, 771, 772, 773, 774,
+ 777, 779, 781, 782, 784, 787, 790, 794, 797, 800,
+ 808, 811, 817, 823, 830, 831, 832, 833, 834, 835,
+ 839, 844, 847, 851, 854, 855, 857, 859, 862, 867,
+ 876, 881, 884, 889, 894, 898, 906, 910, 920, 924,
+ 928, 932, 937, 941, 956, 960, 962, 962, 966, 967,
+ 968, 969, 971, 972, 978, 979, 985, 985, 990, 990,
+ 995, 995, 998, 999, 1001, 1003, 1007, 1009, 1012, 1015,
+ 1023, 1025, 1029, 1034, 1043, 1044, 1046, 1049, 1053, 1057,
+ 1058, 1064, 1065, 1066, 1067, 1071, 1076, 1080, 1085, 1089,
+ 1093, 1094, 1095, 1096, 1097, 1101, 1102, 1103, 1106, 1109,
+ 1110, 1113, 1117, 1122, 1125, 1125, 1129, 1129, 1133, 1133,
+ 1136, 1136, 1139, 1142, 1144, 1148, 1150, 1156, 1157, 1159,
+ 1160, 1161, 1162, 1163, 1164, 1165, 1166, 1167, 1168, 1169,
+ 1170, 1171, 1172, 1173, 1174, 1175, 1177, 1177, 1181, 1181,
+ 1185, 1185, 1189, 1189, 1192, 1195, 1196, 1198, 1199, 1201,
+ 1202, 1203, 1204, 1205, 1206, 1207, 1208, 1209, 1210, 1211,
+ 1212, 1213, 1214, 1215, 1216, 1217, 1219, 1219, 1223, 1223,
+ 1227, 1227, 1231, 1234, 1240, 1244, 1250, 1251, 1254, 1255,
+ 1256, 1256, 1259, 1262, 1263, 1266, 1267, 1268, 1271, 1274,
+ 1279, 1283, 1289, 1292, 1293, 1294, 1295, 1298, 1299, 1300,
+ 1303, 1304, 1305, 1306, 1307, 1314, 1315, 1317, 1318, 1319,
+ 1320, 1321, 1322, 1323, 1324, 1328, 1329, 1332, 1333, 1334,
+ 1337, 1339, 1340, 1341, 1342, 1343, 1344, 1345, 1346, 1347,
+ 1348, 1349, 1350, 1353, 1367, 1368, 1372, 1373, 1375, 1379,
+ 1392, 1394, 1398, 1403, 1404, 1407, 1411, 1413, 1417, 1418,
+ 1419, 1421, 1428, 1429, 1431, 1432, 1435, 1436, 1437, 1438,
+ 1441, 1442, 1443, 1445, 1449, 1450, 1451, 1453, 1459, 1461,
+ 1464, 1469, 1471, 1475, 1476, 1483, 1484, 1485, 1486, 1487,
+ 1488, 1489, 1490, 1491, 1492, 1494, 1496, 1498, 1500, 1502,
+ 1504, 1506, 1511, 1513
+};
+#endif
+
+#if YYDEBUG || YYERROR_VERBOSE || YYTOKEN_TABLE
+/* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM.
+ First, the terminals, then, starting at YYNTOKENS, nonterminals. */
+static const char *const yytname[] =
+{
+ "$end", "error", "$undefined", "SPACE", "TEXT", "SYMTOK", "ALL", "SOME",
+ "NONE", "MAYBE", "CASES", "BLOCK", "CHOOSE", "GATHER", "AND", "OR",
+ "END", "COLLECT", "UNTIL", "COLL", "OUTPUT", "REPEAT", "PUSH", "REP",
+ "SINGLE", "FIRST", "LAST", "EMPTY", "MOD", "MODLAST", "DEFINE", "TRY",
+ "CATCH", "FINALLY", "IF", "ERRTOK", "HASH_BACKSLASH", "HASH_SLASH",
+ "DOTDOT", "HASH_H", "HASH_S", "HASH_R", "HASH_J", "HASH_SEMI",
+ "HASH_B_QUOTE", "HASH_N", "HASH_T", "WORDS", "WSPLICE", "QWORDS",
+ "QWSPLICE", "SECRET_ESCAPE_R", "SECRET_ESCAPE_E", "SECRET_ESCAPE_I",
+ "SECRET_ESCAPE_J", "OLD_DOTDOT", "NUMBER", "METANUM", "JSKW",
+ "HASH_N_EQUALS", "HASH_N_HASH", "REGCHAR", "REGTOKEN", "LITCHAR",
+ "SPLICE", "JSPLICE", "OLD_AT", "CONSDOT", "LAMBDOT", "UREFDOT",
+ "OREFDOT", "UOREFDOT", "'('", "'['", "'@'", "LOW", "'{'", "'}'", "ELSE",
+ "ELIF", "']'", "')'", "'-'", "','", "'\\''", "'^'", "'|'", "'/'", "'&'",
+ "'~'", "'*'", "'?'", "'+'", "'%'", "'.'", "'\\n'", "'#'", "'\"'", "':'",
+ "'`'", "' '", "$accept", "spec", "$@1", "$@2", "$@3",
+ "hash_semi_or_n_expr", "$@4", "$@5", "$@6", "hash_semi_or_i_expr", "$@7",
+ "$@8", "$@9", "byacc_fool", "clauses_rev", "clauses_opt", "clause",
+ "all_clause", "some_clause", "none_clause", "maybe_clause",
+ "cases_clause", "block_clause", "choose_clause", "gather_clause",
+ "gather_parts", "additional_gather_parts", "collect_clause",
+ "collect_repeat", "until_last", "clause_parts", "additional_parts",
+ "if_clause", "elif_clauses_opt", "else_clause_opt", "line", "elems_opt",
+ "elems", "text", "texts", "elem", "clause_parts_h", "additional_parts_h",
+ "define_clause", "try_clause", "catch_clauses_opt", "output_clause",
+ "output_push", "out_clauses", "out_clause", "repeat_clause",
+ "repeat_parts_opt", "out_if_clause", "out_elif_clauses_opt",
+ "out_else_clause_opt", "out_clauses_opt", "o_line", "o_elems_opt",
+ "o_elems", "o_elem", "rep_elem", "rep_parts_opt", "var", "var_op",
+ "modifiers", "o_var", "q_var", "vector", "hash", "struct", "range",
+ "tnode", "tree", "json", "$@10", "json_val", "$@11", "$@12", "$@13",
+ "opt_comma", "json_vals", "json_pairs", "json_col", "list", "meta",
+ "dwim", "compound", "exprs", "exprs_opt", "n_exprs", "listacc", "$@14",
+ "$@15", "$@16", "$@17", "i_expr", "$@18", "$@19", "$@20", "$@21",
+ "i_dot_expr", "n_expr", "$@22", "$@23", "$@24", "$@25", "n_exprs_opt",
+ "n_dot_expr", "regex", "lisp_regex", "regexpr", "regbranch", "regterm",
+ "regclass", "regclassterm", "regrange", "regchar", "regtoken", "newl",
+ "strlit", "chrlit", "quasilit", "quasi_items", "quasi_item", "litchars",
+ "restlitchar", "wordslit", "wordsqlit", "buflit", "buflit_items",
+ "buflit_item", "not_a_clause", 0
+};
+#endif
+
+# ifdef YYPRINT
+/* YYTOKNUM[YYLEX-NUM] -- Internal token number corresponding to
+ token YYLEX-NUM. */
+static const yytype_uint16 yytoknum[] =
+{
+ 0, 256, 257, 258, 259, 260, 261, 262, 263, 264,
+ 265, 266, 267, 268, 269, 270, 271, 272, 273, 274,
+ 275, 276, 277, 278, 279, 280, 281, 282, 283, 284,
+ 285, 286, 287, 288, 289, 290, 291, 292, 293, 294,
+ 295, 296, 297, 298, 299, 300, 301, 302, 303, 304,
+ 305, 306, 307, 308, 309, 310, 311, 312, 313, 314,
+ 315, 316, 317, 318, 319, 320, 321, 322, 323, 324,
+ 325, 326, 40, 91, 64, 327, 123, 125, 328, 329,
+ 93, 41, 45, 44, 39, 94, 124, 47, 38, 126,
+ 42, 63, 43, 37, 46, 10, 35, 34, 58, 96,
+ 32
+};
+# endif
+
+/* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */
+static const yytype_uint8 yyr1[] =
+{
+ 0, 101, 102, 102, 103, 102, 104, 102, 102, 102,
+ 105, 102, 102, 102, 107, 106, 108, 106, 109, 106,
+ 106, 106, 106, 111, 110, 112, 110, 113, 110, 110,
+ 110, 110, 114, 114, 114, 115, 115, 116, 116, 117,
+ 117, 117, 117, 117, 117, 117, 117, 117, 117, 117,
+ 117, 117, 117, 118, 118, 119, 119, 120, 120, 121,
+ 121, 122, 122, 123, 123, 124, 124, 125, 125, 125,
+ 126, 127, 127, 127, 128, 128, 128, 129, 129, 130,
+ 130, 131, 132, 132, 132, 133, 133, 134, 134, 135,
+ 135, 136, 137, 137, 138, 138, 139, 139, 139, 139,
+ 140, 140, 141, 141, 141, 141, 141, 141, 141, 141,
+ 141, 141, 141, 141, 141, 141, 141, 141, 141, 141,
+ 142, 143, 143, 143, 144, 144, 144, 144, 144, 145,
+ 145, 146, 146, 146, 146, 146, 146, 146, 147, 147,
+ 147, 147, 147, 147, 147, 147, 147, 147, 148, 148,
+ 149, 149, 150, 150, 150, 151, 151, 152, 152, 152,
+ 152, 152, 152, 152, 153, 153, 153, 154, 154, 155,
+ 155, 156, 156, 157, 158, 158, 159, 159, 159, 159,
+ 160, 160, 160, 160, 160, 161, 161, 162, 162, 162,
+ 162, 162, 162, 162, 163, 163, 163, 163, 163, 163,
+ 163, 163, 163, 164, 165, 165, 165, 165, 166, 166,
+ 166, 167, 167, 168, 168, 169, 169, 170, 170, 171,
+ 171, 172, 172, 173, 173, 174, 175, 174, 176, 176,
+ 176, 176, 176, 176, 176, 176, 177, 176, 178, 176,
+ 179, 176, 176, 176, 176, 176, 180, 180, 181, 181,
+ 181, 181, 182, 182, 182, 182, 182, 183, 183, 184,
+ 184, 184, 184, 184, 184, 185, 185, 185, 185, 186,
+ 186, 186, 186, 186, 186, 187, 187, 187, 188, 189,
+ 189, 190, 190, 191, 192, 191, 193, 191, 194, 191,
+ 195, 191, 191, 191, 191, 191, 191, 196, 196, 196,
+ 196, 196, 196, 196, 196, 196, 196, 196, 196, 196,
+ 196, 196, 196, 196, 196, 196, 197, 196, 198, 196,
+ 199, 196, 200, 196, 196, 201, 201, 202, 202, 202,
+ 202, 202, 202, 202, 202, 202, 202, 202, 202, 202,
+ 202, 202, 202, 202, 202, 202, 203, 202, 204, 202,
+ 205, 202, 202, 202, 202, 202, 202, 202, 202, 202,
+ 206, 202, 202, 207, 207, 208, 208, 208, 209, 209,
+ 210, 210, 211, 211, 211, 211, 211, 212, 212, 212,
+ 213, 213, 213, 213, 213, 213, 213, 213, 213, 213,
+ 213, 213, 213, 213, 213, 214, 214, 215, 215, 215,
+ 216, 217, 217, 217, 217, 217, 217, 217, 217, 217,
+ 217, 217, 217, 218, 219, 219, 220, 220, 220, 221,
+ 221, 221, 221, 222, 222, 222, 223, 223, 224, 224,
+ 224, 224, 225, 225, 225, 225, 226, 226, 226, 226,
+ 227, 227, 227, 227, 228, 228, 228, 228, 229, 229,
+ 229, 230, 230, 231, 231, 232, 232, 232, 232, 232,
+ 232, 232, 232, 232, 232, 232, 232, 232, 232, 232,
+ 232, 232, 232, 232
+};
+
+/* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */
+static const yytype_uint8 yyr2[] =
+{
+ 0, 2, 1, 2, 0, 4, 0, 4, 1, 1,
+ 0, 4, 1, 2, 0, 3, 0, 4, 0, 4,
+ 1, 2, 2, 0, 3, 0, 4, 0, 4, 1,
+ 2, 2, 1, 1, 0, 1, 2, 1, 0, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 3, 3, 5, 5, 3, 3, 3,
+ 3, 3, 3, 7, 5, 5, 5, 7, 12, 5,
+ 2, 3, 3, 0, 7, 12, 5, 1, 1, 1,
+ 1, 2, 2, 3, 3, 9, 5, 6, 0, 3,
+ 0, 2, 1, 0, 1, 2, 1, 1, 1, 1,
+ 1, 2, 1, 1, 1, 5, 9, 5, 9, 5,
+ 2, 2, 2, 2, 4, 2, 2, 2, 4, 5,
+ 2, 1, 2, 2, 7, 6, 2, 5, 4, 6,
+ 3, 5, 6, 3, 0, 4, 5, 3, 7, 5,
+ 6, 7, 8, 2, 5, 4, 6, 5, 1, 1,
+ 1, 2, 1, 1, 1, 8, 3, 4, 4, 6,
+ 4, 6, 6, 0, 9, 2, 5, 6, 0, 3,
+ 0, 1, 0, 2, 1, 0, 1, 2, 1, 2,
+ 1, 1, 1, 1, 1, 6, 2, 3, 3, 5,
+ 3, 5, 5, 0, 1, 3, 4, 2, 4, 5,
+ 5, 2, 2, 1, 1, 1, 1, 1, 1, 4,
+ 2, 5, 3, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 0, 4, 1, 1,
+ 2, 3, 2, 4, 2, 4, 0, 3, 0, 3,
+ 0, 3, 1, 2, 2, 2, 1, 0, 1, 3,
+ 2, 2, 3, 5, 2, 3, 2, 1, 1, 3,
+ 4, 2, 4, 4, 2, 2, 2, 2, 2, 4,
+ 3, 2, 4, 4, 2, 1, 1, 1, 1, 1,
+ 0, 1, 3, 1, 0, 3, 0, 4, 0, 4,
+ 0, 5, 2, 2, 3, 2, 3, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 2, 2, 1, 2, 0, 3, 0, 3,
+ 0, 3, 0, 3, 1, 2, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 2, 2, 1, 2, 0, 3, 0, 3,
+ 0, 3, 3, 4, 3, 4, 3, 3, 2, 2,
+ 0, 3, 1, 1, 0, 2, 2, 1, 3, 2,
+ 3, 2, 1, 3, 3, 2, 0, 1, 2, 3,
+ 2, 2, 2, 3, 3, 2, 2, 1, 1, 1,
+ 1, 1, 1, 3, 2, 1, 2, 1, 1, 1,
+ 3, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 2, 2, 3, 2, 2,
+ 2, 2, 2, 2, 3, 2, 1, 2, 1, 1,
+ 1, 2, 1, 2, 1, 2, 1, 2, 1, 2,
+ 1, 2, 2, 1, 1, 2, 2, 3, 2, 3,
+ 2, 2, 1, 2, 2, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 3, 3, 3, 3, 3, 3,
+ 3, 5, 3, 3
+};
+
+/* YYDEFACT[STATE-NAME] -- Default reduction number in state STATE-NUM.
+ Performed when YYTABLE doesn't specify something else to do. Zero
+ means the default is an error. */
+static const yytype_uint16 yydefact[] =
+{
+ 0, 0, 97, 96, 0, 0, 280, 0, 0, 0,
+ 0, 280, 280, 77, 0, 148, 78, 149, 0, 99,
+ 0, 0, 364, 376, 8, 9, 12, 0, 0, 0,
+ 203, 0, 37, 2, 35, 39, 40, 41, 42, 43,
+ 44, 45, 47, 46, 280, 50, 52, 0, 92, 100,
+ 102, 94, 48, 49, 51, 0, 103, 0, 104, 98,
+ 13, 201, 0, 93, 280, 93, 93, 93, 0, 280,
+ 0, 414, 0, 113, 0, 327, 0, 0, 0, 0,
+ 0, 0, 284, 0, 0, 0, 0, 0, 0, 0,
+ 329, 328, 360, 362, 350, 0, 0, 0, 0, 0,
+ 348, 0, 346, 0, 0, 0, 331, 332, 333, 334,
+ 335, 336, 337, 275, 277, 276, 330, 279, 0, 278,
+ 281, 283, 338, 340, 339, 341, 344, 115, 0, 116,
+ 0, 117, 0, 112, 0, 0, 0, 110, 0, 111,
+ 0, 126, 0, 0, 0, 363, 0, 392, 390, 413,
+ 0, 0, 388, 389, 376, 387, 3, 372, 377, 391,
+ 14, 0, 0, 4, 20, 297, 23, 0, 0, 299,
+ 298, 322, 324, 320, 0, 318, 0, 316, 0, 6,
+ 301, 302, 303, 304, 305, 306, 307, 300, 29, 308,
+ 310, 309, 311, 314, 228, 229, 240, 242, 238, 0,
+ 0, 236, 0, 10, 264, 0, 0, 261, 0, 0,
+ 0, 369, 0, 1, 36, 0, 91, 101, 95, 143,
+ 0, 0, 202, 197, 0, 415, 0, 0, 0, 0,
+ 93, 93, 121, 120, 54, 0, 53, 422, 421, 419,
+ 420, 371, 0, 216, 215, 218, 217, 220, 219, 226,
+ 225, 286, 0, 450, 0, 448, 0, 452, 222, 221,
+ 224, 223, 443, 434, 432, 440, 0, 0, 342, 293,
+ 430, 0, 444, 0, 429, 0, 426, 428, 343, 295,
+ 0, 0, 268, 267, 358, 359, 274, 0, 0, 271,
+ 0, 0, 266, 265, 0, 0, 0, 367, 345, 0,
+ 214, 213, 418, 416, 0, 425, 423, 0, 0, 288,
+ 0, 0, 0, 292, 0, 0, 0, 0, 58, 57,
+ 60, 59, 62, 61, 0, 0, 0, 93, 0, 0,
+ 0, 130, 134, 0, 394, 0, 386, 412, 405, 385,
+ 406, 407, 411, 409, 408, 403, 401, 404, 410, 402,
+ 0, 395, 397, 398, 399, 375, 376, 376, 376, 380,
+ 382, 381, 376, 378, 18, 16, 0, 22, 21, 34,
+ 27, 25, 0, 312, 313, 0, 0, 31, 0, 0,
+ 326, 315, 0, 30, 34, 0, 0, 244, 232, 248,
+ 0, 245, 234, 0, 247, 0, 243, 230, 0, 34,
+ 0, 0, 0, 259, 207, 204, 195, 0, 206, 205,
+ 368, 0, 181, 180, 0, 455, 456, 457, 458, 459,
+ 280, 280, 280, 460, 461, 280, 280, 280, 280, 0,
+ 280, 462, 280, 463, 0, 0, 0, 176, 184, 182,
+ 183, 0, 178, 0, 0, 93, 0, 93, 0, 122,
+ 123, 0, 0, 0, 81, 370, 0, 0, 285, 454,
+ 453, 449, 451, 438, 436, 435, 433, 441, 442, 0,
+ 431, 445, 446, 0, 427, 361, 351, 0, 0, 0,
+ 270, 349, 366, 365, 347, 417, 424, 114, 0, 290,
+ 0, 294, 296, 282, 0, 352, 0, 354, 357, 356,
+ 0, 0, 118, 0, 0, 0, 0, 128, 0, 0,
+ 0, 0, 0, 0, 0, 393, 384, 396, 0, 373,
+ 374, 379, 383, 0, 0, 15, 33, 5, 32, 0,
+ 0, 24, 323, 321, 319, 325, 317, 7, 241, 239,
+ 251, 246, 250, 0, 256, 257, 258, 254, 0, 246,
+ 0, 0, 237, 231, 11, 263, 262, 260, 196, 0,
+ 210, 0, 0, 0, 0, 0, 0, 0, 186, 0,
+ 0, 0, 0, 364, 0, 177, 145, 0, 0, 0,
+ 0, 150, 152, 153, 154, 0, 174, 179, 0, 0,
+ 0, 198, 0, 38, 38, 82, 227, 287, 439, 437,
+ 212, 364, 447, 273, 272, 269, 56, 55, 0, 289,
+ 353, 355, 109, 64, 0, 66, 65, 69, 73, 0,
+ 105, 79, 80, 280, 107, 280, 0, 119, 127, 0,
+ 0, 0, 0, 0, 86, 88, 400, 19, 17, 28,
+ 26, 249, 233, 252, 0, 255, 235, 76, 0, 464,
+ 465, 468, 466, 467, 472, 473, 175, 469, 470, 280,
+ 0, 144, 0, 139, 0, 0, 165, 0, 0, 151,
+ 173, 0, 147, 0, 200, 199, 83, 84, 0, 291,
+ 0, 0, 0, 70, 0, 280, 0, 0, 125, 0,
+ 0, 0, 137, 133, 129, 364, 90, 0, 0, 280,
+ 193, 0, 209, 0, 0, 156, 0, 140, 146, 0,
+ 0, 211, 63, 38, 38, 67, 0, 93, 0, 124,
+ 135, 134, 0, 0, 0, 0, 253, 74, 0, 175,
+ 175, 280, 175, 280, 280, 0, 471, 138, 172, 0,
+ 0, 141, 71, 72, 0, 0, 0, 131, 136, 134,
+ 0, 38, 0, 0, 193, 193, 0, 193, 0, 0,
+ 185, 171, 163, 166, 168, 142, 38, 106, 108, 132,
+ 38, 89, 85, 38, 187, 188, 175, 190, 175, 175,
+ 0, 0, 280, 0, 280, 280, 0, 364, 170, 0,
+ 88, 0, 193, 193, 193, 172, 172, 0, 172, 0,
+ 0, 0, 0, 0, 0, 0, 87, 0, 189, 191,
+ 192, 163, 163, 0, 163, 0, 0, 155, 0, 172,
+ 0, 68, 75, 157, 158, 172, 160, 172, 172, 172,
+ 169, 164, 163, 163, 163, 168, 159, 161, 162, 167
+};
+
+/* YYDEFGOTO[NTERM-NUM]. */
+static const yytype_int16 yydefgoto[] =
+{
+ -1, 31, 369, 384, 399, 163, 366, 524, 523, 179,
+ 372, 530, 529, 527, 32, 235, 34, 35, 36, 37,
+ 38, 39, 40, 41, 42, 619, 683, 43, 44, 623,
+ 236, 454, 45, 696, 725, 46, 47, 48, 49, 50,
+ 51, 73, 233, 52, 53, 513, 54, 55, 761, 581,
+ 582, 786, 583, 788, 804, 762, 584, 585, 586, 437,
+ 438, 735, 56, 57, 407, 439, 274, 106, 107, 108,
+ 109, 110, 111, 112, 456, 203, 395, 386, 385, 543,
+ 390, 394, 548, 113, 114, 115, 116, 117, 118, 119,
+ 120, 252, 457, 490, 608, 380, 382, 378, 376, 375,
+ 381, 121, 299, 294, 281, 280, 146, 298, 59, 122,
+ 156, 157, 158, 350, 351, 352, 353, 159, 74, 123,
+ 124, 125, 275, 276, 277, 465, 268, 278, 126, 256,
+ 257, 442
+};
+
+/* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing
+ STATE-NUM. */
+#define YYPACT_NINF -664
+static const yytype_int16 yypact[] =
+{
+ 2085, -55, -664, -664, 3053, 4597, 2630, 4597, 4597, 4597,
+ 1393, 2630, 2630, -664, 1467, -664, -664, -664, 1541, -664,
+ 1615, 19, 2630, 830, 2695, 3130, 3373, 1141, 55, 226,
+ -664, 63, 4751, -664, -664, -664, -664, -664, -664, -664,
+ -664, -664, -664, -664, 2630, -664, -664, -29, -664, 42,
+ -664, 4010, -664, -664, -664, 1689, -664, 71, -664, -664,
+ -664, -664, -6, 4010, 2630, 4010, 4010, 4010, 1393, 2630,
+ 2630, -664, 315, -664, 3227, -664, 176, 1079, 47, 48,
+ 50, 1034, 3, 31, 60, 72, 37, 37, 39, 39,
+ -664, -664, -664, -664, -664, 1837, 4204, 4204, 1222, 1911,
+ -664, 2878, -664, 86, 43, 27, -664, -664, -664, -664,
+ -664, -664, -664, -664, -664, -664, -664, -664, 22, -664,
+ 2430, 135, -664, -664, -664, -664, -664, -664, 3259, -664,
+ 3352, -664, 3384, -664, 52, 78, 83, -664, 85, -664,
+ 94, -664, 19, 110, 3477, -664, 115, -664, -664, -664,
+ 1242, 2350, -664, -664, 830, -664, -32, -664, 3247, -664,
+ 93, 4204, 4204, -664, 135, -664, 101, 37, 39, -664,
+ -664, -664, -664, -664, 4500, -664, 4269, -664, 4500, -664,
+ -664, -664, -664, -664, -664, -664, -664, -664, -664, -664,
+ -664, -664, -664, -664, -664, -664, -664, -664, -664, 915,
+ 961, -664, 58, -664, -664, 4204, 4204, -664, 2630, 133,
+ 995, -664, 308, -664, -664, 137, -664, -664, -664, -664,
+ 3511, 139, -664, -664, 131, -664, 141, 144, 166, 168,
+ 4010, 4010, -664, -664, -664, 427, -664, -664, -664, -664,
+ -664, -664, 480, -664, -664, -664, -664, -664, -664, -664,
+ -664, -664, 4204, -664, 49, -664, 4, -664, -664, -664,
+ -664, -664, -664, 11, 99, -664, 37, 37, -664, -664,
+ -664, 3552, -664, 39, -664, 18, 67, -664, -664, -664,
+ 2878, 2878, -664, 135, 113, 113, -664, 4204, 4204, -664,
+ 2630, 114, -664, 195, 2878, 4204, 4204, 135, -664, 2878,
+ -664, -664, -664, -664, 157, -664, -664, 159, 4597, 169,
+ 37, 39, 4204, 135, 3617, 3682, 4204, 4204, -664, -664,
+ -664, -664, -664, -664, 4625, 4597, 19, 4010, 4010, 2869,
+ 4625, -664, 167, 19, -664, 23, -664, -664, -664, -664,
+ -664, -664, -664, -664, -664, -664, -664, -664, -664, -664,
+ 180, 1324, -664, 179, -664, -664, 830, 830, 830, -664,
+ -664, -664, 830, -664, -664, -664, 4204, 135, 135, 3747,
+ -664, -664, 4500, -664, -664, 4269, 4269, -664, 4269, 4500,
+ -664, -664, 4269, -664, 3747, 3373, 2878, -664, -664, -664,
+ 562, -664, -664, 197, 3361, 2878, -664, -664, 175, 3747,
+ 230, 359, 185, -664, -664, -664, -664, 192, -664, -664,
+ -664, 19, -664, -664, 2178, -664, -664, -664, -664, -664,
+ 2630, 2630, 2630, -664, -664, 2630, 2630, 2630, 2630, 1763,
+ 2630, -664, 2630, -664, 4204, 4204, 183, 4844, -664, -664,
+ -664, 2792, 4844, 3511, 116, 4010, 4010, 4010, 4010, -664,
+ -664, 19, 19, 19, -664, -664, 3373, 4204, 135, -664,
+ -664, -664, -664, -664, -664, 35, 220, -664, -664, 1985,
+ 135, -664, -664, 39, -664, -664, -664, 255, 410, 204,
+ -664, -664, 113, 113, -664, -664, -664, -664, 3844, -664,
+ 4204, -664, -664, 135, 4204, 135, 4204, 195, 113, 113,
+ 259, 4366, -664, 3876, 2826, 208, 327, -664, 276, 280,
+ 4398, 2495, 19, 281, 2143, -664, -664, -664, 2039, 217,
+ -664, -664, -664, 4204, 4204, 135, -664, -664, 135, 4500,
+ 4500, -664, -664, -664, -664, -664, -664, -664, -664, -664,
+ -664, 3373, -664, 227, -664, -664, -664, -664, 3373, 3373,
+ 320, 232, -664, -664, -664, -664, -664, -664, -664, 3969,
+ -664, 235, 246, 251, 263, 266, 270, 271, -664, 283,
+ 290, 293, 2560, 2219, 2975, -664, -664, 19, 1307, 4021,
+ 341, 4718, -664, -664, -664, 267, -664, -664, 282, 3012,
+ 304, -664, 330, 4751, 4751, -664, -664, 135, -664, -664,
+ -664, 2219, -664, -664, -664, -664, -664, -664, 4204, 135,
+ 113, 113, -664, -664, 369, -664, -664, -664, 221, 385,
+ -664, -664, -664, 2630, -664, 2630, 19, -664, -664, 399,
+ 19, 337, 4491, 19, -664, 340, -664, 135, 135, -664,
+ -664, -664, -664, -664, 25, -664, -664, -664, 515, -664,
+ -664, -664, -664, -664, -664, -664, 4844, -664, -664, 2219,
+ 345, -664, 409, -664, 349, 430, -664, 2289, 19, -664,
+ -664, 3089, -664, 422, -664, -664, -664, -664, 362, 135,
+ 19, 19, 19, -664, 19, 2630, 371, 376, -664, 19,
+ 4118, 19, -664, -664, -664, 2630, 382, 3373, 19, 2630,
+ 581, 386, -664, 19, 19, -664, 19, -664, -664, 450,
+ 19, -664, -664, 4751, 4751, -664, 389, 4010, 4010, -664,
+ -664, 167, 4152, 390, 19, 456, -664, -664, 395, 4844,
+ 4844, 2630, 4844, 2630, 2630, 461, -664, -664, 4718, 2386,
+ 19, -664, -664, -664, 19, 467, 470, -664, -664, 167,
+ 19, 4751, 19, 19, 581, 581, 407, 581, 408, 414,
+ -664, -664, 628, -664, 420, -664, 4751, -664, -664, -664,
+ 4751, -664, -664, 4751, -664, -664, 4844, -664, 4844, 4844,
+ 19, 19, 2630, 19, 2630, 2630, 484, 2630, 432, 499,
+ 340, 502, 581, 581, 581, 4718, 4718, 438, 4718, 441,
+ 443, 19, 453, 19, 519, 19, -664, 19, -664, -664,
+ -664, 628, 628, 19, 628, 19, 19, -664, 19, 4718,
+ 19, -664, -664, -664, -664, 4718, -664, 4718, 4718, 4718,
+ -664, -664, 628, 628, 628, 420, -664, -664, -664, -664
+};
+
+/* YYPGOTO[NTERM-NUM]. */
+static const yytype_int16 yypgoto[] =
+{
+ -664, -664, -664, -664, -664, -664, -664, -664, -664, -664,
+ -664, -664, -664, -347, -664, 127, 513, -664, -664, -664,
+ -664, -664, -664, -664, -664, -472, -664, -664, -664, -488,
+ -120, -664, -664, -238, -664, -664, 14, -48, -664, 504,
+ -664, 224, -664, -664, -664, -663, -664, -664, -428, -664,
+ -664, -256, -664, -274, -664, -302, -664, -622, -191, -664,
+ -664, -490, -664, -664, -664, -664, -664, 0, 30, 45,
+ 103, 164, 172, 212, -664, -57, -664, -664, -664, 170,
+ -664, -664, -75, 384, -664, -664, -9, -13, 81, -16,
+ -664, -664, -664, -664, -664, 8, -664, -664, -664, -664,
+ -17, 761, -664, -664, -664, -664, -361, -216, -206, 472,
+ -2, 415, -664, 228, -664, -664, 64, -142, -7, 558,
+ 574, 579, -88, -664, -51, 317, -82, -63, 614, -664,
+ 333, -664
+};
+
+/* YYTABLE[YYPACT[STATE-NUM]]. What to do in state STATE-NUM. If
+ positive, shift that token. If negative, reduce the rule which
+ number is the opposite. If YYTABLE_NINF, syntax error. */
+#define YYTABLE_NINF -377
+static const yytype_int16 yytable[] =
+{
+ 128, 130, 132, 218, 409, 269, 145, 143, 319, 354,
+ 321, 209, 323, 580, 144, 463, 187, 307, 625, 72,
+ 62, 72, 72, 72, 250, 180, 279, 212, 305, 436,
+ 545, 263, 253, 188, 700, 267, 267, 537, 262, 598,
+ 60, 263, 221, 263, 302, 2, 3, 263, 243, 245,
+ 459, 247, 554, 304, 356, 181, 357, 229, 747, 396,
+ 210, 258, 263, 213, 475, 476, 216, 254, 569, 19,
+ 182, 263, 222, 260, 464, 242, 223, 72, 481, 72,
+ 72, 72, 291, 484, 270, 373, 769, 300, 461, 225,
+ 264, 134, 135, 136, 254, 138, 270, 251, 599, 140,
+ 264, 271, 264, 308, 515, 374, 264, 754, 755, 356,
+ 757, 357, 460, 271, 71, 255, 267, 472, 473, 27,
+ 27, 264, 27, 546, 270, 215, 306, 33, 183, 29,
+ 264, 685, 27, 324, 265, 329, 444, 266, 272, 273,
+ 303, 271, 389, 393, 27, 226, 662, 224, 335, 227,
+ 228, 398, 355, 669, 792, 397, 793, 794, 27, 325,
+ 699, 673, 464, 364, 326, 187, 327, 187, 315, 187,
+ 539, 370, 590, 314, 180, 328, 180, 237, 180, 552,
+ 238, 239, 377, 316, 467, 468, 383, 365, 474, 184,
+ 315, 330, 402, 591, 480, 371, 333, 185, 544, 511,
+ 512, 408, 545, 29, 181, 316, 181, 317, 181, 354,
+ 471, 440, 660, 441, 403, 267, 267, 664, 411, 182,
+ 443, 182, 445, 182, 620, 446, 621, 211, 491, 317,
+ 147, 127, 129, 131, 622, 681, 682, 186, 592, 240,
+ 678, 742, 743, 709, 72, 72, 575, 447, 492, 448,
+ 315, 587, 588, 194, 485, 195, 196, 197, 486, 267,
+ 516, 518, 198, 489, 774, 775, 557, 777, 314, 558,
+ 199, 332, 553, 200, 479, 612, 500, 183, 574, 183,
+ 506, 183, 509, 599, 605, 315, 201, 148, 149, 127,
+ 129, 131, 626, 314, 202, 546, 627, 633, 150, 151,
+ 316, 488, 808, 809, 810, 357, 152, 642, 153, 646,
+ 315, 555, -376, -376, -376, 154, 649, 501, 503, 504,
+ 155, 645, 72, 510, 317, 316, 514, 650, 538, 230,
+ 231, 232, 651, 542, 723, 603, 547, 550, 184, 72,
+ 184, 505, 184, 624, 652, 621, 185, 653, 185, 317,
+ 185, 654, 655, 622, 519, 520, 521, 668, 532, 533,
+ 522, 534, 670, 187, 656, 536, 187, 187, 607, 187,
+ 187, 657, 180, 187, 658, 180, 180, 671, 180, 180,
+ 531, 674, 180, 616, 58, 680, 186, 535, 186, 58,
+ 186, 58, 58, 58, 356, 410, 357, 314, 500, 596,
+ 509, 684, 181, 621, 559, 181, 181, 675, 181, 181,
+ 602, 622, 181, 145, 315, 689, 58, 182, 691, 695,
+ 182, 182, 702, 182, 182, 703, 802, 182, 440, 316,
+ 704, 705, 440, 440, 440, 58, 589, 764, 710, 711,
+ 556, 451, 452, 453, 593, 594, 595, 58, 314, 58,
+ 58, 58, 717, 317, 449, 450, 508, 718, 58, 72,
+ 724, 72, 244, 246, 248, 315, 740, 736, 259, 261,
+ 744, 750, 752, 676, 677, 183, 753, 760, 183, 183,
+ 316, 183, 183, 767, 641, 183, 768, 301, 776, 778,
+ 604, 643, 644, 811, 812, 779, 814, 189, 631, 787,
+ 801, 561, 562, 563, 317, 632, 564, 565, 566, 567,
+ 803, 570, 58, 571, 58, 805, 58, 830, 807, 813,
+ 187, 187, 815, 832, 816, 833, 834, 835, 58, 180,
+ 180, 698, 487, 621, 818, 820, 184, 639, 640, 184,
+ 184, 622, 184, 184, 185, 214, 184, 185, 185, 502,
+ 185, 185, 806, 217, 185, 823, 824, 145, 826, 181,
+ 181, 839, 145, 540, 551, 440, 356, 455, 357, 697,
+ 663, 665, 440, 363, 182, 182, 836, 837, 838, 517,
+ 440, 466, 636, 190, 186, 145, 0, 186, 186, 462,
+ 186, 186, 0, 0, 186, 0, 0, 0, 0, 191,
+ 0, 0, 0, 0, 192, 729, 730, 731, 732, 733,
+ 734, 0, 0, 0, 58, 58, 0, 0, 194, 688,
+ 195, 196, 197, 690, 0, 0, 694, 198, 614, 0,
+ 0, 618, 183, 183, 0, 199, 0, 629, 200, 193,
+ 726, 635, -247, 0, 0, 541, 189, 440, 189, 0,
+ 189, 201, 780, 781, 782, 783, 784, 785, 0, 202,
+ 0, 707, 440, 0, 0, 0, 0, 0, 0, 487,
+ 746, 502, 0, 712, 713, 714, 0, 715, 0, 145,
+ 0, 0, 719, 0, 722, 0, 648, 0, 0, 0,
+ 0, 727, 58, 184, 184, 0, 737, 738, 0, 739,
+ 0, 185, 185, 741, 686, 0, 687, 0, 58, 58,
+ 0, 58, 58, 58, 58, 0, 0, 751, 0, 0,
+ 440, 440, 0, 440, 0, 0, 0, 0, 0, 440,
+ 440, 745, 190, 765, 190, 0, 190, 766, 0, 0,
+ 701, 186, 186, 770, 0, 772, 773, 0, 191, 0,
+ 191, 0, 191, 192, 0, 192, 0, 192, 0, 693,
+ 0, 0, 0, 0, 0, 0, 716, 440, 0, 440,
+ 440, 145, 0, 795, 796, 0, 798, 0, 0, 0,
+ 728, 0, 0, 0, 0, 164, 440, 440, 193, 440,
+ 193, 0, 193, 0, 817, 0, 819, 0, 821, 0,
+ 822, 0, 0, 0, 0, 0, 825, 0, 827, 828,
+ 440, 829, 756, 831, 758, 759, 440, 721, 440, 440,
+ 440, 0, 0, 0, 0, 0, 0, 0, 0, 58,
+ 58, 58, 58, 0, 147, 0, 0, 0, 0, 0,
+ 618, 618, 0, 0, 189, 0, 0, 189, 189, 749,
+ 189, 189, 0, 0, 189, 0, 283, 284, 285, 0,
+ 293, 0, 297, 797, 0, 799, 800, 0, 0, 0,
+ 0, 0, 58, 0, 0, 0, 0, 0, 771, 0,
+ 0, 313, 0, 0, 0, 58, 0, 58, 58, 0,
+ 0, 148, 149, 789, 58, 0, 0, 790, 58, 0,
+ 791, 0, 150, 151, 0, 0, 0, 0, 0, 0,
+ 152, 0, 153, 0, 0, 0, 387, 0, 0, 154,
+ 0, 0, 367, 368, 155, 0, 0, 0, 0, 0,
+ 190, 0, 0, 190, 190, 0, 190, 190, 0, 0,
+ 190, 0, 0, 58, 0, 0, 191, 0, 0, 191,
+ 191, 192, 191, 191, 192, 192, 191, 192, 192, 0,
+ 0, 192, 391, 0, 0, 0, 400, 401, 0, 0,
+ 0, 194, 0, 195, 196, 197, 0, 58, 58, 0,
+ 198, 0, 0, 0, 0, 0, 193, 0, 199, 193,
+ 193, 200, 193, 193, 0, 388, 193, 0, 0, 0,
+ 404, 189, 189, 0, 201, 0, 0, 0, 0, 0,
+ 0, 0, 202, 458, 0, 0, 58, 194, 0, 195,
+ 196, 197, 0, 0, 0, 0, 198, 0, 0, 0,
+ 0, 0, 470, 0, 199, 0, 0, 200, 392, 0,
+ 0, 297, 297, 0, 0, 0, 0, 0, 477, 478,
+ 201, 405, 0, 0, 0, 297, 482, 483, 202, 0,
+ 297, 95, 0, 0, 0, 0, 0, 27, 98, 99,
+ 0, 0, 406, 493, 58, 495, 497, 498, 499, 0,
+ 241, 0, 29, 147, 0, 0, 0, 190, 190, 0,
+ 194, 0, 195, 196, 197, 0, 0, 58, 58, 198,
+ 0, 58, 58, 191, 191, 0, 58, 199, 192, 192,
+ 200, 0, 0, 0, 0, 0, 0, 0, 0, 249,
+ 0, 0, 0, 201, 0, 0, 0, 525, 0, 0,
+ 528, 202, 0, 0, 0, 58, 0, 0, 0, 0,
+ 148, 149, 204, 193, 193, 528, 75, 297, 0, 0,
+ 58, 150, 151, 0, 58, 0, 297, 58, 0, 152,
+ 528, 153, 0, 0, 0, -376, -376, -376, 154, 0,
+ 0, 0, 0, 155, 0, 0, 0, 76, 77, 0,
+ 78, 79, 80, 81, 82, 83, 84, 85, 86, 87,
+ 88, 89, 0, 0, 0, 572, 573, 90, 91, 0,
+ 92, 93, 0, 0, 0, 94, 0, 95, 205, 206,
+ 96, 0, 97, 27, 98, 99, 0, 0, 597, 0,
+ 0, 0, 207, 286, 100, 101, 102, 75, 0, 0,
+ 601, 0, 0, 0, 0, 208, 0, 103, 104, 0,
+ 105, 0, 0, 334, 0, 0, 147, 0, 0, 0,
+ 0, 609, 0, 0, 0, 610, 0, 611, 76, 77,
+ 0, 78, 79, 80, 81, 82, 83, 84, 85, 86,
+ 87, 88, 89, 0, 0, 0, 0, 0, 90, 91,
+ 0, 92, 93, 0, 637, 638, 94, 0, 95, 287,
+ 288, 96, 0, 97, 27, 98, 99, 0, 0, 0,
+ 0, 0, 289, 148, 149, 100, 101, 102, 62, 0,
+ 0, 0, 75, 0, 150, 151, 290, 0, 103, 104,
+ 0, 105, 152, -376, 153, 0, 0, 0, -376, 0,
+ -376, 154, 0, 659, 0, 0, 155, 0, 0, 0,
+ 667, 0, 0, 76, 77, 0, 78, 79, 80, 81,
+ 82, 83, 84, 85, 86, 87, 88, 89, 0, 0,
+ 0, 0, 0, 90, 91, 0, 92, 93, 0, 679,
+ 0, 94, 0, 95, 0, 0, 96, 0, 97, 27,
+ 98, 99, 0, 0, 0, 337, 149, 0, -364, 0,
+ 100, 101, 102, 0, 133, 0, 338, 0, 75, 0,
+ 0, 0, 71, 103, 104, 340, 105, 0, 0, 0,
+ 341, 342, 343, 344, 345, 346, 347, 348, 349, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 659, 76,
+ 77, 0, 78, 79, 80, 81, 82, 83, 84, 85,
+ 86, 87, 88, 89, 0, 0, 0, 0, 0, 90,
+ 91, 0, 92, 93, 0, 0, 0, 94, 0, 95,
+ 0, 0, 96, 0, 97, 27, 98, 99, 137, 0,
+ 0, 0, 75, 0, -280, 0, 100, 101, 102, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 103,
+ 104, 0, 105, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 76, 77, 0, 78, 79, 80, 81,
+ 82, 83, 84, 85, 86, 87, 88, 89, 0, 0,
+ 0, 0, 0, 90, 91, 0, 92, 93, 0, 0,
+ 0, 94, 0, 95, 0, 0, 96, 0, 97, 27,
+ 98, 99, 139, 0, 0, 0, 75, 0, -280, 0,
+ 100, 101, 102, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 103, 104, 0, 105, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 76, 77, 0,
+ 78, 79, 80, 81, 82, 83, 84, 85, 86, 87,
+ 88, 89, 0, 0, 0, 0, 0, 90, 91, 0,
+ 92, 93, 0, 0, 0, 94, 0, 95, 0, 0,
+ 96, 0, 97, 27, 98, 99, 141, 0, 0, 0,
+ 75, 0, -280, 0, 100, 101, 102, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 103, 104, 0,
+ 105, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 76, 77, 0, 78, 79, 80, 81, 82, 83,
+ 84, 85, 86, 87, 88, 89, 0, 0, 0, 0,
+ 0, 90, 91, 0, 92, 93, 0, 0, 0, 94,
+ 0, 95, 0, 0, 96, 0, 97, 27, 98, 99,
+ 219, 0, 0, 0, 75, 0, 142, 0, 100, 101,
+ 102, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 103, 104, 0, 105, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 76, 77, 0, 78, 79,
+ 80, 81, 82, 83, 84, 85, 86, 87, 88, 89,
+ 0, 0, 0, 0, 0, 90, 91, 0, 92, 93,
+ 0, 0, 0, 94, 0, 95, 0, 0, 96, 0,
+ 97, 27, 98, 99, 568, 0, 0, 0, 75, 0,
+ 220, 0, 100, 101, 102, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 103, 104, 0, 105, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 76,
+ 77, 0, 78, 79, 80, 81, 82, 83, 84, 85,
+ 86, 87, 88, 89, 0, 0, 0, 0, 0, 90,
+ 91, 0, 92, 93, 0, 0, 0, 94, 0, 95,
+ 0, 0, 96, 0, 97, 27, 98, 99, 282, 0,
+ 0, 0, 75, 0, -364, 0, 100, 101, 102, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 103,
+ 104, 0, 105, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 76, 77, 0, 78, 79, 80, 81,
+ 0, 83, 84, 85, 86, 0, 88, 0, 0, 0,
+ 0, 0, 0, 90, 91, 0, 92, 93, 0, 0,
+ 0, 94, 0, 95, 0, 0, 96, 0, 97, 27,
+ 98, 99, 292, 0, 0, 0, 75, 0, 0, 0,
+ 100, 101, 102, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 103, 104, 0, 105, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 76, 77, 0,
+ 78, 79, 80, 81, 0, 83, 84, 85, 86, 0,
+ 88, 0, 0, 0, 0, 0, 0, 90, 91, 0,
+ 92, 93, 0, 0, 0, 94, 0, 95, 0, 0,
+ 96, 0, 97, 27, 98, 99, 600, 0, 0, 0,
+ 75, 0, 0, 0, 100, 101, 102, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 103, 104, 0,
+ 105, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 76, 77, 0, 78, 79, 80, 81, 0, 83,
+ 84, 85, 86, 0, 88, 0, 0, 0, 0, 0,
+ 0, 90, 91, 0, 92, 93, 0, 0, 0, 94,
+ 0, 95, 0, 0, 96, 0, 97, 27, 98, 99,
+ 0, 0, 0, 0, 0, 0, 0, 0, 100, 101,
+ 102, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 103, 104, 0, 105, -38, 1, 0, 2, 3,
+ 4, 5, 6, 7, 8, 9, 10, 11, 12, 0,
+ 337, 0, 13, 0, 14, 15, 16, 17, 18, 0,
+ 0, 338, 19, 0, 0, 20, 21, 0, 0, 22,
+ 340, 0, 0, 0, 0, 341, 342, 343, 344, 345,
+ 346, 347, 348, 349, 0, 0, 23, 24, 25, 26,
+ 0, 0, 0, 0, 634, 0, 2, 3, 4, 5,
+ 6, 7, 8, 9, 10, 11, 12, 27, 0, -38,
+ 13, 28, 14, 15, 16, 17, 18, 0, 0, 0,
+ 19, 0, 29, 20, 21, 30, 0, 22, 0, 560,
+ -93, -208, -208, -208, -208, -208, -208, -208, -208, -208,
+ -208, -208, -208, -208, -208, -208, 0, -208, -208, 0,
+ -208, -208, -208, -208, -208, -208, -208, -208, -208, -208,
+ -208, -208, -208, 0, 0, 27, 0, 0, 0, 28,
+ 0, -38, -38, 0, 75, 0, 0, 0, 0, 0,
+ 29, 0, 0, 30, 0, 0, 0, 0, -93, 0,
+ 0, 0, 0, 0, -208, 0, 0, 0, 0, 0,
+ -208, -208, -208, 0, -208, 76, 77, 314, 78, 79,
+ 80, 81, 82, 83, 84, 85, 86, 87, 88, 89,
+ 0, 0, 0, -208, 315, 90, 91, 0, 92, 93,
+ 0, 0, 0, 94, 0, 95, 0, 0, 96, 316,
+ 97, 27, 98, 99, 75, 0, 0, 0, 0, 0,
+ 0, 0, 100, 101, 102, 0, 0, 0, 0, 0,
+ 0, 0, 0, 317, 0, 103, 104, 0, 105, 0,
+ 0, 0, 0, 0, 0, 76, 77, 314, 78, 79,
+ 80, 81, 0, 83, 84, 85, 86, 0, 88, 0,
+ 0, 0, 0, 0, 315, 90, 91, 0, 92, 93,
+ 0, 336, 0, 94, 0, 95, 0, 0, 96, 316,
+ 97, 27, 98, 99, 0, 0, 0, 0, 0, 0,
+ 706, 0, 100, 101, 102, 0, 0, 0, 0, 0,
+ 0, 0, 0, 317, 0, 103, 104, 763, 105, 412,
+ 413, 414, 415, 416, 417, 418, 419, 420, 421, 422,
+ 423, 424, -172, 425, 0, 426, 427, 578, 428, 429,
+ 0, 337, 149, 0, 0, 0, 430, 431, 432, 433,
+ 579, 0, 338, 0, 0, 0, 0, 0, 0, 0,
+ 339, 340, 0, 0, 0, 75, 341, 342, 343, 344,
+ 345, 346, 347, 348, 349, 0, 0, 0, 0, 0,
+ 0, 0, 95, 0, 0, 0, 0, 0, 27, 98,
+ 99, 0, 435, 0, -172, -172, 76, 77, 0, 78,
+ 79, 80, 81, 309, 83, 84, 85, 86, 310, 88,
+ 311, -175, 0, 0, 0, 0, 90, 91, 0, 92,
+ 93, 0, 0, 0, 94, 0, 95, 312, 0, 96,
+ 75, 97, 27, 98, 99, 0, 0, 0, 0, 0,
+ 0, 0, 0, 100, 101, 102, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 103, 104, 0, 105,
+ 0, 76, 77, 0, 78, 79, 80, 81, 82, 83,
+ 84, 85, 86, 87, 88, 89, 0, 0, 0, 0,
+ 0, 90, 91, 0, 92, 93, 0, 0, 0, 94,
+ 0, 95, 0, 0, 96, 75, 97, 27, 98, 99,
+ 0, 0, 0, 0, 0, 0, 630, 0, 100, 101,
+ 102, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 103, 104, 0, 105, 0, 76, 77, 314, 78,
+ 79, 80, 81, 0, 83, 84, 85, 86, 0, 88,
+ 0, 0, 0, 0, 0, 315, 90, 91, 0, 92,
+ 93, 0, 0, 0, 94, 0, 95, 0, 0, 96,
+ 316, 97, 27, 98, 99, 75, 0, 0, 0, 0,
+ 0, 0, 0, 100, 101, 102, 0, 0, 0, 0,
+ 0, 0, 0, 0, 317, 0, 103, 104, 0, 105,
+ 0, 0, 0, 0, 0, 0, 76, 77, 0, 78,
+ 79, 80, 81, 82, 83, 84, 85, 86, 87, 88,
+ 89, 0, 0, 0, 0, 0, 90, 91, 0, 92,
+ 93, 0, 0, 0, 94, 0, 95, 0, 0, 96,
+ 75, 97, 27, 98, 99, 0, 0, 0, 0, 0,
+ 0, 0, 0, 100, 101, 102, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 103, 104, 0, 105,
+ 0, 76, 77, 0, 78, 79, 80, 81, 160, 83,
+ 84, 85, 86, 0, 88, 0, 0, 0, 0, 0,
+ 0, 90, 91, 0, 92, 93, 0, 0, 0, 94,
+ 0, 95, 0, 0, 96, 161, 97, 27, 98, 99,
+ 0, 0, 0, 0, 0, 0, 0, 0, 100, 101,
+ 102, 0, 0, 0, 0, 0, 0, 0, 0, 162,
+ 0, 103, 104, 576, 105, 412, 413, 414, 415, 416,
+ 417, 418, 419, 420, 421, 422, 423, 424, 577, 425,
+ 0, 426, 427, 578, 428, 429, 0, 0, 0, 0,
+ 0, 0, 430, 431, 432, 433, 579, 617, 0, 2,
+ 3, 4, 5, 6, 7, 8, 9, 10, 11, 12,
+ -38, -38, -38, 13, -38, 14, 15, 16, 17, 18,
+ 0, 0, -38, 19, 0, 0, 20, 21, 95, 0,
+ 22, 0, 0, 0, 27, 98, 99, 0, 435, 0,
+ 507, 0, 2, 3, 4, 5, 6, 7, 8, 9,
+ 10, 11, 12, 75, 0, -38, 13, -175, 14, 15,
+ 16, 17, 18, 0, 0, 0, 19, 0, 27, 20,
+ 21, 0, 28, 22, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 29, 76, 77, 30, 78, 79, 80,
+ 81, -93, 83, 84, 85, 86, 0, 88, 0, 0,
+ 0, 0, 0, 0, 90, 91, 0, 92, 93, 0,
+ 0, 27, 94, 0, 95, 28, 0, 96, 295, 97,
+ 27, 98, 99, 0, 0, 0, 29, 0, 0, 30,
+ 0, 100, 101, 102, -93, 0, 0, 0, 0, 0,
+ 0, 0, 296, 0, 103, 104, 661, 105, 412, 413,
+ 414, 415, 416, 417, 418, 419, 420, 421, 422, 423,
+ 424, 0, 425, 0, 426, 427, 578, 428, 429, 0,
+ 0, 0, 0, 0, 0, 430, 431, 432, 433, 579,
+ 0, 0, 0, 672, 0, 412, 413, 414, 415, 416,
+ 417, 418, 419, 420, 421, 422, 423, 424, 0, 425,
+ 0, 426, 427, 578, 428, 429, 0, 0, 0, 0,
+ 0, 95, 430, 431, 432, 433, 579, 27, 98, 99,
+ 0, 435, 0, 0, 61, 0, -194, -194, -194, -194,
+ -194, -194, -194, -194, -194, -194, 0, -194, -194, -194,
+ -175, -194, -194, 0, 0, 0, -194, 0, 95, -194,
+ -194, 0, 0, -194, 27, 98, 99, 0, 435, 0,
+ 708, 0, 412, 413, 414, 415, 416, 417, 418, 419,
+ 420, 421, 422, 423, 424, 0, 425, -175, 426, 427,
+ 578, 428, 429, 0, 0, 0, 0, 0, 0, 430,
+ 431, 432, 433, 579, 0, -194, 0, 0, 0, -194,
+ 0, 0, 0, 0, 0, 165, 0, 0, 0, 0,
+ -194, 0, 0, -194, 0, 0, 0, 0, -194, 0,
+ 0, 0, 0, 0, 0, 95, 0, 0, 0, 0,
+ 0, 27, 98, 99, 0, 435, 76, 77, 0, 78,
+ 79, 80, 81, 166, 83, 84, 85, 167, 0, 168,
+ 0, 0, 0, 0, -175, 0, 169, 170, 0, 171,
+ 172, 0, 0, 0, 173, 0, 95, 0, 0, 0,
+ 174, 0, 27, 98, 99, 0, 0, 0, 0, 0,
+ 0, 0, 0, 175, 176, 177, 0, 0, 0, 0,
+ 0, 0, 0, 0, 178, 0, 103, 104, 234, 105,
+ 2, 3, 4, 5, 6, 7, 8, 9, 10, 11,
+ 12, -38, -38, -38, 13, 0, 14, 15, 16, 17,
+ 18, 147, 0, 0, 19, 0, 0, 20, 21, 0,
+ 318, 22, 2, 3, 4, 5, 6, 7, 8, 9,
+ 10, 11, 12, -38, -38, -38, 13, 0, 14, 15,
+ 16, 17, 18, 0, 0, 0, 19, 0, 0, 20,
+ 21, 0, 0, 22, 0, 0, 0, 0, 0, 27,
+ 0, 0, 0, 28, 0, 0, 0, 0, 148, 149,
+ 0, 0, 0, 0, 29, 0, 0, 30, 0, 150,
+ 151, 0, -93, 0, 0, 0, 0, 152, 0, 153,
+ 0, 27, 0, 0, 0, 28, 358, 359, 360, 361,
+ 362, 155, 0, 0, 0, 0, 29, 0, 0, 30,
+ 0, 0, 0, 320, -93, 2, 3, 4, 5, 6,
+ 7, 8, 9, 10, 11, 12, -38, -38, -38, 13,
+ 0, 14, 15, 16, 17, 18, 0, 0, 0, 19,
+ 0, 0, 20, 21, 0, 322, 22, 2, 3, 4,
+ 5, 6, 7, 8, 9, 10, 11, 12, -38, -38,
+ -38, 13, 0, 14, 15, 16, 17, 18, 0, 0,
+ 0, 19, 0, 0, 20, 21, 0, 194, 22, 195,
+ 196, 197, 0, 0, 27, 0, 198, 0, 28, 194,
+ 0, 195, 196, 197, 199, 0, 0, 200, 198, 29,
+ 0, 0, 30, 0, 549, 0, 199, -93, 0, 200,
+ 201, 0, 0, 0, 0, 0, 27, 0, 202, 0,
+ 28, 0, 201, 0, 0, 0, 0, 0, 0, 0,
+ 202, 29, 0, 0, 30, 0, 0, 0, 331, -93,
+ 2, 3, 4, 5, 6, 7, 8, 9, 10, 11,
+ 12, 0, 0, -38, 13, 0, 14, 15, 16, 17,
+ 18, 0, 0, 0, 19, 0, 0, 20, 21, -38,
+ -38, 22, 62, 0, 412, 413, 414, 415, 416, 417,
+ 418, 419, 420, 421, 422, 423, 424, 0, 425, 0,
+ 426, 427, 0, 428, 429, 0, 0, 0, 0, 0,
+ 0, 430, 431, 432, 433, 434, 0, 0, 0, 27,
+ 0, 0, 0, 28, 0, 0, 0, 75, 0, 0,
+ 0, 0, 0, 0, 29, 0, 0, 30, 0, 0,
+ 0, 0, -93, 0, 0, 0, 0, 95, 0, 0,
+ 0, 0, 0, 27, 98, 99, 0, 435, 76, 77,
+ 0, 78, 79, 80, 81, 0, 83, 84, 85, 86,
+ 0, 88, 0, 0, 0, 0, 71, 0, 90, 91,
+ 0, 92, 93, 0, 0, 0, 94, 0, 95, 0,
+ 0, 96, 75, 97, 27, 98, 99, 0, 469, 0,
+ 0, 0, 0, 0, 0, 100, 101, 102, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 103, 104,
+ 0, 105, 0, 76, 77, 0, 78, 79, 80, 81,
+ 0, 83, 84, 85, 86, 0, 88, 0, 0, 0,
+ 0, 0, 0, 90, 91, 0, 92, 93, 0, 0,
+ 0, 94, 0, 95, 0, 0, 96, 75, 97, 27,
+ 98, 99, 0, 0, 0, 0, 0, 0, 0, 0,
+ 100, 101, 102, 0, 0, 0, 0, 0, 0, 0,
+ 0, 494, 0, 103, 104, 0, 105, 0, 76, 77,
+ 0, 78, 79, 80, 81, 0, 83, 84, 85, 86,
+ 0, 88, 0, 0, 0, 0, 0, 0, 90, 91,
+ 0, 92, 93, 0, 0, 0, 94, 0, 95, 0,
+ 0, 96, 75, 97, 27, 98, 99, 0, 0, 0,
+ 0, 0, 0, 0, 0, 100, 101, 102, 0, 0,
+ 0, 0, 0, 0, 0, 0, 496, 0, 103, 104,
+ 0, 105, 0, 76, 77, 0, 78, 79, 80, 81,
+ 526, 83, 84, 85, 86, 0, 88, 0, 0, 0,
+ 0, 0, 0, 90, 91, 0, 92, 93, 0, 0,
+ 0, 94, 0, 95, 0, 0, 96, 0, 97, 27,
+ 98, 99, 0, 0, 0, 0, 0, 0, 0, 0,
+ 100, 101, 102, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 103, 104, 606, 105, 2, 3, 4,
+ 5, 6, 7, 8, 9, 10, 11, 12, -38, -38,
+ -38, 13, 0, 14, 15, 16, 17, 18, 0, 0,
+ 0, 19, 0, 0, 20, 21, 0, 615, 22, 2,
+ 3, 4, 5, 6, 7, 8, 9, 10, 11, 12,
+ -38, -38, -38, 13, 0, 14, 15, 16, 17, 18,
+ 0, 0, 0, 19, 0, 0, 20, 21, 0, 0,
+ 22, 0, 0, 0, 0, 0, 27, 0, 0, 0,
+ 28, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 29, 0, 0, 30, 0, 0, 0, 0, -93,
+ 0, 0, 0, 0, 0, 0, 0, 0, 27, 0,
+ 0, 0, 28, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 29, 0, 0, 30, 0, 0, 0,
+ 647, -93, 2, 3, 4, 5, 6, 7, 8, 9,
+ 10, 11, 12, 0, 0, -38, 13, -38, 14, 15,
+ 16, 17, 18, 0, 0, -38, 19, 0, 0, 20,
+ 21, 0, 0, 22, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 2, 3, 4, 63, 64, 65, 66,
+ 67, 68, 69, 0, 0, 0, 75, 0, 0, 14,
+ 0, 0, 0, 18, 0, 0, 0, 19, 0, 0,
+ 70, 27, 0, 0, 0, 28, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 29, 76, 77, 30,
+ 78, 79, 80, 81, -93, 83, 84, 85, 86, 0,
+ 88, 0, 0, 0, 0, 0, 0, 90, 91, 0,
+ 92, 93, 27, 0, 0, 94, 28, 95, 0, 0,
+ 96, 0, 97, 27, 98, 99, 0, 29, 0, 0,
+ 30, 0, 666, 0, 100, 101, 102, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 103, 104, 720,
+ 105, 2, 3, 4, 5, 6, 7, 8, 9, 10,
+ 11, 12, 0, 0, -38, 13, 0, 14, 15, 16,
+ 17, 18, 0, 0, 0, 19, 0, 0, 20, 21,
+ -38, -38, 22, 748, 0, 2, 3, 4, 5, 6,
+ 7, 8, 9, 10, 11, 12, 0, 0, -38, 13,
+ 0, 14, 15, 16, 17, 18, 0, 0, 0, 19,
+ 0, 0, 20, 21, -38, -38, 22, 0, 0, 0,
+ 27, 0, 0, 0, 28, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 29, 0, 0, 30, 75,
+ 0, 0, 0, -93, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 27, 0, 0, 0, 28, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 29,
+ 76, 77, 30, 78, 79, 80, 81, -93, 83, 84,
+ 85, 86, 0, 88, 0, 0, 0, 0, 0, 0,
+ 90, 91, 0, 92, 93, 0, 0, 0, 94, 0,
+ 95, 0, 0, 96, 165, 97, 27, 98, 99, 0,
+ 0, 0, 0, 0, 0, 0, 0, 100, 101, 102,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 103, 104, 0, 105, 0, 76, 77, 0, 78, 79,
+ 80, 81, 0, 83, 84, 85, 167, 0, 168, 0,
+ 0, 0, 0, 0, 0, 169, 170, 0, 171, 172,
+ 0, 0, 0, 173, 0, 95, 0, 0, 0, 0,
+ 0, 27, 98, 99, 0, 0, 0, 0, 0, 0,
+ 0, 0, 175, 176, 177, 0, 0, 0, 0, 0,
+ 0, 0, 0, 379, 0, 103, 104, 613, 105, 2,
+ 3, 4, 5, 6, 7, 8, 9, 10, 11, 12,
+ 0, 0, -38, 13, 0, 14, 15, 16, 17, 18,
+ 0, 0, 0, 19, 0, 0, 20, 21, 0, 628,
+ 22, 2, 3, 4, 5, 6, 7, 8, 9, 10,
+ 11, 12, 0, 0, -38, 13, 0, 14, 15, 16,
+ 17, 18, 0, 0, 0, 19, 0, 0, 20, 21,
+ 0, 0, 22, 0, 0, 0, 0, 0, 27, 0,
+ 0, 0, 28, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 29, 0, 0, 30, 0, 0, 0,
+ 0, -93, 0, 0, 0, 0, 0, 0, 0, 0,
+ 27, 0, 0, 0, 28, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 29, 0, 0, 30, 0,
+ 0, 0, 692, -93, 2, 3, 4, 5, 6, 7,
+ 8, 9, 10, 11, 12, 165, 0, -38, 13, 0,
+ 14, 15, 16, 17, 18, 0, 0, 0, 19, 0,
+ 0, 20, 21, 0, 0, 22, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 76, 77, 0, 78,
+ 79, 80, 81, 0, 83, 84, 85, 167, 0, 168,
+ 0, 0, 0, 0, 0, 0, 169, 170, 0, 171,
+ 172, 0, 0, 27, 173, 0, 95, 28, 0, 0,
+ 0, 0, 27, 98, 99, 0, 0, 0, 29, 0,
+ 0, 30, 0, 175, 176, 177, -93, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 103, 104, 62, 105,
+ 2, 3, 4, 63, 64, 65, 66, 67, 68, 69,
+ 0, -93, -93, -93, 0, 0, 14, 0, 0, 0,
+ 18, 0, 0, 0, 19, 0, 62, 70, 2, 3,
+ 4, 63, 64, 65, 66, 67, 68, 69, 0, 0,
+ 0, 0, 0, 0, 14, 0, 0, 0, 18, 0,
+ 0, 0, 19, 0, 0, 70, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 27,
+ 0, 0, 0, 28, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 29, 0, 0, 30, 0, 0,
+ 0, 0, 71, 0, 0, 0, 0, 27, 0, 0,
+ 0, 28, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 29, 0, 0, 30, 0, 0, 0, 0,
+ 71, 412, 413, 414, 415, 416, 417, 418, 419, 420,
+ 421, 422, 423, 424, 0, 425, 0, 426, 427, 578,
+ 428, 429, 0, 0, 0, 0, 0, 0, 430, 431,
+ 432, 433, 579, 0, 2, 3, 4, 5, 6, 7,
+ 8, 9, 10, 11, 12, 0, 0, 0, 13, 0,
+ 14, 15, 16, 17, 18, 0, 0, 0, 19, 0,
+ 0, 20, 21, 0, 95, 22, 0, 0, 0, 0,
+ 27, 98, 99, 0, 435, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, -175, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 27, 0, 0, 0, 28, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 29, 0,
+ 0, 30, 0, 0, 0, 0, -93, 412, 413, 414,
+ 415, 416, 417, 418, 419, 420, 421, 422, 423, 424,
+ 0, 425, 0, 426, 427, 0, 428, 429, 0, 0,
+ 0, 0, 0, 0, 430, 431, 432, 433, 434, 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,
+ 95, 0, 0, 0, 0, 0, 27, 98, 99, 0,
+ 435
+};
+
+#define yypact_value_is_default(yystate) \
+ ((yystate) == (-664))
+
+#define yytable_value_is_error(yytable_value) \
+ YYID (0)
+
+static const yytype_int16 yycheck[] =
+{
+ 7, 8, 9, 51, 210, 87, 22, 20, 128, 151,
+ 130, 27, 132, 441, 21, 4, 25, 105, 506, 5,
+ 1, 7, 8, 9, 81, 25, 89, 29, 1, 220,
+ 5, 4, 1, 25, 656, 86, 87, 384, 1, 4,
+ 95, 4, 55, 4, 1, 3, 4, 4, 1, 1,
+ 1, 1, 399, 104, 86, 25, 88, 70, 721, 1,
+ 5, 1, 4, 0, 280, 281, 95, 63, 429, 27,
+ 25, 4, 1, 1, 63, 77, 5, 63, 294, 65,
+ 66, 67, 98, 299, 57, 167, 749, 1, 84, 95,
+ 63, 10, 11, 12, 63, 14, 57, 94, 63, 18,
+ 63, 74, 63, 81, 81, 168, 63, 729, 730, 86,
+ 732, 88, 63, 74, 95, 84, 167, 99, 100, 72,
+ 72, 63, 72, 98, 57, 44, 99, 0, 25, 87,
+ 63, 619, 72, 81, 97, 142, 5, 100, 99, 100,
+ 97, 74, 199, 200, 72, 64, 574, 76, 150, 68,
+ 69, 202, 154, 581, 776, 97, 778, 779, 72, 81,
+ 648, 589, 63, 70, 81, 174, 81, 176, 55, 178,
+ 386, 70, 56, 38, 174, 81, 176, 1, 178, 395,
+ 4, 5, 174, 70, 266, 267, 178, 94, 276, 25,
+ 55, 81, 208, 77, 80, 94, 81, 25, 1, 32,
+ 33, 210, 5, 87, 174, 70, 176, 94, 178, 351,
+ 273, 220, 573, 220, 81, 266, 267, 578, 81, 174,
+ 81, 176, 81, 178, 16, 81, 18, 1, 310, 94,
+ 4, 7, 8, 9, 26, 14, 15, 25, 444, 63,
+ 601, 713, 714, 671, 230, 231, 437, 81, 311, 81,
+ 55, 442, 443, 56, 97, 58, 59, 60, 99, 310,
+ 80, 82, 65, 94, 754, 755, 81, 757, 38, 77,
+ 73, 144, 97, 76, 290, 16, 324, 174, 95, 176,
+ 328, 178, 330, 63, 80, 55, 89, 61, 62, 65,
+ 66, 67, 16, 38, 97, 98, 16, 16, 72, 73,
+ 70, 308, 792, 793, 794, 88, 80, 80, 82, 77,
+ 55, 81, 86, 87, 88, 89, 81, 324, 325, 326,
+ 94, 1, 308, 330, 94, 70, 333, 81, 385, 14,
+ 15, 16, 81, 390, 695, 80, 393, 394, 174, 325,
+ 176, 327, 178, 16, 81, 18, 174, 81, 176, 94,
+ 178, 81, 81, 26, 356, 357, 358, 16, 375, 376,
+ 362, 378, 95, 372, 81, 382, 375, 376, 488, 378,
+ 379, 81, 372, 382, 81, 375, 376, 95, 378, 379,
+ 372, 77, 382, 503, 0, 16, 174, 379, 176, 5,
+ 178, 7, 8, 9, 86, 87, 88, 38, 446, 456,
+ 448, 16, 372, 18, 411, 375, 376, 77, 378, 379,
+ 473, 26, 382, 429, 55, 16, 32, 372, 81, 79,
+ 375, 376, 77, 378, 379, 16, 787, 382, 437, 70,
+ 81, 1, 441, 442, 443, 51, 443, 739, 16, 77,
+ 81, 14, 15, 16, 451, 452, 453, 63, 38, 65,
+ 66, 67, 81, 94, 230, 231, 329, 81, 74, 445,
+ 78, 447, 78, 79, 80, 55, 16, 81, 84, 85,
+ 81, 81, 16, 593, 594, 372, 81, 16, 375, 376,
+ 70, 378, 379, 16, 541, 382, 16, 103, 81, 81,
+ 80, 548, 549, 795, 796, 81, 798, 25, 511, 79,
+ 16, 420, 421, 422, 94, 512, 425, 426, 427, 428,
+ 78, 430, 128, 432, 130, 16, 132, 819, 16, 81,
+ 529, 530, 81, 825, 81, 827, 828, 829, 144, 529,
+ 530, 16, 308, 18, 81, 16, 372, 529, 530, 375,
+ 376, 26, 378, 379, 372, 32, 382, 375, 376, 325,
+ 378, 379, 790, 49, 382, 811, 812, 573, 814, 529,
+ 530, 835, 578, 1, 394, 574, 86, 87, 88, 644,
+ 577, 578, 581, 158, 529, 530, 832, 833, 834, 351,
+ 589, 264, 518, 25, 372, 601, -1, 375, 376, 256,
+ 378, 379, -1, -1, 382, -1, -1, -1, -1, 25,
+ -1, -1, -1, -1, 25, 24, 25, 26, 27, 28,
+ 29, -1, -1, -1, 230, 231, -1, -1, 56, 626,
+ 58, 59, 60, 630, -1, -1, 633, 65, 501, -1,
+ -1, 504, 529, 530, -1, 73, -1, 510, 76, 25,
+ 697, 514, 80, -1, -1, 83, 174, 656, 176, -1,
+ 178, 89, 24, 25, 26, 27, 28, 29, -1, 97,
+ -1, 668, 671, -1, -1, -1, -1, -1, -1, 445,
+ 718, 447, -1, 680, 681, 682, -1, 684, -1, 695,
+ -1, -1, 689, -1, 691, -1, 559, -1, -1, -1,
+ -1, 698, 308, 529, 530, -1, 703, 704, -1, 706,
+ -1, 529, 530, 710, 623, -1, 625, -1, 324, 325,
+ -1, 327, 328, 329, 330, -1, -1, 724, -1, -1,
+ 729, 730, -1, 732, -1, -1, -1, -1, -1, 738,
+ 739, 717, 174, 740, 176, -1, 178, 744, -1, -1,
+ 659, 529, 530, 750, -1, 752, 753, -1, 174, -1,
+ 176, -1, 178, 174, -1, 176, -1, 178, -1, 632,
+ -1, -1, -1, -1, -1, -1, 685, 776, -1, 778,
+ 779, 787, -1, 780, 781, -1, 783, -1, -1, -1,
+ 699, -1, -1, -1, -1, 24, 795, 796, 174, 798,
+ 176, -1, 178, -1, 801, -1, 803, -1, 805, -1,
+ 807, -1, -1, -1, -1, -1, 813, -1, 815, 816,
+ 819, 818, 731, 820, 733, 734, 825, 690, 827, 828,
+ 829, -1, -1, -1, -1, -1, -1, -1, -1, 445,
+ 446, 447, 448, -1, 4, -1, -1, -1, -1, -1,
+ 713, 714, -1, -1, 372, -1, -1, 375, 376, 722,
+ 378, 379, -1, -1, 382, -1, 95, 96, 97, -1,
+ 99, -1, 101, 782, -1, 784, 785, -1, -1, -1,
+ -1, -1, 488, -1, -1, -1, -1, -1, 751, -1,
+ -1, 120, -1, -1, -1, 501, -1, 503, 504, -1,
+ -1, 61, 62, 766, 510, -1, -1, 770, 514, -1,
+ 773, -1, 72, 73, -1, -1, -1, -1, -1, -1,
+ 80, -1, 82, -1, -1, -1, 1, -1, -1, 89,
+ -1, -1, 161, 162, 94, -1, -1, -1, -1, -1,
+ 372, -1, -1, 375, 376, -1, 378, 379, -1, -1,
+ 382, -1, -1, 559, -1, -1, 372, -1, -1, 375,
+ 376, 372, 378, 379, 375, 376, 382, 378, 379, -1,
+ -1, 382, 1, -1, -1, -1, 205, 206, -1, -1,
+ -1, 56, -1, 58, 59, 60, -1, 593, 594, -1,
+ 65, -1, -1, -1, -1, -1, 372, -1, 73, 375,
+ 376, 76, 378, 379, -1, 80, 382, -1, -1, -1,
+ 5, 529, 530, -1, 89, -1, -1, -1, -1, -1,
+ -1, -1, 97, 252, -1, -1, 632, 56, -1, 58,
+ 59, 60, -1, -1, -1, -1, 65, -1, -1, -1,
+ -1, -1, 271, -1, 73, -1, -1, 76, 77, -1,
+ -1, 280, 281, -1, -1, -1, -1, -1, 287, 288,
+ 89, 56, -1, -1, -1, 294, 295, 296, 97, -1,
+ 299, 66, -1, -1, -1, -1, -1, 72, 73, 74,
+ -1, -1, 77, 312, 690, 314, 315, 316, 317, -1,
+ 1, -1, 87, 4, -1, -1, -1, 529, 530, -1,
+ 56, -1, 58, 59, 60, -1, -1, 713, 714, 65,
+ -1, 717, 718, 529, 530, -1, 722, 73, 529, 530,
+ 76, -1, -1, -1, -1, -1, -1, -1, -1, 85,
+ -1, -1, -1, 89, -1, -1, -1, 366, -1, -1,
+ 369, 97, -1, -1, -1, 751, -1, -1, -1, -1,
+ 61, 62, 1, 529, 530, 384, 5, 386, -1, -1,
+ 766, 72, 73, -1, 770, -1, 395, 773, -1, 80,
+ 399, 82, -1, -1, -1, 86, 87, 88, 89, -1,
+ -1, -1, -1, 94, -1, -1, -1, 36, 37, -1,
+ 39, 40, 41, 42, 43, 44, 45, 46, 47, 48,
+ 49, 50, -1, -1, -1, 434, 435, 56, 57, -1,
+ 59, 60, -1, -1, -1, 64, -1, 66, 67, 68,
+ 69, -1, 71, 72, 73, 74, -1, -1, 457, -1,
+ -1, -1, 81, 1, 83, 84, 85, 5, -1, -1,
+ 469, -1, -1, -1, -1, 94, -1, 96, 97, -1,
+ 99, -1, -1, 1, -1, -1, 4, -1, -1, -1,
+ -1, 490, -1, -1, -1, 494, -1, 496, 36, 37,
+ -1, 39, 40, 41, 42, 43, 44, 45, 46, 47,
+ 48, 49, 50, -1, -1, -1, -1, -1, 56, 57,
+ -1, 59, 60, -1, 523, 524, 64, -1, 66, 67,
+ 68, 69, -1, 71, 72, 73, 74, -1, -1, -1,
+ -1, -1, 80, 61, 62, 83, 84, 85, 1, -1,
+ -1, -1, 5, -1, 72, 73, 94, -1, 96, 97,
+ -1, 99, 80, 81, 82, -1, -1, -1, 86, -1,
+ 88, 89, -1, 572, -1, -1, 94, -1, -1, -1,
+ 579, -1, -1, 36, 37, -1, 39, 40, 41, 42,
+ 43, 44, 45, 46, 47, 48, 49, 50, -1, -1,
+ -1, -1, -1, 56, 57, -1, 59, 60, -1, 608,
+ -1, 64, -1, 66, -1, -1, 69, -1, 71, 72,
+ 73, 74, -1, -1, -1, 61, 62, -1, 81, -1,
+ 83, 84, 85, -1, 1, -1, 72, -1, 5, -1,
+ -1, -1, 95, 96, 97, 81, 99, -1, -1, -1,
+ 86, 87, 88, 89, 90, 91, 92, 93, 94, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 667, 36,
+ 37, -1, 39, 40, 41, 42, 43, 44, 45, 46,
+ 47, 48, 49, 50, -1, -1, -1, -1, -1, 56,
+ 57, -1, 59, 60, -1, -1, -1, 64, -1, 66,
+ -1, -1, 69, -1, 71, 72, 73, 74, 1, -1,
+ -1, -1, 5, -1, 81, -1, 83, 84, 85, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 96,
+ 97, -1, 99, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 36, 37, -1, 39, 40, 41, 42,
+ 43, 44, 45, 46, 47, 48, 49, 50, -1, -1,
+ -1, -1, -1, 56, 57, -1, 59, 60, -1, -1,
+ -1, 64, -1, 66, -1, -1, 69, -1, 71, 72,
+ 73, 74, 1, -1, -1, -1, 5, -1, 81, -1,
+ 83, 84, 85, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 96, 97, -1, 99, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 36, 37, -1,
+ 39, 40, 41, 42, 43, 44, 45, 46, 47, 48,
+ 49, 50, -1, -1, -1, -1, -1, 56, 57, -1,
+ 59, 60, -1, -1, -1, 64, -1, 66, -1, -1,
+ 69, -1, 71, 72, 73, 74, 1, -1, -1, -1,
+ 5, -1, 81, -1, 83, 84, 85, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 96, 97, -1,
+ 99, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 36, 37, -1, 39, 40, 41, 42, 43, 44,
+ 45, 46, 47, 48, 49, 50, -1, -1, -1, -1,
+ -1, 56, 57, -1, 59, 60, -1, -1, -1, 64,
+ -1, 66, -1, -1, 69, -1, 71, 72, 73, 74,
+ 1, -1, -1, -1, 5, -1, 81, -1, 83, 84,
+ 85, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 96, 97, -1, 99, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 36, 37, -1, 39, 40,
+ 41, 42, 43, 44, 45, 46, 47, 48, 49, 50,
+ -1, -1, -1, -1, -1, 56, 57, -1, 59, 60,
+ -1, -1, -1, 64, -1, 66, -1, -1, 69, -1,
+ 71, 72, 73, 74, 1, -1, -1, -1, 5, -1,
+ 81, -1, 83, 84, 85, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 96, 97, -1, 99, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 36,
+ 37, -1, 39, 40, 41, 42, 43, 44, 45, 46,
+ 47, 48, 49, 50, -1, -1, -1, -1, -1, 56,
+ 57, -1, 59, 60, -1, -1, -1, 64, -1, 66,
+ -1, -1, 69, -1, 71, 72, 73, 74, 1, -1,
+ -1, -1, 5, -1, 81, -1, 83, 84, 85, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 96,
+ 97, -1, 99, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 36, 37, -1, 39, 40, 41, 42,
+ -1, 44, 45, 46, 47, -1, 49, -1, -1, -1,
+ -1, -1, -1, 56, 57, -1, 59, 60, -1, -1,
+ -1, 64, -1, 66, -1, -1, 69, -1, 71, 72,
+ 73, 74, 1, -1, -1, -1, 5, -1, -1, -1,
+ 83, 84, 85, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 96, 97, -1, 99, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 36, 37, -1,
+ 39, 40, 41, 42, -1, 44, 45, 46, 47, -1,
+ 49, -1, -1, -1, -1, -1, -1, 56, 57, -1,
+ 59, 60, -1, -1, -1, 64, -1, 66, -1, -1,
+ 69, -1, 71, 72, 73, 74, 1, -1, -1, -1,
+ 5, -1, -1, -1, 83, 84, 85, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 96, 97, -1,
+ 99, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 36, 37, -1, 39, 40, 41, 42, -1, 44,
+ 45, 46, 47, -1, 49, -1, -1, -1, -1, -1,
+ -1, 56, 57, -1, 59, 60, -1, -1, -1, 64,
+ -1, 66, -1, -1, 69, -1, 71, 72, 73, 74,
+ -1, -1, -1, -1, -1, -1, -1, -1, 83, 84,
+ 85, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 96, 97, -1, 99, 0, 1, -1, 3, 4,
+ 5, 6, 7, 8, 9, 10, 11, 12, 13, -1,
+ 61, -1, 17, -1, 19, 20, 21, 22, 23, -1,
+ -1, 72, 27, -1, -1, 30, 31, -1, -1, 34,
+ 81, -1, -1, -1, -1, 86, 87, 88, 89, 90,
+ 91, 92, 93, 94, -1, -1, 51, 52, 53, 54,
+ -1, -1, -1, -1, 1, -1, 3, 4, 5, 6,
+ 7, 8, 9, 10, 11, 12, 13, 72, -1, 16,
+ 17, 76, 19, 20, 21, 22, 23, -1, -1, -1,
+ 27, -1, 87, 30, 31, 90, -1, 34, -1, 1,
+ 95, 3, 4, 5, 6, 7, 8, 9, 10, 11,
+ 12, 13, 14, 15, 16, 17, -1, 19, 20, -1,
+ 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, -1, -1, 72, -1, -1, -1, 76,
+ -1, 78, 79, -1, 5, -1, -1, -1, -1, -1,
+ 87, -1, -1, 90, -1, -1, -1, -1, 95, -1,
+ -1, -1, -1, -1, 66, -1, -1, -1, -1, -1,
+ 72, 73, 74, -1, 76, 36, 37, 38, 39, 40,
+ 41, 42, 43, 44, 45, 46, 47, 48, 49, 50,
+ -1, -1, -1, 95, 55, 56, 57, -1, 59, 60,
+ -1, -1, -1, 64, -1, 66, -1, -1, 69, 70,
+ 71, 72, 73, 74, 5, -1, -1, -1, -1, -1,
+ -1, -1, 83, 84, 85, -1, -1, -1, -1, -1,
+ -1, -1, -1, 94, -1, 96, 97, -1, 99, -1,
+ -1, -1, -1, -1, -1, 36, 37, 38, 39, 40,
+ 41, 42, -1, 44, 45, 46, 47, -1, 49, -1,
+ -1, -1, -1, -1, 55, 56, 57, -1, 59, 60,
+ -1, 1, -1, 64, -1, 66, -1, -1, 69, 70,
+ 71, 72, 73, 74, -1, -1, -1, -1, -1, -1,
+ 81, -1, 83, 84, 85, -1, -1, -1, -1, -1,
+ -1, -1, -1, 94, -1, 96, 97, 1, 99, 3,
+ 4, 5, 6, 7, 8, 9, 10, 11, 12, 13,
+ 14, 15, 16, 17, -1, 19, 20, 21, 22, 23,
+ -1, 61, 62, -1, -1, -1, 30, 31, 32, 33,
+ 34, -1, 72, -1, -1, -1, -1, -1, -1, -1,
+ 80, 81, -1, -1, -1, 5, 86, 87, 88, 89,
+ 90, 91, 92, 93, 94, -1, -1, -1, -1, -1,
+ -1, -1, 66, -1, -1, -1, -1, -1, 72, 73,
+ 74, -1, 76, -1, 78, 79, 36, 37, -1, 39,
+ 40, 41, 42, 43, 44, 45, 46, 47, 48, 49,
+ 50, 95, -1, -1, -1, -1, 56, 57, -1, 59,
+ 60, -1, -1, -1, 64, -1, 66, 67, -1, 69,
+ 5, 71, 72, 73, 74, -1, -1, -1, -1, -1,
+ -1, -1, -1, 83, 84, 85, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 96, 97, -1, 99,
+ -1, 36, 37, -1, 39, 40, 41, 42, 43, 44,
+ 45, 46, 47, 48, 49, 50, -1, -1, -1, -1,
+ -1, 56, 57, -1, 59, 60, -1, -1, -1, 64,
+ -1, 66, -1, -1, 69, 5, 71, 72, 73, 74,
+ -1, -1, -1, -1, -1, -1, 81, -1, 83, 84,
+ 85, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 96, 97, -1, 99, -1, 36, 37, 38, 39,
+ 40, 41, 42, -1, 44, 45, 46, 47, -1, 49,
+ -1, -1, -1, -1, -1, 55, 56, 57, -1, 59,
+ 60, -1, -1, -1, 64, -1, 66, -1, -1, 69,
+ 70, 71, 72, 73, 74, 5, -1, -1, -1, -1,
+ -1, -1, -1, 83, 84, 85, -1, -1, -1, -1,
+ -1, -1, -1, -1, 94, -1, 96, 97, -1, 99,
+ -1, -1, -1, -1, -1, -1, 36, 37, -1, 39,
+ 40, 41, 42, 43, 44, 45, 46, 47, 48, 49,
+ 50, -1, -1, -1, -1, -1, 56, 57, -1, 59,
+ 60, -1, -1, -1, 64, -1, 66, -1, -1, 69,
+ 5, 71, 72, 73, 74, -1, -1, -1, -1, -1,
+ -1, -1, -1, 83, 84, 85, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 96, 97, -1, 99,
+ -1, 36, 37, -1, 39, 40, 41, 42, 43, 44,
+ 45, 46, 47, -1, 49, -1, -1, -1, -1, -1,
+ -1, 56, 57, -1, 59, 60, -1, -1, -1, 64,
+ -1, 66, -1, -1, 69, 70, 71, 72, 73, 74,
+ -1, -1, -1, -1, -1, -1, -1, -1, 83, 84,
+ 85, -1, -1, -1, -1, -1, -1, -1, -1, 94,
+ -1, 96, 97, 1, 99, 3, 4, 5, 6, 7,
+ 8, 9, 10, 11, 12, 13, 14, 15, 16, 17,
+ -1, 19, 20, 21, 22, 23, -1, -1, -1, -1,
+ -1, -1, 30, 31, 32, 33, 34, 1, -1, 3,
+ 4, 5, 6, 7, 8, 9, 10, 11, 12, 13,
+ 14, 15, 16, 17, 18, 19, 20, 21, 22, 23,
+ -1, -1, 26, 27, -1, -1, 30, 31, 66, -1,
+ 34, -1, -1, -1, 72, 73, 74, -1, 76, -1,
+ 1, -1, 3, 4, 5, 6, 7, 8, 9, 10,
+ 11, 12, 13, 5, -1, 16, 17, 95, 19, 20,
+ 21, 22, 23, -1, -1, -1, 27, -1, 72, 30,
+ 31, -1, 76, 34, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 87, 36, 37, 90, 39, 40, 41,
+ 42, 95, 44, 45, 46, 47, -1, 49, -1, -1,
+ -1, -1, -1, -1, 56, 57, -1, 59, 60, -1,
+ -1, 72, 64, -1, 66, 76, -1, 69, 70, 71,
+ 72, 73, 74, -1, -1, -1, 87, -1, -1, 90,
+ -1, 83, 84, 85, 95, -1, -1, -1, -1, -1,
+ -1, -1, 94, -1, 96, 97, 1, 99, 3, 4,
+ 5, 6, 7, 8, 9, 10, 11, 12, 13, 14,
+ 15, -1, 17, -1, 19, 20, 21, 22, 23, -1,
+ -1, -1, -1, -1, -1, 30, 31, 32, 33, 34,
+ -1, -1, -1, 1, -1, 3, 4, 5, 6, 7,
+ 8, 9, 10, 11, 12, 13, 14, 15, -1, 17,
+ -1, 19, 20, 21, 22, 23, -1, -1, -1, -1,
+ -1, 66, 30, 31, 32, 33, 34, 72, 73, 74,
+ -1, 76, -1, -1, 1, -1, 3, 4, 5, 6,
+ 7, 8, 9, 10, 11, 12, -1, 14, 15, 16,
+ 95, 18, 19, -1, -1, -1, 23, -1, 66, 26,
+ 27, -1, -1, 30, 72, 73, 74, -1, 76, -1,
+ 1, -1, 3, 4, 5, 6, 7, 8, 9, 10,
+ 11, 12, 13, 14, 15, -1, 17, 95, 19, 20,
+ 21, 22, 23, -1, -1, -1, -1, -1, -1, 30,
+ 31, 32, 33, 34, -1, 72, -1, -1, -1, 76,
+ -1, -1, -1, -1, -1, 5, -1, -1, -1, -1,
+ 87, -1, -1, 90, -1, -1, -1, -1, 95, -1,
+ -1, -1, -1, -1, -1, 66, -1, -1, -1, -1,
+ -1, 72, 73, 74, -1, 76, 36, 37, -1, 39,
+ 40, 41, 42, 43, 44, 45, 46, 47, -1, 49,
+ -1, -1, -1, -1, 95, -1, 56, 57, -1, 59,
+ 60, -1, -1, -1, 64, -1, 66, -1, -1, -1,
+ 70, -1, 72, 73, 74, -1, -1, -1, -1, -1,
+ -1, -1, -1, 83, 84, 85, -1, -1, -1, -1,
+ -1, -1, -1, -1, 94, -1, 96, 97, 1, 99,
+ 3, 4, 5, 6, 7, 8, 9, 10, 11, 12,
+ 13, 14, 15, 16, 17, -1, 19, 20, 21, 22,
+ 23, 4, -1, -1, 27, -1, -1, 30, 31, -1,
+ 1, 34, 3, 4, 5, 6, 7, 8, 9, 10,
+ 11, 12, 13, 14, 15, 16, 17, -1, 19, 20,
+ 21, 22, 23, -1, -1, -1, 27, -1, -1, 30,
+ 31, -1, -1, 34, -1, -1, -1, -1, -1, 72,
+ -1, -1, -1, 76, -1, -1, -1, -1, 61, 62,
+ -1, -1, -1, -1, 87, -1, -1, 90, -1, 72,
+ 73, -1, 95, -1, -1, -1, -1, 80, -1, 82,
+ -1, 72, -1, -1, -1, 76, 89, 90, 91, 92,
+ 93, 94, -1, -1, -1, -1, 87, -1, -1, 90,
+ -1, -1, -1, 1, 95, 3, 4, 5, 6, 7,
+ 8, 9, 10, 11, 12, 13, 14, 15, 16, 17,
+ -1, 19, 20, 21, 22, 23, -1, -1, -1, 27,
+ -1, -1, 30, 31, -1, 1, 34, 3, 4, 5,
+ 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
+ 16, 17, -1, 19, 20, 21, 22, 23, -1, -1,
+ -1, 27, -1, -1, 30, 31, -1, 56, 34, 58,
+ 59, 60, -1, -1, 72, -1, 65, -1, 76, 56,
+ -1, 58, 59, 60, 73, -1, -1, 76, 65, 87,
+ -1, -1, 90, -1, 83, -1, 73, 95, -1, 76,
+ 89, -1, -1, -1, -1, -1, 72, -1, 97, -1,
+ 76, -1, 89, -1, -1, -1, -1, -1, -1, -1,
+ 97, 87, -1, -1, 90, -1, -1, -1, 1, 95,
+ 3, 4, 5, 6, 7, 8, 9, 10, 11, 12,
+ 13, -1, -1, 16, 17, -1, 19, 20, 21, 22,
+ 23, -1, -1, -1, 27, -1, -1, 30, 31, 32,
+ 33, 34, 1, -1, 3, 4, 5, 6, 7, 8,
+ 9, 10, 11, 12, 13, 14, 15, -1, 17, -1,
+ 19, 20, -1, 22, 23, -1, -1, -1, -1, -1,
+ -1, 30, 31, 32, 33, 34, -1, -1, -1, 72,
+ -1, -1, -1, 76, -1, -1, -1, 5, -1, -1,
+ -1, -1, -1, -1, 87, -1, -1, 90, -1, -1,
+ -1, -1, 95, -1, -1, -1, -1, 66, -1, -1,
+ -1, -1, -1, 72, 73, 74, -1, 76, 36, 37,
+ -1, 39, 40, 41, 42, -1, 44, 45, 46, 47,
+ -1, 49, -1, -1, -1, -1, 95, -1, 56, 57,
+ -1, 59, 60, -1, -1, -1, 64, -1, 66, -1,
+ -1, 69, 5, 71, 72, 73, 74, -1, 76, -1,
+ -1, -1, -1, -1, -1, 83, 84, 85, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 96, 97,
+ -1, 99, -1, 36, 37, -1, 39, 40, 41, 42,
+ -1, 44, 45, 46, 47, -1, 49, -1, -1, -1,
+ -1, -1, -1, 56, 57, -1, 59, 60, -1, -1,
+ -1, 64, -1, 66, -1, -1, 69, 5, 71, 72,
+ 73, 74, -1, -1, -1, -1, -1, -1, -1, -1,
+ 83, 84, 85, -1, -1, -1, -1, -1, -1, -1,
+ -1, 94, -1, 96, 97, -1, 99, -1, 36, 37,
+ -1, 39, 40, 41, 42, -1, 44, 45, 46, 47,
+ -1, 49, -1, -1, -1, -1, -1, -1, 56, 57,
+ -1, 59, 60, -1, -1, -1, 64, -1, 66, -1,
+ -1, 69, 5, 71, 72, 73, 74, -1, -1, -1,
+ -1, -1, -1, -1, -1, 83, 84, 85, -1, -1,
+ -1, -1, -1, -1, -1, -1, 94, -1, 96, 97,
+ -1, 99, -1, 36, 37, -1, 39, 40, 41, 42,
+ 43, 44, 45, 46, 47, -1, 49, -1, -1, -1,
+ -1, -1, -1, 56, 57, -1, 59, 60, -1, -1,
+ -1, 64, -1, 66, -1, -1, 69, -1, 71, 72,
+ 73, 74, -1, -1, -1, -1, -1, -1, -1, -1,
+ 83, 84, 85, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 96, 97, 1, 99, 3, 4, 5,
+ 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
+ 16, 17, -1, 19, 20, 21, 22, 23, -1, -1,
+ -1, 27, -1, -1, 30, 31, -1, 1, 34, 3,
+ 4, 5, 6, 7, 8, 9, 10, 11, 12, 13,
+ 14, 15, 16, 17, -1, 19, 20, 21, 22, 23,
+ -1, -1, -1, 27, -1, -1, 30, 31, -1, -1,
+ 34, -1, -1, -1, -1, -1, 72, -1, -1, -1,
+ 76, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 87, -1, -1, 90, -1, -1, -1, -1, 95,
+ -1, -1, -1, -1, -1, -1, -1, -1, 72, -1,
+ -1, -1, 76, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 87, -1, -1, 90, -1, -1, -1,
+ 1, 95, 3, 4, 5, 6, 7, 8, 9, 10,
+ 11, 12, 13, -1, -1, 16, 17, 18, 19, 20,
+ 21, 22, 23, -1, -1, 26, 27, -1, -1, 30,
+ 31, -1, -1, 34, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 3, 4, 5, 6, 7, 8, 9,
+ 10, 11, 12, -1, -1, -1, 5, -1, -1, 19,
+ -1, -1, -1, 23, -1, -1, -1, 27, -1, -1,
+ 30, 72, -1, -1, -1, 76, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 87, 36, 37, 90,
+ 39, 40, 41, 42, 95, 44, 45, 46, 47, -1,
+ 49, -1, -1, -1, -1, -1, -1, 56, 57, -1,
+ 59, 60, 72, -1, -1, 64, 76, 66, -1, -1,
+ 69, -1, 71, 72, 73, 74, -1, 87, -1, -1,
+ 90, -1, 81, -1, 83, 84, 85, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 96, 97, 1,
+ 99, 3, 4, 5, 6, 7, 8, 9, 10, 11,
+ 12, 13, -1, -1, 16, 17, -1, 19, 20, 21,
+ 22, 23, -1, -1, -1, 27, -1, -1, 30, 31,
+ 32, 33, 34, 1, -1, 3, 4, 5, 6, 7,
+ 8, 9, 10, 11, 12, 13, -1, -1, 16, 17,
+ -1, 19, 20, 21, 22, 23, -1, -1, -1, 27,
+ -1, -1, 30, 31, 32, 33, 34, -1, -1, -1,
+ 72, -1, -1, -1, 76, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 87, -1, -1, 90, 5,
+ -1, -1, -1, 95, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 72, -1, -1, -1, 76, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 87,
+ 36, 37, 90, 39, 40, 41, 42, 95, 44, 45,
+ 46, 47, -1, 49, -1, -1, -1, -1, -1, -1,
+ 56, 57, -1, 59, 60, -1, -1, -1, 64, -1,
+ 66, -1, -1, 69, 5, 71, 72, 73, 74, -1,
+ -1, -1, -1, -1, -1, -1, -1, 83, 84, 85,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 96, 97, -1, 99, -1, 36, 37, -1, 39, 40,
+ 41, 42, -1, 44, 45, 46, 47, -1, 49, -1,
+ -1, -1, -1, -1, -1, 56, 57, -1, 59, 60,
+ -1, -1, -1, 64, -1, 66, -1, -1, -1, -1,
+ -1, 72, 73, 74, -1, -1, -1, -1, -1, -1,
+ -1, -1, 83, 84, 85, -1, -1, -1, -1, -1,
+ -1, -1, -1, 94, -1, 96, 97, 1, 99, 3,
+ 4, 5, 6, 7, 8, 9, 10, 11, 12, 13,
+ -1, -1, 16, 17, -1, 19, 20, 21, 22, 23,
+ -1, -1, -1, 27, -1, -1, 30, 31, -1, 1,
+ 34, 3, 4, 5, 6, 7, 8, 9, 10, 11,
+ 12, 13, -1, -1, 16, 17, -1, 19, 20, 21,
+ 22, 23, -1, -1, -1, 27, -1, -1, 30, 31,
+ -1, -1, 34, -1, -1, -1, -1, -1, 72, -1,
+ -1, -1, 76, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 87, -1, -1, 90, -1, -1, -1,
+ -1, 95, -1, -1, -1, -1, -1, -1, -1, -1,
+ 72, -1, -1, -1, 76, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 87, -1, -1, 90, -1,
+ -1, -1, 1, 95, 3, 4, 5, 6, 7, 8,
+ 9, 10, 11, 12, 13, 5, -1, 16, 17, -1,
+ 19, 20, 21, 22, 23, -1, -1, -1, 27, -1,
+ -1, 30, 31, -1, -1, 34, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 36, 37, -1, 39,
+ 40, 41, 42, -1, 44, 45, 46, 47, -1, 49,
+ -1, -1, -1, -1, -1, -1, 56, 57, -1, 59,
+ 60, -1, -1, 72, 64, -1, 66, 76, -1, -1,
+ -1, -1, 72, 73, 74, -1, -1, -1, 87, -1,
+ -1, 90, -1, 83, 84, 85, 95, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 96, 97, 1, 99,
+ 3, 4, 5, 6, 7, 8, 9, 10, 11, 12,
+ -1, 14, 15, 16, -1, -1, 19, -1, -1, -1,
+ 23, -1, -1, -1, 27, -1, 1, 30, 3, 4,
+ 5, 6, 7, 8, 9, 10, 11, 12, -1, -1,
+ -1, -1, -1, -1, 19, -1, -1, -1, 23, -1,
+ -1, -1, 27, -1, -1, 30, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 72,
+ -1, -1, -1, 76, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 87, -1, -1, 90, -1, -1,
+ -1, -1, 95, -1, -1, -1, -1, 72, -1, -1,
+ -1, 76, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 87, -1, -1, 90, -1, -1, -1, -1,
+ 95, 3, 4, 5, 6, 7, 8, 9, 10, 11,
+ 12, 13, 14, 15, -1, 17, -1, 19, 20, 21,
+ 22, 23, -1, -1, -1, -1, -1, -1, 30, 31,
+ 32, 33, 34, -1, 3, 4, 5, 6, 7, 8,
+ 9, 10, 11, 12, 13, -1, -1, -1, 17, -1,
+ 19, 20, 21, 22, 23, -1, -1, -1, 27, -1,
+ -1, 30, 31, -1, 66, 34, -1, -1, -1, -1,
+ 72, 73, 74, -1, 76, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 95, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 72, -1, -1, -1, 76, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 87, -1,
+ -1, 90, -1, -1, -1, -1, 95, 3, 4, 5,
+ 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
+ -1, 17, -1, 19, 20, -1, 22, 23, -1, -1,
+ -1, -1, -1, -1, 30, 31, 32, 33, 34, -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,
+ 66, -1, -1, -1, -1, -1, 72, 73, 74, -1,
+ 76
+};
+
+/* YYSTOS[STATE-NUM] -- The (internal number of the) accessing
+ symbol of state STATE-NUM. */
+static const yytype_uint8 yystos[] =
+{
+ 0, 1, 3, 4, 5, 6, 7, 8, 9, 10,
+ 11, 12, 13, 17, 19, 20, 21, 22, 23, 27,
+ 30, 31, 34, 51, 52, 53, 54, 72, 76, 87,
+ 90, 102, 115, 116, 117, 118, 119, 120, 121, 122,
+ 123, 124, 125, 128, 129, 133, 136, 137, 138, 139,
+ 140, 141, 144, 145, 147, 148, 163, 164, 184, 209,
+ 95, 1, 1, 6, 7, 8, 9, 10, 11, 12,
+ 30, 95, 137, 142, 219, 5, 36, 37, 39, 40,
+ 41, 42, 43, 44, 45, 46, 47, 48, 49, 50,
+ 56, 57, 59, 60, 64, 66, 69, 71, 73, 74,
+ 83, 84, 85, 96, 97, 99, 168, 169, 170, 171,
+ 172, 173, 174, 184, 185, 186, 187, 188, 189, 190,
+ 191, 202, 210, 220, 221, 222, 229, 142, 219, 142,
+ 219, 142, 219, 1, 189, 189, 189, 1, 189, 1,
+ 189, 1, 81, 188, 219, 190, 207, 4, 61, 62,
+ 72, 73, 80, 82, 89, 94, 211, 212, 213, 218,
+ 43, 70, 94, 106, 202, 5, 43, 47, 49, 56,
+ 57, 59, 60, 64, 70, 83, 84, 85, 94, 110,
+ 168, 169, 170, 171, 172, 173, 174, 187, 196, 210,
+ 220, 221, 222, 229, 56, 58, 59, 60, 65, 73,
+ 76, 89, 97, 176, 1, 67, 68, 81, 94, 190,
+ 5, 1, 211, 0, 117, 189, 95, 140, 138, 1,
+ 81, 188, 1, 5, 76, 95, 189, 189, 189, 188,
+ 14, 15, 16, 143, 1, 116, 131, 1, 4, 5,
+ 63, 1, 211, 1, 184, 1, 184, 1, 184, 85,
+ 176, 94, 192, 1, 63, 84, 230, 231, 1, 184,
+ 1, 184, 1, 4, 63, 97, 100, 225, 227, 227,
+ 57, 74, 99, 100, 167, 223, 224, 225, 228, 228,
+ 206, 205, 1, 202, 202, 202, 1, 67, 68, 80,
+ 94, 190, 1, 202, 204, 70, 94, 202, 208, 203,
+ 1, 184, 1, 97, 225, 1, 99, 223, 81, 43,
+ 48, 50, 67, 202, 38, 55, 70, 94, 1, 131,
+ 1, 131, 1, 131, 81, 81, 81, 81, 81, 219,
+ 81, 1, 116, 81, 1, 211, 1, 61, 72, 80,
+ 81, 86, 87, 88, 89, 90, 91, 92, 93, 94,
+ 214, 215, 216, 217, 218, 211, 86, 88, 89, 90,
+ 91, 92, 93, 212, 70, 94, 107, 202, 202, 103,
+ 70, 94, 111, 227, 228, 200, 199, 196, 198, 94,
+ 196, 201, 197, 196, 104, 179, 178, 1, 80, 176,
+ 181, 1, 77, 176, 182, 177, 1, 97, 225, 105,
+ 202, 202, 190, 81, 5, 56, 77, 165, 187, 209,
+ 87, 81, 3, 4, 5, 6, 7, 8, 9, 10,
+ 11, 12, 13, 14, 15, 17, 19, 20, 22, 23,
+ 30, 31, 32, 33, 34, 76, 159, 160, 161, 166,
+ 187, 219, 232, 81, 5, 81, 81, 81, 81, 142,
+ 142, 14, 15, 16, 132, 87, 175, 193, 202, 1,
+ 63, 84, 231, 4, 63, 226, 226, 227, 227, 76,
+ 202, 228, 99, 100, 223, 208, 208, 202, 202, 190,
+ 80, 208, 202, 202, 208, 97, 99, 142, 219, 94,
+ 194, 227, 228, 202, 94, 202, 94, 202, 202, 202,
+ 138, 219, 142, 219, 219, 137, 138, 1, 116, 138,
+ 219, 32, 33, 146, 219, 81, 80, 214, 82, 211,
+ 211, 211, 211, 109, 108, 202, 43, 114, 202, 113,
+ 112, 196, 201, 201, 201, 196, 201, 114, 176, 208,
+ 1, 83, 176, 180, 1, 5, 98, 176, 183, 83,
+ 176, 180, 208, 97, 114, 81, 81, 81, 77, 219,
+ 1, 189, 189, 189, 189, 189, 189, 189, 1, 207,
+ 189, 189, 202, 202, 95, 159, 1, 16, 21, 34,
+ 149, 150, 151, 153, 157, 158, 159, 159, 159, 219,
+ 56, 77, 209, 219, 219, 219, 176, 202, 4, 63,
+ 1, 202, 228, 80, 80, 80, 1, 131, 195, 202,
+ 202, 202, 16, 1, 116, 1, 131, 1, 116, 126,
+ 16, 18, 26, 130, 16, 130, 16, 16, 1, 116,
+ 81, 188, 219, 16, 1, 116, 217, 202, 202, 196,
+ 196, 176, 80, 176, 176, 1, 77, 1, 116, 81,
+ 81, 81, 81, 81, 81, 81, 81, 81, 81, 202,
+ 207, 1, 149, 219, 207, 219, 81, 202, 16, 149,
+ 95, 95, 1, 149, 77, 77, 131, 131, 207, 202,
+ 16, 14, 15, 127, 16, 130, 189, 189, 219, 16,
+ 219, 81, 1, 116, 219, 79, 134, 183, 16, 130,
+ 158, 189, 77, 16, 81, 1, 81, 219, 1, 149,
+ 16, 77, 219, 219, 219, 219, 189, 81, 81, 219,
+ 1, 116, 219, 207, 78, 135, 176, 219, 189, 24,
+ 25, 26, 27, 28, 29, 162, 81, 219, 219, 219,
+ 16, 219, 126, 126, 81, 137, 138, 146, 1, 116,
+ 81, 219, 16, 81, 158, 158, 189, 158, 189, 189,
+ 16, 149, 156, 1, 156, 219, 219, 16, 16, 146,
+ 219, 116, 219, 219, 162, 162, 81, 162, 81, 81,
+ 24, 25, 26, 27, 28, 29, 152, 79, 154, 116,
+ 116, 116, 158, 158, 158, 219, 219, 189, 219, 189,
+ 189, 16, 207, 78, 155, 16, 134, 16, 162, 162,
+ 162, 156, 156, 81, 156, 81, 81, 219, 81, 219,
+ 16, 219, 219, 152, 152, 219, 152, 219, 219, 219,
+ 156, 219, 156, 156, 156, 156, 152, 152, 152, 154
+};
+
+#define yyerrok (yyerrstatus = 0)
+#define yyclearin (yychar = YYEMPTY)
+#define YYEMPTY (-2)
+#define YYEOF 0
+
+#define YYACCEPT goto yyacceptlab
+#define YYABORT goto yyabortlab
+#define YYERROR goto yyerrorlab
+
+
+/* Like YYERROR except do call yyerror. This remains here temporarily
+ to ease the transition to the new meaning of YYERROR, for GCC.
+ Once GCC version 2 has supplanted version 1, this can go. However,
+ YYFAIL appears to be in use. Nevertheless, it is formally deprecated
+ in Bison 2.4.2's NEWS entry, where a plan to phase it out is
+ discussed. */
+
+#define YYFAIL goto yyerrlab
+#if defined YYFAIL
+ /* This is here to suppress warnings from the GCC cpp's
+ -Wunused-macros. Normally we don't worry about that warning, but
+ some users do, and we want to make it easy for users to remove
+ YYFAIL uses, which will produce warnings from Bison 2.5. */
+#endif
+
+#define YYRECOVERING() (!!yyerrstatus)
+
+#define YYBACKUP(Token, Value) \
+do \
+ if (yychar == YYEMPTY && yylen == 1) \
+ { \
+ yychar = (Token); \
+ yylval = (Value); \
+ YYPOPSTACK (1); \
+ goto yybackup; \
+ } \
+ else \
+ { \
+ yyerror (scnr, parser, YY_("syntax error: cannot back up")); \
+ YYERROR; \
+ } \
+while (YYID (0))
+
+
+#define YYTERROR 1
+#define YYERRCODE 256
+
+
+/* YYLLOC_DEFAULT -- Set CURRENT to span from RHS[1] to RHS[N].
+ If N is 0, then set CURRENT to the empty location which ends
+ the previous symbol: RHS[0] (always defined). */
+
+#define YYRHSLOC(Rhs, K) ((Rhs)[K])
+#ifndef YYLLOC_DEFAULT
+# define YYLLOC_DEFAULT(Current, Rhs, N) \
+ do \
+ if (YYID (N)) \
+ { \
+ (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \
+ (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \
+ (Current).last_line = YYRHSLOC (Rhs, N).last_line; \
+ (Current).last_column = YYRHSLOC (Rhs, N).last_column; \
+ } \
+ else \
+ { \
+ (Current).first_line = (Current).last_line = \
+ YYRHSLOC (Rhs, 0).last_line; \
+ (Current).first_column = (Current).last_column = \
+ YYRHSLOC (Rhs, 0).last_column; \
+ } \
+ while (YYID (0))
+#endif
+
+
+/* This macro is provided for backward compatibility. */
+
+#ifndef YY_LOCATION_PRINT
+# define YY_LOCATION_PRINT(File, Loc) ((void) 0)
+#endif
+
+
+/* YYLEX -- calling `yylex' with the right arguments. */
+
+#ifdef YYLEX_PARAM
+# define YYLEX yylex (&yylval, YYLEX_PARAM)
+#else
+# define YYLEX yylex (&yylval, scnr)
+#endif
+
+/* Enable debugging if requested. */
+#if YYDEBUG
+
+# ifndef YYFPRINTF
+# include <stdio.h> /* INFRINGES ON USER NAME SPACE */
+# define YYFPRINTF fprintf
+# endif
+
+# define YYDPRINTF(Args) \
+do { \
+ if (yydebug) \
+ YYFPRINTF Args; \
+} while (YYID (0))
+
+# define YY_SYMBOL_PRINT(Title, Type, Value, Location) \
+do { \
+ if (yydebug) \
+ { \
+ YYFPRINTF (stderr, "%s ", Title); \
+ yy_symbol_print (stderr, \
+ Type, Value, scnr, parser); \
+ YYFPRINTF (stderr, "\n"); \
+ } \
+} while (YYID (0))
+
+
+/*--------------------------------.
+| Print this symbol on YYOUTPUT. |
+`--------------------------------*/
+
+/*ARGSUSED*/
+#if (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+static void
+yy_symbol_value_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep, scanner_t *scnr, parser_t *parser)
+#else
+static void
+yy_symbol_value_print (yyoutput, yytype, yyvaluep, scnr, parser)
+ FILE *yyoutput;
+ int yytype;
+ YYSTYPE const * const yyvaluep;
+ scanner_t *scnr;
+ parser_t *parser;
+#endif
+{
+ if (!yyvaluep)
+ return;
+ YYUSE (scnr);
+ YYUSE (parser);
+# ifdef YYPRINT
+ if (yytype < YYNTOKENS)
+ YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep);
+# else
+ YYUSE (yyoutput);
+# endif
+ switch (yytype)
+ {
+ default:
+ break;
+ }
+}
+
+
+/*--------------------------------.
+| Print this symbol on YYOUTPUT. |
+`--------------------------------*/
+
+#if (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+static void
+yy_symbol_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep, scanner_t *scnr, parser_t *parser)
+#else
+static void
+yy_symbol_print (yyoutput, yytype, yyvaluep, scnr, parser)
+ FILE *yyoutput;
+ int yytype;
+ YYSTYPE const * const yyvaluep;
+ scanner_t *scnr;
+ parser_t *parser;
+#endif
+{
+ if (yytype < YYNTOKENS)
+ YYFPRINTF (yyoutput, "token %s (", yytname[yytype]);
+ else
+ YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]);
+
+ yy_symbol_value_print (yyoutput, yytype, yyvaluep, scnr, parser);
+ YYFPRINTF (yyoutput, ")");
+}
+
+/*------------------------------------------------------------------.
+| yy_stack_print -- Print the state stack from its BOTTOM up to its |
+| TOP (included). |
+`------------------------------------------------------------------*/
+
+#if (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+static void
+yy_stack_print (yytype_int16 *yybottom, yytype_int16 *yytop)
+#else
+static void
+yy_stack_print (yybottom, yytop)
+ yytype_int16 *yybottom;
+ yytype_int16 *yytop;
+#endif
+{
+ YYFPRINTF (stderr, "Stack now");
+ for (; yybottom <= yytop; yybottom++)
+ {
+ int yybot = *yybottom;
+ YYFPRINTF (stderr, " %d", yybot);
+ }
+ YYFPRINTF (stderr, "\n");
+}
+
+# define YY_STACK_PRINT(Bottom, Top) \
+do { \
+ if (yydebug) \
+ yy_stack_print ((Bottom), (Top)); \
+} while (YYID (0))
+
+
+/*------------------------------------------------.
+| Report that the YYRULE is going to be reduced. |
+`------------------------------------------------*/
+
+#if (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+static void
+yy_reduce_print (YYSTYPE *yyvsp, int yyrule, scanner_t *scnr, parser_t *parser)
+#else
+static void
+yy_reduce_print (yyvsp, yyrule, scnr, parser)
+ YYSTYPE *yyvsp;
+ int yyrule;
+ scanner_t *scnr;
+ parser_t *parser;
+#endif
+{
+ int yynrhs = yyr2[yyrule];
+ int yyi;
+ unsigned long int yylno = yyrline[yyrule];
+ YYFPRINTF (stderr, "Reducing stack by rule %d (line %lu):\n",
+ yyrule - 1, yylno);
+ /* The symbols being reduced. */
+ for (yyi = 0; yyi < yynrhs; yyi++)
+ {
+ YYFPRINTF (stderr, " $%d = ", yyi + 1);
+ yy_symbol_print (stderr, yyrhs[yyprhs[yyrule] + yyi],
+ &(yyvsp[(yyi + 1) - (yynrhs)])
+ , scnr, parser);
+ YYFPRINTF (stderr, "\n");
+ }
+}
+
+# define YY_REDUCE_PRINT(Rule) \
+do { \
+ if (yydebug) \
+ yy_reduce_print (yyvsp, Rule, scnr, parser); \
+} while (YYID (0))
+
+/* Nonzero means print parse trace. It is left uninitialized so that
+ multiple parsers can coexist. */
+int yydebug;
+#else /* !YYDEBUG */
+# define YYDPRINTF(Args)
+# define YY_SYMBOL_PRINT(Title, Type, Value, Location)
+# define YY_STACK_PRINT(Bottom, Top)
+# define YY_REDUCE_PRINT(Rule)
+#endif /* !YYDEBUG */
+
+
+/* YYINITDEPTH -- initial size of the parser's stacks. */
+#ifndef YYINITDEPTH
+# define YYINITDEPTH 200
+#endif
+
+/* YYMAXDEPTH -- maximum size the stacks can grow to (effective only
+ if the built-in stack extension method is used).
+
+ Do not make this value too large; the results are undefined if
+ YYSTACK_ALLOC_MAXIMUM < YYSTACK_BYTES (YYMAXDEPTH)
+ evaluated with infinite-precision integer arithmetic. */
+
+#ifndef YYMAXDEPTH
+# define YYMAXDEPTH 10000
+#endif
+
+
+#if YYERROR_VERBOSE
+
+# ifndef yystrlen
+# if defined __GLIBC__ && defined _STRING_H
+# define yystrlen strlen
+# else
+/* Return the length of YYSTR. */
+#if (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+static YYSIZE_T
+yystrlen (const char *yystr)
+#else
+static YYSIZE_T
+yystrlen (yystr)
+ const char *yystr;
+#endif
+{
+ YYSIZE_T yylen;
+ for (yylen = 0; yystr[yylen]; yylen++)
+ continue;
+ return yylen;
+}
+# endif
+# endif
+
+# ifndef yystpcpy
+# if defined __GLIBC__ && defined _STRING_H && defined _GNU_SOURCE
+# define yystpcpy stpcpy
+# else
+/* Copy YYSRC to YYDEST, returning the address of the terminating '\0' in
+ YYDEST. */
+#if (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+static char *
+yystpcpy (char *yydest, const char *yysrc)
+#else
+static char *
+yystpcpy (yydest, yysrc)
+ char *yydest;
+ const char *yysrc;
+#endif
+{
+ char *yyd = yydest;
+ const char *yys = yysrc;
+
+ while ((*yyd++ = *yys++) != '\0')
+ continue;
+
+ return yyd - 1;
+}
+# endif
+# endif
+
+# ifndef yytnamerr
+/* Copy to YYRES the contents of YYSTR after stripping away unnecessary
+ quotes and backslashes, so that it's suitable for yyerror. The
+ heuristic is that double-quoting is unnecessary unless the string
+ contains an apostrophe, a comma, or backslash (other than
+ backslash-backslash). YYSTR is taken from yytname. If YYRES is
+ null, do not copy; instead, return the length of what the result
+ would have been. */
+static YYSIZE_T
+yytnamerr (char *yyres, const char *yystr)
+{
+ if (*yystr == '"')
+ {
+ YYSIZE_T yyn = 0;
+ char const *yyp = yystr;
+
+ for (;;)
+ switch (*++yyp)
+ {
+ case '\'':
+ case ',':
+ goto do_not_strip_quotes;
+
+ case '\\':
+ if (*++yyp != '\\')
+ goto do_not_strip_quotes;
+ /* Fall through. */
+ default:
+ if (yyres)
+ yyres[yyn] = *yyp;
+ yyn++;
+ break;
+
+ case '"':
+ if (yyres)
+ yyres[yyn] = '\0';
+ return yyn;
+ }
+ do_not_strip_quotes: ;
+ }
+
+ if (! yyres)
+ return yystrlen (yystr);
+
+ return yystpcpy (yyres, yystr) - yyres;
+}
+# endif
+
+/* Copy into *YYMSG, which is of size *YYMSG_ALLOC, an error message
+ about the unexpected token YYTOKEN for the state stack whose top is
+ YYSSP.
+
+ Return 0 if *YYMSG was successfully written. Return 1 if *YYMSG is
+ not large enough to hold the message. In that case, also set
+ *YYMSG_ALLOC to the required number of bytes. Return 2 if the
+ required number of bytes is too large to store. */
+static int
+yysyntax_error (YYSIZE_T *yymsg_alloc, char **yymsg,
+ yytype_int16 *yyssp, int yytoken)
+{
+ YYSIZE_T yysize0 = yytnamerr (0, yytname[yytoken]);
+ YYSIZE_T yysize = yysize0;
+ YYSIZE_T yysize1;
+ enum { YYERROR_VERBOSE_ARGS_MAXIMUM = 5 };
+ /* Internationalized format string. */
+ const char *yyformat = 0;
+ /* Arguments of yyformat. */
+ char const *yyarg[YYERROR_VERBOSE_ARGS_MAXIMUM];
+ /* Number of reported tokens (one for the "unexpected", one per
+ "expected"). */
+ int yycount = 0;
+
+ /* There are many possibilities here to consider:
+ - Assume YYFAIL is not used. It's too flawed to consider. See
+ <http://lists.gnu.org/archive/html/bison-patches/2009-12/msg00024.html>
+ for details. YYERROR is fine as it does not invoke this
+ function.
+ - If this state is a consistent state with a default action, then
+ the only way this function was invoked is if the default action
+ is an error action. In that case, don't check for expected
+ tokens because there are none.
+ - The only way there can be no lookahead present (in yychar) is if
+ this state is a consistent state with a default action. Thus,
+ detecting the absence of a lookahead is sufficient to determine
+ that there is no unexpected or expected token to report. In that
+ case, just report a simple "syntax error".
+ - Don't assume there isn't a lookahead just because this state is a
+ consistent state with a default action. There might have been a
+ previous inconsistent state, consistent state with a non-default
+ action, or user semantic action that manipulated yychar.
+ - Of course, the expected token list depends on states to have
+ correct lookahead information, and it depends on the parser not
+ to perform extra reductions after fetching a lookahead from the
+ scanner and before detecting a syntax error. Thus, state merging
+ (from LALR or IELR) and default reductions corrupt the expected
+ token list. However, the list is correct for canonical LR with
+ one exception: it will still contain any token that will not be
+ accepted due to an error action in a later state.
+ */
+ if (yytoken != YYEMPTY)
+ {
+ int yyn = yypact[*yyssp];
+ yyarg[yycount++] = yytname[yytoken];
+ if (!yypact_value_is_default (yyn))
+ {
+ /* Start YYX at -YYN if negative to avoid negative indexes in
+ YYCHECK. In other words, skip the first -YYN actions for
+ this state because they are default actions. */
+ int yyxbegin = yyn < 0 ? -yyn : 0;
+ /* Stay within bounds of both yycheck and yytname. */
+ int yychecklim = YYLAST - yyn + 1;
+ int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS;
+ int yyx;
+
+ for (yyx = yyxbegin; yyx < yyxend; ++yyx)
+ if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR
+ && !yytable_value_is_error (yytable[yyx + yyn]))
+ {
+ if (yycount == YYERROR_VERBOSE_ARGS_MAXIMUM)
+ {
+ yycount = 1;
+ yysize = yysize0;
+ break;
+ }
+ yyarg[yycount++] = yytname[yyx];
+ yysize1 = yysize + yytnamerr (0, yytname[yyx]);
+ if (! (yysize <= yysize1
+ && yysize1 <= YYSTACK_ALLOC_MAXIMUM))
+ return 2;
+ yysize = yysize1;
+ }
+ }
+ }
+
+ switch (yycount)
+ {
+# define YYCASE_(N, S) \
+ case N: \
+ yyformat = S; \
+ break
+ YYCASE_(0, YY_("syntax error"));
+ YYCASE_(1, YY_("syntax error, unexpected %s"));
+ YYCASE_(2, YY_("syntax error, unexpected %s, expecting %s"));
+ YYCASE_(3, YY_("syntax error, unexpected %s, expecting %s or %s"));
+ YYCASE_(4, YY_("syntax error, unexpected %s, expecting %s or %s or %s"));
+ YYCASE_(5, YY_("syntax error, unexpected %s, expecting %s or %s or %s or %s"));
+# undef YYCASE_
+ }
+
+ yysize1 = yysize + yystrlen (yyformat);
+ if (! (yysize <= yysize1 && yysize1 <= YYSTACK_ALLOC_MAXIMUM))
+ return 2;
+ yysize = yysize1;
+
+ if (*yymsg_alloc < yysize)
+ {
+ *yymsg_alloc = 2 * yysize;
+ if (! (yysize <= *yymsg_alloc
+ && *yymsg_alloc <= YYSTACK_ALLOC_MAXIMUM))
+ *yymsg_alloc = YYSTACK_ALLOC_MAXIMUM;
+ return 1;
+ }
+
+ /* Avoid sprintf, as that infringes on the user's name space.
+ Don't have undefined behavior even if the translation
+ produced a string with the wrong number of "%s"s. */
+ {
+ char *yyp = *yymsg;
+ int yyi = 0;
+ while ((*yyp = *yyformat) != '\0')
+ if (*yyp == '%' && yyformat[1] == 's' && yyi < yycount)
+ {
+ yyp += yytnamerr (yyp, yyarg[yyi++]);
+ yyformat += 2;
+ }
+ else
+ {
+ yyp++;
+ yyformat++;
+ }
+ }
+ return 0;
+}
+#endif /* YYERROR_VERBOSE */
+
+/*-----------------------------------------------.
+| Release the memory associated to this symbol. |
+`-----------------------------------------------*/
+
+/*ARGSUSED*/
+#if (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+static void
+yydestruct (const char *yymsg, int yytype, YYSTYPE *yyvaluep, scanner_t *scnr, parser_t *parser)
+#else
+static void
+yydestruct (yymsg, yytype, yyvaluep, scnr, parser)
+ const char *yymsg;
+ int yytype;
+ YYSTYPE *yyvaluep;
+ scanner_t *scnr;
+ parser_t *parser;
+#endif
+{
+ YYUSE (yyvaluep);
+ YYUSE (scnr);
+ YYUSE (parser);
+
+ if (!yymsg)
+ yymsg = "Deleting";
+ YY_SYMBOL_PRINT (yymsg, yytype, yyvaluep, yylocationp);
+
+ switch (yytype)
+ {
+
+ default:
+ break;
+ }
+}
+
+
+/* Prevent warnings from -Wmissing-prototypes. */
+#ifdef YYPARSE_PARAM
+#if defined __STDC__ || defined __cplusplus
+int yyparse (void *YYPARSE_PARAM);
+#else
+int yyparse ();
+#endif
+#else /* ! YYPARSE_PARAM */
+#if defined __STDC__ || defined __cplusplus
+int yyparse (scanner_t *scnr, parser_t *parser);
+#else
+int yyparse ();
+#endif
+#endif /* ! YYPARSE_PARAM */
+
+
+/*----------.
+| yyparse. |
+`----------*/
+
+#ifdef YYPARSE_PARAM
+#if (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+int
+yyparse (void *YYPARSE_PARAM)
+#else
+int
+yyparse (YYPARSE_PARAM)
+ void *YYPARSE_PARAM;
+#endif
+#else /* ! YYPARSE_PARAM */
+#if (defined __STDC__ || defined __C99__FUNC__ \
+ || defined __cplusplus || defined _MSC_VER)
+int
+yyparse (scanner_t *scnr, parser_t *parser)
+#else
+int
+yyparse (scnr, parser)
+ scanner_t *scnr;
+ parser_t *parser;
+#endif
+#endif
+{
+/* The lookahead symbol. */
+int yychar;
+
+/* The semantic value of the lookahead symbol. */
+YYSTYPE yylval;
+
+ int yystate;
+ /* Number of tokens to shift before error messages enabled. */
+ int yyerrstatus;
+
+ /* The stacks and their tools:
+ `yyss': related to states.
+ `yyvs': related to semantic values.
+
+ Refer to the stacks thru separate pointers, to allow yyoverflow
+ to reallocate them elsewhere. */
+
+ /* The state stack. */
+ yytype_int16 yyssa[YYINITDEPTH];
+ yytype_int16 *yyss;
+ yytype_int16 *yyssp;
+
+ /* The semantic value stack. */
+ YYSTYPE yyvsa[YYINITDEPTH];
+ YYSTYPE *yyvs;
+ YYSTYPE *yyvsp;
+
+ YYSIZE_T yystacksize;
+
+ int yyn;
+ int yyresult;
+ /* Lookahead token as an internal (translated) token number. */
+ int yytoken;
+ /* The variables used to return semantic value and location from the
+ action routines. */
+ YYSTYPE yyval;
+
+#if YYERROR_VERBOSE
+ /* Buffer for error messages, and its allocated size. */
+ char yymsgbuf[128];
+ char *yymsg = yymsgbuf;
+ YYSIZE_T yymsg_alloc = sizeof yymsgbuf;
+#endif
+
+#define YYPOPSTACK(N) (yyvsp -= (N), yyssp -= (N))
+
+ /* The number of symbols on the RHS of the reduced rule.
+ Keep to zero when no symbol should be popped. */
+ int yylen = 0;
+
+ yytoken = 0;
+ yyss = yyssa;
+ yyvs = yyvsa;
+ yystacksize = YYINITDEPTH;
+
+ YYDPRINTF ((stderr, "Starting parse\n"));
+
+ yystate = 0;
+ yyerrstatus = 0;
+ yychar = YYEMPTY; /* Cause a token to be read. */
+
+ /* Initialize stack pointers.
+ Waste one element of value and location stack
+ so that they stay on the same level as the state stack.
+ The wasted elements are never initialized. */
+ yyssp = yyss;
+ yyvsp = yyvs;
+
+ goto yysetstate;
+
+/*------------------------------------------------------------.
+| yynewstate -- Push a new state, which is found in yystate. |
+`------------------------------------------------------------*/
+ yynewstate:
+ /* In all cases, when you get here, the value and location stacks
+ have just been pushed. So pushing a state here evens the stacks. */
+ yyssp++;
+
+ yysetstate:
+ *yyssp = yystate;
+
+ if (yyss + yystacksize - 1 <= yyssp)
+ {
+ /* Get the current used size of the three stacks, in elements. */
+ YYSIZE_T yysize = yyssp - yyss + 1;
+
+#ifdef yyoverflow
+ {
+ /* Give user a chance to reallocate the stack. Use copies of
+ these so that the &'s don't force the real ones into
+ memory. */
+ YYSTYPE *yyvs1 = yyvs;
+ yytype_int16 *yyss1 = yyss;
+
+ /* Each stack pointer address is followed by the size of the
+ data in use in that stack, in bytes. This used to be a
+ conditional around just the two extra args, but that might
+ be undefined if yyoverflow is a macro. */
+ yyoverflow (YY_("memory exhausted"),
+ &yyss1, yysize * sizeof (*yyssp),
+ &yyvs1, yysize * sizeof (*yyvsp),
+ &yystacksize);
+
+ yyss = yyss1;
+ yyvs = yyvs1;
+ }
+#else /* no yyoverflow */
+# ifndef YYSTACK_RELOCATE
+ goto yyexhaustedlab;
+# else
+ /* Extend the stack our own way. */
+ if (YYMAXDEPTH <= yystacksize)
+ goto yyexhaustedlab;
+ yystacksize *= 2;
+ if (YYMAXDEPTH < yystacksize)
+ yystacksize = YYMAXDEPTH;
+
+ {
+ yytype_int16 *yyss1 = yyss;
+ union yyalloc *yyptr =
+ (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize));
+ if (! yyptr)
+ goto yyexhaustedlab;
+ YYSTACK_RELOCATE (yyss_alloc, yyss);
+ YYSTACK_RELOCATE (yyvs_alloc, yyvs);
+# undef YYSTACK_RELOCATE
+ if (yyss1 != yyssa)
+ YYSTACK_FREE (yyss1);
+ }
+# endif
+#endif /* no yyoverflow */
+
+ yyssp = yyss + yysize - 1;
+ yyvsp = yyvs + yysize - 1;
+
+ YYDPRINTF ((stderr, "Stack size increased to %lu\n",
+ (unsigned long int) yystacksize));
+
+ if (yyss + yystacksize - 1 <= yyssp)
+ YYABORT;
+ }
+
+ YYDPRINTF ((stderr, "Entering state %d\n", yystate));
+
+ if (yystate == YYFINAL)
+ YYACCEPT;
+
+ goto yybackup;
+
+/*-----------.
+| yybackup. |
+`-----------*/
+yybackup:
+
+ /* Do appropriate processing given the current state. Read a
+ lookahead token if we need one and don't already have one. */
+
+ /* First try to decide what to do without reference to lookahead token. */
+ yyn = yypact[yystate];
+ if (yypact_value_is_default (yyn))
+ goto yydefault;
+
+ /* Not known => get a lookahead token if don't already have one. */
+
+ /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol. */
+ if (yychar == YYEMPTY)
+ {
+ YYDPRINTF ((stderr, "Reading a token: "));
+ yychar = YYLEX;
+ }
+
+ if (yychar <= YYEOF)
+ {
+ yychar = yytoken = YYEOF;
+ YYDPRINTF ((stderr, "Now at end of input.\n"));
+ }
+ else
+ {
+ yytoken = YYTRANSLATE (yychar);
+ YY_SYMBOL_PRINT ("Next token is", yytoken, &yylval, &yylloc);
+ }
+
+ /* If the proper action on seeing token YYTOKEN is to reduce or to
+ detect an error, take that action. */
+ yyn += yytoken;
+ if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken)
+ goto yydefault;
+ yyn = yytable[yyn];
+ if (yyn <= 0)
+ {
+ if (yytable_value_is_error (yyn))
+ goto yyerrlab;
+ yyn = -yyn;
+ goto yyreduce;
+ }
+
+ /* Count tokens shifted since error; after three, turn off error
+ status. */
+ if (yyerrstatus)
+ yyerrstatus--;
+
+ /* Shift the lookahead token. */
+ YY_SYMBOL_PRINT ("Shifting", yytoken, &yylval, &yylloc);
+
+ /* Discard the shifted token. */
+ yychar = YYEMPTY;
+
+ yystate = yyn;
+ *++yyvsp = yylval;
+
+ goto yynewstate;
+
+
+/*-----------------------------------------------------------.
+| yydefault -- do the default action for the current state. |
+`-----------------------------------------------------------*/
+yydefault:
+ yyn = yydefact[yystate];
+ if (yyn == 0)
+ goto yyerrlab;
+ goto yyreduce;
+
+
+/*-----------------------------.
+| yyreduce -- Do a reduction. |
+`-----------------------------*/
+yyreduce:
+ /* yyn is the number of a rule to reduce with. */
+ yylen = yyr2[yyn];
+
+ /* If YYLEN is nonzero, implement the default value of the action:
+ `$$ = $1'.
+
+ Otherwise, the following line sets YYVAL to garbage.
+ This behavior is undocumented and Bison
+ users should not rely upon it. Assigning to YYVAL
+ unconditionally makes the parser a bit smaller, and it avoids a
+ GCC warning that YYVAL may be used uninitialized. */
+ yyval = yyvsp[1-yylen];
+
+
+ YY_REDUCE_PRINT (yyn);
+ switch (yyn)
+ {
+ case 2:
+
+/* Line 1806 of yacc.c */
+#line 177 "parser.y"
+ { set_syntax_tree(parser, (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 3:
+
+/* Line 1806 of yacc.c */
+#line 178 "parser.y"
+ { set_syntax_tree(parser, (yyvsp[(2) - (2)].val));
+ end_of_regex(scnr); }
+ break;
+
+ case 4:
+
+/* Line 1806 of yacc.c */
+#line 181 "parser.y"
+ { set_syntax_tree(parser, (yyvsp[(2) - (2)].val)); YYACCEPT; }
+ break;
+
+ case 5:
+
+/* Line 1806 of yacc.c */
+#line 182 "parser.y"
+ { internal_error("notreached"); }
+ break;
+
+ case 6:
+
+/* Line 1806 of yacc.c */
+#line 184 "parser.y"
+ { set_syntax_tree(parser, (yyvsp[(2) - (2)].val)); YYACCEPT; }
+ break;
+
+ case 7:
+
+/* Line 1806 of yacc.c */
+#line 185 "parser.y"
+ { internal_error("notreached"); }
+ break;
+
+ case 8:
+
+/* Line 1806 of yacc.c */
+#line 186 "parser.y"
+ { if (yychar == YYEOF) {
+ parser->syntax_tree = nao;
+ YYACCEPT;
+ } else {
+ yybadtok(yychar, nil);
+ parser->syntax_tree = nil;
+ } }
+ break;
+
+ case 9:
+
+/* Line 1806 of yacc.c */
+#line 193 "parser.y"
+ { if (yychar == YYEOF) {
+ parser->syntax_tree = nao;
+ YYACCEPT;
+ } else {
+ yybadtok(yychar, nil);
+ parser->syntax_tree = nil;
+ } }
+ break;
+
+ case 10:
+
+/* Line 1806 of yacc.c */
+#line 200 "parser.y"
+ { set_syntax_tree(parser, (yyvsp[(2) - (2)].val));
+ YYACCEPT; }
+ break;
+
+ case 11:
+
+/* Line 1806 of yacc.c */
+#line 202 "parser.y"
+ { internal_error("notreached"); }
+ break;
+
+ case 12:
+
+/* Line 1806 of yacc.c */
+#line 203 "parser.y"
+ { if (yychar == YYEOF) {
+ parser->syntax_tree = nao;
+ YYACCEPT;
+ } else {
+ yybadtok(yychar, nil);
+ parser->syntax_tree = nil;
+ } }
+ break;
+
+ case 13:
+
+/* Line 1806 of yacc.c */
+#line 210 "parser.y"
+ { parser->syntax_tree = nil;
+ if (parser->errors >= 8)
+ YYABORT;
+ yyerrok;
+ yybadtok(yychar, nil); }
+ break;
+
+ case 14:
+
+/* Line 1806 of yacc.c */
+#line 219 "parser.y"
+ { parser->ignore = 1; }
+ break;
+
+ case 15:
+
+/* Line 1806 of yacc.c */
+#line 220 "parser.y"
+ { parser->ignore = 0;
+ (yyval.val) = nao; }
+ break;
+
+ case 16:
+
+/* Line 1806 of yacc.c */
+#line 222 "parser.y"
+ { parser->ignore = 1; }
+ break;
+
+ case 17:
+
+/* Line 1806 of yacc.c */
+#line 223 "parser.y"
+ { parser->ignore = 0;
+ (yyval.val) = nao; }
+ break;
+
+ case 18:
+
+/* Line 1806 of yacc.c */
+#line 225 "parser.y"
+ { parser->ignore = 1; }
+ break;
+
+ case 19:
+
+/* Line 1806 of yacc.c */
+#line 226 "parser.y"
+ { parser->ignore = 0;
+ (yyval.val) = nao; }
+ break;
+
+ case 20:
+
+/* Line 1806 of yacc.c */
+#line 228 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 21:
+
+/* Line 1806 of yacc.c */
+#line 229 "parser.y"
+ { (yyval.val) = uref_helper(parser, (yyvsp[(2) - (2)].val)); }
+ break;
+
+ case 22:
+
+/* Line 1806 of yacc.c */
+#line 230 "parser.y"
+ { (yyval.val) = uoref_helper(parser, (yyvsp[(2) - (2)].val)); }
+ break;
+
+ case 23:
+
+/* Line 1806 of yacc.c */
+#line 233 "parser.y"
+ { parser->ignore = 1; }
+ break;
+
+ case 24:
+
+/* Line 1806 of yacc.c */
+#line 234 "parser.y"
+ { parser->ignore = 0;
+ (yyval.val) = nao; }
+ break;
+
+ case 25:
+
+/* Line 1806 of yacc.c */
+#line 236 "parser.y"
+ { parser->ignore = 1; }
+ break;
+
+ case 26:
+
+/* Line 1806 of yacc.c */
+#line 237 "parser.y"
+ { parser->ignore = 0;
+ (yyval.val) = nao; }
+ break;
+
+ case 27:
+
+/* Line 1806 of yacc.c */
+#line 239 "parser.y"
+ { parser->ignore = 1; }
+ break;
+
+ case 28:
+
+/* Line 1806 of yacc.c */
+#line 240 "parser.y"
+ { parser->ignore = 0;
+ (yyval.val) = nao; }
+ break;
+
+ case 29:
+
+/* Line 1806 of yacc.c */
+#line 242 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 30:
+
+/* Line 1806 of yacc.c */
+#line 243 "parser.y"
+ { (yyval.val) = uref_helper(parser, (yyvsp[(2) - (2)].val)); }
+ break;
+
+ case 31:
+
+/* Line 1806 of yacc.c */
+#line 244 "parser.y"
+ { (yyval.val) = uoref_helper(parser, (yyvsp[(2) - (2)].val)); }
+ break;
+
+ case 32:
+
+/* Line 1806 of yacc.c */
+#line 249 "parser.y"
+ { internal_error("notreached"); }
+ break;
+
+ case 33:
+
+/* Line 1806 of yacc.c */
+#line 250 "parser.y"
+ { internal_error("notreached"); }
+ break;
+
+ case 34:
+
+/* Line 1806 of yacc.c */
+#line 251 "parser.y"
+ { internal_error("notreached"); }
+ break;
+
+ case 35:
+
+/* Line 1806 of yacc.c */
+#line 254 "parser.y"
+ { (yyval.val) = check_parse_time_action(cons((yyvsp[(1) - (1)].val), nil)); }
+ break;
+
+ case 36:
+
+/* Line 1806 of yacc.c */
+#line 255 "parser.y"
+ { (yyval.val) = check_parse_time_action(cons((yyvsp[(2) - (2)].val), (yyvsp[(1) - (2)].val))); }
+ break;
+
+ case 37:
+
+/* Line 1806 of yacc.c */
+#line 258 "parser.y"
+ { (yyval.val) = us_nreverse((yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 38:
+
+/* Line 1806 of yacc.c */
+#line 259 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 39:
+
+/* Line 1806 of yacc.c */
+#line 262 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil); rlc((yyval.val), (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 40:
+
+/* Line 1806 of yacc.c */
+#line 263 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil); rlc((yyval.val), (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 41:
+
+/* Line 1806 of yacc.c */
+#line 264 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil); rlc((yyval.val), (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 42:
+
+/* Line 1806 of yacc.c */
+#line 265 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil); rlc((yyval.val), (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 43:
+
+/* Line 1806 of yacc.c */
+#line 266 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil); rlc((yyval.val), (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 44:
+
+/* Line 1806 of yacc.c */
+#line 267 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil); rlc((yyval.val), (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 45:
+
+/* Line 1806 of yacc.c */
+#line 268 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil); rlc((yyval.val), (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 46:
+
+/* Line 1806 of yacc.c */
+#line 269 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil); rlc((yyval.val), (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 47:
+
+/* Line 1806 of yacc.c */
+#line 270 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil); rlc((yyval.val), (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 48:
+
+/* Line 1806 of yacc.c */
+#line 271 "parser.y"
+ { (yyval.val) = list(define_transform(parser, (yyvsp[(1) - (1)].val)), nao);
+ rlc(car((yyval.val)), (yyvsp[(1) - (1)].val));
+ rlc((yyval.val), (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 49:
+
+/* Line 1806 of yacc.c */
+#line 274 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil); rlc((yyval.val), (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 50:
+
+/* Line 1806 of yacc.c */
+#line 275 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil); rlc((yyval.val), (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 51:
+
+/* Line 1806 of yacc.c */
+#line 276 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil); rlc((yyval.val), (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 52:
+
+/* Line 1806 of yacc.c */
+#line 277 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 53:
+
+/* Line 1806 of yacc.c */
+#line 280 "parser.y"
+ { (yyval.val) = list(all_s, (yyvsp[(3) - (3)].val), nao);
+ rl((yyval.val), num((yyvsp[(1) - (3)].lineno))); }
+ break;
+
+ case 54:
+
+/* Line 1806 of yacc.c */
+#line 282 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("all clause")); }
+ break;
+
+ case 55:
+
+/* Line 1806 of yacc.c */
+#line 287 "parser.y"
+ { (yyval.val) = list(some_s, (yyvsp[(5) - (5)].val), (yyvsp[(2) - (5)].val), nao);
+ rl((yyval.val), num((yyvsp[(1) - (5)].lineno))); }
+ break;
+
+ case 56:
+
+/* Line 1806 of yacc.c */
+#line 291 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("some clause")); }
+ break;
+
+ case 57:
+
+/* Line 1806 of yacc.c */
+#line 295 "parser.y"
+ { (yyval.val) = list(none_s, (yyvsp[(3) - (3)].val), nao);
+ rl((yyval.val), num((yyvsp[(1) - (3)].lineno))); }
+ break;
+
+ case 58:
+
+/* Line 1806 of yacc.c */
+#line 297 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("none clause")); }
+ break;
+
+ case 59:
+
+/* Line 1806 of yacc.c */
+#line 301 "parser.y"
+ { (yyval.val) = list(maybe_s, (yyvsp[(3) - (3)].val), nao);
+ rl((yyval.val), num((yyvsp[(1) - (3)].lineno))); }
+ break;
+
+ case 60:
+
+/* Line 1806 of yacc.c */
+#line 303 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("maybe clause")); }
+ break;
+
+ case 61:
+
+/* Line 1806 of yacc.c */
+#line 307 "parser.y"
+ { (yyval.val) = list(cases_s, (yyvsp[(3) - (3)].val), nao);
+ rl((yyval.val), num((yyvsp[(1) - (3)].lineno))); }
+ break;
+
+ case 62:
+
+/* Line 1806 of yacc.c */
+#line 309 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("cases clause")); }
+ break;
+
+ case 63:
+
+/* Line 1806 of yacc.c */
+#line 315 "parser.y"
+ { val name = first((yyvsp[(2) - (7)].val));
+ if (gt(length((yyvsp[(2) - (7)].val)), one))
+ yyerr("block: takes zero or no arguments");
+ if (name && !bindable(name))
+ yyerrorf(scnr,
+ lit("block: ~s is not a bindable symbol"),
+ name, nao);
+ (yyval.val) = list(block_s, name, (yyvsp[(5) - (7)].val), nao);
+ rl((yyval.val), num((yyvsp[(1) - (7)].lineno))); }
+ break;
+
+ case 64:
+
+/* Line 1806 of yacc.c */
+#line 325 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("block clause")); }
+ break;
+
+ case 65:
+
+/* Line 1806 of yacc.c */
+#line 330 "parser.y"
+ { (yyval.val) = list(choose_s, (yyvsp[(5) - (5)].val), (yyvsp[(2) - (5)].val), nao);
+ rl((yyval.val), num((yyvsp[(1) - (5)].lineno))); }
+ break;
+
+ case 66:
+
+/* Line 1806 of yacc.c */
+#line 333 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("choose clause")); }
+ break;
+
+ case 67:
+
+/* Line 1806 of yacc.c */
+#line 339 "parser.y"
+ { val args = match_expand_keyword_args((yyvsp[(2) - (7)].val));
+ (yyval.val) = list(gather_s,
+ append2(mapcar(pa_12_1(func_n2(cons), nil),
+ first((yyvsp[(5) - (7)].val))), rest((yyvsp[(5) - (7)].val))),
+ args, nao);
+ rl((yyval.val), num((yyvsp[(1) - (7)].lineno))); }
+ break;
+
+ case 68:
+
+/* Line 1806 of yacc.c */
+#line 350 "parser.y"
+ { val args = match_expand_keyword_args((yyvsp[(2) - (12)].val));
+ (yyval.val) = list(gather_s,
+ append2(mapcar(pa_12_1(func_n2(cons), nil),
+ first((yyvsp[(5) - (12)].val))), rest((yyvsp[(5) - (12)].val))),
+ args, cons(cdr((yyvsp[(6) - (12)].val)),
+ cons((yyvsp[(7) - (12)].val), (yyvsp[(10) - (12)].val))), nao);
+ rl((yyval.val), num((yyvsp[(1) - (12)].lineno))); }
+ break;
+
+ case 69:
+
+/* Line 1806 of yacc.c */
+#line 359 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("gather clause")); }
+ break;
+
+ case 70:
+
+/* Line 1806 of yacc.c */
+#line 364 "parser.y"
+ { (yyval.val) = if2((yyvsp[(1) - (2)].val), cons((yyvsp[(1) - (2)].val), (yyvsp[(2) - (2)].val))); }
+ break;
+
+ case 71:
+
+/* Line 1806 of yacc.c */
+#line 367 "parser.y"
+ { (yyval.val) = (yyvsp[(3) - (3)].val); }
+ break;
+
+ case 72:
+
+/* Line 1806 of yacc.c */
+#line 368 "parser.y"
+ { (yyval.val) = (yyvsp[(3) - (3)].val); }
+ break;
+
+ case 73:
+
+/* Line 1806 of yacc.c */
+#line 369 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 74:
+
+/* Line 1806 of yacc.c */
+#line 373 "parser.y"
+ { val args = match_expand_keyword_args((yyvsp[(2) - (7)].val));
+ (yyval.val) = list(car((yyvsp[(1) - (7)].val)),
+ (yyvsp[(5) - (7)].val), nil, args,
+ nao);
+ rl((yyval.val), cdr((yyvsp[(1) - (7)].val))); }
+ break;
+
+ case 75:
+
+/* Line 1806 of yacc.c */
+#line 381 "parser.y"
+ { val args = match_expand_keyword_args((yyvsp[(2) - (12)].val));
+ if (nilp((yyvsp[(10) - (12)].val)))
+ yyerr("empty until/last in collect");
+ (yyval.val) = list(car((yyvsp[(1) - (12)].val)), (yyvsp[(5) - (12)].val),
+ cons(cdr((yyvsp[(6) - (12)].val)),
+ cons((yyvsp[(7) - (12)].val), (yyvsp[(10) - (12)].val))),
+ args, nao);
+ rl((yyval.val), cdr((yyvsp[(1) - (12)].val)));
+ rl((yyvsp[(10) - (12)].val), car((yyvsp[(6) - (12)].val))); }
+ break;
+
+ case 76:
+
+/* Line 1806 of yacc.c */
+#line 391 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("collect clause")); }
+ break;
+
+ case 77:
+
+/* Line 1806 of yacc.c */
+#line 395 "parser.y"
+ { (yyval.val) = cons(collect_s, num((yyvsp[(1) - (1)].lineno))); }
+ break;
+
+ case 78:
+
+/* Line 1806 of yacc.c */
+#line 396 "parser.y"
+ { (yyval.val) = cons(repeat_s, num((yyvsp[(1) - (1)].lineno))); }
+ break;
+
+ case 79:
+
+/* Line 1806 of yacc.c */
+#line 399 "parser.y"
+ { (yyval.val) = cons(num((yyvsp[(1) - (1)].lineno)), until_s); }
+ break;
+
+ case 80:
+
+/* Line 1806 of yacc.c */
+#line 400 "parser.y"
+ { (yyval.val) = cons(num((yyvsp[(1) - (1)].lineno)), last_s); }
+ break;
+
+ case 81:
+
+/* Line 1806 of yacc.c */
+#line 403 "parser.y"
+ { (yyval.val) = if2((yyvsp[(1) - (2)].val), cons((yyvsp[(1) - (2)].val), (yyvsp[(2) - (2)].val))); }
+ break;
+
+ case 82:
+
+/* Line 1806 of yacc.c */
+#line 406 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 83:
+
+/* Line 1806 of yacc.c */
+#line 407 "parser.y"
+ { (yyval.val) = (yyvsp[(3) - (3)].val); }
+ break;
+
+ case 84:
+
+/* Line 1806 of yacc.c */
+#line 408 "parser.y"
+ { (yyval.val) = (yyvsp[(3) - (3)].val); }
+ break;
+
+ case 85:
+
+/* Line 1806 of yacc.c */
+#line 415 "parser.y"
+ { if (opt_compat && opt_compat <= 136)
+ { val xexp = expand_meta((yyvsp[(2) - (9)].val), nil);
+ val req = rlc(cons(require_s, xexp), (yyvsp[(2) - (9)].val));
+ val iff = rlc(cons(cons(cons(req, nil), (yyvsp[(5) - (9)].val)), nil), (yyvsp[(2) - (9)].val));
+ val elifs = (yyvsp[(6) - (9)].val);
+ val els = cons((yyvsp[(7) - (9)].val), nil);
+ val cases = nappend2(nappend2(iff, elifs), els);
+ (yyval.val) = list(cases_s, cases, nao); }
+ else
+ { val expr = expand(car((yyvsp[(2) - (9)].val)), nil);
+ val ifs = (yyvsp[(5) - (9)].val);
+ val branch = cons(cons(expr, ifs), nil);
+ val elifs = (yyvsp[(6) - (9)].val);
+ val els = (yyvsp[(7) - (9)].val);
+ if (cdr((yyvsp[(2) - (9)].val)))
+ yyerr("extra expression in if");
+ (yyval.val) = cons(if_s,
+ nappend2(branch, nappend2(elifs, els)));
+ rl((yyval.val), num((yyvsp[(1) - (9)].lineno))); } }
+ break;
+
+ case 86:
+
+/* Line 1806 of yacc.c */
+#line 435 "parser.y"
+ { (yyval.val) = nil; yybadtok(yychar, lit("if clause")); }
+ break;
+
+ case 87:
+
+/* Line 1806 of yacc.c */
+#line 440 "parser.y"
+ { if (opt_compat && opt_compat <= 136)
+ { val xexp = expand_meta((yyvsp[(2) - (6)].val), nil);
+ val req = rlc(cons(require_s, xexp), (yyvsp[(2) - (6)].val));
+ (yyval.val) = cons(cons(cons(req, nil), (yyvsp[(5) - (6)].val)), (yyvsp[(6) - (6)].val)); }
+ else
+ { val expr = expand(car((yyvsp[(2) - (6)].val)), nil);
+ val elifs = (yyvsp[(5) - (6)].val);
+ val branch = cons(cons(expr, elifs), nil);
+ if (cdr((yyvsp[(2) - (6)].val)))
+ yyerr("extra expression in elif");
+ (yyval.val) = nappend2(branch, (yyvsp[(6) - (6)].val)); } }
+ break;
+
+ case 88:
+
+/* Line 1806 of yacc.c */
+#line 451 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 89:
+
+/* Line 1806 of yacc.c */
+#line 455 "parser.y"
+ { if (opt_compat && opt_compat <= 136)
+ { (yyval.val) = (yyvsp[(3) - (3)].val); }
+ else
+ { (yyval.val) = cons(cons(t, (yyvsp[(3) - (3)].val)), nil); } }
+ break;
+
+ case 90:
+
+/* Line 1806 of yacc.c */
+#line 459 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 91:
+
+/* Line 1806 of yacc.c */
+#line 462 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (2)].val); }
+ break;
+
+ case 92:
+
+/* Line 1806 of yacc.c */
+#line 465 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 93:
+
+/* Line 1806 of yacc.c */
+#line 466 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 94:
+
+/* Line 1806 of yacc.c */
+#line 469 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil);
+ rlc((yyval.val), (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 95:
+
+/* Line 1806 of yacc.c */
+#line 471 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (2)].val), (yyvsp[(2) - (2)].val));
+ rlc((yyval.val), (yyvsp[(1) - (2)].val)); }
+ break;
+
+ case 96:
+
+/* Line 1806 of yacc.c */
+#line 476 "parser.y"
+ { (yyval.val) = rl(string_own((yyvsp[(1) - (1)].lexeme)), num(parser->lineno)); }
+ break;
+
+ case 97:
+
+/* Line 1806 of yacc.c */
+#line 477 "parser.y"
+ { if ((yyvsp[(1) - (1)].lexeme)[0] == ' ' && (yyvsp[(1) - (1)].lexeme)[1] == 0)
+ { val spaces = list(oneplus_s,
+ chr(' '), nao);
+ free((yyvsp[(1) - (1)].lexeme));
+ (yyval.val) = regex_compile(spaces, nil);
+ rl((yyval.val), num(parser->lineno)); }
+ else
+ { (yyval.val) = rl(string_own((yyvsp[(1) - (1)].lexeme)), num(parser->lineno)); }}
+ break;
+
+ case 98:
+
+/* Line 1806 of yacc.c */
+#line 485 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val);
+ rl((yyval.val), num(parser->lineno)); }
+ break;
+
+ case 99:
+
+/* Line 1806 of yacc.c */
+#line 487 "parser.y"
+ { (yyval.val) = null_string; }
+ break;
+
+ case 100:
+
+/* Line 1806 of yacc.c */
+#line 490 "parser.y"
+ { (yyval.val) = rlc(cons((yyvsp[(1) - (1)].val), nil), (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 101:
+
+/* Line 1806 of yacc.c */
+#line 491 "parser.y"
+ { (yyval.val) = rlc(cons((yyvsp[(1) - (2)].val), (yyvsp[(2) - (2)].val)), (yyvsp[(2) - (2)].val)); }
+ break;
+
+ case 102:
+
+/* Line 1806 of yacc.c */
+#line 494 "parser.y"
+ { (yyval.val) = rlc(cons(text_s, (yyvsp[(1) - (1)].val)), (yyvsp[(1) - (1)].val));
+ (yyval.val) = rlc(optimize_text((yyval.val)), (yyval.val)); }
+ break;
+
+ case 103:
+
+/* Line 1806 of yacc.c */
+#line 496 "parser.y"
+ { (yyval.val) = rl((yyvsp[(1) - (1)].val), num(parser->lineno));
+ match_reg_elem((yyval.val)); }
+ break;
+
+ case 104:
+
+/* Line 1806 of yacc.c */
+#line 498 "parser.y"
+ { val sym = first((yyvsp[(1) - (1)].val));
+ if (sym == do_s || sym == require_s)
+ (yyval.val) = rlc(cons(sym,
+ expand_forms(rest((yyvsp[(1) - (1)].val)), nil)),
+ (yyvsp[(1) - (1)].val));
+ else if (sym == mdo_s)
+ { eval_intrinsic(cons(progn_s, cdr((yyvsp[(1) - (1)].val))), nil, nil);
+ (yyval.val) = cons(do_s, nil); }
+ else
+ { (yyval.val) = match_expand_elem((yyvsp[(1) - (1)].val));
+ match_reg_elem((yyval.val)); } }
+ break;
+
+ case 105:
+
+/* Line 1806 of yacc.c */
+#line 509 "parser.y"
+ { val args = match_expand_keyword_args((yyvsp[(2) - (5)].val));
+ (yyval.val) = list(coll_s, (yyvsp[(4) - (5)].val), nil, args, nao);
+ rl((yyval.val), num((yyvsp[(1) - (5)].lineno))); }
+ break;
+
+ case 106:
+
+/* Line 1806 of yacc.c */
+#line 514 "parser.y"
+ { val args = match_expand_keyword_args((yyvsp[(2) - (9)].val));
+ (yyval.val) = list(coll_s, (yyvsp[(4) - (9)].val), cons(cdr((yyvsp[(5) - (9)].val)),
+ cons((yyvsp[(6) - (9)].val), (yyvsp[(8) - (9)].val))),
+ args, nao);
+ rl((yyval.val), num((yyvsp[(1) - (9)].lineno)));
+ rl((yyvsp[(6) - (9)].val), car((yyvsp[(5) - (9)].val))); }
+ break;
+
+ case 107:
+
+/* Line 1806 of yacc.c */
+#line 520 "parser.y"
+ { val args = match_expand_keyword_args((yyvsp[(2) - (5)].val));
+ (yyval.val) = list(rep_s, (yyvsp[(4) - (5)].val), nil, args, nao);
+ rl((yyval.val), num((yyvsp[(1) - (5)].lineno))); }
+ break;
+
+ case 108:
+
+/* Line 1806 of yacc.c */
+#line 526 "parser.y"
+ { val args = match_expand_keyword_args((yyvsp[(2) - (9)].val));
+ (yyval.val) = list(rep_s, (yyvsp[(4) - (9)].val), cons(cdr((yyvsp[(5) - (9)].val)),
+ cons((yyvsp[(6) - (9)].val), (yyvsp[(8) - (9)].val))),
+ args, nao);
+ rl((yyval.val), num((yyvsp[(1) - (9)].lineno)));
+ rl((yyvsp[(6) - (9)].val), car((yyvsp[(5) - (9)].val))); }
+ break;
+
+ case 109:
+
+/* Line 1806 of yacc.c */
+#line 532 "parser.y"
+ { (yyval.val) = list(block_s, car((yyvsp[(2) - (5)].val)),
+ cons((yyvsp[(4) - (5)].val), nil), nao);
+ rl((yyval.val), num((yyvsp[(1) - (5)].lineno))); }
+ break;
+
+ case 110:
+
+/* Line 1806 of yacc.c */
+#line 535 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("coll clause")); }
+ break;
+
+ case 111:
+
+/* Line 1806 of yacc.c */
+#line 537 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("rep clause")); }
+ break;
+
+ case 112:
+
+/* Line 1806 of yacc.c */
+#line 539 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("rep clause")); }
+ break;
+
+ case 113:
+
+/* Line 1806 of yacc.c */
+#line 541 "parser.y"
+ { (yyval.val) = rl(list(all_s, t, (yyvsp[(2) - (2)].val), nao), num((yyvsp[(1) - (2)].lineno))); }
+ break;
+
+ case 114:
+
+/* Line 1806 of yacc.c */
+#line 543 "parser.y"
+ { (yyval.val) = rl(list(some_s, t, (yyvsp[(4) - (4)].val), (yyvsp[(2) - (4)].val), nao), num((yyvsp[(1) - (4)].lineno))); }
+ break;
+
+ case 115:
+
+/* Line 1806 of yacc.c */
+#line 544 "parser.y"
+ { (yyval.val) = rl(list(none_s, t, (yyvsp[(2) - (2)].val), nao), num((yyvsp[(1) - (2)].lineno))); }
+ break;
+
+ case 116:
+
+/* Line 1806 of yacc.c */
+#line 545 "parser.y"
+ { (yyval.val) = rl(list(maybe_s, t, (yyvsp[(2) - (2)].val), nao), num((yyvsp[(1) - (2)].lineno))); }
+ break;
+
+ case 117:
+
+/* Line 1806 of yacc.c */
+#line 546 "parser.y"
+ { (yyval.val) = rl(list(cases_s, t, (yyvsp[(2) - (2)].val), nao), num((yyvsp[(1) - (2)].lineno))); }
+ break;
+
+ case 118:
+
+/* Line 1806 of yacc.c */
+#line 548 "parser.y"
+ { (yyval.val) = list(choose_s, t, (yyvsp[(4) - (4)].val), (yyvsp[(2) - (4)].val), nao);
+ rl((yyval.val), num((yyvsp[(1) - (4)].lineno))); }
+ break;
+
+ case 119:
+
+/* Line 1806 of yacc.c */
+#line 551 "parser.y"
+ { (yyval.val) = list(define_s, t, (yyvsp[(4) - (5)].val), (yyvsp[(2) - (5)].val), nao);
+ rl((yyval.val), num((yyvsp[(1) - (5)].lineno)));
+ match_reg_params(second((yyvsp[(2) - (5)].val))); }
+ break;
+
+ case 120:
+
+/* Line 1806 of yacc.c */
+#line 556 "parser.y"
+ { (yyval.val) = if2((yyvsp[(1) - (2)].val), cons((yyvsp[(1) - (2)].val), (yyvsp[(2) - (2)].val))); }
+ break;
+
+ case 121:
+
+/* Line 1806 of yacc.c */
+#line 559 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 122:
+
+/* Line 1806 of yacc.c */
+#line 560 "parser.y"
+ { (yyval.val) = (yyvsp[(2) - (2)].val); }
+ break;
+
+ case 123:
+
+/* Line 1806 of yacc.c */
+#line 561 "parser.y"
+ { (yyval.val) = (yyvsp[(2) - (2)].val); }
+ break;
+
+ case 124:
+
+/* Line 1806 of yacc.c */
+#line 566 "parser.y"
+ { (yyval.val) = list(define_s, (yyvsp[(2) - (7)].val), (yyvsp[(5) - (7)].val), nao);
+ rl((yyval.val), num((yyvsp[(1) - (7)].lineno)));
+ match_reg_params(second((yyvsp[(2) - (7)].val))); }
+ break;
+
+ case 125:
+
+/* Line 1806 of yacc.c */
+#line 571 "parser.y"
+ { (yyval.val) = list(define_s, nil, (yyvsp[(4) - (6)].val), nao);
+ rl((yyval.val), num((yyvsp[(1) - (6)].lineno))); }
+ break;
+
+ case 126:
+
+/* Line 1806 of yacc.c */
+#line 573 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("define directive")); }
+ break;
+
+ case 127:
+
+/* Line 1806 of yacc.c */
+#line 576 "parser.y"
+ { (yyval.val) = nil; yybadtok(yychar, lit("define")); }
+ break;
+
+ case 128:
+
+/* Line 1806 of yacc.c */
+#line 578 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("define")); }
+ break;
+
+ case 129:
+
+/* Line 1806 of yacc.c */
+#line 585 "parser.y"
+ { (yyval.val) = list(try_s,
+ flatten(mapcar(func_n1(second),
+ (yyvsp[(4) - (6)].val))),
+ (yyvsp[(3) - (6)].val), (yyvsp[(4) - (6)].val), nao);
+ rl((yyval.val), num((yyvsp[(1) - (6)].lineno))); }
+ break;
+
+ case 130:
+
+/* Line 1806 of yacc.c */
+#line 591 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("try clause")); }
+ break;
+
+ case 131:
+
+/* Line 1806 of yacc.c */
+#line 597 "parser.y"
+ { (yyval.val) = cons(list(catch_s, cons(t, nil),
+ (yyvsp[(4) - (5)].val), nao), (yyvsp[(5) - (5)].val));
+ rl((yyval.val), num((yyvsp[(1) - (5)].lineno))); }
+ break;
+
+ case 132:
+
+/* Line 1806 of yacc.c */
+#line 602 "parser.y"
+ { (yyval.val) = cons(list(catch_s, (yyvsp[(2) - (6)].val), (yyvsp[(5) - (6)].val), nao),
+ (yyvsp[(6) - (6)].val));
+ process_catch_exprs((yyvsp[(2) - (6)].val));
+ rl((yyval.val), num((yyvsp[(1) - (6)].lineno))); }
+ break;
+
+ case 133:
+
+/* Line 1806 of yacc.c */
+#line 607 "parser.y"
+ { (yyval.val) = cons(list(finally_s, nil,
+ (yyvsp[(3) - (3)].val), nao),
+ nil);
+ rl((yyval.val), num((yyvsp[(1) - (3)].lineno))); }
+ break;
+
+ case 134:
+
+/* Line 1806 of yacc.c */
+#line 611 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 135:
+
+/* Line 1806 of yacc.c */
+#line 613 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("catch clause")); }
+ break;
+
+ case 136:
+
+/* Line 1806 of yacc.c */
+#line 616 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("catch clause")); }
+ break;
+
+ case 137:
+
+/* Line 1806 of yacc.c */
+#line 619 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("finally clause")); }
+ break;
+
+ case 138:
+
+/* Line 1806 of yacc.c */
+#line 626 "parser.y"
+ { (yyval.val) = nil;
+ yyerrorf(scnr, lit("~a: traling material"),
+ car((yyvsp[(1) - (7)].val)), nao); }
+ break;
+
+ case 139:
+
+/* Line 1806 of yacc.c */
+#line 630 "parser.y"
+ { (yyval.val) = rl(list(car((yyvsp[(1) - (5)].val)), nao), (yyvsp[(1) - (5)].val)); }
+ break;
+
+ case 140:
+
+/* Line 1806 of yacc.c */
+#line 633 "parser.y"
+ { (yyval.val) = rl(list(car((yyvsp[(1) - (6)].val)), (yyvsp[(4) - (6)].val), nao), (yyvsp[(1) - (6)].val)); }
+ break;
+
+ case 141:
+
+/* Line 1806 of yacc.c */
+#line 636 "parser.y"
+ { (yyval.val) = output_helper(parser, car((yyvsp[(1) - (7)].val)), (yyvsp[(2) - (7)].val), (yyvsp[(5) - (7)].val));
+ rl((yyval.val), (yyvsp[(1) - (7)].val)); }
+ break;
+
+ case 142:
+
+/* Line 1806 of yacc.c */
+#line 640 "parser.y"
+ { (yyval.val) = nil;
+ yyerr("invalid combination of old and "
+ "new syntax in output directive"); }
+ break;
+
+ case 143:
+
+/* Line 1806 of yacc.c */
+#line 643 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("output directive")); }
+ break;
+
+ case 144:
+
+/* Line 1806 of yacc.c */
+#line 646 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("output clause")); }
+ break;
+
+ case 145:
+
+/* Line 1806 of yacc.c */
+#line 649 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("output clause")); }
+ break;
+
+ case 146:
+
+/* Line 1806 of yacc.c */
+#line 652 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("output clause")); }
+ break;
+
+ case 147:
+
+/* Line 1806 of yacc.c */
+#line 655 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("output clause")); }
+ break;
+
+ case 148:
+
+/* Line 1806 of yacc.c */
+#line 659 "parser.y"
+ { (yyval.val) = cons(output_s, num((yyvsp[(1) - (1)].lineno))); }
+ break;
+
+ case 149:
+
+/* Line 1806 of yacc.c */
+#line 660 "parser.y"
+ { (yyval.val) = cons(push_s, num((yyvsp[(1) - (1)].lineno))); }
+ break;
+
+ case 150:
+
+/* Line 1806 of yacc.c */
+#line 663 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil); }
+ break;
+
+ case 151:
+
+/* Line 1806 of yacc.c */
+#line 664 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (2)].val), (yyvsp[(2) - (2)].val)); }
+ break;
+
+ case 152:
+
+/* Line 1806 of yacc.c */
+#line 667 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil); }
+ break;
+
+ case 153:
+
+/* Line 1806 of yacc.c */
+#line 668 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil); }
+ break;
+
+ case 154:
+
+/* Line 1806 of yacc.c */
+#line 669 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 155:
+
+/* Line 1806 of yacc.c */
+#line 675 "parser.y"
+ { (yyval.val) = repeat_rep_helper(repeat_s,
+ (yyvsp[(2) - (8)].val), (yyvsp[(5) - (8)].val), (yyvsp[(6) - (8)].val));
+ rl((yyval.val), num((yyvsp[(1) - (8)].lineno))); }
+ break;
+
+ case 156:
+
+/* Line 1806 of yacc.c */
+#line 679 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("repeat clause")); }
+ break;
+
+ case 157:
+
+/* Line 1806 of yacc.c */
+#line 685 "parser.y"
+ { (yyval.val) = cons(cons(single_s, (yyvsp[(3) - (4)].val)), (yyvsp[(4) - (4)].val));
+ rl((yyval.val), num((yyvsp[(1) - (4)].lineno))); }
+ break;
+
+ case 158:
+
+/* Line 1806 of yacc.c */
+#line 689 "parser.y"
+ { (yyval.val) = cons(cons(first_s, (yyvsp[(3) - (4)].val)), (yyvsp[(4) - (4)].val));
+ rl((yyval.val), num((yyvsp[(1) - (4)].lineno))); }
+ break;
+
+ case 159:
+
+/* Line 1806 of yacc.c */
+#line 693 "parser.y"
+ { if ((yyvsp[(2) - (6)].val))
+ yyerrorf(scnr,
+ lit("last: in output, "
+ "takes no arguments"),
+ nao);
+ (yyval.val) = cons(cons(last_s, (yyvsp[(5) - (6)].val)), (yyvsp[(6) - (6)].val));
+ rl((yyval.val), num((yyvsp[(1) - (6)].lineno))); }
+ break;
+
+ case 160:
+
+/* Line 1806 of yacc.c */
+#line 702 "parser.y"
+ { (yyval.val) = cons(cons(empty_s, (yyvsp[(3) - (4)].val)), (yyvsp[(4) - (4)].val));
+ rl((yyval.val), num((yyvsp[(1) - (4)].lineno))); }
+ break;
+
+ case 161:
+
+/* Line 1806 of yacc.c */
+#line 707 "parser.y"
+ { (yyval.val) = cons(cons(mod_s,
+ cons(expand_forms_ver((yyvsp[(2) - (6)].val), 166),
+ (yyvsp[(5) - (6)].val))), (yyvsp[(6) - (6)].val));
+ rl((yyval.val), num((yyvsp[(1) - (6)].lineno))); }
+ break;
+
+ case 162:
+
+/* Line 1806 of yacc.c */
+#line 714 "parser.y"
+ { (yyval.val) = cons(cons(modlast_s,
+ cons(expand_forms_ver((yyvsp[(2) - (6)].val), 166),
+ (yyvsp[(5) - (6)].val))), (yyvsp[(6) - (6)].val));
+ rl((yyval.val), num((yyvsp[(1) - (6)].lineno))); }
+ break;
+
+ case 163:
+
+/* Line 1806 of yacc.c */
+#line 718 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 164:
+
+/* Line 1806 of yacc.c */
+#line 725 "parser.y"
+ { val expr = expand((yyvsp[(2) - (9)].val), nil);
+ val ifs = (yyvsp[(5) - (9)].val);
+ val branch = cons(cons(expr, ifs), nil);
+ val elifs = (yyvsp[(6) - (9)].val);
+ val els = (yyvsp[(7) - (9)].val);
+ (yyval.val) = cons(if_s,
+ nappend2(branch, nappend2(elifs, els)));
+ rl((yyval.val), num((yyvsp[(1) - (9)].lineno))); }
+ break;
+
+ case 165:
+
+/* Line 1806 of yacc.c */
+#line 734 "parser.y"
+ { (yyval.val) = nil;
+ yyerr("if requires expression"); }
+ break;
+
+ case 166:
+
+/* Line 1806 of yacc.c */
+#line 737 "parser.y"
+ { (yyval.val) = nil; yybadtok(yychar, lit("if clause")); }
+ break;
+
+ case 167:
+
+/* Line 1806 of yacc.c */
+#line 743 "parser.y"
+ { val expr = expand(car((yyvsp[(2) - (6)].val)), nil);
+ val elifs = (yyvsp[(5) - (6)].val);
+ val branch = cons(cons(expr, elifs), nil);
+ if (null((yyvsp[(2) - (6)].val)))
+ yyerr("elif requires expression");
+ else if (cdr((yyvsp[(2) - (6)].val)))
+ yyerr("extra expression in elif");
+ (yyval.val) = nappend2(branch, (yyvsp[(6) - (6)].val)); }
+ break;
+
+ case 168:
+
+/* Line 1806 of yacc.c */
+#line 751 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 169:
+
+/* Line 1806 of yacc.c */
+#line 756 "parser.y"
+ { (yyval.val) = cons(cons(t, (yyvsp[(3) - (3)].val)), nil); }
+ break;
+
+ case 170:
+
+/* Line 1806 of yacc.c */
+#line 757 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 171:
+
+/* Line 1806 of yacc.c */
+#line 760 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 172:
+
+/* Line 1806 of yacc.c */
+#line 761 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 173:
+
+/* Line 1806 of yacc.c */
+#line 763 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (2)].val); }
+ break;
+
+ case 174:
+
+/* Line 1806 of yacc.c */
+#line 766 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val);
+ rl((yyval.val), num(parser->lineno)); }
+ break;
+
+ case 175:
+
+/* Line 1806 of yacc.c */
+#line 768 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 176:
+
+/* Line 1806 of yacc.c */
+#line 771 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil); }
+ break;
+
+ case 177:
+
+/* Line 1806 of yacc.c */
+#line 772 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (2)].val), (yyvsp[(2) - (2)].val)); }
+ break;
+
+ case 178:
+
+/* Line 1806 of yacc.c */
+#line 773 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil); }
+ break;
+
+ case 179:
+
+/* Line 1806 of yacc.c */
+#line 774 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (2)].val), (yyvsp[(2) - (2)].val)); }
+ break;
+
+ case 180:
+
+/* Line 1806 of yacc.c */
+#line 777 "parser.y"
+ { (yyval.val) = string_own((yyvsp[(1) - (1)].lexeme));
+ rl((yyval.val), num(parser->lineno)); }
+ break;
+
+ case 181:
+
+/* Line 1806 of yacc.c */
+#line 779 "parser.y"
+ { (yyval.val) = string_own((yyvsp[(1) - (1)].lexeme));
+ rl((yyval.val), num(parser->lineno)); }
+ break;
+
+ case 182:
+
+/* Line 1806 of yacc.c */
+#line 781 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 183:
+
+/* Line 1806 of yacc.c */
+#line 782 "parser.y"
+ { (yyval.val) = rlc(list(expr_s,
+ expand((yyvsp[(1) - (1)].val), nil), nao), (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 184:
+
+/* Line 1806 of yacc.c */
+#line 784 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 185:
+
+/* Line 1806 of yacc.c */
+#line 788 "parser.y"
+ { (yyval.val) = repeat_rep_helper(rep_s, (yyvsp[(2) - (6)].val), (yyvsp[(4) - (6)].val), (yyvsp[(5) - (6)].val));
+ rl((yyval.val), num((yyvsp[(1) - (6)].lineno))); }
+ break;
+
+ case 186:
+
+/* Line 1806 of yacc.c */
+#line 790 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("rep clause")); }
+ break;
+
+ case 187:
+
+/* Line 1806 of yacc.c */
+#line 795 "parser.y"
+ { (yyval.val) = cons(cons(single_s, (yyvsp[(2) - (3)].val)), (yyvsp[(3) - (3)].val));
+ rl((yyval.val), num((yyvsp[(1) - (3)].lineno))); }
+ break;
+
+ case 188:
+
+/* Line 1806 of yacc.c */
+#line 798 "parser.y"
+ { (yyval.val) = cons(cons(first_s, (yyvsp[(2) - (3)].val)), (yyvsp[(3) - (3)].val));
+ rl((yyval.val), num((yyvsp[(1) - (3)].lineno))); }
+ break;
+
+ case 189:
+
+/* Line 1806 of yacc.c */
+#line 801 "parser.y"
+ { if ((yyvsp[(2) - (5)].val))
+ yyerrorf(scnr,
+ lit("last: in output, "
+ "takes no arguments"),
+ nao);
+ (yyval.val) = cons(cons(last_s, (yyvsp[(4) - (5)].val)), (yyvsp[(5) - (5)].val));
+ rl((yyval.val), num((yyvsp[(1) - (5)].lineno))); }
+ break;
+
+ case 190:
+
+/* Line 1806 of yacc.c */
+#line 809 "parser.y"
+ { (yyval.val) = cons(cons(empty_s, (yyvsp[(2) - (3)].val)), (yyvsp[(3) - (3)].val));
+ rl((yyval.val), num((yyvsp[(1) - (3)].lineno))); }
+ break;
+
+ case 191:
+
+/* Line 1806 of yacc.c */
+#line 813 "parser.y"
+ { (yyval.val) = cons(cons(mod_s,
+ cons(expand_forms_ver((yyvsp[(2) - (5)].val), 166),
+ (yyvsp[(4) - (5)].val))), (yyvsp[(5) - (5)].val));
+ rl((yyval.val), num((yyvsp[(1) - (5)].lineno))); }
+ break;
+
+ case 192:
+
+/* Line 1806 of yacc.c */
+#line 819 "parser.y"
+ { (yyval.val) = cons(cons(modlast_s,
+ cons(expand_forms_ver((yyvsp[(2) - (5)].val), 166),
+ (yyvsp[(4) - (5)].val))), (yyvsp[(5) - (5)].val));
+ rl((yyval.val), num((yyvsp[(1) - (5)].lineno))); }
+ break;
+
+ case 193:
+
+/* Line 1806 of yacc.c */
+#line 823 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 194:
+
+/* Line 1806 of yacc.c */
+#line 830 "parser.y"
+ { (yyval.val) = list(var_s, symhlpr((yyvsp[(1) - (1)].lexeme), nil), nao); }
+ break;
+
+ case 195:
+
+/* Line 1806 of yacc.c */
+#line 831 "parser.y"
+ { (yyval.val) = list(var_s, symhlpr((yyvsp[(2) - (3)].lexeme), nil), nao); }
+ break;
+
+ case 196:
+
+/* Line 1806 of yacc.c */
+#line 832 "parser.y"
+ { (yyval.val) = list(var_s, symhlpr((yyvsp[(2) - (4)].lexeme), nil), (yyvsp[(3) - (4)].val), nao); }
+ break;
+
+ case 197:
+
+/* Line 1806 of yacc.c */
+#line 833 "parser.y"
+ { (yyval.val) = list(var_s, symhlpr((yyvsp[(2) - (2)].lexeme), nil), (yyvsp[(1) - (2)].val), nao); }
+ break;
+
+ case 198:
+
+/* Line 1806 of yacc.c */
+#line 834 "parser.y"
+ { (yyval.val) = list(var_s, symhlpr((yyvsp[(3) - (4)].lexeme), nil), (yyvsp[(1) - (4)].val), nao); }
+ break;
+
+ case 199:
+
+/* Line 1806 of yacc.c */
+#line 835 "parser.y"
+ { (yyval.val) = nil;
+ free((yyvsp[(3) - (5)].lexeme));
+ yyerr("longest match "
+ "not useable with regex"); }
+ break;
+
+ case 200:
+
+/* Line 1806 of yacc.c */
+#line 839 "parser.y"
+ { (yyval.val) = nil;
+ free((yyvsp[(3) - (5)].lexeme));
+ yyerr("longest match "
+ "not useable with "
+ "fixed width match"); }
+ break;
+
+ case 201:
+
+/* Line 1806 of yacc.c */
+#line 844 "parser.y"
+ { (yyval.val) = nil;
+ free((yyvsp[(1) - (2)].lexeme));
+ yybadtok(yychar, lit("variable spec")); }
+ break;
+
+ case 202:
+
+/* Line 1806 of yacc.c */
+#line 847 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("variable spec")); }
+ break;
+
+ case 203:
+
+/* Line 1806 of yacc.c */
+#line 851 "parser.y"
+ { (yyval.val) = list(t, nao); }
+ break;
+
+ case 204:
+
+/* Line 1806 of yacc.c */
+#line 854 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil); }
+ break;
+
+ case 205:
+
+/* Line 1806 of yacc.c */
+#line 855 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil);
+ rlc((yyval.val), (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 206:
+
+/* Line 1806 of yacc.c */
+#line 857 "parser.y"
+ { (yyval.val) = rlc(cons(expand_meta((yyvsp[(1) - (1)].val), nil),
+ nil), (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 207:
+
+/* Line 1806 of yacc.c */
+#line 859 "parser.y"
+ { (yyval.val) = cons(symhlpr((yyvsp[(1) - (1)].lexeme), nil), nil); }
+ break;
+
+ case 208:
+
+/* Line 1806 of yacc.c */
+#line 862 "parser.y"
+ { val expr = symhlpr((yyvsp[(1) - (1)].lexeme), nil);
+ if (!opt_compat || opt_compat > 128)
+ expr = expand(expr, nil);
+ (yyval.val) = list(var_s, expr, nao);
+ rl((yyval.val), num(parser->lineno)); }
+ break;
+
+ case 209:
+
+/* Line 1806 of yacc.c */
+#line 868 "parser.y"
+ { if (opt_compat && opt_compat <= 128)
+ { (yyval.val) = list(var_s,
+ expand_meta((yyvsp[(2) - (4)].val), nil),
+ expand_meta((yyvsp[(3) - (4)].val), nil), nao); }
+ else
+ { val quasi_var = list(var_s, (yyvsp[(2) - (4)].val), (yyvsp[(3) - (4)].val), nao);
+ val quasi_items = cons(quasi_var, nil);
+ (yyval.val) = car(expand_quasi(quasi_items, nil)); } }
+ break;
+
+ case 210:
+
+/* Line 1806 of yacc.c */
+#line 876 "parser.y"
+ { (yyval.val) = nil;
+ free((yyvsp[(1) - (2)].lexeme));
+ yybadtok(yychar, lit("variable spec")); }
+ break;
+
+ case 211:
+
+/* Line 1806 of yacc.c */
+#line 882 "parser.y"
+ { (yyval.val) = list(var_s, (yyvsp[(3) - (5)].val), (yyvsp[(4) - (5)].val), nao);
+ rl((yyval.val), num(parser->lineno)); }
+ break;
+
+ case 212:
+
+/* Line 1806 of yacc.c */
+#line 884 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("variable spec")); }
+ break;
+
+ case 213:
+
+/* Line 1806 of yacc.c */
+#line 889 "parser.y"
+ { if (parser->quasi_level > 0)
+ (yyval.val) = rlc(cons(vector_lit_s,
+ cons((yyvsp[(2) - (2)].val), nil)), (yyvsp[(2) - (2)].val));
+ else
+ (yyval.val) = rlc(vec_list((yyvsp[(2) - (2)].val)), (yyvsp[(2) - (2)].val)); }
+ break;
+
+ case 214:
+
+/* Line 1806 of yacc.c */
+#line 894 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("unassigned/reserved # notation")); }
+ break;
+
+ case 215:
+
+/* Line 1806 of yacc.c */
+#line 898 "parser.y"
+ { if (parser->ignore)
+ (yyval.val) = nil;
+ else if (parser->quasi_level > 0)
+ (yyval.val) = rl(cons(hash_lit_s, (yyvsp[(2) - (2)].val)), num((yyvsp[(1) - (2)].lineno)));
+ else
+ (yyval.val) = rl(hash_construct(first((yyvsp[(2) - (2)].val)),
+ rest((yyvsp[(2) - (2)].val))),
+ num((yyvsp[(1) - (2)].lineno))); }
+ break;
+
+ case 216:
+
+/* Line 1806 of yacc.c */
+#line 906 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("hash literal")); }
+ break;
+
+ case 217:
+
+/* Line 1806 of yacc.c */
+#line 910 "parser.y"
+ { if (parser->ignore)
+ { (yyval.val) = nil; }
+ else if ((parser->quasi_level > 0) ||
+ (parser->read_unknown_structs &&
+ !find_struct_type(first((yyvsp[(2) - (2)].val)))))
+ { (yyval.val) = rl(cons(struct_lit_s, (yyvsp[(2) - (2)].val)), num((yyvsp[(1) - (2)].lineno))); }
+ else
+ { val strct = make_struct_lit(first((yyvsp[(2) - (2)].val)),
+ rest((yyvsp[(2) - (2)].val)));
+ (yyval.val) = rl(strct, num((yyvsp[(1) - (2)].lineno))); } }
+ break;
+
+ case 218:
+
+/* Line 1806 of yacc.c */
+#line 920 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("struct literal")); }
+ break;
+
+ case 219:
+
+/* Line 1806 of yacc.c */
+#line 924 "parser.y"
+ { if (length((yyvsp[(2) - (2)].val)) != two)
+ yyerr("range literal needs two elements");
+ { val range = rcons(first((yyvsp[(2) - (2)].val)), second((yyvsp[(2) - (2)].val)));
+ (yyval.val) = rl(range, num((yyvsp[(1) - (2)].lineno))); } }
+ break;
+
+ case 220:
+
+/* Line 1806 of yacc.c */
+#line 928 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("range literal")); }
+ break;
+
+ case 221:
+
+/* Line 1806 of yacc.c */
+#line 932 "parser.y"
+ { if (gt(length((yyvsp[(2) - (2)].val)), three))
+ yyerr("excess elements in tree node");
+ { val tn = tnode(first((yyvsp[(2) - (2)].val)), second((yyvsp[(2) - (2)].val)),
+ third((yyvsp[(2) - (2)].val)));
+ (yyval.val) = rl(tn, num((yyvsp[(1) - (2)].lineno))); } }
+ break;
+
+ case 222:
+
+/* Line 1806 of yacc.c */
+#line 937 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("tree node literal")); }
+ break;
+
+ case 223:
+
+/* Line 1806 of yacc.c */
+#line 941 "parser.y"
+ { if (parser->ignore)
+ { (yyval.val) = nil; }
+ else if (parser->quasi_level > 0)
+ { (yyval.val) = rl(cons(tree_lit_s, (yyvsp[(2) - (2)].val)), num((yyvsp[(1) - (2)].lineno))); }
+ else
+ { val opts = first((yyvsp[(2) - (2)].val));
+ val key_fn_name = pop(&opts);
+ val less_fn_name = pop(&opts);
+ val equal_fn_name = pop(&opts);
+ val key_fn = fname_helper(parser, key_fn_name);
+ val less_fn = fname_helper(parser, less_fn_name);
+ val equal_fn = fname_helper(parser, equal_fn_name);
+ val tr = tree(rest((yyvsp[(2) - (2)].val)), key_fn,
+ less_fn, equal_fn, t);
+ (yyval.val) = rl(tr, num((yyvsp[(1) - (2)].lineno))); } }
+ break;
+
+ case 224:
+
+/* Line 1806 of yacc.c */
+#line 956 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("tree node literal")); }
+ break;
+
+ case 225:
+
+/* Line 1806 of yacc.c */
+#line 960 "parser.y"
+ { (yyval.val) = list(json_s, quote_s, (yyvsp[(2) - (2)].val), nao);
+ end_of_json(scnr); }
+ break;
+
+ case 226:
+
+/* Line 1806 of yacc.c */
+#line 962 "parser.y"
+ { parser->quasi_level++; }
+ break;
+
+ case 227:
+
+/* Line 1806 of yacc.c */
+#line 963 "parser.y"
+ { parser->quasi_level--;
+ end_of_json(scnr);
+ (yyval.val) = list(json_s, sys_qquote_s, (yyvsp[(4) - (4)].val), nao); }
+ break;
+
+ case 228:
+
+/* Line 1806 of yacc.c */
+#line 966 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 229:
+
+/* Line 1806 of yacc.c */
+#line 967 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 230:
+
+/* Line 1806 of yacc.c */
+#line 968 "parser.y"
+ { (yyval.val) = null_string; }
+ break;
+
+ case 231:
+
+/* Line 1806 of yacc.c */
+#line 969 "parser.y"
+ { (yyval.val) = (yyvsp[(2) - (3)].val);
+ rl((yyval.val), num(parser->lineno)); }
+ break;
+
+ case 232:
+
+/* Line 1806 of yacc.c */
+#line 971 "parser.y"
+ { (yyval.val) = vector(zero, nil); }
+ break;
+
+ case 233:
+
+/* Line 1806 of yacc.c */
+#line 973 "parser.y"
+ { (yyval.val) = if3(vectorp((yyvsp[(2) - (4)].val)),
+ (yyvsp[(2) - (4)].val),
+ rl(cons(vector_lit_s,
+ cons(nreverse((yyvsp[(2) - (4)].val)), nil)),
+ (yyvsp[(2) - (4)].val))); }
+ break;
+
+ case 234:
+
+/* Line 1806 of yacc.c */
+#line 978 "parser.y"
+ { (yyval.val) = make_hash(hash_weak_none, t); }
+ break;
+
+ case 235:
+
+/* Line 1806 of yacc.c */
+#line 980 "parser.y"
+ { (yyval.val) = if3(hashp((yyvsp[(2) - (4)].val)),
+ (yyvsp[(2) - (4)].val),
+ rl(cons(hash_lit_s,
+ cons(nil, nreverse((yyvsp[(2) - (4)].val)))),
+ (yyvsp[(2) - (4)].val))); }
+ break;
+
+ case 236:
+
+/* Line 1806 of yacc.c */
+#line 985 "parser.y"
+ { parser->quasi_level--; }
+ break;
+
+ case 237:
+
+/* Line 1806 of yacc.c */
+#line 986 "parser.y"
+ { parser->quasi_level++;
+ end_of_json_unquote(scnr);
+ (yyval.val) = rl(rlc(list(sys_unquote_s, (yyvsp[(3) - (3)].val), nao), (yyvsp[(3) - (3)].val)),
+ num(parser->lineno)); }
+ break;
+
+ case 238:
+
+/* Line 1806 of yacc.c */
+#line 990 "parser.y"
+ { parser->quasi_level--; }
+ break;
+
+ case 239:
+
+/* Line 1806 of yacc.c */
+#line 991 "parser.y"
+ { parser->quasi_level++;
+ end_of_json_unquote(scnr);
+ (yyval.val) = rl(rlc(list(sys_splice_s, (yyvsp[(3) - (3)].val), nao), (yyvsp[(3) - (3)].val)),
+ num(parser->lineno)); }
+ break;
+
+ case 240:
+
+/* Line 1806 of yacc.c */
+#line 995 "parser.y"
+ { parser_circ_def(parser, (yyvsp[(1) - (1)].val), unique_s); }
+ break;
+
+ case 241:
+
+/* Line 1806 of yacc.c */
+#line 996 "parser.y"
+ { parser_circ_def(parser, (yyvsp[(1) - (3)].val), (yyvsp[(3) - (3)].val));
+ (yyval.val) = (yyvsp[(3) - (3)].val); }
+ break;
+
+ case 242:
+
+/* Line 1806 of yacc.c */
+#line 998 "parser.y"
+ { (yyval.val) = parser_circ_ref(parser, (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 243:
+
+/* Line 1806 of yacc.c */
+#line 999 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("JSON string")); }
+ break;
+
+ case 244:
+
+/* Line 1806 of yacc.c */
+#line 1001 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("JSON array")); }
+ break;
+
+ case 245:
+
+/* Line 1806 of yacc.c */
+#line 1003 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("JSON hash")); }
+ break;
+
+ case 246:
+
+/* Line 1806 of yacc.c */
+#line 1007 "parser.y"
+ { if (!parser->read_bad_json)
+ yyerr("trailing comma in JSON array"); }
+ break;
+
+ case 248:
+
+/* Line 1806 of yacc.c */
+#line 1012 "parser.y"
+ { (yyval.val) = if3(parser->quasi_level > 0,
+ cons((yyvsp[(1) - (1)].val), nil),
+ vector(one, (yyvsp[(1) - (1)].val))); }
+ break;
+
+ case 249:
+
+/* Line 1806 of yacc.c */
+#line 1015 "parser.y"
+ { if (consp((yyvsp[(1) - (3)].val)))
+ { (yyval.val) = cons((yyvsp[(3) - (3)].val), (yyvsp[(1) - (3)].val)); }
+ else if (parser->quasi_level > 0)
+ { val li = list_vec((yyvsp[(1) - (3)].val));
+ (yyval.val) = cons((yyvsp[(3) - (3)].val), li); }
+ else
+ { vec_push((yyvsp[(1) - (3)].val), (yyvsp[(3) - (3)].val));
+ (yyval.val) = (yyvsp[(1) - (3)].val); } }
+ break;
+
+ case 250:
+
+/* Line 1806 of yacc.c */
+#line 1023 "parser.y"
+ { yyerr("missing comma in JSON array");
+ (yyval.val) = (yyvsp[(1) - (2)].val); }
+ break;
+
+ case 251:
+
+/* Line 1806 of yacc.c */
+#line 1025 "parser.y"
+ { yybadtok(yychar, lit("JSON array"));
+ (yyval.val) = (yyvsp[(1) - (2)].val); }
+ break;
+
+ case 252:
+
+/* Line 1806 of yacc.c */
+#line 1029 "parser.y"
+ { if (parser->quasi_level > 0)
+ { (yyval.val) = cons(list((yyvsp[(1) - (3)].val), (yyvsp[(3) - (3)].val), nao), nil); }
+ else
+ { (yyval.val) = make_hash(hash_weak_none, t);
+ sethash((yyval.val), (yyvsp[(1) - (3)].val), (yyvsp[(3) - (3)].val)); } }
+ break;
+
+ case 253:
+
+/* Line 1806 of yacc.c */
+#line 1035 "parser.y"
+ { if (consp((yyvsp[(1) - (5)].val)))
+ { (yyval.val) = cons(list((yyvsp[(3) - (5)].val), (yyvsp[(5) - (5)].val), nao), (yyvsp[(1) - (5)].val)); }
+ else if (parser->quasi_level > 0)
+ { val pa = hash_pairs((yyvsp[(1) - (5)].val));
+ (yyval.val) = cons(list((yyvsp[(3) - (5)].val), (yyvsp[(5) - (5)].val), nao), pa); }
+ else
+ { sethash((yyvsp[(1) - (5)].val), (yyvsp[(3) - (5)].val), (yyvsp[(5) - (5)].val));
+ (yyval.val) = (yyvsp[(1) - (5)].val); } }
+ break;
+
+ case 254:
+
+/* Line 1806 of yacc.c */
+#line 1043 "parser.y"
+ { yyerr("missing colon in JSON hash"); }
+ break;
+
+ case 255:
+
+/* Line 1806 of yacc.c */
+#line 1045 "parser.y"
+ { yyerr("missing comma in JSON hash"); }
+ break;
+
+ case 256:
+
+/* Line 1806 of yacc.c */
+#line 1046 "parser.y"
+ { yybadtok(yychar, lit("JSON hash")); }
+ break;
+
+ case 257:
+
+/* Line 1806 of yacc.c */
+#line 1049 "parser.y"
+ { if ((yyvsp[(1) - (1)].lexeme)[0] == ':' && (yyvsp[(1) - (1)].lexeme)[1] == 0)
+ { (yyval.val) = nil; }
+ else
+ { yybadtok(yychar, lit("JSON hash")); } }
+ break;
+
+ case 258:
+
+/* Line 1806 of yacc.c */
+#line 1053 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 259:
+
+/* Line 1806 of yacc.c */
+#line 1057 "parser.y"
+ { (yyval.val) = rl((yyvsp[(2) - (3)].val), num((yyvsp[(1) - (3)].lineno))); }
+ break;
+
+ case 260:
+
+/* Line 1806 of yacc.c */
+#line 1058 "parser.y"
+ { val a = car((yyvsp[(3) - (4)].val));
+ val ur = uref_helper(parser, a);
+ if (ur == a)
+ (yyval.val) = (yyvsp[(3) - (4)].val);
+ else
+ (yyval.val) = rlc(cons(ur, cdr((yyvsp[(3) - (4)].val))), ur); }
+ break;
+
+ case 261:
+
+/* Line 1806 of yacc.c */
+#line 1064 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 262:
+
+/* Line 1806 of yacc.c */
+#line 1065 "parser.y"
+ { (yyval.val) = (yyvsp[(3) - (4)].val); }
+ break;
+
+ case 263:
+
+/* Line 1806 of yacc.c */
+#line 1066 "parser.y"
+ { (yyval.val) = (yyvsp[(3) - (4)].val); }
+ break;
+
+ case 264:
+
+/* Line 1806 of yacc.c */
+#line 1067 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("expression")); }
+ break;
+
+ case 265:
+
+/* Line 1806 of yacc.c */
+#line 1071 "parser.y"
+ { if (consp((yyvsp[(2) - (2)].val)))
+ (yyval.val) = rl(cons(expr_s, cons((yyvsp[(2) - (2)].val), nil)), num((yyvsp[(1) - (2)].lineno)));
+ else
+ (yyval.val) = rl(cons(var_s, cons((yyvsp[(2) - (2)].val), nil)),
+ num((yyvsp[(1) - (2)].lineno))); }
+ break;
+
+ case 266:
+
+/* Line 1806 of yacc.c */
+#line 1076 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("meta expression")); }
+ break;
+
+ case 267:
+
+/* Line 1806 of yacc.c */
+#line 1080 "parser.y"
+ { if (consp((yyvsp[(2) - (2)].val)))
+ (yyval.val) = rl(cons(expr_s, cons((yyvsp[(2) - (2)].val), nil)), num((yyvsp[(1) - (2)].chr)));
+ else
+ (yyval.val) = rl(cons(var_s, cons((yyvsp[(2) - (2)].val), nil)),
+ num((yyvsp[(1) - (2)].chr))); }
+ break;
+
+ case 268:
+
+/* Line 1806 of yacc.c */
+#line 1085 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("meta expression")); }
+ break;
+
+ case 269:
+
+/* Line 1806 of yacc.c */
+#line 1089 "parser.y"
+ { val a = car((yyvsp[(3) - (4)].val));
+ val ur = uref_helper(parser, a);
+ (yyval.val) = rlcp_tree(cons(dwim_s,
+ cons(ur, cdr((yyvsp[(3) - (4)].val)))), ur); }
+ break;
+
+ case 270:
+
+/* Line 1806 of yacc.c */
+#line 1093 "parser.y"
+ { (yyval.val) = rl(cons(dwim_s, (yyvsp[(2) - (3)].val)), num((yyvsp[(1) - (3)].lineno))); }
+ break;
+
+ case 271:
+
+/* Line 1806 of yacc.c */
+#line 1094 "parser.y"
+ { (yyval.val) = rl(cons(dwim_s, nil), num((yyvsp[(1) - (2)].lineno))); }
+ break;
+
+ case 272:
+
+/* Line 1806 of yacc.c */
+#line 1095 "parser.y"
+ { (yyval.val) = rl(cons(dwim_s, (yyvsp[(3) - (4)].val)), num((yyvsp[(1) - (4)].lineno))); }
+ break;
+
+ case 273:
+
+/* Line 1806 of yacc.c */
+#line 1096 "parser.y"
+ { (yyval.val) = rl(cons(dwim_s, (yyvsp[(3) - (4)].val)), num((yyvsp[(1) - (4)].lineno))); }
+ break;
+
+ case 274:
+
+/* Line 1806 of yacc.c */
+#line 1097 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("DWIM expression")); }
+ break;
+
+ case 278:
+
+/* Line 1806 of yacc.c */
+#line 1106 "parser.y"
+ { (yyval.val) = rlc(expand_meta((yyvsp[(1) - (1)].val), nil), (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 279:
+
+/* Line 1806 of yacc.c */
+#line 1109 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 280:
+
+/* Line 1806 of yacc.c */
+#line 1110 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 281:
+
+/* Line 1806 of yacc.c */
+#line 1113 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val)->c.cdr;
+ (yyvsp[(1) - (1)].val)->c.cdr = nil;
+ if ((yyval.val)->c.car == nao)
+ (yyval.val) = (yyval.val)->c.cdr; }
+ break;
+
+ case 282:
+
+/* Line 1806 of yacc.c */
+#line 1118 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (3)].val)->c.cdr;
+ (yyvsp[(1) - (3)].val)->c.cdr = (yyvsp[(3) - (3)].val); }
+ break;
+
+ case 283:
+
+/* Line 1806 of yacc.c */
+#line 1122 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil);
+ rlc((yyval.val), (yyvsp[(1) - (1)].val));
+ (yyval.val)->c.cdr = (yyval.val); }
+ break;
+
+ case 284:
+
+/* Line 1806 of yacc.c */
+#line 1125 "parser.y"
+ { parser->ignore = 1; }
+ break;
+
+ case 285:
+
+/* Line 1806 of yacc.c */
+#line 1126 "parser.y"
+ { parser->ignore = 0;
+ (yyval.val) = cons(nao, nil);
+ (yyval.val)->c.cdr = (yyval.val); }
+ break;
+
+ case 286:
+
+/* Line 1806 of yacc.c */
+#line 1129 "parser.y"
+ { parser->ignore = 1; }
+ break;
+
+ case 287:
+
+/* Line 1806 of yacc.c */
+#line 1130 "parser.y"
+ { parser->ignore = 0;
+ (yyval.val) = cons(nao, nil);
+ (yyval.val)->c.cdr = (yyval.val); }
+ break;
+
+ case 288:
+
+/* Line 1806 of yacc.c */
+#line 1133 "parser.y"
+ { parser->ignore = 1; }
+ break;
+
+ case 289:
+
+/* Line 1806 of yacc.c */
+#line 1134 "parser.y"
+ { parser->ignore = 0;
+ (yyval.val) = (yyvsp[(1) - (4)].val); }
+ break;
+
+ case 290:
+
+/* Line 1806 of yacc.c */
+#line 1136 "parser.y"
+ { parser->ignore = 1; }
+ break;
+
+ case 291:
+
+/* Line 1806 of yacc.c */
+#line 1137 "parser.y"
+ { parser->ignore = 0;
+ (yyval.val) = (yyvsp[(1) - (5)].val); }
+ break;
+
+ case 292:
+
+/* Line 1806 of yacc.c */
+#line 1139 "parser.y"
+ { uses_or2;
+ (yyval.val) = rlc(cons((yyvsp[(2) - (2)].val), (yyvsp[(1) - (2)].val)->c.cdr), or2((yyvsp[(2) - (2)].val), (yyvsp[(1) - (2)].val)->c.cdr));
+ (yyvsp[(1) - (2)].val)->c.cdr = (yyval.val); }
+ break;
+
+ case 293:
+
+/* Line 1806 of yacc.c */
+#line 1142 "parser.y"
+ { (yyval.val) = lastcons(rl((yyvsp[(2) - (2)].val), num((yyvsp[(1) - (2)].lineno))));
+ (yyval.val)->c.cdr = (yyvsp[(2) - (2)].val); }
+ break;
+
+ case 294:
+
+/* Line 1806 of yacc.c */
+#line 1145 "parser.y"
+ { (yyval.val) = lastcons(rl((yyvsp[(3) - (3)].val), num((yyvsp[(2) - (3)].lineno))));
+ (yyval.val)->c.cdr = (yyvsp[(1) - (3)].val)->c.cdr;
+ (yyvsp[(1) - (3)].val)->c.cdr = (yyvsp[(3) - (3)].val); }
+ break;
+
+ case 295:
+
+/* Line 1806 of yacc.c */
+#line 1148 "parser.y"
+ { (yyval.val) = lastcons(rl((yyvsp[(2) - (2)].val), num((yyvsp[(1) - (2)].lineno))));
+ (yyval.val)->c.cdr = (yyvsp[(2) - (2)].val); }
+ break;
+
+ case 296:
+
+/* Line 1806 of yacc.c */
+#line 1151 "parser.y"
+ { (yyval.val) = lastcons(rl((yyvsp[(3) - (3)].val), num((yyvsp[(2) - (3)].lineno))));
+ (yyval.val)->c.cdr = (yyvsp[(1) - (3)].val)->c.cdr;
+ (yyvsp[(1) - (3)].val)->c.cdr = (yyvsp[(3) - (3)].val); }
+ break;
+
+ case 297:
+
+/* Line 1806 of yacc.c */
+#line 1156 "parser.y"
+ { (yyval.val) = ifnign(symhlpr((yyvsp[(1) - (1)].lexeme), t)); }
+ break;
+
+ case 298:
+
+/* Line 1806 of yacc.c */
+#line 1157 "parser.y"
+ { (yyval.val) = cons(var_s, cons((yyvsp[(1) - (1)].val), nil));
+ rl((yyval.val), num(parser->lineno)); }
+ break;
+
+ case 299:
+
+/* Line 1806 of yacc.c */
+#line 1159 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 300:
+
+/* Line 1806 of yacc.c */
+#line 1160 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 301:
+
+/* Line 1806 of yacc.c */
+#line 1161 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 302:
+
+/* Line 1806 of yacc.c */
+#line 1162 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 303:
+
+/* Line 1806 of yacc.c */
+#line 1163 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 304:
+
+/* Line 1806 of yacc.c */
+#line 1164 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 305:
+
+/* Line 1806 of yacc.c */
+#line 1165 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 306:
+
+/* Line 1806 of yacc.c */
+#line 1166 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 307:
+
+/* Line 1806 of yacc.c */
+#line 1167 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 308:
+
+/* Line 1806 of yacc.c */
+#line 1168 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 309:
+
+/* Line 1806 of yacc.c */
+#line 1169 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 310:
+
+/* Line 1806 of yacc.c */
+#line 1170 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 311:
+
+/* Line 1806 of yacc.c */
+#line 1171 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 312:
+
+/* Line 1806 of yacc.c */
+#line 1172 "parser.y"
+ { (yyval.val) = rl((yyvsp[(2) - (2)].val), num((yyvsp[(1) - (2)].lineno))); }
+ break;
+
+ case 313:
+
+/* Line 1806 of yacc.c */
+#line 1173 "parser.y"
+ { (yyval.val) = rl(cons(quasilist_s, (yyvsp[(2) - (2)].val)), num((yyvsp[(1) - (2)].lineno))); }
+ break;
+
+ case 314:
+
+/* Line 1806 of yacc.c */
+#line 1174 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 315:
+
+/* Line 1806 of yacc.c */
+#line 1175 "parser.y"
+ { (yyval.val) = rl(rlc(list(quote_s, (yyvsp[(2) - (2)].val), nao), (yyvsp[(2) - (2)].val)),
+ num(parser->lineno)); }
+ break;
+
+ case 316:
+
+/* Line 1806 of yacc.c */
+#line 1177 "parser.y"
+ { parser->quasi_level++; }
+ break;
+
+ case 317:
+
+/* Line 1806 of yacc.c */
+#line 1178 "parser.y"
+ { parser->quasi_level--;
+ (yyval.val) = rl(rlc(list(sys_qquote_s, (yyvsp[(3) - (3)].val), nao), (yyvsp[(3) - (3)].val)),
+ num(parser->lineno)); }
+ break;
+
+ case 318:
+
+/* Line 1806 of yacc.c */
+#line 1181 "parser.y"
+ { parser->quasi_level--; }
+ break;
+
+ case 319:
+
+/* Line 1806 of yacc.c */
+#line 1182 "parser.y"
+ { parser->quasi_level++;
+ (yyval.val) = rl(rlc(list(sys_unquote_s, (yyvsp[(3) - (3)].val), nao), (yyvsp[(3) - (3)].val)),
+ num(parser->lineno)); }
+ break;
+
+ case 320:
+
+/* Line 1806 of yacc.c */
+#line 1185 "parser.y"
+ { parser->quasi_level--; }
+ break;
+
+ case 321:
+
+/* Line 1806 of yacc.c */
+#line 1186 "parser.y"
+ { parser->quasi_level++;
+ (yyval.val) = rl(rlc(list(sys_splice_s, (yyvsp[(3) - (3)].val), nao), (yyvsp[(3) - (3)].val)),
+ num(parser->lineno)); }
+ break;
+
+ case 322:
+
+/* Line 1806 of yacc.c */
+#line 1189 "parser.y"
+ { parser_circ_def(parser, (yyvsp[(1) - (1)].val), unique_s); }
+ break;
+
+ case 323:
+
+/* Line 1806 of yacc.c */
+#line 1190 "parser.y"
+ { parser_circ_def(parser, (yyvsp[(1) - (3)].val), (yyvsp[(3) - (3)].val));
+ (yyval.val) = (yyvsp[(3) - (3)].val); }
+ break;
+
+ case 324:
+
+/* Line 1806 of yacc.c */
+#line 1192 "parser.y"
+ { (yyval.val) = parser_circ_ref(parser, (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 325:
+
+/* Line 1806 of yacc.c */
+#line 1195 "parser.y"
+ { (yyval.val) = uref_helper(parser, (yyvsp[(2) - (2)].val)); }
+ break;
+
+ case 326:
+
+/* Line 1806 of yacc.c */
+#line 1196 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 327:
+
+/* Line 1806 of yacc.c */
+#line 1198 "parser.y"
+ { (yyval.val) = ifnign(symhlpr((yyvsp[(1) - (1)].lexeme), t)); }
+ break;
+
+ case 328:
+
+/* Line 1806 of yacc.c */
+#line 1199 "parser.y"
+ { (yyval.val) = cons(var_s, cons((yyvsp[(1) - (1)].val), nil));
+ rl((yyval.val), num(parser->lineno)); }
+ break;
+
+ case 329:
+
+/* Line 1806 of yacc.c */
+#line 1201 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 330:
+
+/* Line 1806 of yacc.c */
+#line 1202 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 331:
+
+/* Line 1806 of yacc.c */
+#line 1203 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 332:
+
+/* Line 1806 of yacc.c */
+#line 1204 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 333:
+
+/* Line 1806 of yacc.c */
+#line 1205 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 334:
+
+/* Line 1806 of yacc.c */
+#line 1206 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 335:
+
+/* Line 1806 of yacc.c */
+#line 1207 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 336:
+
+/* Line 1806 of yacc.c */
+#line 1208 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 337:
+
+/* Line 1806 of yacc.c */
+#line 1209 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 338:
+
+/* Line 1806 of yacc.c */
+#line 1210 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 339:
+
+/* Line 1806 of yacc.c */
+#line 1211 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 340:
+
+/* Line 1806 of yacc.c */
+#line 1212 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 341:
+
+/* Line 1806 of yacc.c */
+#line 1213 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 342:
+
+/* Line 1806 of yacc.c */
+#line 1214 "parser.y"
+ { (yyval.val) = rl((yyvsp[(2) - (2)].val), num((yyvsp[(1) - (2)].lineno))); }
+ break;
+
+ case 343:
+
+/* Line 1806 of yacc.c */
+#line 1215 "parser.y"
+ { (yyval.val) = rl(cons(quasilist_s, (yyvsp[(2) - (2)].val)), num((yyvsp[(1) - (2)].lineno))); }
+ break;
+
+ case 344:
+
+/* Line 1806 of yacc.c */
+#line 1216 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 345:
+
+/* Line 1806 of yacc.c */
+#line 1217 "parser.y"
+ { (yyval.val) = rl(rlc(list(quote_s, (yyvsp[(2) - (2)].val), nao), (yyvsp[(2) - (2)].val)),
+ num(parser->lineno)); }
+ break;
+
+ case 346:
+
+/* Line 1806 of yacc.c */
+#line 1219 "parser.y"
+ { parser->quasi_level++; }
+ break;
+
+ case 347:
+
+/* Line 1806 of yacc.c */
+#line 1220 "parser.y"
+ { parser->quasi_level--;
+ (yyval.val) = rl(rlc(list(sys_qquote_s, (yyvsp[(3) - (3)].val), nao), (yyvsp[(3) - (3)].val)),
+ num(parser->lineno)); }
+ break;
+
+ case 348:
+
+/* Line 1806 of yacc.c */
+#line 1223 "parser.y"
+ { parser->quasi_level--; }
+ break;
+
+ case 349:
+
+/* Line 1806 of yacc.c */
+#line 1224 "parser.y"
+ { parser->quasi_level++;
+ (yyval.val) = rl(rlc(list(sys_unquote_s, (yyvsp[(3) - (3)].val), nao), (yyvsp[(3) - (3)].val)),
+ num(parser->lineno)); }
+ break;
+
+ case 350:
+
+/* Line 1806 of yacc.c */
+#line 1227 "parser.y"
+ { parser->quasi_level--; }
+ break;
+
+ case 351:
+
+/* Line 1806 of yacc.c */
+#line 1228 "parser.y"
+ { parser->quasi_level++;
+ (yyval.val) = rl(rlc(list(sys_splice_s, (yyvsp[(3) - (3)].val), nao), (yyvsp[(3) - (3)].val)),
+ num(parser->lineno)); }
+ break;
+
+ case 352:
+
+/* Line 1806 of yacc.c */
+#line 1231 "parser.y"
+ { uses_or2;
+ (yyval.val) = rlc(list(rcons_s, (yyvsp[(1) - (3)].val), (yyvsp[(3) - (3)].val), nao),
+ or2((yyvsp[(1) - (3)].val), (yyvsp[(3) - (3)].val))); }
+ break;
+
+ case 353:
+
+/* Line 1806 of yacc.c */
+#line 1235 "parser.y"
+ { uses_or2;
+ (yyval.val) = rlc(list(rcons_s, (yyvsp[(1) - (4)].val),
+ uref_helper(parser, (yyvsp[(4) - (4)].val)),
+ nao),
+ or2((yyvsp[(1) - (4)].val), (yyvsp[(4) - (4)].val))); }
+ break;
+
+ case 354:
+
+/* Line 1806 of yacc.c */
+#line 1241 "parser.y"
+ { uses_or2;
+ (yyval.val) = rlc(list(rcons_s, (yyvsp[(1) - (3)].val), (yyvsp[(3) - (3)].val), nao),
+ or2((yyvsp[(1) - (3)].val), (yyvsp[(3) - (3)].val))); }
+ break;
+
+ case 355:
+
+/* Line 1806 of yacc.c */
+#line 1245 "parser.y"
+ { uses_or2;
+ (yyval.val) = rlc(list(rcons_s, (yyvsp[(1) - (4)].val),
+ uref_helper(parser, (yyvsp[(4) - (4)].val)),
+ nao),
+ or2((yyvsp[(1) - (4)].val), (yyvsp[(4) - (4)].val))); }
+ break;
+
+ case 356:
+
+/* Line 1806 of yacc.c */
+#line 1250 "parser.y"
+ { (yyval.val) = qref_helper(parser, (yyvsp[(1) - (3)].val), (yyvsp[(3) - (3)].val)); }
+ break;
+
+ case 357:
+
+/* Line 1806 of yacc.c */
+#line 1251 "parser.y"
+ { (yyval.val) = qref_helper(parser,
+ cons(t, cons((yyvsp[(1) - (3)].val), nil)),
+ (yyvsp[(3) - (3)].val)); }
+ break;
+
+ case 358:
+
+/* Line 1806 of yacc.c */
+#line 1254 "parser.y"
+ { (yyval.val) = uref_helper(parser, (yyvsp[(2) - (2)].val)); }
+ break;
+
+ case 359:
+
+/* Line 1806 of yacc.c */
+#line 1255 "parser.y"
+ { (yyval.val) = uoref_helper(parser, (yyvsp[(2) - (2)].val)); }
+ break;
+
+ case 360:
+
+/* Line 1806 of yacc.c */
+#line 1256 "parser.y"
+ { parser_circ_def(parser, (yyvsp[(1) - (1)].val), unique_s); }
+ break;
+
+ case 361:
+
+/* Line 1806 of yacc.c */
+#line 1257 "parser.y"
+ { parser_circ_def(parser, (yyvsp[(1) - (3)].val), (yyvsp[(3) - (3)].val));
+ (yyval.val) = (yyvsp[(3) - (3)].val); }
+ break;
+
+ case 362:
+
+/* Line 1806 of yacc.c */
+#line 1259 "parser.y"
+ { (yyval.val) = parser_circ_ref(parser, (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 363:
+
+/* Line 1806 of yacc.c */
+#line 1262 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 364:
+
+/* Line 1806 of yacc.c */
+#line 1263 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 365:
+
+/* Line 1806 of yacc.c */
+#line 1266 "parser.y"
+ { (yyval.val) = uref_helper(parser, (yyvsp[(2) - (2)].val)); }
+ break;
+
+ case 366:
+
+/* Line 1806 of yacc.c */
+#line 1267 "parser.y"
+ { (yyval.val) = uoref_helper(parser, (yyvsp[(2) - (2)].val)); }
+ break;
+
+ case 367:
+
+/* Line 1806 of yacc.c */
+#line 1268 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 368:
+
+/* Line 1806 of yacc.c */
+#line 1271 "parser.y"
+ { (yyval.val) = regex_compile((yyvsp[(2) - (3)].val), nil);
+ end_of_regex(scnr);
+ rl((yyval.val), num(parser->lineno)); }
+ break;
+
+ case 369:
+
+/* Line 1806 of yacc.c */
+#line 1274 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("regex"));
+ end_of_regex(scnr); }
+ break;
+
+ case 370:
+
+/* Line 1806 of yacc.c */
+#line 1280 "parser.y"
+ { (yyval.val) = regex_compile((yyvsp[(2) - (3)].val), nil);
+ end_of_regex(scnr);
+ rl((yyval.val), num(parser->lineno)); }
+ break;
+
+ case 371:
+
+/* Line 1806 of yacc.c */
+#line 1284 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("regex"));
+ end_of_regex(scnr); }
+ break;
+
+ case 372:
+
+/* Line 1806 of yacc.c */
+#line 1289 "parser.y"
+ { (yyval.val) = if3(cdr((yyvsp[(1) - (1)].val)),
+ cons(compound_s, (yyvsp[(1) - (1)].val)),
+ car((yyvsp[(1) - (1)].val))); }
+ break;
+
+ case 373:
+
+/* Line 1806 of yacc.c */
+#line 1292 "parser.y"
+ { (yyval.val) = list(or_s, (yyvsp[(1) - (3)].val), (yyvsp[(3) - (3)].val), nao); }
+ break;
+
+ case 374:
+
+/* Line 1806 of yacc.c */
+#line 1293 "parser.y"
+ { (yyval.val) = list(and_s, (yyvsp[(1) - (3)].val), (yyvsp[(3) - (3)].val), nao); }
+ break;
+
+ case 375:
+
+/* Line 1806 of yacc.c */
+#line 1294 "parser.y"
+ { (yyval.val) = list(compl_s, (yyvsp[(2) - (2)].val), nao); }
+ break;
+
+ case 376:
+
+/* Line 1806 of yacc.c */
+#line 1295 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 377:
+
+/* Line 1806 of yacc.c */
+#line 1298 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil); }
+ break;
+
+ case 378:
+
+/* Line 1806 of yacc.c */
+#line 1299 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (2)].val), (yyvsp[(2) - (2)].val)); }
+ break;
+
+ case 379:
+
+/* Line 1806 of yacc.c */
+#line 1300 "parser.y"
+ { (yyval.val) = list((yyvsp[(1) - (3)].val), list(compl_s, (yyvsp[(3) - (3)].val), nao), nao); }
+ break;
+
+ case 380:
+
+/* Line 1806 of yacc.c */
+#line 1303 "parser.y"
+ { (yyval.val) = list(zeroplus_s, (yyvsp[(1) - (2)].val), nao); }
+ break;
+
+ case 381:
+
+/* Line 1806 of yacc.c */
+#line 1304 "parser.y"
+ { (yyval.val) = list(oneplus_s, (yyvsp[(1) - (2)].val), nao); }
+ break;
+
+ case 382:
+
+/* Line 1806 of yacc.c */
+#line 1305 "parser.y"
+ { (yyval.val) = list(optional_s, (yyvsp[(1) - (2)].val), nao); }
+ break;
+
+ case 383:
+
+/* Line 1806 of yacc.c */
+#line 1306 "parser.y"
+ { (yyval.val) = list(nongreedy_s, (yyvsp[(1) - (3)].val), (yyvsp[(3) - (3)].val), nao); }
+ break;
+
+ case 384:
+
+/* Line 1806 of yacc.c */
+#line 1307 "parser.y"
+ { if (first((yyvsp[(2) - (3)].val)) == chr('^'))
+ { if (rest((yyvsp[(2) - (3)].val)))
+ (yyval.val) = cons(cset_s, rest((yyvsp[(2) - (3)].val)));
+ else
+ (yyval.val) = wild_s; }
+ else
+ (yyval.val) = cons(set_s, (yyvsp[(2) - (3)].val)); }
+ break;
+
+ case 385:
+
+/* Line 1806 of yacc.c */
+#line 1314 "parser.y"
+ { (yyval.val) = cons(set_s, nil); }
+ break;
+
+ case 386:
+
+/* Line 1806 of yacc.c */
+#line 1315 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("regex character class")); }
+ break;
+
+ case 387:
+
+/* Line 1806 of yacc.c */
+#line 1317 "parser.y"
+ { (yyval.val) = wild_s; }
+ break;
+
+ case 388:
+
+/* Line 1806 of yacc.c */
+#line 1318 "parser.y"
+ { (yyval.val) = chr(']'); }
+ break;
+
+ case 389:
+
+/* Line 1806 of yacc.c */
+#line 1319 "parser.y"
+ { (yyval.val) = chr('-'); }
+ break;
+
+ case 390:
+
+/* Line 1806 of yacc.c */
+#line 1320 "parser.y"
+ { (yyval.val) = chr((yyvsp[(1) - (1)].chr)); }
+ break;
+
+ case 391:
+
+/* Line 1806 of yacc.c */
+#line 1321 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 392:
+
+/* Line 1806 of yacc.c */
+#line 1322 "parser.y"
+ { (yyval.val) = list(compound_s, string_own((yyvsp[(1) - (1)].lexeme)), nao); }
+ break;
+
+ case 393:
+
+/* Line 1806 of yacc.c */
+#line 1323 "parser.y"
+ { (yyval.val) = (yyvsp[(2) - (3)].val); }
+ break;
+
+ case 394:
+
+/* Line 1806 of yacc.c */
+#line 1324 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("regex subexpression")); }
+ break;
+
+ case 395:
+
+/* Line 1806 of yacc.c */
+#line 1328 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil); }
+ break;
+
+ case 396:
+
+/* Line 1806 of yacc.c */
+#line 1329 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (2)].val), (yyvsp[(2) - (2)].val)); }
+ break;
+
+ case 397:
+
+/* Line 1806 of yacc.c */
+#line 1332 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 398:
+
+/* Line 1806 of yacc.c */
+#line 1333 "parser.y"
+ { (yyval.val) = chr((yyvsp[(1) - (1)].chr)); }
+ break;
+
+ case 399:
+
+/* Line 1806 of yacc.c */
+#line 1334 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 400:
+
+/* Line 1806 of yacc.c */
+#line 1337 "parser.y"
+ { (yyval.val) = cons(chr((yyvsp[(1) - (3)].chr)), chr((yyvsp[(3) - (3)].chr))); }
+ break;
+
+ case 401:
+
+/* Line 1806 of yacc.c */
+#line 1339 "parser.y"
+ { (yyval.chr) = '?'; }
+ break;
+
+ case 402:
+
+/* Line 1806 of yacc.c */
+#line 1340 "parser.y"
+ { (yyval.chr) = '.'; }
+ break;
+
+ case 403:
+
+/* Line 1806 of yacc.c */
+#line 1341 "parser.y"
+ { (yyval.chr) = '*'; }
+ break;
+
+ case 404:
+
+/* Line 1806 of yacc.c */
+#line 1342 "parser.y"
+ { (yyval.chr) = '+'; }
+ break;
+
+ case 405:
+
+/* Line 1806 of yacc.c */
+#line 1343 "parser.y"
+ { (yyval.chr) = '('; }
+ break;
+
+ case 406:
+
+/* Line 1806 of yacc.c */
+#line 1344 "parser.y"
+ { (yyval.chr) = ')'; }
+ break;
+
+ case 407:
+
+/* Line 1806 of yacc.c */
+#line 1345 "parser.y"
+ { (yyval.chr) = '|'; }
+ break;
+
+ case 408:
+
+/* Line 1806 of yacc.c */
+#line 1346 "parser.y"
+ { (yyval.chr) = '~'; }
+ break;
+
+ case 409:
+
+/* Line 1806 of yacc.c */
+#line 1347 "parser.y"
+ { (yyval.chr) = '&'; }
+ break;
+
+ case 410:
+
+/* Line 1806 of yacc.c */
+#line 1348 "parser.y"
+ { (yyval.chr) = '%'; }
+ break;
+
+ case 411:
+
+/* Line 1806 of yacc.c */
+#line 1349 "parser.y"
+ { (yyval.chr) = '/'; }
+ break;
+
+ case 412:
+
+/* Line 1806 of yacc.c */
+#line 1350 "parser.y"
+ { (yyval.chr) = (yyvsp[(1) - (1)].chr); }
+ break;
+
+ case 413:
+
+/* Line 1806 of yacc.c */
+#line 1353 "parser.y"
+ { switch ((yyvsp[(1) - (1)].chr))
+ { case 's':
+ (yyval.val) = space_k; break;
+ case 'S':
+ (yyval.val) = cspace_k; break;
+ case 'd':
+ (yyval.val) = digit_k; break;
+ case 'D':
+ (yyval.val) = cdigit_k; break;
+ case 'w':
+ (yyval.val) = word_char_k; break;
+ case 'W':
+ (yyval.val) = cword_char_k; break; }}
+ break;
+
+ case 415:
+
+/* Line 1806 of yacc.c */
+#line 1368 "parser.y"
+ { yyerr("newline expected after directive");
+ yyerrok; }
+ break;
+
+ case 416:
+
+/* Line 1806 of yacc.c */
+#line 1372 "parser.y"
+ { (yyval.val) = null_string; }
+ break;
+
+ case 417:
+
+/* Line 1806 of yacc.c */
+#line 1373 "parser.y"
+ { (yyval.val) = (yyvsp[(2) - (3)].val);
+ rl((yyval.val), num(parser->lineno)); }
+ break;
+
+ case 418:
+
+/* Line 1806 of yacc.c */
+#line 1375 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("string literal")); }
+ break;
+
+ case 419:
+
+/* Line 1806 of yacc.c */
+#line 1379 "parser.y"
+ { wchar_t ch;
+ val str = string_own((yyvsp[(2) - (2)].lexeme));
+ const wchar_t *cstr = c_str(str, nil);
+
+ if (cstr[1] == 0)
+ { ch = cstr[0]; }
+ else
+ { ch = char_from_name(cstr);
+ if (ch == L'!')
+ { yyerrorf(scnr, lit("unknown character name: ~a"),
+ str, nao); }}
+ end_of_char(scnr);
+ (yyval.val) = chr(ch); }
+ break;
+
+ case 420:
+
+/* Line 1806 of yacc.c */
+#line 1392 "parser.y"
+ { (yyval.val) = chr((yyvsp[(2) - (2)].chr));
+ end_of_char(scnr); }
+ break;
+
+ case 421:
+
+/* Line 1806 of yacc.c */
+#line 1394 "parser.y"
+ { free((yyvsp[(2) - (2)].lexeme));
+ yyerrorf(scnr,
+ lit("invalid UTF-8 used as character name"),
+ nao); }
+ break;
+
+ case 422:
+
+/* Line 1806 of yacc.c */
+#line 1398 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar,
+ lit("character literal")); }
+ break;
+
+ case 423:
+
+/* Line 1806 of yacc.c */
+#line 1403 "parser.y"
+ { (yyval.val) = null_string; }
+ break;
+
+ case 424:
+
+/* Line 1806 of yacc.c */
+#line 1404 "parser.y"
+ { (yyval.val) = cons(quasi_s, (yyvsp[(2) - (3)].val));
+ rlc((yyval.val), (yyvsp[(2) - (3)].val));
+ rl((yyval.val), num(parser->lineno)); }
+ break;
+
+ case 425:
+
+/* Line 1806 of yacc.c */
+#line 1407 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("quasistring")); }
+ break;
+
+ case 426:
+
+/* Line 1806 of yacc.c */
+#line 1411 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (1)].val), nil);
+ rl((yyval.val), num(parser->lineno)); }
+ break;
+
+ case 427:
+
+/* Line 1806 of yacc.c */
+#line 1413 "parser.y"
+ { (yyval.val) = cons((yyvsp[(1) - (2)].val), (yyvsp[(2) - (2)].val));
+ rl((yyval.val), num(parser->lineno)); }
+ break;
+
+ case 428:
+
+/* Line 1806 of yacc.c */
+#line 1417 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 429:
+
+/* Line 1806 of yacc.c */
+#line 1418 "parser.y"
+ { (yyval.val) = (yyvsp[(1) - (1)].val); }
+ break;
+
+ case 430:
+
+/* Line 1806 of yacc.c */
+#line 1419 "parser.y"
+ { (yyval.val) = cons(var_s, cons((yyvsp[(1) - (1)].val), nil));
+ rl((yyval.val), num(parser->lineno)); }
+ break;
+
+ case 431:
+
+/* Line 1806 of yacc.c */
+#line 1421 "parser.y"
+ { if (integerp((yyvsp[(2) - (2)].val)) || symbolp((yyvsp[(2) - (2)].val)))
+ (yyval.val) = rlcp_tree(cons(var_s, cons((yyvsp[(2) - (2)].val), nil)),
+ (yyvsp[(2) - (2)].val));
+ else
+ (yyval.val) = (yyvsp[(2) - (2)].val); }
+ break;
+
+ case 432:
+
+/* Line 1806 of yacc.c */
+#line 1428 "parser.y"
+ { (yyval.val) = mkstring(one, chr((yyvsp[(1) - (1)].chr))); }
+ break;
+
+ case 433:
+
+/* Line 1806 of yacc.c */
+#line 1429 "parser.y"
+ { val ch = mkstring(one, chr((yyvsp[(1) - (2)].chr)));
+ (yyval.val) = string_extend(ch, (yyvsp[(2) - (2)].val), t); }
+ break;
+
+ case 434:
+
+/* Line 1806 of yacc.c */
+#line 1431 "parser.y"
+ { (yyval.val) = string_own((yyvsp[(1) - (1)].lexeme)); }
+ break;
+
+ case 435:
+
+/* Line 1806 of yacc.c */
+#line 1432 "parser.y"
+ { (yyval.val) = string_extend(string_own((yyvsp[(1) - (2)].lexeme)), (yyvsp[(2) - (2)].val), t); }
+ break;
+
+ case 436:
+
+/* Line 1806 of yacc.c */
+#line 1435 "parser.y"
+ { (yyval.val) = mkstring(one, chr((yyvsp[(1) - (1)].chr))); }
+ break;
+
+ case 437:
+
+/* Line 1806 of yacc.c */
+#line 1436 "parser.y"
+ { (yyval.val) = string_extend((yyvsp[(1) - (2)].val), chr((yyvsp[(2) - (2)].chr)), nil); }
+ break;
+
+ case 438:
+
+/* Line 1806 of yacc.c */
+#line 1437 "parser.y"
+ { (yyval.val) = string_own((yyvsp[(1) - (1)].lexeme)); }
+ break;
+
+ case 439:
+
+/* Line 1806 of yacc.c */
+#line 1438 "parser.y"
+ { (yyval.val) = string_extend((yyvsp[(1) - (2)].val), string_own((yyvsp[(2) - (2)].lexeme)), nil); }
+ break;
+
+ case 440:
+
+/* Line 1806 of yacc.c */
+#line 1441 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 441:
+
+/* Line 1806 of yacc.c */
+#line 1442 "parser.y"
+ { (yyval.val) = (yyvsp[(2) - (2)].val); }
+ break;
+
+ case 442:
+
+/* Line 1806 of yacc.c */
+#line 1443 "parser.y"
+ { val word = (yyvsp[(1) - (2)].val);
+ (yyval.val) = rlc(cons(word, (yyvsp[(2) - (2)].val)), (yyvsp[(1) - (2)].val)); }
+ break;
+
+ case 443:
+
+/* Line 1806 of yacc.c */
+#line 1445 "parser.y"
+ { (yyval.val) = nil;
+ yybadtok(yychar, lit("word list")); }
+ break;
+
+ case 444:
+
+/* Line 1806 of yacc.c */
+#line 1449 "parser.y"
+ { (yyval.val) = nil; }
+ break;
+
+ case 445:
+
+/* Line 1806 of yacc.c */
+#line 1450 "parser.y"
+ { (yyval.val) = (yyvsp[(2) - (2)].val); }
+ break;
+
+ case 446:
+
+/* Line 1806 of yacc.c */
+#line 1451 "parser.y"
+ { val qword = cons(quasi_s, (yyvsp[(1) - (2)].val));
+ (yyval.val) = rlc(cons(qword, nil), (yyvsp[(1) - (2)].val)); }
+ break;
+
+ case 447:
+
+/* Line 1806 of yacc.c */
+#line 1455 "parser.y"
+ { val qword = cons(quasi_s, (yyvsp[(1) - (3)].val));
+ (yyval.val) = rlc(cons(qword, (yyvsp[(3) - (3)].val)), (yyvsp[(1) - (3)].val)); }
+ break;
+
+ case 448:
+
+/* Line 1806 of yacc.c */
+#line 1459 "parser.y"
+ { (yyval.val) = make_buf(zero, nil, nil);
+ end_of_buflit(scnr); }
+ break;
+
+ case 449:
+
+/* Line 1806 of yacc.c */
+#line 1461 "parser.y"
+ { end_of_buflit(scnr);
+ buf_trim((yyvsp[(2) - (3)].val));
+ (yyval.val) = (yyvsp[(2) - (3)].val); }
+ break;
+
+ case 450:
+
+/* Line 1806 of yacc.c */
+#line 1464 "parser.y"
+ { yyerr("unterminated buffer literal");
+ end_of_buflit(scnr);
+ yyerrok; }
+ break;
+
+ case 451:
+
+/* Line 1806 of yacc.c */
+#line 1469 "parser.y"
+ { buf_put_u8((yyvsp[(1) - (2)].val), length_buf((yyval.val)), (yyvsp[(2) - (2)].val));
+ (yyval.val) = (yyvsp[(1) - (2)].val); }
+ break;
+
+ case 452:
+
+/* Line 1806 of yacc.c */
+#line 1471 "parser.y"
+ { (yyval.val) = make_buf(zero, nil, num_fast(512));
+ buf_put_u8((yyval.val), zero, (yyvsp[(1) - (1)].val)); }
+ break;
+
+ case 453:
+
+/* Line 1806 of yacc.c */
+#line 1475 "parser.y"
+ { (yyval.val) = num((yyvsp[(1) - (2)].chr) << 4 | (yyvsp[(2) - (2)].chr)); }
+ break;
+
+ case 454:
+
+/* Line 1806 of yacc.c */
+#line 1476 "parser.y"
+ { (yyval.val) = zero;
+ yyerr("unpaired digit in buffer literal");
+ yyerrok; }
+ break;
+
+ case 455:
+
+/* Line 1806 of yacc.c */
+#line 1483 "parser.y"
+ { (yyval.val) = mkexp(all_s, nil, num(parser->lineno)); }
+ break;
+
+ case 456:
+
+/* Line 1806 of yacc.c */
+#line 1484 "parser.y"
+ { (yyval.val) = mkexp(some_s, nil, num(parser->lineno)); }
+ break;
+
+ case 457:
+
+/* Line 1806 of yacc.c */
+#line 1485 "parser.y"
+ { (yyval.val) = mkexp(none_s, nil, num(parser->lineno)); }
+ break;
+
+ case 458:
+
+/* Line 1806 of yacc.c */
+#line 1486 "parser.y"
+ { (yyval.val) = mkexp(maybe_s, nil, num(parser->lineno)); }
+ break;
+
+ case 459:
+
+/* Line 1806 of yacc.c */
+#line 1487 "parser.y"
+ { (yyval.val) = mkexp(cases_s, nil, num(parser->lineno)); }
+ break;
+
+ case 460:
+
+/* Line 1806 of yacc.c */
+#line 1488 "parser.y"
+ { (yyval.val) = mkexp(and_s, nil, num(parser->lineno)); }
+ break;
+
+ case 461:
+
+/* Line 1806 of yacc.c */
+#line 1489 "parser.y"
+ { (yyval.val) = mkexp(or_s, nil, num(parser->lineno)); }
+ break;
+
+ case 462:
+
+/* Line 1806 of yacc.c */
+#line 1490 "parser.y"
+ { (yyval.val) = mkexp(try_s, nil, num(parser->lineno)); }
+ break;
+
+ case 463:
+
+/* Line 1806 of yacc.c */
+#line 1491 "parser.y"
+ { (yyval.val) = mkexp(finally_s, nil, num(parser->lineno)); }
+ break;
+
+ case 464:
+
+/* Line 1806 of yacc.c */
+#line 1493 "parser.y"
+ { (yyval.val) = mkexp(block_s, (yyvsp[(2) - (3)].val), nil); }
+ break;
+
+ case 465:
+
+/* Line 1806 of yacc.c */
+#line 1495 "parser.y"
+ { (yyval.val) = mkexp(choose_s, (yyvsp[(2) - (3)].val), nil); }
+ break;
+
+ case 466:
+
+/* Line 1806 of yacc.c */
+#line 1497 "parser.y"
+ { (yyval.val) = mkexp(collect_s, (yyvsp[(2) - (3)].val), nil); }
+ break;
+
+ case 467:
+
+/* Line 1806 of yacc.c */
+#line 1499 "parser.y"
+ { (yyval.val) = mkexp(coll_s, (yyvsp[(2) - (3)].val), nil); }
+ break;
+
+ case 468:
+
+/* Line 1806 of yacc.c */
+#line 1501 "parser.y"
+ { (yyval.val) = mkexp(gather_s, (yyvsp[(2) - (3)].val), nil); }
+ break;
+
+ case 469:
+
+/* Line 1806 of yacc.c */
+#line 1503 "parser.y"
+ { (yyval.val) = mkexp(define_s, (yyvsp[(2) - (3)].val), nil); }
+ break;
+
+ case 470:
+
+/* Line 1806 of yacc.c */
+#line 1505 "parser.y"
+ { (yyval.val) = mkexp(catch_s, (yyvsp[(2) - (3)].val), nil); }
+ break;
+
+ case 471:
+
+/* Line 1806 of yacc.c */
+#line 1507 "parser.y"
+ { (yyval.val) = mkexp(if_s,
+ cons((yyvsp[(2) - (5)].val),
+ cons((yyvsp[(3) - (5)].val), (yyvsp[(4) - (5)].val))),
+ nil); }
+ break;
+
+ case 472:
+
+/* Line 1806 of yacc.c */
+#line 1512 "parser.y"
+ { yyerr("@(output) doesn't nest"); }
+ break;
+
+ case 473:
+
+/* Line 1806 of yacc.c */
+#line 1514 "parser.y"
+ { yyerr("@(push) doesn't nest"); }
+ break;
+
+
+
+/* Line 1806 of yacc.c */
+#line 7033 "y.tab.c"
+ default: break;
+ }
+ /* User semantic actions sometimes alter yychar, and that requires
+ that yytoken be updated with the new translation. We take the
+ approach of translating immediately before every use of yytoken.
+ One alternative is translating here after every semantic action,
+ but that translation would be missed if the semantic action invokes
+ YYABORT, YYACCEPT, or YYERROR immediately after altering yychar or
+ if it invokes YYBACKUP. In the case of YYABORT or YYACCEPT, an
+ incorrect destructor might then be invoked immediately. In the
+ case of YYERROR or YYBACKUP, subsequent parser actions might lead
+ to an incorrect destructor call or verbose syntax error message
+ before the lookahead is translated. */
+ YY_SYMBOL_PRINT ("-> $$ =", yyr1[yyn], &yyval, &yyloc);
+
+ YYPOPSTACK (yylen);
+ yylen = 0;
+ YY_STACK_PRINT (yyss, yyssp);
+
+ *++yyvsp = yyval;
+
+ /* Now `shift' the result of the reduction. Determine what state
+ that goes to, based on the state we popped back to and the rule
+ number reduced by. */
+
+ yyn = yyr1[yyn];
+
+ yystate = yypgoto[yyn - YYNTOKENS] + *yyssp;
+ if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == *yyssp)
+ yystate = yytable[yystate];
+ else
+ yystate = yydefgoto[yyn - YYNTOKENS];
+
+ goto yynewstate;
+
+
+/*------------------------------------.
+| yyerrlab -- here on detecting error |
+`------------------------------------*/
+yyerrlab:
+ /* Make sure we have latest lookahead translation. See comments at
+ user semantic actions for why this is necessary. */
+ yytoken = yychar == YYEMPTY ? YYEMPTY : YYTRANSLATE (yychar);
+
+ /* If not already recovering from an error, report this error. */
+ if (!yyerrstatus)
+ {
+#if ! YYERROR_VERBOSE
+ yyerror (scnr, parser, YY_("syntax error"));
+#else
+# define YYSYNTAX_ERROR yysyntax_error (&yymsg_alloc, &yymsg, \
+ yyssp, yytoken)
+ {
+ char const *yymsgp = YY_("syntax error");
+ int yysyntax_error_status;
+ yysyntax_error_status = YYSYNTAX_ERROR;
+ if (yysyntax_error_status == 0)
+ yymsgp = yymsg;
+ else if (yysyntax_error_status == 1)
+ {
+ if (yymsg != yymsgbuf)
+ YYSTACK_FREE (yymsg);
+ yymsg = (char *) YYSTACK_ALLOC (yymsg_alloc);
+ if (!yymsg)
+ {
+ yymsg = yymsgbuf;
+ yymsg_alloc = sizeof yymsgbuf;
+ yysyntax_error_status = 2;
+ }
+ else
+ {
+ yysyntax_error_status = YYSYNTAX_ERROR;
+ yymsgp = yymsg;
+ }
+ }
+ yyerror (scnr, parser, yymsgp);
+ if (yysyntax_error_status == 2)
+ goto yyexhaustedlab;
+ }
+# undef YYSYNTAX_ERROR
+#endif
+ }
+
+
+
+ if (yyerrstatus == 3)
+ {
+ /* If just tried and failed to reuse lookahead token after an
+ error, discard it. */
+
+ if (yychar <= YYEOF)
+ {
+ /* Return failure if at end of input. */
+ if (yychar == YYEOF)
+ YYABORT;
+ }
+ else
+ {
+ yydestruct ("Error: discarding",
+ yytoken, &yylval, scnr, parser);
+ yychar = YYEMPTY;
+ }
+ }
+
+ /* Else will try to reuse lookahead token after shifting the error
+ token. */
+ goto yyerrlab1;
+
+
+/*---------------------------------------------------.
+| yyerrorlab -- error raised explicitly by YYERROR. |
+`---------------------------------------------------*/
+yyerrorlab:
+
+ /* Pacify compilers like GCC when the user code never invokes
+ YYERROR and the label yyerrorlab therefore never appears in user
+ code. */
+ if (/*CONSTCOND*/ 0)
+ goto yyerrorlab;
+
+ /* Do not reclaim the symbols of the rule which action triggered
+ this YYERROR. */
+ YYPOPSTACK (yylen);
+ yylen = 0;
+ YY_STACK_PRINT (yyss, yyssp);
+ yystate = *yyssp;
+ goto yyerrlab1;
+
+
+/*-------------------------------------------------------------.
+| yyerrlab1 -- common code for both syntax error and YYERROR. |
+`-------------------------------------------------------------*/
+yyerrlab1:
+ yyerrstatus = 3; /* Each real token shifted decrements this. */
+
+ for (;;)
+ {
+ yyn = yypact[yystate];
+ if (!yypact_value_is_default (yyn))
+ {
+ yyn += YYTERROR;
+ if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR)
+ {
+ yyn = yytable[yyn];
+ if (0 < yyn)
+ break;
+ }
+ }
+
+ /* Pop the current state because it cannot handle the error token. */
+ if (yyssp == yyss)
+ YYABORT;
+
+
+ yydestruct ("Error: popping",
+ yystos[yystate], yyvsp, scnr, parser);
+ YYPOPSTACK (1);
+ yystate = *yyssp;
+ YY_STACK_PRINT (yyss, yyssp);
+ }
+
+ *++yyvsp = yylval;
+
+
+ /* Shift the error token. */
+ YY_SYMBOL_PRINT ("Shifting", yystos[yyn], yyvsp, yylsp);
+
+ yystate = yyn;
+ goto yynewstate;
+
+
+/*-------------------------------------.
+| yyacceptlab -- YYACCEPT comes here. |
+`-------------------------------------*/
+yyacceptlab:
+ yyresult = 0;
+ goto yyreturn;
+
+/*-----------------------------------.
+| yyabortlab -- YYABORT comes here. |
+`-----------------------------------*/
+yyabortlab:
+ yyresult = 1;
+ goto yyreturn;
+
+#if !defined(yyoverflow) || YYERROR_VERBOSE
+/*-------------------------------------------------.
+| yyexhaustedlab -- memory exhaustion comes here. |
+`-------------------------------------------------*/
+yyexhaustedlab:
+ yyerror (scnr, parser, YY_("memory exhausted"));
+ yyresult = 2;
+ /* Fall through. */
+#endif
+
+yyreturn:
+ if (yychar != YYEMPTY)
+ {
+ /* Make sure we have latest lookahead translation. See comments at
+ user semantic actions for why this is necessary. */
+ yytoken = YYTRANSLATE (yychar);
+ yydestruct ("Cleanup: discarding lookahead",
+ yytoken, &yylval, scnr, parser);
+ }
+ /* Do not reclaim the symbols of the rule which action triggered
+ this YYABORT or YYACCEPT. */
+ YYPOPSTACK (yylen);
+ YY_STACK_PRINT (yyss, yyssp);
+ while (yyssp != yyss)
+ {
+ yydestruct ("Cleanup: popping",
+ yystos[*yyssp], yyvsp, scnr, parser);
+ YYPOPSTACK (1);
+ }
+#ifndef yyoverflow
+ if (yyss != yyssa)
+ YYSTACK_FREE (yyss);
+#endif
+#if YYERROR_VERBOSE
+ if (yymsg != yymsgbuf)
+ YYSTACK_FREE (yymsg);
+#endif
+ /* Make sure YYID is used. */
+ return YYID (yyresult);
+}
+
+
+
+/* Line 2067 of yacc.c */
+#line 1517 "parser.y"
+
+
+const int have_yydebug = YYDEBUG;
+
+int yylex(YYSTYPE *, yyscan_t scanner);
+
+void yydebug_onoff(int val)
+{
+#if YYDEBUG
+ yydebug = val;
+#else
+ (void) val;
+#endif
+}
+
+static void set_syntax_tree(parser_t *parser, val tree)
+{
+ if (tree == nao)
+ parser->syntax_tree = tree;
+ else
+ set(mkloc(parser->syntax_tree, parser->parser), tree);
+}
+
+static val sym_helper(parser_t *parser, wchar_t *lexeme, val meta_allowed)
+{
+ scanner_t *scnr = parser->scanner;
+ int leading_at = *lexeme == L'@';
+ wchar_t *tokfree = lexeme;
+ wchar_t *colon = wcschr(lexeme, L':');
+ val sym;
+
+ if (leading_at) {
+ if (!meta_allowed) {
+ val tok = string_own(lexeme);
+ yyerrorf(scnr, lit("~a: meta variable not allowed in this context"), tok, nao);
+ return nil;
+ }
+ lexeme++;
+ }
+
+ if (colon != 0)
+ *colon = 0;
+
+ if (colon == lexeme) {
+ val sym_name = string(colon + 1);
+ scrub_scanner(parser->scanner, SYMTOK, tokfree);
+ free(tokfree);
+ sym = intern(sym_name, keyword_package);
+ } else if (colon != 0) {
+ val pkg_name = string(lexeme);
+ val sym_name = string(colon + 1);
+ scrub_scanner(parser->scanner, SYMTOK, tokfree);
+ free(tokfree);
+ if (equal(pkg_name, lit("#"))) {
+ sym = make_sym(sym_name);
+ } else {
+ val package = find_package(pkg_name);
+ if (!package) {
+ yyerrorf(scnr, lit("~a:~a: package ~a not found"),
+ pkg_name, sym_name, pkg_name, nao);
+ return nil;
+ }
+ sym = intern(sym_name, package);
+ }
+ } else {
+ val sym_name = string(lexeme);
+ scrub_scanner(parser->scanner, SYMTOK, tokfree);
+ free(tokfree);
+ sym = intern_fallback(sym_name, cur_package);
+ }
+
+ return leading_at ? rl(list(var_s, sym, nao), num(parser->lineno)) : sym;
+}
+
+static val expand_repeat_rep_args(val args)
+{
+ list_collect_decl (out, ptail);
+ val exp_pair = nil, exp_pairs = nil;
+
+ for (; args; args = cdr(args)) {
+ val arg = car(args);
+
+ if (consp(arg)) {
+ if (exp_pairs) {
+ list_collect_decl (iout, iptail);
+ for (; arg; arg = cdr(arg)) {
+ val iarg = car(arg);
+ if (consp(iarg)) {
+ val sym = first(iarg);
+ iptail = list_collect(iptail, list(sym,
+ expand(second(iarg), nil),
+ nao));
+ match_reg_var(sym);
+ } else {
+ iptail = list_collect(iptail, iarg);
+ match_reg_var(iarg);
+ }
+ }
+ ptail = list_collect(ptail, iout);
+ } else if (exp_pair) {
+ val sym = first(arg);
+ ptail = list_collect(ptail, list(sym,
+ expand(second(arg), nil),
+ nao));
+ match_reg_var(sym);
+ } else {
+ ptail = list_collect(ptail, arg);
+ }
+ } else if (!exp_pair && !exp_pairs) {
+ if (arg == counter_k) {
+ exp_pair = t;
+ ptail = list_collect(ptail, arg);
+ continue;
+ } else if (arg == vars_k) {
+ exp_pairs = t;
+ ptail = list_collect(ptail, arg);
+ continue;
+ }
+ } else if (exp_pair) {
+ match_reg_var(arg);
+ ptail = list_collect(ptail, arg);
+ }
+
+ exp_pair = exp_pairs = nil;
+ }
+
+ return out;
+}
+
+static val extract_vars(val output_spec)
+{
+ list_collect_decl (vars, tai);
+
+ if (consp(output_spec)) {
+ val sym = first(output_spec);
+ if (sym == var_s) {
+ val expr = second(output_spec);
+ val modifiers = third(output_spec);
+
+ if (bindable(expr)) {
+ tai = list_collect(tai, expr);
+ } else if (opt_compat && opt_compat <= 128) {
+ tai = list_collect_nconc(tai, extract_vars(expr));
+ } else {
+ val frefs = expand_with_free_refs(expr, nil, nil);
+ tai = list_collect_nconc(tai, second(frefs));
+ }
+
+ for (; modifiers; modifiers = cdr(modifiers)) {
+ val mod = car(modifiers);
+ if (bindable(mod)) {
+ tai = list_collect(tai, mod);
+ } else if (consp(mod)) {
+ val msym = car(mod);
+
+ if (msym == dwim_s) {
+ val arg = second(mod);
+
+ if (bindable(arg)) {
+ tai = list_collect(tai, arg);
+ } else if (consp(arg) && car(arg) == rcons_s) {
+ val f = second(arg);
+ val t = third(arg);
+ if (bindable(f))
+ tai = list_collect(tai, f);
+ if (bindable(t))
+ tai = list_collect(tai, t);
+ }
+ }
+ }
+ }
+ } else if (sym == expr_s) {
+ val expr = second(output_spec);
+ val frefs = expand_with_free_refs(expr, nil, nil);
+ tai = list_collect_nconc(tai, second(frefs));
+ } else {
+ for (; output_spec; output_spec = cdr(output_spec))
+ tai = list_collect_nconc(tai, extract_vars(car(output_spec)));
+ }
+ }
+
+ return vars;
+}
+
+static val repeat_rep_helper(val sym, val args, val main, val parts)
+{
+ uses_or2;
+ val exp_args = expand_repeat_rep_args(args);
+ val single_parts = nil, single_parts_p = nil;
+ val first_parts = nil, first_parts_p = nil;
+ val last_parts = nil, last_parts_p = nil;
+ val empty_parts = nil, empty_parts_p = nil;
+ val mod_parts = nil, mod_parts_p = nil;
+ val modlast_parts = nil, modlast_parts_p = nil;
+ val occur_vars = nil;
+ val iter;
+
+ for (iter = parts; iter != nil; iter = cdr(iter)) {
+ val part = car(iter);
+ val sym = car(part);
+ val clauses = copy_list(cdr(part));
+
+ if (sym == single_s) {
+ single_parts = nappend2(single_parts, clauses);
+ single_parts_p = t;
+ } else if (sym == first_s) {
+ first_parts = nappend2(first_parts, clauses);
+ first_parts_p = t;
+ } else if (sym == last_s) {
+ last_parts = nappend2(last_parts, clauses);
+ last_parts_p = t;
+ } else if (sym == empty_s) {
+ empty_parts = nappend2(empty_parts, clauses);
+ empty_parts_p = t;
+ } else if (sym == mod_s) {
+ mod_parts = cons(clauses, mod_parts);
+ mod_parts_p = t;
+ } else if (sym == modlast_s) {
+ modlast_parts = cons(clauses, modlast_parts);
+ modlast_parts_p = t;
+ } else {
+ abort();
+ }
+ }
+
+ single_parts = or2(single_parts, single_parts_p);
+ first_parts = or2(first_parts, first_parts_p);
+ last_parts = or2(last_parts, last_parts_p);
+ empty_parts = or2(empty_parts, empty_parts_p);
+ mod_parts = or2(nreverse(mod_parts), mod_parts_p);
+ modlast_parts = or2(nreverse(modlast_parts), modlast_parts_p);
+
+ occur_vars = extract_vars(main);
+ occur_vars = nappend2(occur_vars, extract_vars(single_parts));
+ occur_vars = nappend2(occur_vars, extract_vars(first_parts));
+ occur_vars = nappend2(occur_vars, extract_vars(last_parts));
+ occur_vars = nappend2(occur_vars, extract_vars(empty_parts));
+ occur_vars = nappend2(occur_vars, extract_vars(mod_parts));
+ occur_vars = uniq(occur_vars);
+
+ return list(sym, exp_args, main, single_parts, first_parts,
+ last_parts, empty_parts, nreverse(mod_parts),
+ nreverse(modlast_parts), occur_vars, nao);
+}
+
+static void process_catch_exprs(val exprs)
+{
+ val params = second(exprs);
+ for (; params; params = cdr(params)) {
+ val param = first(params);
+ if (consp(param))
+ match_reg_var(car(param));
+ else
+ match_reg_var(param);
+ }
+}
+
+static val define_transform(parser_t *parser, val define_form)
+{
+ scanner_t *scnr = parser->scanner;
+ val sym = first(define_form);
+ val args = second(define_form);
+
+ if (define_form == nil)
+ return nil;
+
+ assert (sym == define_s);
+
+ if (args == nil) {
+ yyerr("define requires arguments");
+ return define_form;
+ }
+
+ if (!consp(args) || !listp(cdr(args))) {
+ yyerr("bad define argument syntax");
+ return define_form;
+ } else {
+ val name = first(args);
+ val params = second(args);
+
+ if (!symbolp(name)) {
+ yyerr("function name must be a symbol");
+ return define_form;
+ }
+
+ if (!proper_list_p(params)) {
+ yyerr("invalid function parameter list");
+ return define_form;
+ }
+
+ if (!all_satisfy(params, func_n1(symbolp), nil))
+ yyerr("function parameters must be symbols");
+ }
+
+ return define_form;
+}
+
+static val optimize_text(val text_form)
+{
+ if (all_satisfy(rest(text_form), func_n1(stringp), nil))
+ return cat_str(rest(text_form), lit(""));
+ return text_form;
+}
+
+val expand_meta(val form, val menv)
+{
+ val sym;
+
+ if (atom(form))
+ return form;
+
+ menv = default_arg(menv, make_env(nil, nil, nil));
+
+ if ((sym = car(form)) == quasi_s) {
+ if (opt_compat && opt_compat <= 128) {
+ list_collect_decl (out, ptail);
+
+ for (; consp(form); form = cdr(form)) {
+ val subform = car(form);
+ if (consp(subform) && car(subform) == expr_s)
+ ptail = list_collect(ptail, expand_meta(subform, menv));
+ else
+ ptail = list_collect(ptail, subform);
+ }
+
+ ptail = list_collect_nconc(ptail, form);
+
+ return rlcp(out, form);
+ }
+
+ return expand(form, nil);
+ }
+
+ if ((sym = car(form)) == expr_s) {
+ val exp_x = expand(second(form), menv);
+ if (!bindable(exp_x))
+ return rlcp(cons(sym, cons(exp_x, nil)), form);
+ return rlcp(cons(var_s, cons(exp_x, nil)), form);
+ }
+
+ if (sym == var_s) {
+ val var_x = expand(second(form), menv);
+ if (!bindable(var_x))
+ return rlcp(cons(expr_s, cons(var_x, nil)), form);
+ return rlcp(cons(var_s, cons(var_x, nil)), form);
+ }
+
+ {
+ list_collect_decl (out, ptail);
+
+ for (; consp(form); form = cdr(form)) {
+ loc nptail = list_collect(ptail, expand_meta(car(form), menv));
+ rlcp(deref(ptail), form);
+ ptail = nptail;
+ }
+
+ ptail = list_collect_nconc(ptail, form);
+
+ return out;
+ }
+}
+
+static val rlviable(val form)
+{
+ switch (type(form)) {
+ case NIL:
+ case LIT:
+ case CHR:
+ case NUM:
+ case SYM:
+ case BGNUM:
+ case FLNUM:
+ return nil;
+ default:
+ return t;
+ }
+}
+
+val rlset(val form, val info)
+{
+ if (rlviable(form)) {
+ loc place = gethash_l(lit("rlcp"), form_to_ln_hash, form, nulloc);
+ if (nilp(deref(place)))
+ set(place, info);
+ }
+ return form;
+}
+
+val rlrec(parser_t *parser, val form, val line)
+{
+ if (parser->rec_source_loc)
+ rlset(form, cons(line, parser->name));
+ return form;
+}
+
+val rlcp_parser(parser_t *parser, val to, val from)
+{
+ if (parser->rec_source_loc)
+ rlset(to, source_loc(from));
+ return to;
+}
+
+static val rlcp_tree_rec(val to, val from, struct circ_stack *up)
+{
+ val ret = to;
+
+ while (consp(to)) {
+ val a = car(to);
+ struct circ_stack rlcs = { up, a };
+ rlcp(to, from);
+ if (!parser_callgraph_circ_check(up, a))
+ break;
+ rlcp_tree_rec(a, from, &rlcs);
+ to = cdr(to);
+ if (!parser_callgraph_circ_check(up, to))
+ break;
+ }
+ return ret;
+}
+
+
+val rlcp_tree(val to, val from)
+{
+ return rlcp_tree_rec(to, from, 0);
+}
+
+static wchar_t char_from_name(const wchar_t *name)
+{
+ static struct {
+ const wchar_t *name;
+ const wchar_t ch;
+ } map[] = {
+ { L"nul", 0 },
+ { L"alarm", L'\a' },
+ { L"backspace", L'\b' },
+ { L"tab", L'\t' },
+ { L"linefeed", L'\n' },
+ { L"newline", L'\n' },
+ { L"vtab", L'\v' },
+ { L"page", L'\f' },
+ { L"return", L'\r' },
+ { L"esc", 27 },
+ { L"space", L' ' },
+ { L"pnul", 0xDC00 },
+ { 0, 0 },
+ };
+ int i;
+
+ for (i = 0; map[i].name; i++) {
+ if (wcscmp(map[i].name, name) == 0)
+ return map[i].ch;
+ }
+
+ return L'!'; /* code meaning not found */
+}
+
+static val make_expr(parser_t *parser, val sym, val rest, val lineno)
+{
+ val expr = cons(sym, rest);
+ val ret = cons(expr_s, cons(expand(expr, nil), nil));
+
+ if (rest) {
+ rlc(expr, rest);
+ rlc(ret, rest);
+ } else {
+ rl(expr, lineno);
+ rl(ret, lineno);
+ }
+
+ return ret;
+}
+
+static val check_parse_time_action(val spec_rev)
+{
+ val line = first(spec_rev);
+
+ if (consp(line)) {
+ val elem = first(line);
+ if (consp(elem)) {
+ val sym = car(elem);
+ if (sym == include_s) {
+ return nappend2(nreverse(include(line)), rest(spec_rev));
+ }
+ if (sym == in_package_s) {
+ eval_intrinsic(elem, nil, nil);
+ return nil;
+ }
+ }
+ }
+ return spec_rev;
+}
+
+static val uref_helper(parser_t *parser, val expr)
+{
+ if (consp(expr) && car(expr) == qref_s) {
+ return rplaca(expr, uref_s);
+ } else {
+ return rl(rlc(list(uref_s, expr, nao), expr), num(parser->lineno));
+ }
+}
+
+static val uoref_helper(parser_t *parser, val expr)
+{
+ val uref = uref_helper(parser, expr);
+ rplacd(uref, cons(t, cdr(uref)));
+ return uref;
+}
+
+static val qref_helper(parser_t *parser, val lexpr, val rexpr)
+{
+ uses_or2;
+
+ if (consp(rexpr) && car(rexpr) == qref_s) {
+ rplacd(rexpr, rlc(cons(lexpr, cdr(rexpr)), lexpr));
+ return rl(rexpr, num(parser->lineno));
+ } else {
+ return rl(rlc(list(qref_s, lexpr, rexpr, nao),
+ or2(lexpr, rexpr)),
+ num(parser->lineno));
+ }
+}
+
+static val fname_helper(parser_t *parser, val name)
+{
+ if (!name) {
+ return nil;
+ } else if (!bindable(name)) {
+ yyerrorf(parser->scanner, lit("#T: ~s isn't a function name"),
+ name, nao);
+ } else if (!memq(name, tree_fun_whitelist)) {
+ yyerrorf(parser->scanner, lit("#T: ~s not in *tree-fun-whitelist*"),
+ name, nao);
+ } else {
+ val fbinding = lookup_fun(nil, name);
+ if (fbinding)
+ return cdr(fbinding);
+ yyerrorf(parser->scanner, lit("#T: function named ~s doesn't exist"),
+ name, nao);
+ }
+
+ return nil;
+}
+
+static val output_helper(parser_t *parser, val sym, val exprs, val clauses)
+{
+ cons_bind (dest, rest, exprs);
+
+ val dest_ex = expand_form_ver(dest, 166);
+ val args = if3(dest_ex == dest, exprs, cons(dest_ex, rest));
+ val args_kw = keywordp(car(args));
+ val alist = improper_plist_to_alist(if3(args_kw, args, cdr(args)),
+ v_output_keys);
+
+ if (!args_kw && sym == push_s)
+ {
+ yyerrorf(parser->scanner, lit("~s: doesn't support destination argument"),
+ sym, nao);
+ }
+
+
+ while (alist) {
+ val key = car(pop(&alist));
+
+ if (key == filter_k)
+ continue;
+
+ if (sym != push_s) {
+ if (key == nothrow_k || key == append_k ||
+ key == named_k || key == continue_k ||
+ key == finish_k || key == into_k)
+ {
+ continue;
+ }
+ }
+
+ yyerrorf(parser->scanner, lit("~s: unsupported keyword ~s"),
+ sym, key, nao);
+ }
+
+ if (sym != push_s) {
+ val into_var = second(memql(into_k, args));
+ val named_var = second(memql(named_k, args));
+ match_reg_var(into_var);
+ match_reg_var(named_var);
+ }
+
+ return list(sym, clauses, args, nao);
+}
+
+#ifndef YYEOF
+#define YYEOF 0
+#endif
+
+void yybadtoken(parser_t *parser, int tok, val context)
+{
+ val problem = nil;
+ scanner_t *scnr = parser->scanner;
+
+ switch (tok) {
+ case ERRTOK:
+ return;
+ case SPACE: problem = lit("space"); break;
+ case TEXT: problem = lit("text"); break;
+ case SYMTOK: problem = lit("symbol-token"); break;
+ case METANUM: problem = lit("metanum"); break;
+ case ALL: problem = lit("\"all\""); break;
+ case SOME: problem = lit("\"some\""); break;
+ case NONE: problem = lit("\"none\""); break;
+ case MAYBE: problem = lit("\"maybe\""); break;
+ case CASES: problem = lit("\"cases\""); break;
+ case BLOCK: problem = lit("\"block\""); break;
+ case CHOOSE: problem = lit("\"choose\""); break;
+ case GATHER: problem = lit("\"gather\""); break;
+ case AND: problem = lit("\"and\""); break;
+ case OR: problem = lit("\"or\""); break;
+ case END: problem = lit("\"end\""); break;
+ case COLLECT: problem = lit("\"collect\""); break;
+ case UNTIL: problem = lit("\"until\""); break;
+ case COLL: problem = lit("\"coll\""); break;
+ case OUTPUT: problem = lit("\"output\""); break;
+ case REPEAT: problem = lit("\"repeat\""); break;
+ case REP: problem = lit("\"rep\""); break;
+ case SINGLE: problem = lit("\"single\""); break;
+ case FIRST: problem = lit("\"first\""); break;
+ case LAST: problem = lit("\"last\""); break;
+ case EMPTY: problem = lit("\"empty\""); break;
+ case MOD: problem = lit("\"mod\""); break;
+ case MODLAST: problem = lit("\"modlast\""); break;
+ case DEFINE: problem = lit("\"define\""); break;
+ case TRY: problem = lit("\"try\""); break;
+ case CATCH: problem = lit("\"catch\""); break;
+ case FINALLY: problem = lit("\"finally\""); break;
+ case IF: problem = lit("\"if\""); break;
+ case ELIF: problem = lit("\"elif\""); break;
+ case ELSE: problem = lit("\"else\""); break;
+ case NUMBER: problem = lit("number"); break;
+ case JSKW: problem = lit("JSON keyword"); break;
+ case REGCHAR: problem = lit("regular expression character"); break;
+ case REGTOKEN: problem = lit("regular expression token"); break;
+ case LITCHAR: problem = lit("string literal character"); break;
+ case SPLICE: problem = lit("*"); break;
+ case JSPLICE: problem = lit("~*"); break;
+ case CONSDOT:
+ case LAMBDOT: problem = lit("consing dot"); break;
+ case DOTDOT: problem = lit(".."); break;
+ case OLD_DOTDOT: problem = lit(".."); break;
+ case UREFDOT: problem = lit("referencing dot"); break;
+ case OREFDOT:
+ case UOREFDOT: problem = lit("referencing .?"); break;
+ case HASH_BACKSLASH: problem = lit("#\\"); break;
+ case HASH_SLASH: problem = lit("#/"); break;
+ case HASH_H: problem = lit("#H"); break;
+ case HASH_S: problem = lit("#S"); break;
+ case HASH_R: problem = lit("#R"); break;
+ case HASH_N: problem = lit("#N"); break;
+ case HASH_T: problem = lit("#T"); break;
+ case HASH_J: problem = lit("#J"); break;
+ case HASH_SEMI: problem = lit("#;"); break;
+ case HASH_N_EQUALS: problem = lit("#<n>="); break;
+ case HASH_N_HASH: problem = lit("#<n>#"); break;
+ case HASH_B_QUOTE: problem = lit("#b'"); break;
+ case WORDS: problem = lit("#\""); break;
+ case WSPLICE: problem = lit("#*\""); break;
+ case QWORDS: problem = lit("#`"); break;
+ case QWSPLICE: problem = lit("#*`"); break;
+ case OLD_AT: problem = lit("@"); break;
+ }
+
+ if (problem != 0)
+ if (context)
+ yyerrorf(scnr, lit("misplaced ~a in ~a"), problem, context, nao);
+ else
+ yyerrorf(scnr, lit("unexpected ~a"), problem, nao);
+ else
+ if (context) /* Byacc sets yychar to 0 */
+ if (tok == YYEOF || tok == YYEMPTY)
+ yyerrorf(scnr, lit("unterminated ~a"), context, nao);
+ else if (tok == '\n')
+ yyerrorf(scnr, lit("newline in ~a"), context, nao);
+ else
+ yyerrorf(scnr, lit("misplaced character ~a in ~a"), chr(tok), context, nao);
+ else
+ if (tok == YYEOF)
+ yyerrorf(scnr, lit("unexpected end of input"), nao);
+ else if (tok == YYEMPTY)
+ return;
+ else
+ yyerrorf(scnr, lit("unexpected character ~a"), chr(tok), nao);
+}
+
+int parse_once(val self, val stream, val name)
+{
+ int res = 0;
+#if CONFIG_DEBUG_SUPPORT
+ unsigned dbg_state = debug_clear(opt_dbg_expansion ? 0 : DBG_ENABLE);
+#endif
+ val parser_obj = ensure_parser(stream, name);
+ parser_t *parser = parser_get_impl(self, parser_obj);
+ parser->rec_source_loc = 1;
+
+ uw_catch_begin(cons(error_s, nil), esym, eobj);
+
+
+ res = yyparse(parser->scanner, parser);
+
+ parser_resolve_circ(parser);
+
+ uw_catch(esym, eobj) {
+ yyerrorf(parser->scanner, lit("error exception during parse"), nao);
+ uw_throw(esym, eobj);
+ }
+
+ uw_unwind {
+#if CONFIG_DEBUG_SUPPORT
+ debug_set(dbg_state);
+#endif
+ }
+
+ uw_catch_end;
+
+ return res;
+}
+
+int parse(parser_t *parser, val name, enum prime_parser prim)
+{
+ int res = 0;
+ cnum start_line = parser->lineno;
+
+ parser->errors = 0;
+ parser->eof = 0;
+ parser->ignore = 0;
+ parser->prepared_msg = nil;
+ parser->circ_ref_hash = nil;
+ parser->circ_count = 0;
+ parser->syntax_tree = nil;
+ parser->quasi_level = 0;
+
+ prime_parser(parser, name, prim);
+
+ uw_catch_begin(cons(error_s, nil), esym, eobj);
+
+ res = yyparse(parser->scanner, parser);
+
+ prime_parser_post(parser, prim);
+
+ parser_resolve_circ(parser);
+
+ uw_catch(esym, eobj) {
+ yyerrorf(parser->scanner, lit("error exception during parse"), nao);
+ uw_throw(esym, eobj);
+ }
+
+ uw_unwind;
+
+ uw_catch_end;
+
+ if (parser->errors && parser->syntax_tree == nil &&
+ parser->lineno != start_line)
+ {
+ cnum curline = parser->lineno;
+ parser->lineno = start_line;
+ yyerrorf(parser->scanner,
+ lit("while parsing expression starting on this line"), nao);
+ parser->lineno = curline;
+ }
+
+ return res;
+}
+
diff --git a/y.tab.h.shipped b/y.tab.h.shipped
new file mode 100644
index 00000000..fdf1b170
--- /dev/null
+++ b/y.tab.h.shipped
@@ -0,0 +1,186 @@
+/* A Bison parser, made by GNU Bison 2.5. */
+
+
+
+/* Tokens. */
+#ifndef YYTOKENTYPE
+# define YYTOKENTYPE
+ /* Put the tokens into the symbol table, so that GDB and other debuggers
+ know about them. */
+ enum yytokentype {
+ SPACE = 258,
+ TEXT = 259,
+ SYMTOK = 260,
+ ALL = 261,
+ SOME = 262,
+ NONE = 263,
+ MAYBE = 264,
+ CASES = 265,
+ BLOCK = 266,
+ CHOOSE = 267,
+ GATHER = 268,
+ AND = 269,
+ OR = 270,
+ END = 271,
+ COLLECT = 272,
+ UNTIL = 273,
+ COLL = 274,
+ OUTPUT = 275,
+ REPEAT = 276,
+ PUSH = 277,
+ REP = 278,
+ SINGLE = 279,
+ FIRST = 280,
+ LAST = 281,
+ EMPTY = 282,
+ MOD = 283,
+ MODLAST = 284,
+ DEFINE = 285,
+ TRY = 286,
+ CATCH = 287,
+ FINALLY = 288,
+ IF = 289,
+ ERRTOK = 290,
+ HASH_BACKSLASH = 291,
+ HASH_SLASH = 292,
+ DOTDOT = 293,
+ HASH_H = 294,
+ HASH_S = 295,
+ HASH_R = 296,
+ HASH_J = 297,
+ HASH_SEMI = 298,
+ HASH_B_QUOTE = 299,
+ HASH_N = 300,
+ HASH_T = 301,
+ WORDS = 302,
+ WSPLICE = 303,
+ QWORDS = 304,
+ QWSPLICE = 305,
+ SECRET_ESCAPE_R = 306,
+ SECRET_ESCAPE_E = 307,
+ SECRET_ESCAPE_I = 308,
+ SECRET_ESCAPE_J = 309,
+ OLD_DOTDOT = 310,
+ NUMBER = 311,
+ METANUM = 312,
+ JSKW = 313,
+ HASH_N_EQUALS = 314,
+ HASH_N_HASH = 315,
+ REGCHAR = 316,
+ REGTOKEN = 317,
+ LITCHAR = 318,
+ SPLICE = 319,
+ JSPLICE = 320,
+ OLD_AT = 321,
+ CONSDOT = 322,
+ LAMBDOT = 323,
+ UREFDOT = 324,
+ OREFDOT = 325,
+ UOREFDOT = 326,
+ LOW = 327,
+ ELSE = 328,
+ ELIF = 329
+ };
+#endif
+/* Tokens. */
+#define SPACE 258
+#define TEXT 259
+#define SYMTOK 260
+#define ALL 261
+#define SOME 262
+#define NONE 263
+#define MAYBE 264
+#define CASES 265
+#define BLOCK 266
+#define CHOOSE 267
+#define GATHER 268
+#define AND 269
+#define OR 270
+#define END 271
+#define COLLECT 272
+#define UNTIL 273
+#define COLL 274
+#define OUTPUT 275
+#define REPEAT 276
+#define PUSH 277
+#define REP 278
+#define SINGLE 279
+#define FIRST 280
+#define LAST 281
+#define EMPTY 282
+#define MOD 283
+#define MODLAST 284
+#define DEFINE 285
+#define TRY 286
+#define CATCH 287
+#define FINALLY 288
+#define IF 289
+#define ERRTOK 290
+#define HASH_BACKSLASH 291
+#define HASH_SLASH 292
+#define DOTDOT 293
+#define HASH_H 294
+#define HASH_S 295
+#define HASH_R 296
+#define HASH_J 297
+#define HASH_SEMI 298
+#define HASH_B_QUOTE 299
+#define HASH_N 300
+#define HASH_T 301
+#define WORDS 302
+#define WSPLICE 303
+#define QWORDS 304
+#define QWSPLICE 305
+#define SECRET_ESCAPE_R 306
+#define SECRET_ESCAPE_E 307
+#define SECRET_ESCAPE_I 308
+#define SECRET_ESCAPE_J 309
+#define OLD_DOTDOT 310
+#define NUMBER 311
+#define METANUM 312
+#define JSKW 313
+#define HASH_N_EQUALS 314
+#define HASH_N_HASH 315
+#define REGCHAR 316
+#define REGTOKEN 317
+#define LITCHAR 318
+#define SPLICE 319
+#define JSPLICE 320
+#define OLD_AT 321
+#define CONSDOT 322
+#define LAMBDOT 323
+#define UREFDOT 324
+#define OREFDOT 325
+#define UOREFDOT 326
+#define LOW 327
+#define ELSE 328
+#define ELIF 329
+
+
+
+
+#if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED
+typedef union YYSTYPE
+{
+
+/* Line 2068 of yacc.c */
+#line 109 "parser.y"
+
+ wchar_t *lexeme;
+ union obj *val;
+ wchar_t chr;
+ cnum lineno;
+
+
+
+/* Line 2068 of yacc.c */
+#line 207 "y.tab.h"
+} YYSTYPE;
+# define YYSTYPE_IS_TRIVIAL 1
+# define yystype YYSTYPE /* obsolescent; will be withdrawn */
+# define YYSTYPE_IS_DECLARED 1
+#endif
+
+
+
+