├── ChangeLog ├── LICENSE.BSD ├── LICENSE.LGPL ├── Makefile.in ├── README ├── TODO ├── boot └── empty.hoglisp ├── configure ├── def2doc.c ├── docbook2xhtml.xsl ├── docbook2xhtml2ps.xsl ├── hh.docbook ├── hh.html2psrc ├── hh_ast.c ├── hh_ast.h ├── hh_avl.c ├── hh_avl.h ├── hh_builtins.def ├── hh_codegen.c ├── hh_codegen.h ├── hh_common.h ├── hh_compiler.c ├── hh_crypto.c ├── hh_crypto.h ├── hh_data.c ├── hh_data.h ├── hh_error.c ├── hh_error.def ├── hh_error.h ├── hh_insn.def ├── hh_interp.c ├── hh_interp.h ├── hh_interp_unix.c ├── hh_lambda.c ├── hh_lambda.h ├── hh_lex.c ├── hh_lex.l ├── hh_macroexpand.c ├── hh_macroexpand.h ├── hh_opt.c ├── hh_opt.h ├── hh_output.c ├── hh_output.h ├── hh_peephole.c ├── hh_peephole.h ├── hh_printf.c ├── hh_printf.h ├── hh_seed.c ├── hh_uses.c ├── hh_uses.h ├── hh_version.awk ├── hhc.1 ├── hhdoc.py ├── hhi.1 ├── hhprof ├── linked-list.fig ├── oliodoc.css ├── prelude.d ├── 050-controls.hl ├── 100-builtins.hl ├── 200-unit-testing.hl ├── 400-avl.hl ├── 400-dict.hl ├── 400-getput.hl ├── 400-ip.hl ├── 400-list.hl ├── 400-math.hl ├── 400-misc.hl ├── 400-queue.hl ├── 400-string.hl ├── 500-state-machine.hl ├── interface-gen.c ├── interface-gen.pl └── interface-unix └── tests ├── apply.hl ├── atoi.hl ├── avl.hl ├── catch.hl ├── crypto.hl ├── fib.hl ├── fork.hl ├── gc-catch.hl ├── hello.hl ├── ifdef.hl ├── ip-srv-test.hl ├── lambda.hl ├── liw-test.hl ├── mount.hl ├── quote.hl ├── set.hl ├── sm.hl ├── snprint.hl ├── strings.hl ├── time.hl ├── tuple.hl └── varargs.hl /ChangeLog: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sbp/hedgehog/d3d34c093f4c3ddc68a8e3c45fbca472ef7f194b/ChangeLog -------------------------------------------------------------------------------- /LICENSE.BSD: -------------------------------------------------------------------------------- 1 | Copyright (c) 2002-2004, Oliotalo Ltd. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | * Redistributions in binary form must reproduce the above 11 | copyright notice, this list of conditions and the following 12 | disclaimer in the documentation and/or other materials provided 13 | with the distribution. 14 | * Neither the name of Oliotalo Ltd. nor the names of its 15 | contributors may be used to endorse or promote products derived 16 | from this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /Makefile.in: -------------------------------------------------------------------------------- 1 | # This file is part of Hedgehog LISP. 2 | # Copyright (C) 2003, 2004, 2005 Oliotalo Ltd. 3 | # See file LICENSE.LGPL for pertinent licensing conditions. 4 | # 5 | # Author: Kenneth Oksanen 6 | # Lars Wirzenius 7 | # 8 | 9 | srcdir = @srcdir@ 10 | VPATH = @vpath@ 11 | 12 | HHVER = $(shell awk -f $(srcdir)/hh_version.awk $(srcdir)/hh_common.h) 13 | 14 | CC = @CC@ 15 | CFLAGS = @CFLAGS@ @shared_secret@ -DHEDGEHOG_VERSION_STRING='"$(HHVER)"' \ 16 | -DDEFAULT_PRELUDE='"$(prefix)/lib/hh/prelude.d$(suffix)"' 17 | LIBS = @LIBS@ 18 | LD = @LD@ 19 | LFLAGS = @LFLAGS@ 20 | LD2 = @LD2@ 21 | AWK = @AWK@ 22 | 23 | XCC = @XCC@ 24 | XCFLAGS = @XCFLAGS@ -DHEDGEHOG_VERSION_STRING='"$(HHVER)"' 25 | XLIBS = @XLIBS@ 26 | XLD = @XLD@ 27 | XLFLAGS = @XLFLAGS@ 28 | XLD2 = @XLD2@ 29 | XEXEC = @XEXEC@ 30 | 31 | platform = @platform@ 32 | boot = @boot@ 33 | targets = @targets@ 34 | prefix = @prefix@ 35 | suffix = @suffix@ 36 | 37 | 38 | all: $(targets) prelude.d 39 | 40 | ver: 41 | echo $(HHVER) 42 | 43 | hhc$(suffix): hh_lex.o hh_ast.o hh_compiler.o hh_lambda.o hh_macroexpand.o \ 44 | hh_opt.o hh_uses.o hh_codegen.o hh_data_compiler.o hh_peephole.o \ 45 | hh_output.o 46 | $(LD) $(LFLAGS) @LDOUTPUT@ $^ $(LIBS) 47 | $(LD2) @L2FLAGS@ 48 | 49 | hhi$(suffix): hh_data.o hh_interp.o hh_error.o hh_avl.o hh_printf.o \ 50 | hh_crypto.o $(platform) $(boot) 51 | $(XLD) $(XLFLAGS) @XLDOUTPUT@ $^ $(XLIBS) 52 | $(XLD2) @XL2FLAGS@ 53 | 54 | hh_seed: hh_seed.o hh_crypto_host.o 55 | $(LD) $(LFLAGS) @LDOUTPUT@ $^ $(LIBS) 56 | $(LD2) @L2FLAGS@ 57 | 58 | hh_seed.h: hh_insn.def hh_seed 59 | rm -f hh_seed.h 60 | ./hh_seed < $(srcdir)/hh_insn.def > hh_seed.h 61 | 62 | hh_avl.o hh_interp.o hh_data.o hh_error.o hh_printf.o hh_crypto.o $(platform): 63 | $(XCC) $(XCFLAGS) -c $< 64 | 65 | hh_lex.c: hh_lex.l 66 | flex -t -Phh_ $(srcdir)/hh_lex.l > hh_lex.c 67 | 68 | hh_data_compiler.c: hh_data.c 69 | echo '#define HH_COMPILER 1' > hh_data_compiler.c 70 | cat $(srcdir)/hh_data.c >> hh_data_compiler.c 71 | 72 | hh_crypto_host.c: hh_crypto.c 73 | cp $(srcdir)/hh_crypto.c hh_crypto_host.c 74 | 75 | hh_boot.h: hh_boot.hl hhc hh_seed.h 76 | ./hhc -X -o hh_boot.h -p $(srcdir)/prelude.d $(srcdir)/hh_boot.hl 77 | 78 | prelude.d: 300-unix.hl dummy 79 | if [ ! -d prelude.d ]; \ 80 | then \ 81 | mkdir prelude.d; \ 82 | fi; \ 83 | cp -p $(srcdir)/prelude.d/* 300-unix.hl prelude.d 84 | dummy: 85 | 86 | 300-unix: 300-unix.o 87 | $(XLD) $(XLFLAGS) @XLDOUTPUT@ $^ $(XLIBS) 88 | $(XLD2) @XL2FLAGS@ 89 | 90 | 300-unix.o: 300-unix.c 91 | $(XCC) $(XCFLAGS) -I$(srcdir)/prelude.d -c $< 92 | 93 | 300-unix.c: prelude.d/interface-gen.pl prelude.d/interface-gen.c \ 94 | prelude.d/interface-unix 95 | rm -f 300-unix.c 96 | perl $(srcdir)/prelude.d/interface-gen.pl unix- \ 97 | < $(srcdir)/prelude.d/interface-unix > 300-unix.c 98 | 99 | 300-unix.hl: 300-unix 100 | rm -f 300-unix.hl 101 | $(XEXEC)300-unix > 300-unix.hl 102 | 103 | def2doc$(suffix): def2doc.o 104 | $(LD) $(LFLAGS) @LDOUTPUT@ $^ $(LIBS) 105 | $(LD2) @L2FLAGS@ 106 | 107 | hh_builtins.incl: def2doc hh_builtins.def 108 | ./def2doc > hh_builtins.incl 109 | 110 | prelude.incl: prelude.d dummy 111 | env LC_COLLATE=C sh -c 'cat prelude.d/*.hl' > prelude.hl 112 | python $(srcdir)/hhdoc.py prelude.hl > prelude.incl 113 | 114 | doc: linked-list.png hh.html hh.ps hh.pdf 115 | 116 | linked-list.png: linked-list.fig 117 | fig2dev -L png $(srcdir)/linked-list.fig linked-list.png 118 | 119 | hh.html: hh.docbook hh_builtins.incl prelude.incl docbook2xhtml.xsl hh_common.h 120 | cp $(srcdir)/hh.docbook $(srcdir)/oliodoc.css . 121 | xsltproc --stringparam version \ 122 | `awk -f $(srcdir)/hh_version.awk $(srcdir)/hh_common.h` \ 123 | --novalid -o hh.html $(srcdir)/docbook2xhtml.xsl \ 124 | hh.docbook 125 | rm -f hh.docbook 126 | 127 | hh.ps: $(srcdir)/hh.html2psrc hh.docbook hh_builtins.incl prelude.incl \ 128 | docbook2xhtml.xsl hh_common.h 129 | cp $(srcdir)/hh.docbook . 130 | xsltproc --stringparam version \ 131 | `awk -f $(srcdir)/hh_version.awk $(srcdir)/hh_common.h` \ 132 | --novalid -o hh.temp $(srcdir)/docbook2xhtml2ps.xsl \ 133 | hh.docbook 134 | rm -f hh.docbook 135 | html2ps -o hh.ps -D -C bh -n -t -x 1 -f $(srcdir)/hh.html2psrc hh.temp 136 | rm -f hh.temp 137 | 138 | hh.pdf: hh.ps 139 | ps2pdf hh.ps 140 | 141 | TAGS: $(OBJS) 142 | etags *.h *.c 143 | 144 | install: 145 | install -d $(prefix)/bin $(prefix)/lib/hh/prelude.d$(suffix) 146 | install hhc$(suffix) hhi$(suffix) $(prefix)/bin 147 | install prelude.d/*.hl $(prefix)/lib/hh/prelude.d$(suffix) 148 | 149 | clean: 150 | rm -f core *~ *.o *.a \#* hh_lex.c *.axf *.incl def2doc 151 | rm -f def2doc hhc hhi hh_seed builtins.incl linked-list.png hh_seed.h 152 | rm -f hhi.bin *.exe hh_boot.cod hh_boot.asm hh_boot.h 153 | rm -f hh_data_compiler.c hh_crypto_host.c 154 | rm -f hh.html hh.ps hh.pdf oliodoc.css prelude.hl 155 | rm -f 300-* 156 | rm -rf prelude.d 157 | 158 | 159 | # The dependencies below this line have been generated with `gcc *.c -MM'. 160 | # And then duplicate the dependencies of `hh_data.o' for `hh_data_compiler.o'. 161 | def2doc.o: def2doc.c hh_common.h hh_builtins.def 162 | hh_ast.o: hh_ast.c hh_common.h hh_ast.h hh_builtins.def hh_data.h \ 163 | hh_interp.h hh_error.h hh_error.def hh_insn.def 164 | hh_avl.o: hh_avl.c hh_common.h hh_error.h hh_error.def hh_avl.h hh_data.h \ 165 | hh_interp.h hh_insn.def hh_printf.h 166 | hh_codegen.o: hh_codegen.c hh_common.h hh_ast.h hh_builtins.def hh_data.h \ 167 | hh_interp.h hh_error.h hh_error.def hh_insn.def hh_codegen.h \ 168 | hh_lambda.h 169 | hh_compiler.o: hh_compiler.c hh_common.h hh_ast.h hh_builtins.def \ 170 | hh_macroexpand.h hh_opt.h hh_lambda.h hh_uses.h hh_codegen.h \ 171 | hh_interp.h hh_error.h hh_error.def hh_insn.def hh_peephole.h \ 172 | hh_output.h 173 | hh_crypto.o: hh_crypto.c hh_common.h hh_interp.h hh_error.h hh_error.def \ 174 | hh_insn.def 175 | hh_data.o: hh_data.c hh_common.h hh_error.h hh_error.def hh_interp.h \ 176 | hh_insn.def hh_data.h hh_printf.h hh_avl.h 177 | hh_data_compiler.o: hh_data.c hh_common.h hh_error.h hh_error.def hh_interp.h \ 178 | hh_insn.def hh_data.h hh_printf.h hh_avl.h 179 | hh_error.o: hh_error.c hh_common.h hh_error.h hh_error.def hh_interp.h \ 180 | hh_insn.def hh_data.h hh_printf.h 181 | hh_interp.o: hh_interp.c hh_common.h hh_interp.h hh_error.h hh_error.def \ 182 | hh_insn.def hh_data.h hh_printf.h hh_avl.h hh_crypto.h hh_seed.h 183 | hh_interp_unix.o: hh_interp_unix.c hh_common.h hh_interp.h hh_error.h \ 184 | hh_error.def hh_insn.def hh_data.h hh_printf.h 185 | hh_lambda.o: hh_lambda.c hh_common.h hh_ast.h hh_builtins.def 186 | hh_lex.o: hh_lex.c hh_common.h hh_ast.h hh_builtins.def 187 | hh_macroexpand.o: hh_macroexpand.c hh_common.h hh_ast.h hh_builtins.def \ 188 | hh_macroexpand.h 189 | hh_opt.o: hh_opt.c hh_common.h hh_ast.h hh_builtins.def 190 | hh_output.o: hh_output.c hh_common.h hh_codegen.h hh_ast.h \ 191 | hh_builtins.def hh_interp.h hh_error.h hh_error.def hh_insn.def \ 192 | hh_output.h hh_data.h hh_seed.h 193 | hh_peephole.o: hh_peephole.c hh_common.h hh_data.h hh_interp.h hh_error.h \ 194 | hh_error.def hh_insn.def hh_codegen.h hh_ast.h hh_builtins.def 195 | hh_printf.o: hh_printf.c hh_printf.h 196 | hh_seed.o: hh_seed.c hh_crypto.h hh_common.h 197 | hh_uses.o: hh_uses.c hh_common.h hh_ast.h hh_builtins.def 198 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | # This file is part of Hedgehog 2 | # 3 | # Author: Kenneth Oksanen 4 | # 5 | 6 | We have ported Hedgehog to Solaris (SunOS) and FreeBSD in the sense 7 | that they compile and we have ran some rudimentary tests on them. 8 | However, we have not ran any deeper tests, such as actually checking 9 | that various system-dependent builtins work. User contributions and 10 | bug/success reports are welcome. 11 | 12 | Improve documentation. 13 | 14 | A web server demo. 15 | 16 | A monitor state machine. It is distinct from normal user-level state 17 | machines in the sense that 18 | 19 | More system calls: 20 | stat? 21 | pipe? 22 | (Note that the intention of Hedgehog is /NOT/ to support all possible 23 | and impossible system calls - we're primarily interested in small M2M 24 | boxes where, for example, root is the only user and chown is therefore 25 | pretty useless... But if someone really starts to use Hedgehog in 26 | other apps as well, then we'll listen and hopefully include their 27 | contribs. If the number of system calls and subsequently the system 28 | requirements become painfully large, group then under suitable 29 | #ifdefs.) 30 | 31 | Allocate the memory needed by unix-exec from the semispace. 32 | Or use the old semispace (nah, bad idea, because we may wish to change 33 | to a singlespace collector some day). 34 | 35 | Signed/unsigned in interface-gen.pl. Causes problems in 36 | (def-syntax unix-CRTSCTS -2147483648) 37 | 38 | Replace requirement for perl (in prelude.d/interface-gen.pl) and gawk 39 | (in hh_version.awk) with python, which is already used 40 | in generating the document. 41 | 42 | Add more constant folding rules to hh_opt.c 43 | 44 | Add a small, concise compression/decompression algorithm. It should 45 | be usable both from byte code instructions to compress/decompress 46 | strings, and from the main program to decompress byte code files. 47 | Probably the best solution is something based on the Burrows-Wheeler 48 | transform. 49 | 50 | Instead of having each instruction check its arguments, perhaps we 51 | should go towards a design where a special typecheck instruction 52 | checks the type of the one argument in accu. The drawback is that 53 | typechecking becomes much more costly in terms of CPU (the number of 54 | dispatched instructions almost doubles), but the benefit is that the 55 | size of the typechecking byte code interpreter would decrease 56 | significantly. It is possible that compiler optimizations (partial 57 | type inference) and perhaps statically type checked annotations will 58 | reduce the performance overhead. 59 | 60 | /Cheap/ live-precise gc. 61 | 62 | Singlespace unidirectional collector. 63 | 64 | Spend a good while improving the language: 65 | - syntax: pattern matching etc. 66 | - typing: have optional static typing, classes. 67 | -------------------------------------------------------------------------------- /boot/empty.hoglisp: -------------------------------------------------------------------------------- 1 | (panic "Empty bootstrap!") 2 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | # This file has NOT been created by autoconf. Please DO modify it! ;-) 2 | # 3 | # This file is part of Hedgehog LISP. 4 | # Copyright (C) 2003, 2004, 2005 Oliotalo Ltd. 5 | # See file LICENSE.LGPL for pertinent licensing conditions. 6 | # 7 | # Authors: Lars Wirzenius 8 | # Kenneth Oksanen 9 | # 10 | 11 | if [ $# -eq 3 ] 12 | then 13 | shared_secret=-DHH_SHARED_SECRET=\\\\\"$3\\\\\" 14 | else 15 | if [ $# -ne 2 ] 16 | then 17 | echo "Usage: $0 target-type prefix [shared-secret]" 18 | exit 1 19 | fi 20 | shared_secret=-DHH_SHARED_SECRET=\\\\\"\\\\\" 21 | fi 22 | 23 | prefix=$2 24 | 25 | srcdir=`dirname $0` 26 | if [ "$srcdir" = "." ] 27 | then 28 | echo "$0: Don't run configure in the source directory." 1>&2 29 | exit 1 30 | fi 31 | if [ ! -f "$srcdir/hh_interp.c" ] 32 | then 33 | echo "$0: $srcdir/Makefile.in does not exist." 1>&2 34 | exit 1 35 | fi 36 | 37 | vpath="$srcdir" 38 | case "$srcdir" in 39 | /*) ;; 40 | *) srcdir="`pwd`/$srcdir" ;; 41 | esac 42 | 43 | case "`uname -s`" in 44 | Linux) 45 | hosttype=linux 46 | ;; 47 | 48 | CYGWIN*) 49 | hosttype=cygwin 50 | ;; 51 | 52 | FreeBSD|OpenBSD|Darwin) 53 | hosttype=BSD 54 | ;; 55 | 56 | SunOS) 57 | hosttype=SunOS 58 | ;; 59 | esac 60 | 61 | 62 | case "$hosttype,$1" in 63 | 64 | linux,linux) 65 | CC=gcc 66 | CFLAGS='-Wall -O -g -I. -I$(srcdir) -DHH_LINUX' 67 | LD='$(CC)' 68 | LDOUTPUT='-o $@' 69 | LFLAGS='' 70 | LIBS='' 71 | LD2=: 72 | L2FLAGS='' 73 | 74 | XCC='$(CC)' 75 | XCFLAGS='-Wall -O -g -I. -I$(srcdir) -DHH_LINUX -DHH_TESTING' 76 | XLD='$(CC)' 77 | XLDOUTPUT='-o $@' 78 | XLFLAGS='' 79 | XLIBS='' 80 | XLD2=: 81 | XL2FLAGS='' 82 | XEXEC='./' 83 | 84 | AWK=gawk 85 | platform="hh_interp_unix.o" 86 | boot="" 87 | targets="hh_seed.h hhc hhi 300-unix.hl" 88 | suffix='' 89 | ;; 90 | 91 | linux,small-linux) 92 | CC=gcc 93 | CFLAGS='-Wall -O -g -I. -I$(srcdir) -DHH_LINUX' 94 | LD='$(CC)' 95 | LDOUTPUT='-o $@' 96 | LFLAGS='' 97 | LIBS='' 98 | LD2=: 99 | L2FLAGS='' 100 | 101 | XCC='$(CC)' 102 | XCFLAGS='-Wall -Os -I. -I$(srcdir) -DHH_LINUX -DHH_SMALL' 103 | XLD='$(XCC)' 104 | XLDOUTPUT='-o $@' 105 | XLFLAGS='' 106 | XLIBS='' 107 | XLD2=: 108 | XL2FLAGS='' 109 | XEXEC='./' 110 | 111 | AWK=gawk 112 | platform="hh_interp_unix.o" 113 | boot="" 114 | targets="hh_seed.h hhc hhi 300-unix.hl" 115 | suffix='' 116 | ;; 117 | 118 | linux,small-nosys) 119 | CC=gcc 120 | CFLAGS='-Wall -O -g -I. -I$(srcdir)' 121 | LD='$(CC)' 122 | LDOUTPUT='-o $@' 123 | LFLAGS='' 124 | LIBS='' 125 | LD2=: 126 | L2FLAGS='' 127 | 128 | XCC='$(CC)' 129 | XCFLAGS='-Wall -Os -I. -I$(srcdir) -DHH_SMALL' 130 | XLD='$(XCC)' 131 | XLDOUTPUT='-o $@' 132 | XLFLAGS='' 133 | XLIBS='' 134 | XLD2=: 135 | XL2FLAGS='' 136 | XEXEC='./' 137 | 138 | AWK=gawk 139 | platform="hh_interp_unix.o" 140 | boot="" 141 | targets="hh_seed.h hhc hhi" 142 | suffix='' 143 | ;; 144 | 145 | linux,arm-linux) 146 | CC=gcc 147 | CFLAGS='-Wall -O -g -I. -I$(srcdir) -DHH_LINUX' 148 | LD='$(CC)' 149 | LDOUTPUT='-o $@' 150 | LFLAGS='' 151 | LIBS='' 152 | LD2=: 153 | L2FLAGS='' 154 | 155 | XCC=/usr/local/arm/bin/arm-linux-gcc 156 | XCFLAGS='-Wall -Os -I. -I$(srcdir) -DHH_LINUX -DHH_SMALL' 157 | XLD='$(XCC)' 158 | XLDOUTPUT='-o $@' 159 | XLFLAGS='-static -s -L/usr/local/arm/lib' 160 | XLIBS='' 161 | XLD2=: 162 | XL2FLAGS='' 163 | XEXEC='qemu-arm ' 164 | 165 | platform="hh_interp_unix.o" 166 | boot="" 167 | targets="hh_seed.h hhc hhi 300-unix.hl" 168 | suffix='' 169 | ;; 170 | 171 | linux,arm-nosys) 172 | CC=gcc 173 | CFLAGS='-Wall -O -g -I. -I$(srcdir) -DHH_LINUX' 174 | LD='$(CC)' 175 | LDOUTPUT='-o $@' 176 | LFLAGS='' 177 | LIBS='' 178 | LD2=: 179 | L2FLAGS='' 180 | 181 | XCC=/usr/local/arm/2.95.3/bin/arm-linux-gcc 182 | XCFLAGS='-Wall -Os -I. -I$(srcdir) -DHH_SMALL' 183 | XLD='$(XCC)' 184 | XLDOUTPUT='-o $@' 185 | XLFLAGS='-static -s -L/usr/local/arm/2.95.3/lib' 186 | XLIBS='' 187 | XLD2=: 188 | XL2FLAGS='' 189 | XEXEC='qemu-arm ' 190 | 191 | platform="hh_interp_unix.o" 192 | boot="" 193 | targets="hh_seed.h hhc hhi" 194 | suffix='' 195 | ;; 196 | 197 | SunOS,SunOS) 198 | CC=gcc 199 | CFLAGS='-O -g -I. -I$(srcdir) -DHH_SUNOS' 200 | LD='$(CC)' 201 | LDOUTPUT='-o $@' 202 | LFLAGS='' 203 | LIBS='' 204 | LD2=: 205 | L2FLAGS='' 206 | 207 | XCC='$(CC)' 208 | XCFLAGS='-O -g -I. -I$(srcdir) -DHH_SUNOS -DHH_TESTING' 209 | XLD='$(CC)' 210 | XLDOUTPUT='-o $@' 211 | XLFLAGS='' 212 | XLIBS='-lsocket -lnsl' 213 | XLD2=: 214 | XL2FLAGS='' 215 | XEXEC='./' 216 | 217 | AWK=gawk 218 | platform="hh_interp_unix.o" 219 | boot="" 220 | targets="hh_seed.h hhc hhi 300-unix.hl" 221 | suffix='' 222 | ;; 223 | 224 | BSD,BSD) 225 | CC=gcc 226 | CFLAGS='-O -g -I. -I$(srcdir) -DHH_BSD' 227 | LD='$(CC)' 228 | LDOUTPUT='-o $@' 229 | LFLAGS='' 230 | LIBS='' 231 | LD2=: 232 | L2FLAGS='' 233 | 234 | XCC='$(CC)' 235 | XCFLAGS='-O -g -I. -I$(srcdir) -DHH_BSD -DHH_TESTING' 236 | XLD='$(CC)' 237 | XLDOUTPUT='-o $@' 238 | XLFLAGS='' 239 | XLIBS='' 240 | XLD2=: 241 | XL2FLAGS='' 242 | XEXEC='./' 243 | 244 | AWK=gawk 245 | platform="hh_interp_unix.o" 246 | boot="" 247 | targets="hh_seed.h hhc hhi 300-unix.hl" 248 | suffix='' 249 | ;; 250 | 251 | *) 252 | echo "$0: Unknown target '$1'" 1>&2 253 | exit 1 254 | esac 255 | 256 | 257 | sed "s#@srcdir@#$srcdir#g; 258 | s#@vpath@#$vpath#g; 259 | s#@CC@#$CC#g; 260 | s#@CFLAGS@#$CFLAGS#g; 261 | s#@LD@#$LD#g; 262 | s#@LDOUTPUT@#$LDOUTPUT#g; 263 | s#@LFLAGS@#$LFLAGS#g; 264 | s#@LIBS@#$LIBS#g; 265 | s#@LD2@#$LD2#g; 266 | s#@L2FLAGS@#$L2FLAGS#g; 267 | s#@AWK@#$AWK#g; 268 | s#@XCC@#$XCC#g; 269 | s#@XCFLAGS@#$XCFLAGS#g; 270 | s#@XLD@#$XLD#g; 271 | s#@XLDOUTPUT@#$XLDOUTPUT#g; 272 | s#@XLFLAGS@#$XLFLAGS#g; 273 | s#@XLIBS@#$XLIBS#g; 274 | s#@XLD2@#$XLD2#g; 275 | s#@XL2FLAGS@#$XL2FLAGS#g; 276 | s#@XEXEC@#$XEXEC#g; 277 | s#@platform@#$platform#g; 278 | s#@boot@#$boot#g; 279 | s#@targets@#$targets#g; 280 | s#@prefix@#$prefix#g; 281 | s#@shared_secret@#$shared_secret#g; 282 | s#@suffix@#$suffix#g; 283 | " $srcdir/Makefile.in > Makefile 284 | -------------------------------------------------------------------------------- /def2doc.c: -------------------------------------------------------------------------------- 1 | /* A byte code interpreter for Hedgehog LISP. 2 | * Copyright (C) 2003, 2004, 2005 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Authors: Lars Wirzenius 6 | * Kenneth Oksanen (minor tweaking) 7 | */ 8 | 9 | /* This file, to be executed on the host, takes the definitions and 10 | documentation of builtins in `hh_builtins.def' and produces an SGML 11 | document of them. */ 12 | 13 | #include "hh_common.h" 14 | #include 15 | #include 16 | #include 17 | 18 | #define EMPTY_CELL "any" 19 | #define STRING_CELL "string" 20 | #define INTEGER_CELL "integer" 21 | #define CONS_CELL "cons" 22 | #define CONS3_CELL "cons3" 23 | #define SYMBOL_CELL "symbol" 24 | #define AVL_CELL "AVL-tree node" 25 | 26 | #define MAX_ARGS 128 27 | #define MAX_FUNCS 128 28 | 29 | struct arg { 30 | int single; 31 | const char *name; 32 | const char *type; 33 | const char *doc; 34 | }; 35 | 36 | struct func { 37 | const char *name; 38 | const char *doc; 39 | struct arg args[MAX_ARGS + 1]; 40 | }; 41 | 42 | struct module { 43 | const char *doc; 44 | struct func funcs[MAX_FUNCS + 1]; 45 | }; 46 | 47 | 48 | struct module modules[] = { 49 | #define MODULE(doc) \ 50 | { \ 51 | doc, \ 52 | { 53 | 54 | #define MODULE_END \ 55 | } \ 56 | }, 57 | 58 | #define ARG(name, type, doc) \ 59 | { \ 60 | 1, \ 61 | #name, \ 62 | type, \ 63 | doc, \ 64 | }, 65 | 66 | #define REMAINING_ARGS(name, type, doc) \ 67 | { \ 68 | 0, \ 69 | #name, \ 70 | type, \ 71 | doc, \ 72 | }, 73 | 74 | #define BUILTIN(lisp_name, c_name, doc_string, args, code_gen) \ 75 | { \ 76 | lisp_name, \ 77 | doc_string, \ 78 | { { -1, "XXX" }, args }, \ 79 | }, 80 | 81 | #include "hh_builtins.def" 82 | 83 | }; 84 | 85 | const int num_modules = sizeof(modules) / sizeof(modules[0]); 86 | 87 | void safe(const char *tag, const char *value) 88 | { 89 | if (tag) 90 | printf("<%s>", tag); 91 | for (; *value != '\0'; ++value) { 92 | switch (*value) { 93 | case '<': printf("<"); break; 94 | case '>': printf(">"); break; 95 | case '&': printf("&"); break; 96 | default: printf("%c", *value); break; 97 | } 98 | } 99 | if (tag) 100 | printf("", tag); 101 | } 102 | 103 | void title2id(const char *title) 104 | { 105 | for (; *title != '\0'; ++title) { 106 | if (isalnum(*title)) 107 | printf("%c", tolower(*title)); 108 | } 109 | } 110 | 111 | int main(void) 112 | { 113 | int i; 114 | int j; 115 | int has_args; 116 | struct module *m; 117 | struct func *f; 118 | struct arg *a; 119 | 120 | for (i = 0; i < num_modules; ++i) { 121 | m = &modules[i]; 122 | if (m->doc == NULL) 123 | continue; 124 | if (strstr(m->doc, "Internal") != NULL) 125 | continue; 126 | 127 | printf("\n"); 130 | safe("title", m->doc); 131 | printf("\n"); 132 | 133 | for (j = 0; m->funcs[j].name != NULL; ++j) { 134 | f = &m->funcs[j]; 135 | 136 | printf("\n"); 137 | printf("("); 138 | safe("literal", f->name); 139 | has_args = 0; 140 | for (a = f->args; a->name != NULL; ++a) { 141 | if (a->single == -1) 142 | continue; 143 | printf(" "); 144 | safe("replaceable", a->name); 145 | has_args = 1; 146 | } 147 | printf(")\n"); 148 | 149 | printf("\n"); 150 | safe("para", f->doc); 151 | 152 | if (has_args) { 153 | printf("\n"); 154 | for (a = f->args; a->name != NULL; ++a) { 155 | if (a->single == -1) 156 | continue; 157 | printf(""); 158 | safe("replaceable", a->name); 159 | if (a->single) 160 | printf(" (%s): ", a->type); 161 | else 162 | printf(" (%s, optional): ", a->type); 163 | safe(NULL, a->doc); 164 | printf(""); 165 | } 166 | printf("\n"); 167 | } 168 | 169 | printf("\n"); 170 | printf("\n"); 171 | } 172 | 173 | printf("\n"); 174 | printf("\n"); 175 | } 176 | 177 | return 0; 178 | } 179 | -------------------------------------------------------------------------------- /docbook2xhtml.xsl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | <xsl:value-of select="bookinfo/title"/> 23 | <xsl:text> </xsl:text> 24 | <xsl:value-of select="$version"/> 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | <xsl:value-of select="artheader/title"/> 41 | <xsl:text> </xsl:text> 42 | <xsl:value-of select="$version"/> 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 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 |

Contents

83 |
    84 | 85 |
86 | 87 | 88 | 89 |
  • 90 | 91 | 92 | 93 | 94 |
      95 | 96 |
    97 |     98 |
    • 99 |     100 | 101 | 102 | 103 | 104 | 105 | 106 |

    107 | 108 | 109 | 110 | ( 111 | 112 | ) 113 |

    114 |     115 | 116 | 117 |

    118 | 119 | 120 | 121 |

    122 | 123 | 124 |     125 | 126 | 127 |

    128 | 129 | 130 | 131 |

    132 | 133 | 134 |     135 | 136 | 137 |

    138 |     139 | 140 | 141 | 142 | 143 | 144 | 146 | 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 |
    165 | 166 |
    167 |     168 | 169 | 170 |
    171 | 172 |

    173 | 174 | Example: 175 | 176 | 177 |

    178 |     179 | 180 |
    181 |     182 | 183 | 184 |
    185 |     186 | 187 | 188 |
    189 |     190 | 191 | 192 |
      193 | 194 |
    195 |     196 | 197 | 198 |
      199 | 200 |
    201 |     202 | 203 | 204 |
  • 205 | 206 |
    • 207 |     208 | 209 | 210 | 211 | 212 |
    213 |     214 | 215 | 216 | 217 | 218 | 219 | 220 | 221 | 222 | 223 | 224 | 225 | 226 | 227 | 228 |
    229 | 230 | 231 | 234 | 235 | 236 | 237 | 238 |
    232 | {title} 233 |
    Figure:
    239 |
    240 |     241 | 242 | 243 |
    244 |

    245 | Table: 246 | 247 |

    248 | 249 | 250 |
    251 |
    252 |     253 | 254 | 255 | 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 | XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 303 | 304 | 305 |     306 | -------------------------------------------------------------------------------- /docbook2xhtml2ps.xsl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | <xsl:value-of select="bookinfo/title"/> 21 | <xsl:text> </xsl:text> 22 | <xsl:value-of select="$version"/> 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | <xsl:value-of select="artheader/title"/> 39 | <xsl:text> </xsl:text> 40 | <xsl:value-of select="$version"/> 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 |

    Contents

    58 |
      59 | 60 |
    61 |     62 | 63 | 64 |
  • 65 | 66 | 67 | 68 | 69 |
      70 | 71 |
    72 |     73 |
    • 74 |     75 | 76 | 77 | 78 | 79 | 80 | 81 |

    82 | 83 | 84 | 85 | ( 86 | 87 | ) 88 |

    89 |     90 | 91 | 92 |

    93 | 94 | 95 | 96 |

    97 | 98 | 99 |     100 | 101 | 102 |

    103 | 104 | 105 | 106 |

    107 | 108 | 109 |     110 | 111 | 112 |

    113 |     114 | 115 | 116 | 117 | 118 | 119 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 |
    140 | 141 |
    142 |     143 | 144 | 145 |
    146 | 147 |

    148 | 149 | Example: 150 | 151 | 152 |

    153 |     154 | 155 |
    156 |     157 | 158 | 159 |
    160 |     161 | 162 | 163 |
    164 |     165 | 166 | 167 |
      168 | 169 |
    170 |     171 | 172 | 173 |
      174 | 175 |
    176 |     177 | 178 | 179 |
  • 180 | 181 |
    • 182 |     183 | 184 | 185 | 186 | 187 |
    188 |     189 | 190 | 191 | 192 | 193 | 194 | 195 | 196 | 197 | 198 | 199 | 200 | 201 | 202 | 203 |
    204 | 205 | 206 | 209 | 210 | 211 | 212 | 213 |
    207 | {title} 208 |
    Figure:
    214 |
    215 |     216 | 217 | 218 |
    219 |

    220 | Table: 221 | 222 |

    223 | 224 | 225 |
    226 |
    227 |     228 | 229 | 230 | 231 | 232 | 233 | 234 | 235 | 236 | 237 | 238 | 239 | 240 | 241 | 242 | 243 | 244 | 245 | 246 | 247 | 248 |
    249 | 250 |
    251 |     252 | 253 | 254 | 255 | 256 | 257 | 258 |
    259 | 260 |
    261 |     262 | 263 | 264 |
    265 | 266 |
    267 |     268 | 269 | 270 | 271 | 272 | 273 | 274 | 275 | 276 | 277 | XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 278 | 279 | 280 |     281 | -------------------------------------------------------------------------------- /hh.html2psrc: -------------------------------------------------------------------------------- 1 | @html2ps { 2 | seq-number: 1; 3 | } 4 | 5 | paper { 6 | type: a4; 7 | } 8 | 9 | options { 10 | duplex: 1; 11 | } 12 | 13 | body { 14 | font-family: Times; 15 | margin-top: 5ex; 16 | text-align: justify; 17 | } 18 | 19 | h1 { 20 | margin-left: -5%; 21 | text-align: left; 22 | font-family: Helvetica; 23 | font-size: 24pt; 24 | } 25 | 26 | h2 { 27 | text-align: left; 28 | padding-top: 1ex; 29 | margin-left: -5%; 30 | font-family: Helvetica; 31 | } 32 | 33 | a { 34 | text-decoration: underline; 35 | } 36 | 37 | blockquote { 38 | margin-right: 1em; 39 | } 40 | -------------------------------------------------------------------------------- /hh_ast.h: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2003, 2004 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | /* Abstract Syntax Tree for the compiler. 9 | */ 10 | 11 | #ifndef HH_INCL_AST 12 | #define HH_INCL_AST 1 13 | 14 | 15 | #include "hh_common.h" 16 | 17 | 18 | /* Forward declaration. */ 19 | typedef struct hh_ast_t hh_ast_t; 20 | 21 | 22 | /* Symbols. */ 23 | 24 | typedef struct hh_symbol_t { 25 | /* Is the symbol quoted anywhere? If it is, then it might be 26 | printed, and we have to add its name into the constant pool of 27 | the program file, and this ptr tells where it is. It remains 28 | HH_NIL if the symbol is not quoted. */ 29 | hh_word_t name_ptr; 30 | /* Is the symbol a name of a function? If so, then this is the 31 | pointer to its function tuple in the constant pool. */ 32 | hh_word_t fn_ptr; 33 | /* If the symbol's value is ever asked in the global scope, then 34 | `is_used' is set to two. The value one is used internally by the 35 | uses-analysis. */ 36 | unsigned char is_used; 37 | /* Is this a symbol of a builtin, which can only be redefined in the 38 | prelude? */ 39 | unsigned char is_builtin; 40 | /* If this symbol is used as a catch tag, then this is its non-zero 41 | numerical value. */ 42 | unsigned int catch_tag; 43 | /* A unique integer for this symbol. */ 44 | unsigned int number; 45 | /* A pointer used internally by the symbol table's data 46 | structures. */ 47 | struct hh_symbol_t *next; 48 | /* The symbol's name, written extending this struct. Null-char 49 | terminated. */ 50 | char name[1]; 51 | } hh_symbol_t; 52 | 53 | extern hh_symbol_t *hh_symbols; 54 | 55 | /* "Intern" the given string into a symbol, i.e. if the same string 56 | has not yet been interned then allocate and initialize a 57 | `hh_symbol_t' for it, otherwise return the already created 58 | `hh_symbol_t'. This makes a private copy of `name'. */ 59 | hh_symbol_t *hh_ast_symbol(const char *name); 60 | 61 | 62 | /* Symbols for builtins and special forms. */ 63 | 64 | extern hh_symbol_t 65 | #define MODULE(name) /* Nothing. */ 66 | #define MODULE_END /* Nothing. */ 67 | #define BUILTIN(lisp_name, c_name, doc_string, args, code_gen) \ 68 | *hh_symbol_ ## c_name, 69 | 70 | #include "hh_builtins.def" 71 | 72 | *hh_symbol_out_of_memory, *hh_symbol_def, *hh_symbol_fn, *hh_symbol_dot_do, 73 | *hh_symbol_macroconcat, *hh_symbol_macroquote, 74 | *hh_symbol_true, *hh_symbol_nil, *hh_symbol_defs, *hh_symbol_ellipsis; 75 | 76 | 77 | /* String constants. */ 78 | 79 | typedef struct hh_string_t { 80 | struct hh_string_t *next; 81 | hh_word_t string_ptr; 82 | unsigned int n_bytes; 83 | char bytes[1]; /* Not necessarily null-char-terminated. */ 84 | } hh_string_t; 85 | 86 | extern hh_string_t *hh_strings; 87 | 88 | /* This is similar to interning symbols. */ 89 | hh_string_t *hh_ast_string(const char *string, unsigned int n_bytes); 90 | 91 | 92 | /* And finally we get to the AST definitions. */ 93 | 94 | typedef enum { 95 | HH_AST_NIL = 0, 96 | /* The values from 1 onwards are arities of s-expression. */ 97 | /* The last values represent terminal nodes, such as constants and 98 | symbols. */ 99 | HH_AST_ATOMS_START = 251, 100 | HH_AST_STRING = 252, 101 | HH_AST_SYMBOL = 253, 102 | HH_AST_INTEGER = 254, 103 | HH_AST_UNSIGNED_INTEGER = 255 104 | } hh_ast_kind_t; 105 | 106 | 107 | struct hh_ast_t { 108 | /* What is the arity of this node? If the arity is zero, the node 109 | is a terminal node, i.e. either a constant or symbol. */ 110 | unsigned int arity : 8; 111 | /* The file from which this AST node was read from. This is an 112 | index to the `hh_filename' array in order to save space. */ 113 | unsigned int file : 8; 114 | /* What line number did this AST node come from. */ 115 | unsigned int line : 16; 116 | /* XXX */ 117 | union { 118 | hh_signed_word_t integer; 119 | hh_word_t unsigned_integer; 120 | hh_symbol_t *symbol; 121 | hh_string_t *string; 122 | struct hh_ast_t *ast[1]; 123 | } u; 124 | }; 125 | 126 | hh_ast_t *hh_alloc_node(unsigned int arity); 127 | 128 | /* Does this AST node originate from the prelude file? Some 129 | overridings etc. are possible only in the prelude. */ 130 | extern int hh_n_preludes; 131 | #define HH_NODE_IS_IN_PRELUDE(ast) ((ast)->file < hh_n_preludes) 132 | 133 | void hh_ast_copy_location(hh_ast_t *to, hh_ast_t *from); 134 | 135 | /* Read in the given HogLisp file, and return a list of the 136 | s-expressions in it. */ 137 | hh_ast_t *hh_ast_read_file(const char *filename); 138 | 139 | /* Dump an expression to stderr. This is used only for debugging. */ 140 | void hh_ast_dump(hh_ast_t *n); 141 | 142 | 143 | /* This must be called before anything else. It, for example, interns 144 | the built-in symbols. */ 145 | void hh_ast_init(void); 146 | 147 | 148 | /* Routines and definitions to be used by the lexer: file position and 149 | error reporting information. */ 150 | 151 | extern const char *hh_filename[]; 152 | extern unsigned int hh_n_files, hh_current_line; 153 | #define HH_CURRENT_FILENAME hh_filename[hh_n_files] 154 | 155 | 156 | void hh_fatal(hh_ast_t *node, const char *fmt, ...); 157 | 158 | 159 | /* Normally these would be defined by the yacc-generated header. */ 160 | 161 | hh_ast_t *hh_lval; 162 | #define HH_ATOM 257 163 | #define HH_ELLIPSIS 258 164 | 165 | void hh_directive_define(const char *name); 166 | 167 | 168 | extern int hh_n_catch_tags; 169 | 170 | 171 | #endif /* !HH_INCL_AST */ 172 | -------------------------------------------------------------------------------- /hh_avl.h: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2003, 2004 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | 9 | #ifndef HH_INCL_AVL 10 | #define HH_INCL_AVL 1 11 | 12 | 13 | #include "hh_common.h" 14 | #include "hh_data.h" 15 | #include "hh_error.h" 16 | 17 | 18 | #define HH_IS_AVL(ptr) ((*(ptr) & 0xFF) == 0x16) 19 | #define HH_AVL_KEY(ptr) ((ptr)[1]) 20 | #define HH_AVL_VALUE(ptr) ((ptr)[2]) 21 | #define HH_AVL_RIGHT_HEIGHT(ptr) (((ptr)[0] >> 8) & 0xFF) 22 | #define HH_AVL_LEFT_HEIGHT(ptr) (((ptr)[0] >> 16) & 0xFF) 23 | #define HH_AVL_HEIGHT(ptr) ((ptr)[0] >> 24) 24 | #define HH_AVL_LEFT(ptr) (HH_AVL_LEFT_HEIGHT(ptr) ? (ptr)[3] : HH_NIL) 25 | #define HH_AVL_RIGHT(ptr) (HH_AVL_RIGHT_HEIGHT(ptr) \ 26 | ? (ptr)[HH_AVL_LEFT_HEIGHT(ptr) ? 4 : 3] \ 27 | : HH_NIL) 28 | 29 | /* A simple default comparison function for symbols, integers, and 30 | strings. Returns -1, 0, or 1 if `a' is considered to be less than, 31 | equal to, or greater than `b', respectively. */ 32 | 33 | int hh_default_cmpfun(hh_context_t *ctx, 34 | hh_word_t a, 35 | hh_word_t b); 36 | 37 | /* Make a new AVL-tree node with the given key, value and subtrees. 38 | If the height difference of the subtrees is two, the routine 39 | performs necessary rotations to bring the new node into balance. 40 | No rotations are made if the heights differ less, and a fatal error 41 | is raised if the heights differ by three or more. It is assumed 42 | that `HH_AVL_MAKE_NODE_N_WORDS' words can be allocated from the 43 | heap. */ 44 | 45 | hh_word_t hh_avl_make_node(hh_context_t *ctx, 46 | hh_word_t key, 47 | hh_word_t value, 48 | hh_word_t left, 49 | hh_word_t right); 50 | 51 | #define HH_AVL_MAKE_NODE_N_WORDS (3 * 5) 52 | 53 | 54 | /* Perform a search in the given tree using the default comparison 55 | function. Return the value stored for the given key, or 56 | `default_value' if not found. */ 57 | 58 | hh_word_t hh_avl_default_get(hh_context_t *ctx, 59 | hh_word_t tree, 60 | hh_word_t key, 61 | hh_word_t default_value); 62 | 63 | /* Perform insertion/replacement in the given tree using the default 64 | comparison function. Return the new tree, or HH_NIL if the heap 65 | did not contain enough memory. */ 66 | 67 | hh_word_t hh_avl_default_put(hh_context_t *ctx, 68 | hh_word_t tree, 69 | hh_word_t key, 70 | hh_word_t value); 71 | 72 | #endif /* HH_INCL_AVL */ 73 | -------------------------------------------------------------------------------- /hh_codegen.h: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2003, 2004 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | 9 | #ifndef HH_INCL_CODEGEN 10 | #define HH_INCL_CODEGEN 1 11 | 12 | 13 | #include "hh_common.h" 14 | #include "hh_ast.h" 15 | #include "hh_interp.h" 16 | 17 | 18 | /* A doubly-linked list of byte code instructions in a form amenable 19 | for either peephole optimizations and outputting. */ 20 | 21 | typedef struct hh_code_t { 22 | hh_ast_t *ast; 23 | struct hh_code_t *prev, *next; 24 | enum { HH_IMM, HH_IMM2, HH_INSN, HH_BRANCH, HH_LABEL, HH_FN } kind; 25 | hh_signed_word_t position; 26 | int reachable; 27 | union { 28 | hh_insn_t insn; 29 | struct { 30 | hh_imm_insn_t insn; 31 | hh_signed_word_t value; 32 | } imm; 33 | struct { 34 | hh_imm_insn_t insn; 35 | hh_signed_word_t value1; 36 | hh_signed_word_t value2; 37 | } imm2; 38 | struct { 39 | hh_imm_insn_t insn; 40 | struct hh_code_t *target; 41 | } branch; 42 | struct { 43 | unsigned char n_args; 44 | unsigned char allow_excess_args; 45 | hh_symbol_t *symbol; 46 | } fn; 47 | } u; 48 | } hh_code_t; 49 | 50 | 51 | extern hh_context_t hh_constant_ctx; 52 | 53 | hh_code_t *hh_gen_code(hh_ast_t *list); 54 | 55 | void hh_grow_constant_ctx(unsigned long n_words); 56 | 57 | void hh_gen_init(int generate_debug_data); 58 | 59 | 60 | #endif /* !HH_INCL_CODEGEN */ 61 | -------------------------------------------------------------------------------- /hh_common.h: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2003, 2004, 2005 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Authors: Kenneth Oksanen 6 | * Lars Wirzenius 7 | */ 8 | 9 | /* Some common routines for both the byte code compiler and the byte 10 | code interpreter. The CFLAGS may define platform-specific values 11 | to macros 12 | HH_WORD_T: C type of the 32-bit integer values. 13 | HH_TESTING: Defined if various run-time checks should be included in the 14 | byte code interpreter. This also increases the executable 15 | size and slows down the interpreter significantly. 16 | HH_SMALL: May be used to reduce executable size when HH_TESTING 17 | is not defined. 18 | */ 19 | 20 | 21 | #ifndef HH_INCL_COMMON 22 | #define HH_INCL_COMMON 1 23 | 24 | 25 | #ifndef HH_COMPILER 26 | /* Add here definitions specific for your platform, e.g. stuff like 27 | #define HH_MEMMOVE my_own_memmove_because_the_system_memcpy_is_broken 28 | */ 29 | #endif 30 | 31 | 32 | /* Types for 32-bit values in the target. */ 33 | #ifdef HH_WORD_T 34 | typedef unsigned HH_WORD_T hh_word_t; 35 | typedef signed HH_WORD_T hh_signed_word_t; 36 | #else 37 | typedef unsigned long hh_word_t; 38 | typedef signed long hh_signed_word_t; 39 | #endif 40 | 41 | 42 | #ifdef HH_LINUX 43 | #define HH_UNIX 1 44 | #endif 45 | 46 | #ifdef HH_SUNOS 47 | #define HH_UNIX 1 48 | #endif 49 | 50 | #ifdef HH_BSD 51 | #define HH_UNIX 1 52 | #endif 53 | 54 | 55 | /* Collected include liturgy here. */ 56 | 57 | #include 58 | #include 59 | #include 60 | #include 61 | 62 | #ifndef HH_COMPILER 63 | 64 | /* Some possibly system-dependent includes for the interpreter. */ 65 | #include 66 | #include 67 | #include 68 | #include 69 | #include 70 | 71 | #ifdef HH_UNIX 72 | #include 73 | #ifdef HH_BSD 74 | #include 75 | #endif 76 | #include 77 | #ifdef HH_SUNOS 78 | #include 79 | #include 80 | #else 81 | #include 82 | #endif 83 | #include 84 | #include 85 | #include 86 | #include 87 | #endif 88 | 89 | #endif 90 | 91 | 92 | #ifdef HH_TESTING 93 | 94 | #ifndef HH_ASSERT 95 | #ifdef NDEBUG 96 | #define HH_ASSERT(expr) ((void) 0) 97 | #else 98 | #define HH_ASSERT_WITH_POS(expr, file, line) \ 99 | ((void) ((expr) \ 100 | || (hh_panic("%s:%ld:%s\n", file, (long) line, #expr), 0))) 101 | #define HH_ASSERT(expr) (HH_ASSERT_WITH_POS(expr, __FILE__, __LINE__)) 102 | void hh_panic(const char *fmt, ...); /* Defined in hh_interp_*.c */ 103 | #endif 104 | #endif /* HH_ASSERT */ 105 | 106 | #else 107 | 108 | #ifndef HH_ASSERT 109 | #define HH_ASSERT(expr) ((void) 0) 110 | #endif 111 | 112 | #endif 113 | 114 | #ifndef HH_NOTREACHED 115 | #define HH_NOTREACHED HH_ASSERT(0) 116 | #endif 117 | 118 | 119 | #ifndef HH_BACKTRACE 120 | #ifdef HH_SMALL 121 | #define HH_BACKTRACE(ctx) /* Does not exist. */ 122 | #else 123 | #define HH_BACKTRACE(ctx) hh_backtrace(ctx) 124 | #endif 125 | #endif 126 | 127 | 128 | /* Calls to malloc, free, memcmp, memcpy and memmove are all hidden 129 | behind macros. This may help to circumvent incorrect 130 | implementations of them in various platforms, or to define a layer 131 | in between Hedgehog's memory allocation and the system's default 132 | allocator. */ 133 | 134 | #ifndef HH_MALLOC 135 | #define HH_MALLOC(n_bytes) malloc(n_bytes) 136 | #endif 137 | #ifndef HH_FREE 138 | #define HH_FREE(obj) free(obj) 139 | #endif 140 | 141 | #include 142 | #ifndef HH_MEMCMP 143 | /* HH_MEMCMP should compare the bytes in p[0..n_bytes-1] and 144 | q[0..n_bytes-1] as unsigned chars. If this is not the case, the 145 | person porting should define memcmp for example as follows: 146 | int hh_memcmp(void *p, void *q, unsigned long n) 147 | { 148 | unsigned char *up = (unsigned char *) p; 149 | unsigned char *uq = (unsigned char *) q; 150 | while (n-- > 0) { 151 | if (*up < *uq) 152 | return -1; 153 | else if (*up++ > *uq++) 154 | return 1; 155 | } 156 | return 0; 157 | } 158 | */ 159 | #define HH_MEMCMP(p, q, n_bytes) memcmp(p, q, n_bytes) 160 | #endif 161 | #ifndef HH_MEMMOVE 162 | #define HH_MEMMOVE(to, from, n_bytes) memmove(to, from, n_bytes) 163 | #endif 164 | 165 | 166 | #ifdef HH_COMPILER 167 | 168 | #include 169 | #include 170 | 171 | void hh_print_compiler(const char *fmt, ...); /* Defined in hh_compiler.c */ 172 | #define HH_PRINT hh_print_compiler 173 | 174 | #else 175 | 176 | int hh_print_interpreter(const char *fmt, ...); /* Defined in hh_interp_*.c */ 177 | #define HH_PRINT hh_print_interpreter 178 | 179 | #ifndef HH_LISP_PRINT_DEPTH_INCR 180 | #define HH_LISP_PRINT_DEPTH_INCR 5 181 | #endif 182 | struct hh_context_t; /* Forward declaration. */ 183 | int hh_lisp_print_interpreter(struct hh_context_t *ctx, /* In hh_interp_*.c */ 184 | hh_word_t word, int depth); 185 | 186 | #endif 187 | 188 | 189 | #if __GNUC__ >= 3 190 | /* Macros that make it possible to give the compiler hints on which 191 | branch is most likely taken. */ 192 | #define HH_LIKELY(cond) __builtin_expect((cond), 1) 193 | #define HH_UNLIKELY(cond) __builtin_expect((cond), 0) 194 | #endif 195 | 196 | #ifndef HH_LIKELY 197 | #define HH_LIKELY(cond) (cond) 198 | #define HH_UNLIKELY(cond) (cond) 199 | #endif 200 | 201 | 202 | /* The first four bytes of the byte code files should contain the 203 | values 0x4E, 0xD6, 0xE4 and 0x06, respectively. */ 204 | #define HH_COOKIE 0x4ED6E406 205 | 206 | /* A one-byte running counter for the version number of the byte code 207 | file format (the header, constant value and debugging information 208 | representation). */ 209 | #define HH_BCODE_VERSION 1 210 | 211 | 212 | /* Version number of the Hedgehog Lisp language. The version number 213 | consists of two parts: major and minor. The version number defines 214 | the language implemented: whenever a new builtin function or other 215 | language feature is added, the minor version number is 216 | incremented. When a builtin function is removed or its interface 217 | changes in an incompatible manner, or something else changes that 218 | breaks existing programs, the major version is incremented. This 219 | means that when a Hedgehog Lisp program is written for version a.b, 220 | it will work with a version a.B, as long as b <= B. 221 | 222 | Note that this version number is for the LANGUAGE, not the 223 | implementation. If the implementation is rewritten completely, but 224 | in a manner that keeps the language exactly the same, this version 225 | number won't change even if the implementation's version number 226 | does. */ 227 | 228 | #define HEDGEHOG_LISP_VERSION_MAJOR 2 229 | #define HEDGEHOG_LISP_VERSION_MINOR 0 230 | 231 | /* The Hedgehog Lisp implementation also has a version number. Its 232 | major and minor numbers are the same as for the language it 233 | implements, and its patch level number increases for each 234 | version. This should be an easy enough system to deal with. If it 235 | doesn't suffice, we'll change it later. */ 236 | 237 | #define HEDGEHOG_IMPLEMENTATION_VERSION_MAJOR HEDGEHOG_LISP_VERSION_MAJOR 238 | #define HEDGEHOG_IMPLEMENTATION_VERSION_MINOR HEDGEHOG_LISP_VERSION_MINOR 239 | #define HEDGEHOG_IMPLEMENTATION_VERSION_PATCH 1 240 | 241 | 242 | #endif /* HH_INCL_COMMON */ 243 | -------------------------------------------------------------------------------- /hh_crypto.h: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2005 Kenneth Oksanen. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | /* This file includes concise implementations of the SHA-256 hash 9 | function and a slightly modified variant of the XXTEA for 128-bit 10 | blocks. */ 11 | 12 | 13 | #include "hh_common.h" 14 | 15 | 16 | /* Compute a 256-bit (32-byte) cryptographically strong hash value of 17 | the given `n_bytes' in `data'. The `digest' must refer to at least 18 | 32 bytes of memory which are overwritten by the hash. */ 19 | 20 | void hh_sha256(unsigned char *data, unsigned long n_bytes, 21 | unsigned char *digest); 22 | 23 | 24 | /* Encrypt or decrypt, depending on whether `encrypt' is non-zero or 25 | zero, the given `n_bytes_in' bytes in `in' with the given 16 bytes 26 | of password data in `password'. The `out' must refer to at least 27 | `n_bytes' + 19 bytes of memory, some of which may be unused. The 28 | `*n_bytes_out' is assigned the actual number of bytes in the 29 | en/decrypted message. 30 | 31 | This function returns always one on encryption or on successful 32 | decryption. However, should the given input buffer be of incorrect 33 | length for the decryption to finish, then the function returns 34 | zero. The caller can assume this to indicate an attack. */ 35 | 36 | int hh_xxtea(unsigned char *in, hh_word_t n_bytes_in, 37 | unsigned char *out, hh_word_t *n_bytes_out, 38 | int encrypt, 39 | const unsigned char *password); 40 | -------------------------------------------------------------------------------- /hh_data.h: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2003, 2004 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | 9 | #ifndef HH_INCL_DATA 10 | #define HH_INCL_DATA 1 11 | 12 | 13 | #include "hh_common.h" 14 | #include "hh_interp.h" 15 | #include "hh_error.h" 16 | 17 | 18 | /* Memory allocation macros. Issue `HH_CAN_ALLOCATE' to test whether 19 | there is sufficient memory to allocate the given number of words, 20 | and `HH_ALLOCATE' to actually allocate the words. */ 21 | 22 | #ifdef HH_COMPILER 23 | 24 | /* During compilation the heap is actually same as the constant pool, 25 | and it must grow upwards. */ 26 | 27 | #define HH_CAN_ALLOCATE(ctx, n_words) \ 28 | ((ctx)->heap_ptr + (n_words) < (ctx)->heap + (ctx)->heap_n_words) 29 | 30 | #define HH_ALLOCATE(ctx, n_words) \ 31 | (((ctx)->heap_ptr += (n_words)) - (n_words)) 32 | 33 | #else /* Not HH_COMPILER. */ 34 | 35 | /* The run-time dynamic heap grows downwards. */ 36 | 37 | #define HH_CAN_ALLOCATE(ctx, n_words) \ 38 | ((ctx)->heap_ptr - (n_words) >= (ctx)->heap_free) 39 | 40 | #define HH_ALLOCATE(ctx, n_words) \ 41 | ((ctx)->heap_ptr -= (n_words)) 42 | 43 | #endif /* Not HH_COMPILER */ 44 | 45 | 46 | /* Basic pointer codec. */ 47 | 48 | #define HH_WORD_IS_PTR(word) \ 49 | (((word) & 0x3) == 0x0) 50 | 51 | #define HH_WORD_IS_HEAP_PTR(word) \ 52 | (((word) & 0x83) == 0x00) 53 | 54 | #define HH_WORD_TO_PTR(ctx, word) \ 55 | (((word) & 0x80 ? (ctx)->constant : (ctx)->heap) + ((word) >> 8)) 56 | 57 | #ifdef HH_COMPILER 58 | 59 | /* During compilation, ptr necessarily refers to the constant pool. */ 60 | 61 | #define HH_PTR_TO_WORD(ctx, ptr, tag) \ 62 | ((((ptr) - (ctx)->heap) << 8) | (tag) | 0x80) 63 | 64 | #else 65 | 66 | /* During byte code interpretation, this is never called for pointers 67 | in the constant pool. */ 68 | 69 | #define HH_PTR_TO_WORD(ctx, ptr, tag) \ 70 | ((((ptr) - (ctx)->heap) << 8) | (tag)) 71 | 72 | #endif /* HH_COMPILER */ 73 | 74 | 75 | /* Integer codec. See the file README for the algorithm of how this 76 | is done. */ 77 | 78 | #define HH_WORD_IS_INT(word) \ 79 | (((word) & 0x1) \ 80 | || ((word) & 0x7B) == 0x40) 81 | 82 | #define HH_WORD_TO_UNSIGNED(ctx, word) \ 83 | ((word) & 0x1 \ 84 | ? (word) >> 1 \ 85 | : *HH_WORD_TO_PTR(ctx, word) ^ (((word) >> 2) & 0x1)) 86 | 87 | #define HH_WORD_TO_SIGNED(ctx, word) \ 88 | ((word) & 0x1 \ 89 | ? ((hh_signed_word_t) (word)) >> 1 \ 90 | : (hh_signed_word_t) (*HH_WORD_TO_PTR(ctx, word) ^ (((word) >> 2) & 0x1))) 91 | 92 | /* This function should be called only from either of the macros 93 | below. It allocates a word from heap and stores 31 bits in it and 94 | creates a suitably tagged pointer to it. */ 95 | hh_word_t hh_box_integer(hh_context_t *ctx, hh_word_t w); 96 | 97 | #define HH_UNSIGNED_TO_WORD(ctx, u) \ 98 | ((u) >> 31 \ 99 | ? hh_box_integer(ctx, u) \ 100 | : (((hh_word_t) (u)) << 1) | 0x1) 101 | 102 | extern unsigned char hh_is_large_abs_value[4]; 103 | 104 | #define HH_SIGNED_TO_WORD(ctx, i) \ 105 | (hh_is_large_abs_value[((hh_word_t) (i)) >> 30] \ 106 | ? hh_box_integer(ctx, (hh_word_t) i) \ 107 | : (((hh_word_t) (i)) << 1) | 0x1) 108 | 109 | #define HH_BOX_N_WORDS 1 110 | 111 | /* In many cases we can assume the integer is not realistically 112 | outside the range from -2^30 to 2^30-1. In such cases we use the 113 | following macros. */ 114 | #define HH_WORD_IS_SHORT(word) \ 115 | ((word) & 0x1) 116 | 117 | #define HH_WORD_TO_SHORT(word) \ 118 | (((hh_signed_word_t) word) >> 1) 119 | 120 | #define HH_SHORT_TO_WORD(i) \ 121 | (((i) << 1) | 0x1) 122 | 123 | 124 | /* Empty list. 125 | */ 126 | 127 | #define HH_NIL 0x2 128 | #define HH_IS_NIL(word) ((word) == HH_NIL) 129 | 130 | 131 | /* Truth values. The integer zero and empty list are regarded as 132 | false. Incidentally also the forward pointer to the beginning of 133 | the heap is regarded as boolean false, but that is never seen by 134 | the user program, so it is irrelevant. */ 135 | 136 | #define HH_IS_FALSE(word) ((word) <= HH_NIL) 137 | #define HH_IS_TRUE(word) ((word) > HH_NIL) 138 | 139 | #define HH_FALSE HH_NIL 140 | #define HH_TRUE (0x102) 141 | 142 | 143 | /* Byte code position. 144 | */ 145 | 146 | #define HH_IS_PC(word) \ 147 | (((word) & 0xFF) == 0x06) 148 | #define HH_PC_TO_WORD(ctx, pc) \ 149 | ((((pc) - (ctx)->program) << 8) | 0x06) 150 | #define HH_WORD_TO_PC(ctx, word) \ 151 | (((word) >> 8) + (ctx)->program) 152 | 153 | 154 | /* Debugging information. 155 | */ 156 | 157 | #if defined(HH_TESTING) || defined(HH_COMPILER) 158 | #define HH_DEBUG_INFO_HDR_WORD 0x1A 159 | #endif 160 | 161 | 162 | /* Cons processing. 163 | */ 164 | 165 | #define HH_IS_CONS(word) (((word) & 0x7F) == 0x08) 166 | #define HH_CAR(ptr) ((ptr)[0]) 167 | #define HH_CDR(ptr) ((ptr)[1]) 168 | 169 | #define HH_CONS(ctx, dest_ptr, dest_word, car, cdr) \ 170 | do { \ 171 | (dest_ptr) = HH_ALLOCATE((ctx), HH_CONS_N_WORDS); \ 172 | HH_CAR(dest_ptr) = (car); \ 173 | HH_CDR(dest_ptr) = (cdr); \ 174 | (dest_word) = HH_PTR_TO_WORD((ctx), (dest_ptr), 0x08); \ 175 | } while (0) 176 | 177 | #define HH_CONS_N_WORDS 2 178 | 179 | 180 | /* Tuple processing. 181 | */ 182 | 183 | #define HH_IS_TUPLE(word) \ 184 | (HH_WORD_IS_PTR(word) \ 185 | && (((word) & 0x7F) >= 0x08) \ 186 | && (((word) & 0x7F) <= 0x3C)) 187 | #define HH_TUPLE_ARITY(word) (((word) >> 2) & 0xF) 188 | 189 | 190 | 191 | /* Functions are cons-cells where the car is a byte code position. 192 | */ 193 | 194 | #define HH_WORD_IS_FN(ctx, word) \ 195 | (HH_IS_CONS(word) && HH_IS_PC(HH_CAR(HH_WORD_TO_PTR(ctx, word)))) 196 | 197 | 198 | /* Lisp-heap -allocated strings. 199 | */ 200 | 201 | #define HH_IS_STRING(ptr) ((*(ptr) & 0xFF) == 0x0A) 202 | 203 | /* How many bytes (octets) does the string contain? */ 204 | #define HH_STRING_LEN(ptr) ((*(ptr)) >> 8) 205 | 206 | /* How many heap-allocated words is needed for a string of given 207 | length? */ 208 | #define HH_STRING_N_WORDS(len) (((len) + 8) >> 2) 209 | 210 | /* The header word of a string of given length. */ 211 | #define HH_STRING_HDR(len) (((len) << 8) | 0x0A) 212 | 213 | #define HH_STRING_PTR(ptr) ((char *) ((ptr) + 1)) 214 | 215 | /* Allocate a string of given length and return an unboxed pointer to 216 | it. The string's content is not initialized with this call except 217 | for the terminating '\0' character. */ 218 | hh_word_t *hh_alloc_string(hh_context_t *ctx, size_t n_bytes); 219 | 220 | /* Copy the given array of bytes into the lisp heap. The memory must 221 | be pre-reserved. */ 222 | hh_word_t hh_box_string(hh_context_t *ctx, const char *string, size_t n_bytes); 223 | 224 | /* Perform string comparison similar to C's `strcmp', except for 225 | assuming null-character termination, on the two strings. */ 226 | int hh_strcmp(hh_word_t *s1, hh_word_t *s2); 227 | 228 | /* Encode the given integer to a heap-allocated string with the given 229 | base. The base must be within the range 2 to 36. */ 230 | hh_word_t hh_itoa(hh_context_t *ctx, hh_signed_word_t value, 231 | unsigned int base); 232 | 233 | #define HH_ITOA_N_WORDS HH_STRING_N_WORDS(8 * sizeof(hh_word_t) + 1) 234 | 235 | /* Decode the signed integer in the given string cell in the given 236 | base. The base must be in range 2 to 36, and sufficient memory 237 | must be reserved that an integer boxing is possible. */ 238 | hh_word_t hh_atoi(hh_context_t *ctx, hh_word_t *str, unsigned int base); 239 | 240 | /* Return the number of cons cells in the list. */ 241 | hh_word_t hh_list_length(hh_context_t *ctx, hh_word_t list); 242 | 243 | 244 | #ifndef HH_COMPILER 245 | 246 | /* Callback for printing Lisp heap values with hh_printf. The first 247 | value in ctx must be a struct of type hh_lisp_print_ctx_t. */ 248 | 249 | #include "hh_printf.h" 250 | 251 | typedef struct { 252 | hh_context_t *ctx; 253 | int depth, max_depth; 254 | } hh_lisp_print_ctx_t; 255 | 256 | int hh_lisp_print(hh_printf_callback_t cb, void *ctx, void *value); 257 | 258 | #endif 259 | 260 | 261 | /* Symbols. Currently only a header and a pointer to the string. */ 262 | 263 | #define HH_IS_SYMBOL(ptr) ((*(ptr) & 0xFF) == 0x0E) 264 | #define HH_SYMBOL_STRING(ptr) ((ptr)[1]) 265 | #define HH_SYMBOL_N_WORDS 2 266 | #define HH_SYMBOL_HDR 0x0E 267 | 268 | 269 | /* Change the byte order of the program file to suit that of the 270 | processor currently used. */ 271 | 272 | hh_error_t hh_fix_byteorder(hh_word_t *heap, unsigned long n_words); 273 | 274 | 275 | /* Garbage collection primitives. First issue `hh_gc_start', then 276 | apply `HH_ROOT' for each word belonging to the root set, and 277 | finally issue `hh_gc_finish'. `hh_gc_copy' is an internal function 278 | used by the garbage collector. */ 279 | 280 | void hh_gc_start(hh_context_t *ctx); 281 | 282 | #define HH_ROOT(ctx, word) \ 283 | do { \ 284 | if (HH_WORD_IS_HEAP_PTR(word)) \ 285 | (word) = hh_gc_copy((ctx), (word)); \ 286 | } while (0) 287 | 288 | hh_word_t hh_gc_copy(hh_context_t *ctx, hh_word_t word); 289 | 290 | void hh_gc_finish(hh_context_t *ctx); 291 | 292 | 293 | #endif /* !HH_INCL_DATA */ 294 | -------------------------------------------------------------------------------- /hh_error.c: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2003, 2004, 2005 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | #include "hh_common.h" 9 | #include "hh_error.h" 10 | #include "hh_interp.h" 11 | #include "hh_data.h" 12 | #include "hh_printf.h" 13 | 14 | 15 | unsigned char hh_error_kind[HH_N_ERRORS] = { 16 | 0, /* HH_OK */ 17 | #define ERROR(code, kind, description_string) \ 18 | kind, 19 | #include "hh_error.def" 20 | }; 21 | 22 | 23 | char *hh_error_string[HH_N_ERRORS] = { 24 | "OK", /* HH_OK */ 25 | #define ERROR(code, kind, description_string) \ 26 | description_string, 27 | #include "hh_error.def" 28 | }; 29 | 30 | 31 | void hh_error_print(hh_error_t error, void *aux_info) 32 | { 33 | char *s; 34 | 35 | switch (hh_error_kind[error]) { 36 | case HH_SYSTEM_WARNING: 37 | s = "System warning"; 38 | break; 39 | case HH_PROGRAM_WARNING: 40 | s = "Program warning"; 41 | break; 42 | case HH_SYSTEM_FATAL: 43 | s = "Fatal system error"; 44 | break; 45 | case HH_PROGRAM_FATAL: 46 | s = "Fatal program error"; 47 | break; 48 | default: 49 | s = "Unknown error"; 50 | break; 51 | } 52 | 53 | HH_PRINT("%s #%d: %s", s, (int) error, hh_error_string[error]); 54 | 55 | #ifndef HH_SMALL 56 | if (aux_info == NULL) 57 | return; 58 | if (hh_error_kind[error] == HH_PROGRAM_FATAL 59 | || hh_error_kind[error] == HH_PROGRAM_WARNING) { 60 | hh_context_t *ctx = (hh_context_t *) aux_info; 61 | 62 | if (ctx->offending_value != 0) { 63 | HH_PRINT(", got "); 64 | hh_lisp_print_interpreter(ctx, ctx->offending_value, -1); 65 | } 66 | HH_PRINT(". pc = %06d, sp = %d.\n", 67 | ctx->pc - (ctx->program + 12), 68 | ctx->sp - ctx->stack); 69 | } 70 | #else 71 | HH_PRINT(".\n"); 72 | #endif 73 | } 74 | -------------------------------------------------------------------------------- /hh_error.def: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2003, 2004, 2005, 2006 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | 9 | ERROR(HH_ERROR_EXPECT_CONS, 10 | HH_PROGRAM_FATAL, 11 | "Expected a (non-empty) list") 12 | 13 | ERROR(HH_ERROR_EXPECT_CONS_OR_NIL, 14 | HH_PROGRAM_FATAL, 15 | "Expected a list or nil") 16 | 17 | ERROR(HH_ERROR_EXPECT_STRING, 18 | HH_PROGRAM_FATAL, 19 | "Expected a string") 20 | 21 | ERROR(HH_ERROR_EXPECT_STRING_LIST, 22 | HH_PROGRAM_FATAL, 23 | "Expected a list of strings") 24 | 25 | ERROR(HH_ERROR_EXPECT_NONEMPTY_STRING, 26 | HH_PROGRAM_FATAL, 27 | "Expected a non-empty string") 28 | 29 | ERROR(HH_ERROR_EXPECT_STRING_OR_INT, 30 | HH_PROGRAM_FATAL, 31 | "Expected a string or integer") 32 | 33 | ERROR(HH_ERROR_EXPECT_INT, 34 | HH_PROGRAM_FATAL, 35 | "Expected an integer") 36 | 37 | ERROR(HH_ERROR_EXPECT_SHORT, 38 | HH_PROGRAM_FATAL, 39 | "Expected a small integer") 40 | 41 | ERROR(HH_ERROR_EXPECT_POSITIVE, 42 | HH_PROGRAM_FATAL, 43 | "Expected a positive integer") 44 | 45 | ERROR(HH_ERROR_EXPECT_FN, 46 | HH_PROGRAM_FATAL, 47 | "Expected a function") 48 | 49 | ERROR(HH_ERROR_EXPECT_SYMBOL, 50 | HH_PROGRAM_FATAL, 51 | "Expected a symbol") 52 | 53 | ERROR(HH_ERROR_EXPECT_TUPLE, 54 | HH_PROGRAM_FATAL, 55 | "Expected a tuple (of sufficient width)") 56 | 57 | ERROR(HH_ERROR_TOO_WIDE_TUPLE, 58 | HH_PROGRAM_FATAL, 59 | "Tuple too wide") 60 | 61 | ERROR(HH_ERROR_EXPECT_AVL, 62 | HH_PROGRAM_FATAL, 63 | "Expected an AVL-tree node") 64 | 65 | ERROR(HH_ERROR_PANIC, 66 | HH_PROGRAM_FATAL, 67 | "(panic ...) called") 68 | 69 | ERROR(HH_ERROR_BAD_BASE, 70 | HH_PROGRAM_FATAL, 71 | "`itoa' or `atoi' given base outside range from 2 to 36") 72 | 73 | ERROR(HH_ERROR_BAD_CHAR, 74 | HH_PROGRAM_FATAL, 75 | "`chr' given an integer less than zero or over 255") 76 | 77 | ERROR(HH_ERROR_WRONG_ARGS, 78 | HH_PROGRAM_FATAL, 79 | "Incorrect number of arguments") 80 | 81 | ERROR(HH_ERROR_UNCAUGHT_EXCEPTION, 82 | HH_PROGRAM_FATAL, 83 | "Uncaught exception") 84 | 85 | ERROR(HH_ERROR_HEAP_FULL, 86 | HH_PROGRAM_FATAL, 87 | "Heap exhausted") 88 | 89 | ERROR(HH_ERROR_MALLOC, 90 | HH_SYSTEM_FATAL, 91 | "Memory allocation failed") 92 | 93 | ERROR(HH_ERROR_INITIAL_MALLOC, 94 | HH_PROGRAM_NORUN, 95 | "Initial memory allocation failed") 96 | 97 | ERROR(HH_ERROR_MALLOC_MAY_FAIL, 98 | HH_SYSTEM_WARNING, 99 | "Non-essential memory allocation failed") 100 | 101 | ERROR(HH_ERROR_PROGRAM_CORRUPT, 102 | HH_PROGRAM_NORUN, 103 | "Program corrupted") 104 | 105 | ERROR(HH_ERROR_PROGRAM_WRONG_VERSION, 106 | HH_PROGRAM_NORUN, 107 | "Program of wrong version") 108 | 109 | ERROR(HH_ERROR_PROGRAM_EXITED, 110 | HH_PROGRAM_NORUN, 111 | "Program exited") 112 | 113 | ERROR(HH_ERROR_PROGRAM_DID_EXEC, 114 | HH_PROGRAM_NORUN, 115 | "Program replaced its byte code file with a new one") 116 | 117 | #undef ERROR 118 | -------------------------------------------------------------------------------- /hh_error.h: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2003, 2004, 2005 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | #ifndef HH_INCL_ERROR 9 | #define HH_INCL_ERROR 1 10 | 11 | 12 | /* Define the enumerated type for the kinds of errors. 13 | */ 14 | typedef enum { 15 | /* Recoverable warnings and notifications come here. */ 16 | HH_SYSTEM_WARNING, 17 | HH_PROGRAM_WARNING, 18 | 19 | /* The program is not runnable for some reason, but the byte code 20 | interpreter and the operating system are still alive. */ 21 | HH_PROGRAM_NORUN, 22 | 23 | /* This must be here. */ 24 | HH_N_WARNING_KINDS, 25 | 26 | /* Irrecoverable fatal errors which require rebooting or something 27 | equally violent come here. */ 28 | HH_SYSTEM_FATAL, 29 | HH_PROGRAM_FATAL 30 | } hh_error_kind_t; 31 | 32 | 33 | /* Define the enumerated type of all error codes. 34 | */ 35 | typedef enum { 36 | HH_OK = 0, 37 | #define ERROR(code, kind, description_string) \ 38 | code, 39 | #include "hh_error.def" 40 | #undef ERROR 41 | HH_N_ERRORS, 42 | } hh_error_t; 43 | 44 | extern unsigned char hh_error_kind[]; 45 | 46 | #define HH_ERROR_IS_FATAL(error) (hh_error_kind[error] > HH_N_WARNING_KINDS) 47 | 48 | /* HH_PRINT the error message into the given buffer. `aux_info' could 49 | be a `hh_ctx_t *' in case of a run-time error in the byte code 50 | program. 51 | */ 52 | void hh_error_print(hh_error_t error, void *aux_info); 53 | 54 | 55 | #endif /* !HH_INCL_ERROR */ 56 | -------------------------------------------------------------------------------- /hh_interp.h: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2003, 2004, 2005 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | 9 | #ifndef HH_INTERP 10 | #define HH_INTERP 1 11 | 12 | #include "hh_common.h" 13 | #include "hh_error.h" 14 | 15 | 16 | 17 | /* Macros for unaligned MSB first memory reads. `p' is assumed to be 18 | a valid pointer value of type `unsigned char *'. */ 19 | 20 | #define HH_GET_UINT32(p) \ 21 | (((hh_word_t) (p)[0] << 24) \ 22 | | ((hh_word_t) (p)[1] << 16) \ 23 | | ((hh_word_t) (p)[2] << 8) \ 24 | | (p)[3]) 25 | 26 | #define HH_GET_UINT24(p) \ 27 | (((hh_word_t) (p)[0] << 16) \ 28 | | ((hh_word_t) (p)[1] << 8) \ 29 | | (p)[2]) 30 | 31 | #define HH_GET_UINT16(p) \ 32 | (((hh_word_t) (p)[0] << 8) | (p)[1]) 33 | 34 | 35 | /* Converses for writing. */ 36 | 37 | #define HH_PUT_UINT32(p, w) \ 38 | do { \ 39 | (p)[0] = (w) >> 24; \ 40 | (p)[1] = (w) >> 16; \ 41 | (p)[2] = (w) >> 8; \ 42 | (p)[3] = (w); \ 43 | } while (0) 44 | 45 | #define HH_PUT_UINT24(p, w) \ 46 | do { \ 47 | (p)[0] = (w) >> 16; \ 48 | (p)[1] = (w) >> 8; \ 49 | (p)[2] = (w); \ 50 | } while (0) 51 | 52 | #define HH_PUT_UINT16(p, w) \ 53 | do { \ 54 | (p)[0] = (w) >> 8; \ 55 | (p)[1] = (w); \ 56 | } while (0) 57 | 58 | 59 | /* Instruction mnemonics. */ 60 | 61 | typedef enum { 62 | #define INSN(mnemonic, flags, code) HH_INSN_ ## mnemonic, 63 | #define IMM(mnemonic, flags, code) /* Nothing */ 64 | #define EXT_INSN(mnemonic, flags, code) /* Nothing */ 65 | 66 | #include "hh_insn.def" 67 | 68 | HH_NUMBER_OF_INSNS, 69 | 70 | HH_START_OF_EXT_INSNS = 255, /* First HH_EXT_INSN_... will be 256. */ 71 | 72 | #define INSN(mnemonic, flags, code) /* Nothing */ 73 | #define IMM(mnemonic, flags, code) /* Nothing */ 74 | #define EXT_INSN(mnemonic, flags, code) HH_INSN_ ## mnemonic, 75 | 76 | #include "hh_insn.def" 77 | 78 | HH_NUMBER_OF_EXT_INSNS, 79 | 80 | } hh_insn_t; 81 | 82 | 83 | typedef enum { 84 | #define INSN(mnemonic, flags, code) /* Nothing */ 85 | #define IMM(mnemonic, flags, code) HH_IMM_ ## mnemonic, 86 | #define EXT_INSN(mnemonic, flags, code) /* Nothing */ 87 | 88 | #include "hh_insn.def" 89 | 90 | HH_IMM_ext, 91 | HH_NUMBER_OF_IMMS, 92 | } hh_imm_insn_t; 93 | 94 | 95 | /* Internal state of a single HedgeHog interpreter execution. 96 | */ 97 | 98 | typedef struct hh_context_t { 99 | unsigned char *program; 100 | /* `heap' is the pointer to the current heap, and during collection, 101 | the to-space. `old_heap' is correspondingly the from-space. For 102 | various convenience and performance reasons allocation happens 103 | downwords starting from `heap + heap_n_words', but upwards during 104 | garbage collection. The field `heap_free' tells how high the 105 | allocation took place during the last gc, and `heap_ptr' is the 106 | current allocation pointer during normal allocation. */ 107 | hh_word_t *heap, *old_heap, *heap_ptr, *heap_free; 108 | hh_word_t heap_n_words; 109 | /* Pointer to the beginning of the constant pool. */ 110 | hh_word_t *constant; 111 | /* The rest of this structure is not needed by the compiler. */ 112 | #ifndef HH_COMPILER 113 | unsigned char *pc; 114 | hh_word_t accu, env, new_env; 115 | hh_word_t *sp; 116 | hh_word_t stack_n_words; 117 | #ifdef HH_UNIX 118 | /* This part is included if we are in a UNIX and support select(2). 119 | See the documentation of hh_interp_step below for information 120 | about these fields. */ 121 | fd_set select_read_fds, select_write_fds; 122 | int select_max_fd; 123 | struct timeval select_timeout; 124 | int select_retval; 125 | unsigned char program_wants_to_select; 126 | #endif 127 | #ifdef HH_TESTING 128 | hh_word_t offending_value; 129 | unsigned char insn_trace_enabled; 130 | unsigned char gc_trace_enabled; 131 | /* If profiling is enabled, then this is a pointer to a `hh_word_t' 132 | array as large as the number of byte code insns in the entire 133 | program. When executing an insn, the corresponding slot in the 134 | array is incremented. If profiling is disabled, this is NULL. */ 135 | hh_word_t *profile_data; 136 | hh_word_t redzone; 137 | #endif 138 | /* The run-time stack is below. `hh_context_allocate' allocates 139 | extra memory for this struct, and the stack grows there. */ 140 | hh_word_t stack[1]; 141 | /* Do not add any additional fields here! */ 142 | #endif /* !HH_COMPILER */ 143 | } hh_context_t; 144 | 145 | 146 | /* The rest of this file is not needed by the compiler. */ 147 | #ifndef HH_COMPILER 148 | 149 | /* Check the given program file is correct and executable on this byte 150 | code interpreter. This function also fixes the byte order of the 151 | program file's constant pool, and therefore this function *MUST* be 152 | called prior to using the program for anything else. `program' 153 | must be word-aligned. Returns non-zero on success. */ 154 | 155 | hh_error_t hh_program_check(unsigned char *program, unsigned int n_bytes); 156 | 157 | 158 | /* Allocate a Hedgehog execution context. Note that it *must* be 159 | allocated with this function. The `heap_n_words' tells the size of 160 | one semispace in the garbage-collectable dynamic heap. 161 | `stack_n_words' tells the number of words to be reserved for the 162 | stack. If `enable_profiling' is non-zero and `HH_TESTING' is 163 | defined, allocate an array used for profiling. This array is 164 | `HH_PRINT'ed in `hh_context_free'. Returns NULL in case of 165 | HH_MALLOC failure. */ 166 | 167 | hh_context_t *hh_context_allocate(unsigned char *program, 168 | unsigned long heap_n_words, 169 | unsigned long stack_n_words, 170 | int enable_profiling); 171 | 172 | /* Free the Hedgehog execution context, including the call stack and 173 | the lisp heap(s). If `HH_TESTING' is defined, then return the 174 | highest stack position used during the execution. */ 175 | 176 | long hh_context_free(hh_context_t *ctx); 177 | 178 | 179 | /* Interprete the byte code program for the given number of `ticks'. 180 | Return `HH_OK' if the program did not exit. Return 181 | `HH_ERROR_PROGRAM_EXITED', in which case the next call to interp 182 | will rerun the same program. In case of error, return the error 183 | code and restore `ctx' to something that is possible to pass to 184 | `hh_error_fmt' as `aux_info'. 185 | 186 | I suggest using relatively large values for `n_ticks' for sake of 187 | reasonable performance, typically in the range of hundreds to 188 | thousands. 189 | 190 | If HH_UNIX is defined, hh_interp_step returns HH_OK and 191 | ctx->program_wants_to_select is non-zero, then the caller should issue 192 | ctx->select_retval = select(ctx->select_max_fd + 1, 193 | &ctx->select_read_fds, 194 | &ctx->select_write_fds, 195 | NULL, 196 | &ctx->select_timeout); 197 | and thereafter call hh_interp_step again. This architecture of 198 | returning to the caller for select allows the programmers to merge 199 | several event loops to one and therby avoid a severe anti-pattern. */ 200 | 201 | hh_error_t hh_interp_step(hh_context_t *ctx, hh_signed_word_t n_ticks); 202 | 203 | 204 | #ifndef HH_SMALL 205 | 206 | /* Print, using HH_PRINT, a function call backtrace of the current 207 | state of execution. */ 208 | void hh_backtrace(hh_context_t *ctx); 209 | 210 | #endif /* HH_SMALL */ 211 | 212 | #endif /* !HH_COMPILER */ 213 | 214 | #endif /* !HH_INTERP */ 215 | -------------------------------------------------------------------------------- /hh_lambda.h: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2003, 2004 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | 9 | #ifndef HH_INCL_LAMBDA 10 | #define HH_INCL_LAMBDA 1 11 | 12 | 13 | /* List all `fn's and `def's in non-top-level context into 14 | corresponding `def's in top-level context, add relevant closure 15 | generation and reading instructions. */ 16 | hh_ast_t *hh_lambda(hh_ast_t *expr); 17 | 18 | 19 | /* Lambda-lifting prefixes all symbols it generates for lifted 20 | functions with `$.'. */ 21 | #define HH_SYMBOL_IS_LIFTED_LAMBDA(sym) \ 22 | ((sym)->name[0] == '$' && (sym)->name[1] == '.') 23 | 24 | 25 | #endif /* !HH_INCL_LAMBDA */ 26 | -------------------------------------------------------------------------------- /hh_macroexpand.h: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2003, 2004 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | 9 | #ifndef HH_INCL_MACROEXPAND 10 | #define HH_INCL_MACROEXPAND 1 11 | 12 | 13 | #include "hh_ast.h" 14 | 15 | 16 | /* Perform macro expansion for the given list of definitions. */ 17 | 18 | void hh_macroexpand(hh_ast_t **list, hh_ast_t *macro_list, 19 | int n_rec_expansions); 20 | 21 | 22 | #endif /* !HH_INCL_MACROEXPAND */ 23 | -------------------------------------------------------------------------------- /hh_opt.c: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2003, 2004 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | /* This file implements algebraic optimizations, such as constant 9 | folding, let hoisting, inlining, etc. 10 | 11 | For the time being the only algebraic optimization implemented is 12 | constant folding of boolean expressions, but more will hopefully 13 | come. */ 14 | 15 | #define HH_COMPILER 1 16 | 17 | 18 | #include "hh_common.h" 19 | #include "hh_ast.h" 20 | 21 | 22 | /* Note that the constant folder operates on three-value logic: true, 23 | false and don't know. Hence `!hh_expr_is_true(x)' does not imply 24 | `hh_expr_is_false(x)', and vice versa. */ 25 | 26 | static int hh_expr_is_true(hh_ast_t *expr) 27 | { 28 | return expr != NULL 29 | && ((expr->arity == HH_AST_INTEGER && expr->u.integer != 0) 30 | || (expr->arity == HH_AST_UNSIGNED_INTEGER 31 | && expr->u.unsigned_integer != 0) 32 | || (expr->arity == HH_AST_SYMBOL && expr->u.symbol == hh_symbol_true)); 33 | } 34 | 35 | static int hh_expr_is_false(hh_ast_t *expr) 36 | { 37 | return expr != NULL 38 | && ((expr->arity == HH_AST_INTEGER && expr->u.integer == 0) 39 | || (expr->arity == HH_AST_UNSIGNED_INTEGER 40 | && expr->u.unsigned_integer == 0) 41 | || expr->arity == HH_AST_NIL); 42 | } 43 | 44 | 45 | static hh_ast_t *hh_rec_fold(hh_ast_t *expr) 46 | { 47 | int i, j; 48 | hh_signed_word_t sw; 49 | hh_ast_t *n; 50 | int n_true, n_false; 51 | 52 | if (expr == NULL) 53 | return NULL; 54 | 55 | switch (expr->arity) { 56 | case HH_AST_NIL: 57 | case HH_AST_STRING: 58 | case HH_AST_SYMBOL: 59 | case HH_AST_INTEGER: 60 | case HH_AST_UNSIGNED_INTEGER: 61 | return expr; 62 | break; 63 | case 2: 64 | /* Remove quoting from strings, integers, nil and t. */ 65 | if (expr->u.ast[0]->arity == HH_AST_SYMBOL 66 | && expr->u.ast[0]->u.symbol == hh_symbol_quote) { 67 | if (expr->u.ast[1]->arity == HH_AST_STRING 68 | || expr->u.ast[1]->arity == HH_AST_INTEGER 69 | || expr->u.ast[1]->arity == HH_AST_UNSIGNED_INTEGER 70 | || expr->u.ast[1]->arity == HH_AST_NIL 71 | || (expr->u.ast[1]->arity == HH_AST_SYMBOL 72 | && expr->u.ast[1]->u.symbol == hh_symbol_true)) 73 | return expr->u.ast[1]; 74 | /* Otherwise return expr itself - we mustn't do any 75 | simplifications into anything quoted. */ 76 | return expr; 77 | } 78 | /*FALLTHROUGH*/ 79 | default: 80 | /* Apply `hh_rec_fold' recursively bottom-up. */ 81 | for (i = 0; i < expr->arity; i++) 82 | expr->u.ast[i] = hh_rec_fold(expr->u.ast[i]); 83 | 84 | if (expr->u.ast[0]->arity == HH_AST_SYMBOL) { 85 | /* Simplification of boolean if, not, and, or. */ 86 | 87 | if (expr->u.ast[0]->u.symbol == hh_symbol_if) { 88 | if (expr->arity < 3 || expr->arity > 4) 89 | hh_fatal(expr, "if expects 2 or 3 arguments"); 90 | if (hh_expr_is_true(expr->u.ast[1])) 91 | return expr->u.ast[2]; 92 | if (hh_expr_is_false(expr->u.ast[1])) { 93 | if (expr->arity == 4) 94 | return expr->u.ast[3]; 95 | else { 96 | n = hh_alloc_node(HH_AST_NIL); 97 | hh_ast_copy_location(n, expr); 98 | return n; 99 | } 100 | } 101 | 102 | } else if (expr->u.ast[0]->u.symbol == hh_symbol_not) { 103 | if (expr->arity != 2) 104 | hh_fatal(expr, "not expects one argument"); 105 | if (hh_expr_is_true(expr->u.ast[1])) { 106 | n = hh_alloc_node(HH_AST_NIL); 107 | hh_ast_copy_location(n, expr); 108 | return n; 109 | } 110 | if (hh_expr_is_false(expr->u.ast[1])) { 111 | n = hh_alloc_node(HH_AST_SYMBOL); 112 | hh_ast_copy_location(n, expr); 113 | n->u.symbol = hh_symbol_true; 114 | return n; 115 | } 116 | 117 | } else if (expr->u.ast[0]->u.symbol == hh_symbol_and) { 118 | 119 | /* Drop out all true subexpressions. */ 120 | n_true = 0; 121 | n = NULL; 122 | for (i = 1; i < expr->arity; i++) { 123 | if (hh_expr_is_true(expr->u.ast[i])) { 124 | n_true++; 125 | n = expr->u.ast[i]; 126 | } else 127 | expr->u.ast[i - n_true] = expr->u.ast[i]; 128 | } 129 | expr->arity -= n_true; 130 | if (expr->arity == 1) { 131 | /* The value of `(and)' is true. */ 132 | if (n == NULL) { 133 | expr->arity = HH_AST_SYMBOL; 134 | expr->u.symbol = hh_symbol_true; 135 | } else 136 | expr = n; 137 | return expr; 138 | } 139 | /* Check if there's a false. If one is first, the whole expr 140 | is false. Otherwise cut the expression to the arity of the 141 | first false. */ 142 | if (hh_expr_is_false(expr->u.ast[1])) 143 | return expr->u.ast[1]; 144 | for (i = 2; i < expr->arity; i++) 145 | if (hh_expr_is_false(expr->u.ast[i])) { 146 | expr->arity = i + 1; 147 | return expr; 148 | } 149 | 150 | } else if (expr->u.ast[0]->u.symbol == hh_symbol_or) { 151 | 152 | /* This is essentially a converse of the folding of ands. */ 153 | n_false = 0; 154 | n = NULL; 155 | for (i = 1; i < expr->arity; i++) { 156 | if (hh_expr_is_false(expr->u.ast[i])) { 157 | n_false++; 158 | n = expr->u.ast[i]; 159 | } else 160 | expr->u.ast[i - n_false] = expr->u.ast[i]; 161 | } 162 | expr->arity -= n_false; 163 | if (expr->arity == 1) { 164 | /* The value of `(or)' is false. */ 165 | if (n == NULL) 166 | expr->arity = HH_AST_NIL; 167 | else 168 | expr = n; 169 | return expr; 170 | } 171 | /* Check if there's a true, etc... See the folding of 172 | ands. */ 173 | if (hh_expr_is_true(expr->u.ast[1])) 174 | return expr->u.ast[1]; 175 | for (i = 2; i < expr->arity; i++) 176 | if (hh_expr_is_true(expr->u.ast[i])) { 177 | expr->arity = i + 1; 178 | return expr; 179 | } 180 | 181 | } else if (expr->u.ast[0]->u.symbol == hh_symbol_add) { 182 | 183 | /* Simple constant folding of addition. It can fold any 184 | expression containing only integer constants, e.g. 185 | (+ 1 (+ 2 -3)) is folded into zero. But there are 186 | limitations - for example if -3 were replaced by a 187 | non-constant expression, nothing could be done to it. */ 188 | sw = 0; 189 | for (i = j = 1; i < expr->arity; i++) { 190 | if (expr->u.ast[i]->arity == HH_AST_INTEGER) 191 | sw += expr->u.ast[i]->u.integer; 192 | else 193 | expr->u.ast[j++] = expr->u.ast[i]; 194 | } 195 | HH_ASSERT(j <= i); 196 | if (sw != 0) 197 | if (j == 1) { 198 | expr->arity = HH_AST_INTEGER; 199 | expr->u.integer = sw; 200 | } else { 201 | expr->u.ast[j] = hh_alloc_node(HH_AST_INTEGER); 202 | hh_ast_copy_location(expr->u.ast[j], expr); 203 | expr->u.ast[j]->arity = HH_AST_INTEGER; 204 | expr->u.ast[j++]->u.integer = sw; 205 | expr->arity -= i - j; 206 | } 207 | else { 208 | /* sw == 0 */ 209 | if (j == 2) 210 | return expr->u.ast[1]; 211 | else if (j == 1) { 212 | expr->arity = HH_AST_INTEGER; 213 | expr->u.integer = 0; 214 | } else 215 | expr->arity -= i - j; 216 | } 217 | return expr; 218 | 219 | } else if (expr->u.ast[0]->u.symbol == hh_symbol_eq) { 220 | 221 | if (expr->arity == 1) { 222 | make_true: 223 | expr->arity = HH_AST_SYMBOL; 224 | expr->u.symbol = hh_symbol_true; 225 | return expr; 226 | } 227 | 228 | if (expr->arity == 3 229 | && ((expr->u.ast[1]->arity == HH_AST_UNSIGNED_INTEGER 230 | && expr->u.ast[2]->arity == HH_AST_UNSIGNED_INTEGER 231 | && expr->u.ast[1]->u.unsigned_integer == 232 | expr->u.ast[2]->u.unsigned_integer) 233 | || (expr->u.ast[1]->arity == HH_AST_INTEGER 234 | && expr->u.ast[2]->arity == HH_AST_INTEGER 235 | && expr->u.ast[1]->u.integer == 236 | expr->u.ast[2]->u.integer))) 237 | goto make_true; 238 | 239 | if (expr->arity == 3 240 | && ((expr->u.ast[1]->arity == HH_AST_UNSIGNED_INTEGER 241 | && expr->u.ast[2]->arity == HH_AST_UNSIGNED_INTEGER 242 | && expr->u.ast[1]->u.unsigned_integer != 243 | expr->u.ast[2]->u.unsigned_integer) 244 | || (expr->u.ast[1]->arity == HH_AST_INTEGER 245 | && expr->u.ast[2]->arity == HH_AST_INTEGER 246 | && expr->u.ast[1]->u.integer != 247 | expr->u.ast[2]->u.integer))) { 248 | /* make_false: */ 249 | expr->arity = HH_AST_SYMBOL; 250 | expr->u.symbol = hh_symbol_nil; 251 | return expr; 252 | } 253 | 254 | } 255 | } 256 | return expr; 257 | } 258 | } 259 | 260 | 261 | hh_ast_t *hh_opt(hh_ast_t *expr) 262 | { 263 | return hh_rec_fold(expr); 264 | } 265 | -------------------------------------------------------------------------------- /hh_opt.h: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2003, 2004 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | 9 | #ifndef HH_INCL_OPT 10 | #define HH_INCL_OPT 1 11 | 12 | 13 | hh_ast_t *hh_opt(hh_ast_t *expr); 14 | 15 | 16 | #endif /* !HH_INCL_OPT */ 17 | -------------------------------------------------------------------------------- /hh_output.h: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2003, 2004 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | 9 | #ifndef HH_INCL_OUTPUT 10 | #define HH_INCL_OUTPUT 1 11 | 12 | 13 | #include "hh_common.h" 14 | #include "hh_codegen.h" 15 | #include "hh_interp.h" 16 | 17 | 18 | /* Dump the given code sequence to the given file. */ 19 | 20 | typedef enum { 21 | HH_BYTECODE, 22 | HH_HEX, 23 | HH_HEX_C, 24 | } hh_output_type_t; 25 | 26 | void hh_output(hh_code_t *codes, FILE *code_fp, hh_output_type_t type, 27 | int generate_debug_data, FILE *asm_fp); 28 | 29 | 30 | /* Usable only during debugging. */ 31 | 32 | void hh_dump_codes(hh_code_t *codes); 33 | 34 | 35 | #endif /* !HH_INCL_OUTPUT */ 36 | -------------------------------------------------------------------------------- /hh_peephole.c: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2003, 2004 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | /* This file implements some peephole optimizations. 9 | */ 10 | 11 | #define HH_COMPILER 1 12 | 13 | #include "hh_common.h" 14 | #include "hh_data.h" 15 | #include "hh_codegen.h" 16 | 17 | 18 | #define HH_PURE 0x00000001 19 | 20 | 21 | static const int hh_insn_is_pure[] = { 22 | #define INSN(mnemonic, flags, code) ((flags) & HH_PURE), 23 | #define IMM(mnemonic, flags, code) /* Nothing */ 24 | #define EXT_INSN(mnemonic, flags, code) /* Nothing */ 25 | 26 | #include "hh_insn.def" 27 | 28 | 0 29 | }; 30 | 31 | 32 | static const int hh_ext_insn_is_pure[] = { 33 | #define INSN(mnemonic, flags, code) /* Nothing */ 34 | #define IMM(mnemonic, flags, code) /* Nothing */ 35 | #define EXT_INSN(mnemonic, flags, code) ((flags) & HH_PURE), 36 | 37 | #include "hh_insn.def" 38 | 39 | 0 40 | }; 41 | 42 | 43 | static const int hh_imm_is_pure[] = { 44 | #define INSN(mnemonic, flags, code) /* Nothing */ 45 | #define IMM(mnemonic, flags, code) ((flags) & HH_PURE), 46 | #define EXT_INSN(mnemonic, flags, code) /* Nothing */ 47 | 48 | #include "hh_insn.def" 49 | 50 | 0 51 | }; 52 | 53 | 54 | /* Is an instruction "pure", i.e. free of side effects such as IO, 55 | memory writes, etc. For example the computing the string length is 56 | pure, since it inspects the given string and leaves its length into 57 | `accu'. It does not pop values from stack, for example. We do not 58 | regard side effects of error cases as side effects in this sense. 59 | Therefore computing string length is pure even though it has a 60 | side-effecting type check. */ 61 | 62 | static int hh_code_is_pure(hh_code_t *code) 63 | { 64 | if (code->kind == HH_INSN) 65 | if (code->u.insn < HH_START_OF_EXT_INSNS) 66 | return hh_insn_is_pure[code->u.insn]; 67 | else 68 | return hh_ext_insn_is_pure[code->u.insn - HH_START_OF_EXT_INSNS - 1]; 69 | else if (code->kind == HH_IMM) 70 | return hh_imm_is_pure[code->u.imm.insn]; 71 | else 72 | return 0; 73 | } 74 | 75 | 76 | static hh_code_t *hh_eliminate_dead_code(hh_code_t *codes) 77 | { 78 | hh_code_t *code, **codep; 79 | int changed; 80 | 81 | /* Clear reachable marks in insns. */ 82 | for (code = codes; code != NULL; code = code->next) 83 | code->reachable = 0; 84 | 85 | /* The first insn is reachable, since that's where the execution 86 | starts. */ 87 | codes->reachable = 1; 88 | 89 | /* Compute reachable instructions. */ 90 | do { 91 | changed = 0; 92 | 93 | for (code = codes; code != NULL; code = code->next) { 94 | /* Mark function entry points as reachable. */ 95 | if (code->kind == HH_FN && !code->reachable) { 96 | code->reachable = 1; 97 | changed = 1; 98 | } 99 | /* Do nothing for this insn if it is not reachable. */ 100 | if (!code->reachable) 101 | continue; 102 | /* The instructions after branch, return, and tailcall are not by 103 | default reachable, otherwise mark them as reachable. */ 104 | if (code->next != NULL 105 | && !code->next->reachable 106 | && !(code->kind == HH_BRANCH 107 | && code->u.branch.insn == HH_IMM_branch) 108 | && !(code->kind == HH_IMM 109 | && code->u.imm.insn == HH_IMM_return) 110 | && !(code->kind == HH_IMM2 111 | && code->u.imm2.insn == HH_IMM_tailcall)) { 112 | code->next->reachable = 1; 113 | changed = 1; 114 | } 115 | /* The branch targets are reachable. */ 116 | if (code->kind == HH_BRANCH 117 | && !code->u.branch.target->reachable) { 118 | code->u.branch.target->reachable = 1; 119 | changed = 1; 120 | } 121 | } 122 | } while (changed); 123 | 124 | /* Remove all unreachable insns. */ 125 | for (codep = &codes, code = *codep; 126 | code != NULL; 127 | code = *codep) 128 | if (!code->reachable) 129 | *codep = code->next; 130 | else 131 | codep = &code->next; 132 | 133 | /* hh_dump_codes(codes); */ 134 | 135 | return codes; 136 | } 137 | 138 | 139 | hh_code_t *hh_peephole(hh_code_t *codes) 140 | { 141 | hh_code_t *code, **codep, *target, *next; 142 | int dropped, changed; 143 | 144 | do { 145 | changed = 0; 146 | 147 | codes = hh_eliminate_dead_code(codes); 148 | 149 | for (codep = &codes, code = *codep; 150 | code != NULL; 151 | codep = dropped ? codep : &code->next, code = *codep) { 152 | dropped = 0; 153 | /* Remove a pure instruction followed by an immeadiate load. */ 154 | if (hh_code_is_pure(code) 155 | && code->next != NULL 156 | && code->next->kind == HH_IMM 157 | && (code->next->u.imm.insn == HH_IMM_load 158 | || code->next->u.imm.insn == HH_IMM_pick 159 | || code->next->u.imm.insn == HH_IMM_get_env)) { 160 | *codep = code->next; 161 | dropped = 1; 162 | } 163 | /* Merge `drop x' and `return y' into `return x+y', 164 | or `drop x' and `drop y' into `drop x+y'. */ 165 | if (code->kind == HH_IMM 166 | && code->u.imm.insn == HH_IMM_drop 167 | && code->next != NULL 168 | && code->next->kind == HH_IMM 169 | && (code->next->u.imm.insn == HH_IMM_return 170 | || code->next->u.imm.insn == HH_IMM_drop)) { 171 | *codep = code->next; 172 | code->next->u.imm.value += code->u.imm.value; 173 | dropped = 1; 174 | } 175 | /* Replace an unconditional branch to a label followed by a 176 | return, tailcall or unconditional branch with that insn. */ 177 | if (code->kind == HH_BRANCH 178 | && code->u.branch.insn == HH_IMM_branch) { 179 | target = code->u.branch.target; 180 | while (target->kind == HH_LABEL) 181 | target = target->next; 182 | if ((target->kind == HH_IMM2 && target->u.imm.insn == HH_IMM_tailcall) 183 | || (target->kind == HH_IMM && target->u.imm.insn == HH_IMM_return) 184 | || (target->kind == HH_IMM 185 | && target->u.imm.insn == HH_IMM_branch)) { 186 | next = code->next; 187 | *code = *target; 188 | code->next = next; 189 | changed = 1; 190 | } 191 | } 192 | #if 0 193 | /* XXX This optimization is incorrect - it leaves an un-negated 194 | value into `accu'. */ 195 | /* Replace `not' and `branch_if_false' with `branch_if_true', 196 | and vice versa. */ 197 | if (code->kind == HH_INSN 198 | && code->u.insn == HH_INSN_not 199 | && code->next != NULL 200 | && code->next->kind == HH_BRANCH) { 201 | if (code->next->u.branch.insn == HH_IMM_branch_if_true) { 202 | code->next->u.branch.insn = HH_IMM_branch_if_false; 203 | *codep = code->next; 204 | dropped = 1; 205 | } else if (code->next->u.branch.insn == HH_IMM_branch_if_false) { 206 | code->next->u.branch.insn = HH_IMM_branch_if_true; 207 | *codep = code->next; 208 | dropped = 1; 209 | } 210 | } 211 | #endif 212 | /* A `pick -1' after a `push' is redundant. */ 213 | if (code->kind == HH_INSN 214 | && code->u.insn == HH_INSN_push 215 | && code->next != NULL 216 | && code->next->kind == HH_IMM 217 | && code->next->u.imm.insn == HH_IMM_pick 218 | && code->next->u.imm.value == -1) { 219 | code->next = code->next->next; 220 | changed = 1; 221 | } 222 | /* Other rewrites to be implemented. */ 223 | 224 | if (dropped) 225 | changed = 1; 226 | } 227 | } while (changed); 228 | 229 | /* A second peephole optimization creates aggregate instructions, 230 | such as `push_load'. Note that there may be no labels in between 231 | the aggregated instructions. */ 232 | for (codep = &codes, code = *codep; 233 | code != NULL; 234 | codep = &code->next, code = *codep) { 235 | /* Aggregate a push, load, and add/sub to add_imm. */ 236 | if (code->kind == HH_INSN 237 | && code->u.insn == HH_INSN_push 238 | && code->next != NULL 239 | && code->next->kind == HH_IMM 240 | && code->next->u.imm.insn == HH_IMM_load 241 | && code->next->next != NULL 242 | && code->next->next->kind == HH_INSN) { 243 | if (code->next->next->u.insn == HH_INSN_add) { 244 | /* Make the load into `add_imm' and remove the `push' in 245 | `code' and `add' in `code->next->next'. */ 246 | code->next->u.imm.insn = HH_IMM_add_imm; 247 | *codep = code->next; 248 | code->next->next = code->next->next->next; 249 | continue; 250 | } else if (code->next->next->u.insn == HH_INSN_sub) { 251 | /* Make the load into `add_imm' with changed sign, and remove 252 | the `push' in `code' and `add' in `code->next->next'. */ 253 | code->next->u.imm.insn = HH_IMM_add_imm; 254 | hh_grow_constant_ctx(HH_BOX_N_WORDS); 255 | code->next->u.imm.value = 256 | HH_SIGNED_TO_WORD(&hh_constant_ctx, 257 | -HH_WORD_TO_SIGNED(&hh_constant_ctx, 258 | code->next->u.imm.value)); 259 | *codep = code->next; 260 | code->next->next = code->next->next->next; 261 | continue; 262 | } 263 | } 264 | /* Aggregate a push and load into push_load. */ 265 | if (code->kind == HH_INSN 266 | && code->u.insn == HH_INSN_push 267 | && code->next != NULL 268 | && code->next->kind == HH_IMM 269 | && code->next->u.imm.insn == HH_IMM_load) { 270 | code->next->u.imm.insn = HH_IMM_push_load; 271 | *codep = code->next; 272 | continue; 273 | } 274 | /* Aggregate a `push', `pick y', `push', and `pick x' into into 275 | `push_pick_push_pick x, y' when x negative (local variable 276 | reference). */ 277 | if (code->kind == HH_INSN 278 | && code->u.insn == HH_INSN_push 279 | && code->next != NULL 280 | && code->next->kind == HH_IMM 281 | && code->next->u.imm.insn == HH_IMM_pick 282 | && code->next->u.imm.value < 0 283 | && code->next->u.imm.value >= -128 284 | && code->next->next != NULL 285 | && code->next->next->kind == HH_INSN 286 | && code->next->next->u.insn == HH_INSN_push 287 | && code->next->next->next != NULL 288 | && code->next->next->next->kind == HH_IMM 289 | && code->next->next->next->u.imm.insn == HH_IMM_pick) { 290 | hh_signed_word_t p1 = code->next->u.imm.value; 291 | hh_signed_word_t p2 = code->next->next->next->u.imm.value; 292 | code->next->kind = HH_IMM2; 293 | code->next->u.imm2.insn = HH_IMM_push_pick_push_pick; 294 | code->next->u.imm2.value1 = p2; 295 | code->next->u.imm2.value2 = p1; 296 | *codep = code->next; 297 | code->next->next = code->next->next->next->next; 298 | continue; 299 | } 300 | /* Aggregate a push and pick into push_pick. */ 301 | if (code->kind == HH_INSN 302 | && code->u.insn == HH_INSN_push 303 | && code->next != NULL 304 | && code->next->kind == HH_IMM 305 | && code->next->u.imm.insn == HH_IMM_pick) { 306 | code->next->u.imm.insn = HH_IMM_push_pick; 307 | *codep = code->next; 308 | continue; 309 | } 310 | } 311 | 312 | return codes; 313 | } 314 | -------------------------------------------------------------------------------- /hh_peephole.h: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2003, 2004 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | 9 | #ifndef HH_INCL_PEEPHOLE 10 | #define HH_INCL_PEEPHOLE 1 11 | 12 | 13 | #include "hh_common.h" 14 | #include "hh_codegen.h" 15 | #include "hh_interp.h" 16 | 17 | 18 | /* Perform various peephole optimizations on the given program. */ 19 | 20 | hh_code_t *hh_peephole(hh_code_t *codes); 21 | 22 | 23 | #endif /* !HH_INCL_PEEPHOLE */ 24 | -------------------------------------------------------------------------------- /hh_printf.h: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2003, 2004 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | /* A concise, generic, callback-based printf routine, used by the byte 9 | code interpreter. The byte code interpreter does NOT use standard 10 | c library printf-like functions or even the `FILE *' abstraction. 11 | */ 12 | 13 | 14 | #ifndef HH_INCL_PRINTF 15 | #define HH_INCL_PRINTF 1 16 | 17 | #include 18 | 19 | 20 | /* A callback called to "print" one character. The callback can do 21 | whatever it wants - put it on the screen, write it into a resizing 22 | or size-limited buffer or file, send it to a socket, ..., or 23 | perhaps just discard it. Returns zero on failure, in which case 24 | printing will cease, or non-zero in which case printing will 25 | continue. */ 26 | 27 | typedef int (*hh_printf_callback_t)(char ch, void *ctx); 28 | 29 | /* Type of the recursive printing function passed to the format 30 | directive `%@'. */ 31 | 32 | typedef int (*hh_rec_printf_t)(hh_printf_callback_t cb, void *ctx, 33 | void *value); 34 | 35 | /* Printf the given values according to the given format string using 36 | the given callback and context. Returns the number of characters 37 | successfully written. The format characters understood are as 38 | follows. First printing of integer values: 39 | %d print the given signed int in decimal base 10. 40 | %u print the given unsigned int in decimal base 10. 41 | %o print the given unsigned int in octal base 8. 42 | %x print the given unsigned int in hexadecimal base 16. 43 | %X print the given unsigned int in hexadecimal base 16 44 | with uppercase letters. 45 | %p print the given pointer value in hexadecimal base 16. 46 | %P print the given pointer value in hexadecimal base 16 47 | with uppercase letters. 48 | The modifier l tells the integer values are of type long instead of 49 | int. The modifier b in conjunction with %d or %u tells to use the 50 | base given in the argument list. The modifier B is identical, but 51 | tells to use uppercase letters. 52 | 53 | Next the textual values: 54 | %c print the given character 55 | %C print the given character so that unprintable characters 56 | are printed in octal, e.g. \010 57 | %s print the given string 58 | %S print the given string so that unprintable characters 59 | are printed in octal, e.g. \010 60 | All integer and textual values can be specified to have a minimum 61 | width and justification in that minimum width. For example %12d 62 | prints the given signed integer padding it from the left with 63 | spaces so that the pad and integer use (at least) 12 integers, 64 | %012d uses zeros as padding, and %-12d pads the integer from the 65 | right (i.e. justifies to the left). %*d takes the minimum width 66 | and justification from the argument list. 67 | 68 | Examples: 69 | hh_printf(..., "%*lBd", -7, 20, -7777) prints the value -7777 in 70 | base 20 with uppercase letters justified to the left and using 71 | at least 7 characters: the printed characters are "-J8H " and 72 | return value is 7. 73 | hh_printf(..., "f%8Sr", "oo\ba") prints first `f', then the given 74 | string as right-justified using at least 8 characters and 75 | escaping any non-printable characters, and finally prints `r': 76 | the printed characters are "f oo\010ar" and return value is 10. 77 | 78 | The most powerful feature in hh_printf is the possibility to invoke 79 | recursively printing functions dedicated for specific types. The 80 | directive %@ takes the given function pointer of type 81 | `hh_rec_printf_t' and `void *'-value from the argument list, and 82 | calls the function with the print-callback and context that were 83 | given to the hh_printf. The type-specific printing functions are 84 | of course able to use hh_printf again. 85 | 86 | The phrase to use hh_printf as fprintf is to define a function like 87 | int hh_fputc(char ch, void *ctx) 88 | { 89 | return fputc(ch, (FILE *) ctx) != EOF; 90 | } 91 | and use it like 92 | hh_printf(hh_fputc, stdout, "Hello, world!\n"); 93 | However, I have not wanted to place such code in this file, because 94 | this file should be possible to use verbatim even if no stdio.h, 95 | stdout or stderr is present. */ 96 | 97 | 98 | int hh_printf(hh_printf_callback_t cb, void *ctx, const char *fmt, ...); 99 | int hh_vprintf(hh_printf_callback_t cb, void *ctx, const char *fmt, 100 | va_list args); 101 | 102 | /* Functions built on the above ones. First the equivalents for 103 | standard `snprintf' and `vsnprintf'. */ 104 | 105 | int hh_snprintf(char *buf, unsigned long buf_size, const char *fmt, ...); 106 | int hh_vsnprintf(char *buf, unsigned long buf_size, const char *fmt, 107 | va_list args); 108 | 109 | #if 0 110 | 111 | /* These functions are not used by Hedgehog, but left here as a 112 | suggestion of things that motivate the callback-ctx-based printing. */ 113 | 114 | /* These functions allocate the string into which the result will be 115 | written. It is up to the caller to free the return value. Returns 116 | NULL on failure of any kind. */ 117 | 118 | char *hh_bprintf(const char *fmt, ...); 119 | char *hh_vbprintf(const char *fmt, va_list args); 120 | 121 | #endif 122 | 123 | 124 | /* Some convenience macros, in case we don't have or want to use 125 | `ctype.h'. */ 126 | 127 | #ifndef HH_IS_DIGIT 128 | #define HH_IS_DIGIT(ch) ((ch) >= '0' && ch <= '9') 129 | #endif 130 | #ifndef HH_IS_PRINT 131 | #define HH_IS_PRINT(ch) ((ch) >= 32 && (ch) <= 126) 132 | #endif 133 | 134 | 135 | #endif /* HH_INCL_PRINTF */ 136 | -------------------------------------------------------------------------------- /hh_seed.c: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2005 Kenneth Oksanen. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | /* This file precomputes the seed value and the SHA256 of the shared 9 | secret. */ 10 | 11 | 12 | #include 13 | #include 14 | #include 15 | 16 | #include "hh_crypto.h" 17 | 18 | 19 | #define DIGEST_SIZE 32 20 | #define BUF_SIZE 1024 21 | static unsigned char digest[DIGEST_SIZE], buf[BUF_SIZE + DIGEST_SIZE]; 22 | static unsigned int buf_ptr; 23 | 24 | static void digest_init(void) 25 | { 26 | memset(digest, 0, DIGEST_SIZE); 27 | memset(buf, 0, BUF_SIZE + DIGEST_SIZE); 28 | buf_ptr = 0; 29 | } 30 | 31 | static void digest_char(unsigned char ch) 32 | { 33 | if (buf_ptr == BUF_SIZE) { 34 | hh_sha256(buf, BUF_SIZE + DIGEST_SIZE, digest); 35 | memset(buf, 0, BUF_SIZE); 36 | memcpy(buf + BUF_SIZE, digest, DIGEST_SIZE); 37 | buf_ptr = 0; 38 | } 39 | buf[buf_ptr++] = ch; 40 | } 41 | 42 | static void digest_finish(void) 43 | { 44 | hh_sha256(buf, BUF_SIZE + DIGEST_SIZE, digest); 45 | } 46 | 47 | 48 | int main(void) 49 | { 50 | #define LINE_LEN 1024 51 | char *s, line[LINE_LEN]; 52 | int i; 53 | 54 | printf("/* This file is automatically generated by `hh_seed.c' from\n\ 55 | the contents of the `hh_insn.def' file and the shared secret. */\n\n"); 56 | 57 | digest_init(); 58 | for (s = HH_SHARED_SECRET; *s != '\0'; s++) 59 | digest_char(*s); 60 | digest_finish(); 61 | 62 | printf("unsigned char hh_shared_secret[32] = {"); 63 | for (i = 0; i < 32; i++) { 64 | if (i % 8 == 0) 65 | printf("\n "); 66 | printf(" 0x%02X,", digest[i]); 67 | } 68 | printf("\n};\n\n"); 69 | 70 | /* The shared secret used in communication does not include the 71 | cookie, because that could cause logistic hassles when 72 | communicating (but not updating byte codes) with clients on 73 | several different targets. Nor does the insn cookie include the 74 | shared secret, because the shared secret is only 32-bits long and 75 | not sufficiently strong agaist a determined attack. */ 76 | 77 | digest_init(); 78 | while (!feof(stdin)) { 79 | fgets(line, LINE_LEN, stdin); 80 | if (strncmp(line, "INSN", 4) == 0 81 | || strncmp(line, "EXT_INSN", 8) == 0 82 | || strncmp(line, "IMM", 3) == 0) 83 | for (s = line; *s != '\0' && *s != ',' && *s != 0x0A; s++) 84 | digest_char(*s); 85 | } 86 | digest_finish(); 87 | printf("#define HH_INSN_COOKIE 0x%02X%02X%02X%02X\n", 88 | digest[0], digest[1], digest[2], digest[3]); 89 | 90 | return 0; 91 | } 92 | -------------------------------------------------------------------------------- /hh_uses.c: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2003, 2004 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | /* This file implements uses analysis, i.e. it sets the `is_used'-flag 9 | in all symbols reachable from the top-level program. 10 | 11 | XXX Currently this does not pay attention to local variables that 12 | in reality hide references to global functions. For example if any 13 | reachable part of the code contains `(let ((hex ...)) ...)', then 14 | the byte code of `hex' defined in `stdlib.lisp' will be included 15 | even though in reality it won't be referred. */ 16 | 17 | #define HH_COMPILER 1 18 | 19 | #include "hh_common.h" 20 | #include "hh_ast.h" 21 | 22 | static int has_changed; 23 | 24 | static void hh_rec_uses(hh_ast_t *expr) 25 | { 26 | int i; 27 | hh_ast_t *args; 28 | int n_args; 29 | 30 | if (expr == NULL) 31 | return; 32 | 33 | switch (expr->arity) { 34 | case HH_AST_NIL: 35 | case HH_AST_STRING: 36 | case HH_AST_INTEGER: 37 | case HH_AST_UNSIGNED_INTEGER: 38 | return; 39 | case HH_AST_SYMBOL: 40 | if (expr->u.symbol->is_used == 0) { 41 | expr->u.symbol->is_used = 1; 42 | has_changed = 1; 43 | } 44 | return; 45 | case 3: 46 | if (expr->u.ast[0]->arity == HH_AST_SYMBOL 47 | && expr->u.ast[0]->u.symbol == hh_symbol_def) { 48 | args = expr->u.ast[1]; 49 | 50 | /* Check the syntax of the argument list. */ 51 | args = expr->u.ast[1]; 52 | n_args = args->arity; 53 | if (n_args == HH_AST_SYMBOL) 54 | hh_fatal(args, "`def's of non-functions not yet implemented"); 55 | if (n_args == HH_AST_NIL 56 | || n_args > HH_AST_ATOMS_START 57 | || args->u.ast[0]->arity != HH_AST_SYMBOL) 58 | hh_fatal(args, "Unrecognized form for `def'"); 59 | if (n_args > 127) 60 | hh_fatal(args, "Too long argument list"); 61 | 62 | if (args->u.ast[0]->u.symbol->is_used == 1) { 63 | /* The function is referred but it has not yet been traversed. 64 | Traverse and mark traversed. */ 65 | hh_rec_uses(expr->u.ast[2]); 66 | args->u.ast[0]->u.symbol->is_used = 2; 67 | } 68 | return; 69 | } 70 | default: 71 | /* Apply `hh_rec_uses' recursively bottom-up. */ 72 | for (i = 1; i < expr->arity; i++) 73 | hh_rec_uses(expr->u.ast[i]); 74 | 75 | /* The head of the expression is treated a little smarter. If it 76 | is any of the defined builtins, then *don't* traverse to the 77 | symbol. */ 78 | if (expr->u.ast[0]->arity == HH_AST_SYMBOL) { 79 | #define MODULE(name) /* Nothing. */ 80 | #define MODULE_END /* Nothing. */ 81 | #define BUILTIN(lisp_name, c_name, doc_string, args, code_gen) \ 82 | if (expr->u.ast[0]->u.symbol == hh_symbol_ ## c_name) \ 83 | return; 84 | #include "hh_builtins.def" 85 | } 86 | 87 | /* The head is not any of the defined builtins, therefore traverse 88 | it too. */ 89 | hh_rec_uses(expr->u.ast[0]); 90 | } 91 | } 92 | 93 | 94 | void hh_uses(hh_ast_t *prog) 95 | { 96 | do { 97 | has_changed = 0; 98 | hh_rec_uses(prog); 99 | } while (has_changed); 100 | } 101 | -------------------------------------------------------------------------------- /hh_uses.h: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2003, 2004 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | 9 | #ifndef HH_INCL_USES 10 | #define HH_INCL_USES 1 11 | 12 | 13 | void hh_uses(hh_ast_t *expr); 14 | 15 | 16 | #endif /* !HH_INCL_USES */ 17 | -------------------------------------------------------------------------------- /hh_version.awk: -------------------------------------------------------------------------------- 1 | /^#define HEDGEHOG_LISP_VERSION_MAJOR/ { major=$NF } 2 | /^#define HEDGEHOG_LISP_VERSION_MINOR/ { minor=$NF } 3 | /^#define HEDGEHOG_IMPLEMENTATION_VERSION_PATCH/ { patch=$NF } 4 | END { print major "." minor "." patch } 5 | -------------------------------------------------------------------------------- /hhc.1: -------------------------------------------------------------------------------- 1 | .TH HEDGEHOG 1 2 | .SH NAME 3 | hhc \- Hedgehog LISP compiler 4 | .SH SYNOPSIS 5 | .B hhc 6 | .IR "" [ options "] [" lisp-files ] 7 | .SH "DESCRIPTION" 8 | .B hhc 9 | is a compiler for the Hedgehog LISP programming language for 10 | embedded telematic applications. 11 | It compiles Lisp source code to binary byte code, 12 | which is then interpreted by 13 | .BR hhi . 14 | See the tutorial for more information. 15 | .SH OPTIONS 16 | .TP 17 | .BR -h ", " --help 18 | Help message, with a summary of the options. 19 | .TP 20 | .BR -D " name" 21 | Define the given conditional compilation name. 22 | .TP 23 | .BR -g 24 | Add debugging info to the compiled byte code. 25 | .TP 26 | .BR -o " file" 27 | Place the byte code program into the given file. 28 | The default is the last source code file name with 29 | the suffix replaced with ".hlo". 30 | .TP 31 | .BR -p ", " --prelude " file" 32 | Name of the standard prelude directory, or '-' if none. 33 | .TP 34 | .BR -x ", " --hex 35 | Produce a hex dump of the byte code. If no output file is explicitely 36 | specified, write the hex dump to stdout. 37 | .TP 38 | .BR -X ", " --hex-c 39 | Produce a C constant containing the hex dump of the byte code. If no 40 | output file is explicitely specified, write the hex dump to stdout. 41 | .TP 42 | .BR -v ", " --verbose 43 | Dump various debugging information about the compilation process. 44 | .SH "SEE ALSO" 45 | .BR hhi (1) 46 | -------------------------------------------------------------------------------- /hhdoc.py: -------------------------------------------------------------------------------- 1 | import string 2 | import sys 3 | import re 4 | 5 | def printline(text, indent): 6 | print "%*s%s" % (indent * 1, "", text) 7 | 8 | def protect(str): 9 | str = string.join(str.split("&"), "&") 10 | str = string.join(str.split("<"), "<") 11 | str = string.join(str.split(">"), ">") 12 | return str 13 | 14 | def stripcmt(str): 15 | while str and str[0] == ";": 16 | str = str[1:] 17 | return str 18 | 19 | def title2id(str): 20 | return string.join(str.lower().split(), "") 21 | 22 | def paras(text, indent): 23 | lines = map(lambda s: stripcmt(s).strip(), text.split("\n")) 24 | while lines: 25 | i = lines.index("") 26 | if i == -1: 27 | i = len(lines) 28 | para = map(lambda s: protect(s), lines[:i]) 29 | if len(para) == 1: 30 | printline("%s" % para[0], indent) 31 | elif len(para) > 1: 32 | printline("%s" % para[0], indent) 33 | for line in para[1:-1]: 34 | printline("%s" % line, indent) 35 | printline("%s" % para[-1], indent) 36 | lines = lines[i+1:] 37 | 38 | def funcdef(text): 39 | text = text.strip() 40 | assert len(text) > 0 41 | assert text[0] == "(" 42 | assert text[-1] == ")" 43 | words = text[1:-1].split() 44 | assert len(words) > 0 45 | if len(words) == 1: 46 | return "(%s)" % protect(words[0]) 47 | else: 48 | return "(%s %s)" % (protect(words[0]), 49 | string.join(map(lambda s: 50 | "%s" % 51 | protect(s), 52 | words[1:]), 53 | " ")) 54 | 55 | def printfunc(m): 56 | printline("", 2) 57 | printline("%s" % funcdef(m.group("decl")), 3) 58 | printline("", 3) 59 | paras(m.group("text"), 4) 60 | printline("", 3) 61 | printline("", 2) 62 | 63 | def printconst(s, m): 64 | text = m.group("text") 65 | 66 | printline("", 2) 67 | 68 | printline("%s" % m.group("decl"), 3) 69 | s = s[m.end():] 70 | m = moreconst.match(s) 71 | while m: 72 | printline("%s" % m.group("decl"), 3) 73 | s = s[m.end():] 74 | m = moreconst.match(s) 75 | 76 | printline("", 3) 77 | paras(text, 4) 78 | printline("", 3) 79 | printline("", 2) 80 | 81 | return s 82 | 83 | section = re.compile("(.*\n)*?(?P
    ;; Section:(.*\n)*?)(;; Section:|$)") 84 | 85 | intro = re.compile("^;; Section:\s+(?P.*)\n(?P<text>(;;.*\n)*)") 86 | 87 | func = re.compile("(.*\n)*?(?P<text>(;;.*\n)+)" + 88 | "\\s+\\(def(-syntax)?\\s+(?P<decl>\\(([^)]|\n)*\))") 89 | 90 | firstconst = re.compile("(.*\n)*?(?P<text>(;;.*\n)+)" + 91 | "\\s+\\((set|def-syntax)\\s+(?P<decl>\\S*)\\s.*\\n") 92 | moreconst = re.compile("\\((set|def-syntax)\\s+(?P<decl>\\S*)\\s.*\\n") 93 | 94 | 95 | 96 | for filename in sys.argv[1:]: 97 | f = open(filename, "r") 98 | data = f.read() 99 | f.close() 100 | 101 | m = section.match(data) 102 | while m: 103 | s = m.group("section") 104 | data = data[m.end("section"):] 105 | m = intro.match(s) 106 | s = s[m.end():] 107 | printline("<sect2 id='%s'>" % title2id(m.group("title")), 0) 108 | printline("<title>%s" % m.group("title"), 1) 109 | printline("", 1) 110 | 111 | paras(m.group("text"), 1) 112 | printline("", 1) 113 | 114 | mf = func.match(s) 115 | mc = firstconst.match(s) 116 | while mf or mc: 117 | if mf and not mc: 118 | printfunc(mf) 119 | s = s[mf.end():] 120 | elif mc and not mf: 121 | s = printconst(s, mc) 122 | elif mf.end() < mc.end(): 123 | printfunc(mf) 124 | s = s[mf.end():] 125 | else: 126 | s = printconst(s, mc) 127 | mf = func.match(s) 128 | mc = firstconst.match(s) 129 | 130 | printline("", 1) 131 | printline("", 1) 132 | printline("", 0) 133 | printline("", 0) 134 | m = section.match(data) 135 | -------------------------------------------------------------------------------- /hhi.1: -------------------------------------------------------------------------------- 1 | .TH HHI 1 2 | .SH NAME 3 | hhi \- Hedgehog LISP interpreter 4 | .SH SYNOPSIS 5 | .B hhi 6 | .IR "" [ options "] " bytecode-file 7 | .SH "DESCRIPTION" 8 | .B hhc 9 | is a byte code interpreter for the Hedgehog LISP programming language for 10 | embedded applications. 11 | It interprets byte code produced by the 12 | .BR hhc 13 | compiler. 14 | .PP 15 | See the tutorial for more information. 16 | .SH OPTIONS 17 | These options are generally not available if 18 | .BR HH_SMALL 19 | was defined during compilation of 20 | .BR hhi. 21 | Refer to the source code for those special cases. 22 | .TP 23 | .BR -b ", " --bootstracp 24 | Use the interpreter's built-in byte code instead of reading one from a given file. 25 | Not available unless HH_USE_BOOT was defined during compilation. 26 | .TP 27 | .BR -g ", " --gc-trace 28 | Enable garbage collection messages. 29 | Not available unless HH_TESTING was defined during compilation. 30 | .TP 31 | .BR -h ", " --help 32 | Help message, with a summary of the options. 33 | .TP 34 | .BR -H ", " --heap " n_words" 35 | Dynamic heap semispace size, in 32-bit words. Default is 65536. 36 | .TP 37 | .BR -i ", " --insn-trace 38 | Enable byte code instruction trace. 39 | Not available unless HH_TESTING was defined during compilation. 40 | .TP 41 | .BR -p ", " --profile 42 | Enable byte code profiling. 43 | Not available unless HH_TESTING was defined during compilation. 44 | .TP 45 | .BR -S ", " --stack " n_words" 46 | Stack size, in 32-bit words. Default is 1024. 47 | .TP 48 | .BR -v ", " --verbose 49 | Verbose execution: print out useful information during and after 50 | execution of the byte code, for example the maximum size of the stack. 51 | .TP 52 | .BR -V ", " --version 53 | Display Hedgehog LISP version and other information, and then exit. 54 | -------------------------------------------------------------------------------- /hhprof: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Profilation script for Hedgehog. 4 | 5 | asm="$1" 6 | prof="$2" 7 | 8 | if [ -z "$1" -o -z "$2" ] 9 | then 10 | echo "Usage: $0 assembly-file profilation-output-file" 1>&2 11 | exit 1 12 | fi 13 | 14 | sed '1,/^Instruction execution count follows:$/d' "$prof" | 15 | grep -v '^CAN: ' | 16 | sort -k 2 -n -r -s | 17 | while read instr count 18 | do 19 | echo -n "$count " 20 | grep "^$instr" "$asm" 21 | done | 22 | awk '{ t[$3] += $1 } END { for (x in t) print t[x], x }' | 23 | sort -nr 24 | -------------------------------------------------------------------------------- /linked-list.fig: -------------------------------------------------------------------------------- 1 | #FIG 3.2 2 | Landscape 3 | Center 4 | Metric 5 | A4 6 | 100.00 7 | Single 8 | -2 9 | 1200 2 10 | 6 225 225 1125 675 11 | 2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 12 | 225 225 1125 225 1125 675 225 675 225 225 13 | 2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 14 | 675 225 675 675 15 | -6 16 | 6 1575 225 2475 675 17 | 2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 18 | 1575 225 2475 225 2475 675 1575 675 1575 225 19 | 2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 20 | 2025 225 2025 675 21 | -6 22 | 6 2925 225 3825 675 23 | 2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 24 | 2925 225 3825 225 3825 675 2925 675 2925 225 25 | 2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 26 | 3375 225 3375 675 27 | -6 28 | 2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 29 | 225 1125 675 1125 675 1575 225 1575 225 1125 30 | 2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 31 | 1575 1125 2025 1125 2025 1575 1575 1575 1575 1125 32 | 2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5 33 | 2925 1125 3375 1125 3375 1575 2925 1575 2925 1125 34 | 2 1 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 2 35 | 3375 675 3825 225 36 | 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 2 37 | 0 0 1.00 60.00 120.00 38 | 450 450 450 1125 39 | 0.000 0.000 40 | 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 2 41 | 0 0 1.00 60.00 120.00 42 | 3150 450 3150 1125 43 | 0.000 0.000 44 | 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 2 45 | 0 0 1.00 60.00 120.00 46 | 1800 450 1800 1125 47 | 0.000 0.000 48 | 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 2 49 | 0 0 1.00 60.00 120.00 50 | 900 450 1575 450 51 | 0.000 0.000 52 | 3 2 0 1 0 7 50 0 -1 0.000 0 1 0 2 53 | 0 0 1.00 60.00 120.00 54 | 2250 450 2925 450 55 | 0.000 0.000 56 | 4 0 0 50 0 0 24 0.0000 4 255 180 1755 1485 2\001 57 | 4 0 0 50 0 0 24 0.0000 4 255 180 3105 1485 3\001 58 | 4 0 0 50 0 0 24 0.0000 4 255 180 405 1485 1\001 59 | -------------------------------------------------------------------------------- /oliodoc.css: -------------------------------------------------------------------------------- 1 | body { 2 | color: #000000; 3 | background: #ffffff; 4 | font-family: serif; 5 | margin-left: 10%; 6 | margin-right: 10%; 7 | text-align: justify; 8 | } 9 | 10 | p.title { 11 | text-align: center; 12 | margin-left: 20%; 13 | margin-right: 20%; 14 | margin-top: 5ex; 15 | margin-bottom: 5ex; 16 | padding-top: 1ex; 17 | font-size: 150%; 18 | } 19 | 20 | h1 { 21 | text-align: left; 22 | margin-left: -5%; 23 | margin-right: 0%; 24 | padding-top: 1ex; 25 | font-size: 150%; 26 | } 27 | 28 | h2 { 29 | text-align: left; 30 | margin-left: -5%; 31 | margin-right: 0%; 32 | padding-top: 1ex; 33 | font-size: 110%; 34 | } 35 | 36 | a:link { 37 | color:#0000ff; 38 | } 39 | 40 | a:visited { 41 | color:#000077; 42 | } 43 | 44 | a:active { 45 | color:#ff0000; 46 | } 47 | 48 | a:hover { 49 | background: #dddddd; 50 | } 51 | 52 | div.authors { 53 | text-align: center; 54 | margin-bottom: 5ex; 55 | } 56 | 57 | div.example { 58 | border-width: 1pt; 59 | border-color: black; 60 | border-style: solid; 61 | padding-left: 1em; 62 | padding-right: 1em; 63 | margin-bottom: 1ex; 64 | } 65 | 66 | div.figure { 67 | margin-left: 2em; 68 | margin-right: 2em; 69 | font-style: italic; 70 | } 71 | 72 | div.table { 73 | margin-left: 2em; 74 | margin-right: 2em; 75 | } 76 | 77 | p.tabletitle { 78 | font-style: italic; 79 | } 80 | 81 | table { 82 | width: 100%; 83 | text-align: left; 84 | border-width: 1pt; 85 | border-color: black; 86 | border-style: solid; 87 | } 88 | 89 | table.figure { 90 | border-width: 0pt; 91 | } 92 | 93 | td.func { 94 | width: 25%; 95 | vertical-align: top; 96 | } 97 | 98 | td.desc { 99 | vertical-align: top; 100 | } 101 | 102 | dl { 103 | margin-left: 0em; 104 | margin-right: 0em; 105 | border-width: 0pt; 106 | border-color: black; 107 | border-style: solid; 108 | padding: 0em 0em 0em 0em; 109 | } 110 | 111 | dt { 112 | font-weight: bold; 113 | } 114 | 115 | dd { 116 | } 117 | -------------------------------------------------------------------------------- /prelude.d/050-controls.hl: -------------------------------------------------------------------------------- 1 | ;; This file is part of Hedgehog LISP standard library. 2 | ;; Copyright (C) 2003, 2004, 2005 Oliotalo Ltd. 3 | ;; See file LICENSE.BSD for pertinent licensing conditions. 4 | ;; 5 | ;; Author: Lars Wirzenius 6 | ;; Kenneth Oksanen 7 | 8 | 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | ;; Section: Control structures 11 | ;; 12 | ;; The following control structures are implemented at the Lisp level, 13 | ;; using macros. 14 | 15 | ;; (cond predicate_1 expr_1 predicate_2 expr_2 ... default_expr) is a 16 | ;; replacement for multiple 'if' expressiones within each other. 17 | 18 | (def-syntax (cond ?c ?t ... ?r) 19 | (if ?c ?t (cond ... ?r))) 20 | (def-syntax (cond ?c ?t) 21 | (if ?c ?t)) 22 | (def-syntax (cond ?e) 23 | ?e) 24 | 25 | ;; (let symbol_1 expr_1 symbol_2 expr_2 ... expr) is a replacement for 26 | ;; multiple (set foo bar) sequences. expr_i are evaluated and bound to 27 | ;; symbol_i in sequence, and the bindings are not visible outside the let. 28 | ;; Note that there are fewer parentheses than in most Lisp dialects. 29 | ;; 30 | ;; Example: (let foo 1 bar 2 (pr (+ foo bar))) prints out 3. 31 | 32 | (def-syntax (let ?name ?value ... ?rest) 33 | (do (set ?name ?value) 34 | (let ... ?rest))) 35 | 36 | (def-syntax (let ?name ?value ?expr) 37 | (do (set ?name ?value) 38 | ?expr)) 39 | 40 | ;; (def-record record_name field_1 value_1 ...) defines a set of 41 | ;; macros for accessing and updating fields mnemonically in a tuple. 42 | ;; For example (def-record abc a 1 b 2 c 3) creates a record called abc 43 | ;; containing three fields a, b, and c with default values of 1, 2, and 3, 44 | ;; respectively. The record definition expands into three macros abc-a, 45 | ;; abc-b, and abc-c for reading the fields of the record, and abc-with-a, 46 | ;; abc-with-b etc. for copying the given record with the respective field 47 | ;; bound to a new value. Furthermore a new value abc-default containing 48 | ;; the default bindings of abc is generated. 49 | 50 | (def-syntax (def-record ?name ... ?fields) 51 | (def-record-accessors ?name ?fields 0) 52 | (def-record-withs ?name ?fields 0) 53 | (set (## ?name - default) 54 | (tuple-make-from-list (def-record-values ?fields)))) 55 | 56 | (def-syntax (def-record-accessors ?name () ?n) 57 | ()) 58 | (def-syntax (def-record-accessors ?name (?field ?value ... ?fields) ?n) 59 | (def-syntax ((## ?name - ?field) (#' ?record)) 60 | (tuple-index (#' ?record) ?n)) 61 | (def-record-accessors ?name ?fields (+ ?n 1))) 62 | 63 | (def-syntax (def-record-withs ?name () ?n) 64 | ()) 65 | (def-syntax (def-record-withs ?name (?field ?value ... ?fields) ?n) 66 | (def-syntax ((## ?name -with- ?field) (#' ?record) (#' ?value)) 67 | (tuple-with (#' ?record) ?n (#' ?value))) 68 | (def-record-withs ?name ?fields (+ ?n 1))) 69 | 70 | (def-syntax (def-record-values ()) 71 | ()) 72 | (def-syntax (def-record-values (?field ?value ... ?fields)) 73 | (cons ?value (def-record-values ?fields))) 74 | 75 | -------------------------------------------------------------------------------- /prelude.d/100-builtins.hl: -------------------------------------------------------------------------------- 1 | ;; This file is part of Hedgehog LISP standard library. 2 | ;; Copyright (C) 2003, 2004, 2005 Oliotalo Ltd. 3 | ;; See file LICENSE.BSD for pertinent licensing conditions. 4 | ;; 5 | ;; Author: Kenneth Oksanen 6 | ;; Lars Wirzenius 7 | 8 | ;; (Commented indented by one so that it wouldn't be included in the 9 | ;; automatically generated documentation.) 10 | ;; This file also defines higher-order counterparts to all primitives 11 | ;; which are recognized by the compiler only if they appear with their 12 | ;; real symbol in the head of an s-expression. See hh_builtins.def for 13 | ;; documentation. 14 | 15 | (def (and ... args) 16 | (or (nil? args) (builtin-and args))) 17 | (def (builtin-and args) 18 | (if (nil? (cdr args)) 19 | (car args) 20 | (and (car args) (builtin-and (cdr args))))) 21 | 22 | (def (or ... args) 23 | (or (nil? args) (builtin-or args))) 24 | (def (builtin-or args) 25 | (if (nil? (cdr args)) 26 | (car args) 27 | (or (car args) (builtin-or (cdr args))))) 28 | 29 | (def (not arg) 30 | (not arg)) 31 | 32 | (def (cons a d) 33 | (cons a d)) 34 | 35 | (def (car o) 36 | (car o)) 37 | 38 | (def (cdr o) 39 | (cdr o)) 40 | 41 | (def (tuple-arity x) 42 | (tuple-arity x)) 43 | 44 | (def (tuple-make ... x) 45 | (tuple-make-from-list x)) 46 | 47 | (def (tuple-make-from-list l) 48 | (tuple-make-from-list l)) 49 | 50 | (def (tuple-index x i) 51 | (tuple-index x i)) 52 | 53 | (def (tuple-with x i v) 54 | (tuple-with x i v)) 55 | 56 | (def (avl-make-node k v l r) 57 | (avl-make-node k v l r)) 58 | 59 | (def (avl-height n) 60 | (avl-height n)) 61 | 62 | (def (avl-key n) 63 | (avl-key n)) 64 | 65 | (def (avl-value n) 66 | (avl-value n)) 67 | 68 | (def (avl-left n) 69 | (avl-left n)) 70 | 71 | (def (avl-right n) 72 | (avl-right n)) 73 | 74 | (def (default-cmpfun x y) 75 | (default-cmpfun x y)) 76 | 77 | (def (default-avl-get t k d) 78 | (default-avl-get t k d)) 79 | 80 | (def (default-avl-put t k v) 81 | (default-avl-put t k v)) 82 | 83 | (def (int? x) 84 | (int? x)) 85 | 86 | (def (string? x) 87 | (string? x)) 88 | 89 | (def (symbol? x) 90 | (symbol? x)) 91 | 92 | (def (fn? x) 93 | (fn? x)) 94 | 95 | (def (cons? x) 96 | (cons? x)) 97 | 98 | (def (eq? x y) 99 | (eq? x y)) 100 | 101 | ;; Are two values equal? 102 | ;; 103 | ;; The builtin eq? doesn't deal with lists, for example. This 104 | ;; function returns true of eq? returns true for its arguments, or if 105 | ;; both arguments are cons and equal? is true for both element pairs, 106 | ;; or if the two arguments are structurally identical AVL-trees with 107 | ;; equal? keys and values. 108 | 109 | (def (equal? a b) 110 | (cond 111 | (eq? a b) 112 | t 113 | (and (cons? a) (cons? b)) 114 | (and (equal? (car a) (car b)) 115 | (tailcall (equal? (cdr a) (cdr b)))) 116 | (and (> (avl-height a) 0) (> (avl-height b) 0)) 117 | (and (equal? (avl-key a) (avl-key b)) 118 | (equal? (avl-value a) (avl-value b)) 119 | (equal? (avl-left a) (avl-left b)) 120 | (tailcall (equal? (avl-right a) (avl-right b)))) 121 | nil)) 122 | 123 | (def (< ... args) 124 | (builtin-< args)) 125 | (def (builtin-< args) 126 | (if (and args (cdr args)) 127 | (if (< (car args) (car (cdr args))) 128 | (tailcall (builtin-< (cdr args))) 129 | nil) 130 | t)) 131 | 132 | (def (<= ... args) 133 | (builtin-<= args)) 134 | (def (builtin-<= args) 135 | (if (and args (cdr args)) 136 | (if (<= (car args) (car (cdr args))) 137 | (tailcall (builtin-<= (cdr args))) 138 | nil) 139 | t)) 140 | 141 | (def (> ... args) 142 | (builtin-> args)) 143 | (def (builtin-> args) 144 | (if (and args (cdr args)) 145 | (if (> (car args) (car (cdr args))) 146 | (tailcall (builtin-> (cdr args))) 147 | nil) 148 | t)) 149 | 150 | (def (>= ... args) 151 | (builtin->= args)) 152 | (def (builtin->= args) 153 | (if (and args (cdr args)) 154 | (if (>= (car args) (car (cdr args))) 155 | (tailcall (builtin->= (cdr args))) 156 | nil) 157 | t)) 158 | 159 | (def (= ... args) 160 | (builtin-= args)) 161 | (def (builtin-= args) 162 | (if (and args (cdr args)) 163 | (if (= (car args) (car (cdr args))) 164 | (tailcall (builtin-= (cdr args))) 165 | nil) 166 | t)) 167 | 168 | (def (!= ... args) 169 | (builtin-!= args)) 170 | (def (builtin-!= args) 171 | (if (and args (cdr args)) 172 | (if (!= (car args) (car (cdr args))) 173 | (tailcall (builtin-!= (cdr args))) 174 | nil) 175 | t)) 176 | 177 | (def (+ ... args) 178 | (builtin-+ args 0)) 179 | (def (builtin-+ args sum) 180 | (if args 181 | (tailcall (builtin-+ (cdr args) (+ (car args) sum))) 182 | sum)) 183 | 184 | (def (- arg ... args) 185 | (if args 186 | (- arg (builtin-+ args)) 187 | (- arg))) 188 | 189 | (def (* ... args) 190 | (builtin-* args 1)) 191 | (def (builtin-* args product) 192 | (if args 193 | (tailcall (builtin-* (cdr args) (* (car args) product))) 194 | product)) 195 | 196 | (def (/ arg ... args) 197 | (if args 198 | (/ arg (builtin-* args)) 199 | arg)) 200 | 201 | (def (% a b) 202 | (% a b)) 203 | 204 | (def (& arg ... args) 205 | (builtin-& arg args)) 206 | (def (builtin-& arg args) 207 | (if args 208 | (tailcall (builtin-& (& arg (car args)) (cdr args))) 209 | arg)) 210 | 211 | (def (| arg ... args) 212 | (builtin-| arg args)) 213 | (def (builtin-| arg args) 214 | (if args 215 | (tailcall (builtin-| (| arg (car args)) (cdr args))) 216 | arg)) 217 | 218 | (def (~ x) 219 | (~ x)) 220 | 221 | (def (^ arg ... args) 222 | (builtin-^ arg args)) 223 | (def (builtin-^ arg args) 224 | (if args 225 | (tailcall (builtin-^ (^ arg (car args)) (cdr args))) 226 | arg)) 227 | 228 | ;; Alternative syntaxes for bit operations - some prefer not to use 229 | ;; characters which mess emacs modes, for example... 230 | 231 | (def-syntax bitwise-and &) 232 | (def-syntax bitwise-or |) 233 | (def-syntax bitwise-xor ^) 234 | (def-syntax bitwise-not ~) 235 | 236 | 237 | (def (<< value n) 238 | (<< value n)) 239 | 240 | (def (>> value n) 241 | (>> value n)) 242 | 243 | (def (strlen s) 244 | (strlen s)) 245 | 246 | (def (substr str pos len) 247 | (substr str pos len)) 248 | 249 | (def (strcmp str1 str2) 250 | (strcmp str1 str2)) 251 | 252 | (def (ord s) 253 | (ord s)) 254 | 255 | (def (chr s) 256 | (chr s)) 257 | 258 | (def (strcat arg ... args) 259 | (builtin-strcat arg args)) 260 | (def (builtin-strcat arg args) 261 | (if args 262 | (tailcall (builtin-strcat (strcat arg (car args)) (cdr args))) 263 | arg)) 264 | 265 | (def (atoi str base) 266 | (atoi str base)) 267 | 268 | (def (itoa value base) 269 | (itoa value base)) 270 | 271 | (def (symboltostring x) 272 | (symboltostring x)) 273 | 274 | (def (strstr string pattern) 275 | (strstr string pattern)) 276 | 277 | (def (strrstr string pattern) 278 | (strrstr string pattern)) 279 | 280 | (def (strsplit-last string sep) 281 | (strsplit-last string sep)) 282 | 283 | (def (hex string) 284 | (hex string)) 285 | 286 | (def (print ... x) 287 | (builtin-print x)) 288 | (def (builtin-print x) 289 | (if x 290 | (do (print (car x)) 291 | (tailcall (builtin-print (cdr x)))))) 292 | 293 | (def (snprint l a val) 294 | (snprint l a val)) 295 | 296 | (def (panic ... x) 297 | (builtin-panic x)) 298 | (def (builtin-panic x) 299 | (if x 300 | (do (print (car x)) 301 | (tailcall (builtin-panic (cdr x)))) 302 | (panic))) 303 | 304 | (def (available-mem) 305 | (available-mem)) 306 | 307 | (def (gc) 308 | (gc)) 309 | 310 | #ifdef HH_UNIX 311 | 312 | (def (unix-gettimeofday) 313 | (unix-gettimeofday)) 314 | 315 | (def (unix-fork) 316 | (unix-fork)) 317 | 318 | (def (unix-exec filename argv envp) 319 | (unix-exec filename argv envp)) 320 | 321 | (def (unix-dup2 from_fd to_fd) 322 | (unix-dup2 from_fd to_fd)) 323 | 324 | (def (unix-close fd) 325 | (unix-close fd)) 326 | 327 | (def (unix-select secs msecs) 328 | (unix-select secs msecs)) 329 | 330 | (def (unix-add-to-read-fds fd) 331 | (unix-add-to-read-fds fd)) 332 | 333 | (def (unix-add-to-write-fds fd) 334 | (unix-add-to-write-fds fd)) 335 | 336 | (def (unix-fd-is-readable fd) 337 | (unix-fd-is-readable fd)) 338 | 339 | (def (unix-fd-is-writable fd) 340 | (unix-fd-is-writable fd)) 341 | 342 | (def (unix-clr-fdsets) 343 | (unix-clr-fdsets)) 344 | 345 | (def (unix-dir-list dirname) 346 | (unix-dir-list dirname)) 347 | 348 | (def (unix-unlink filename) 349 | (unix-unlink filename)) 350 | 351 | (def (unix-open filename flags) 352 | (unix-open filename flags)) 353 | 354 | (def (unix-socket domain type proto) 355 | (unix-socket domain type proto)) 356 | 357 | (def (unix-setsockopt sock lev optname optval) 358 | (unix-setsockopt sock lev optname optval)) 359 | 360 | (def (unix-fcntl fd cmd data) 361 | (unix-fcntl fd cmd data)) 362 | 363 | (def (unix-connect sock addr) 364 | (unix-connect sock addr)) 365 | 366 | (def (unix-bind sock addr) 367 | (unix-bind sock addr)) 368 | 369 | (def (unix-listen sock backlog) 370 | (unix-listen sock backlog)) 371 | 372 | (def (unix-accept sock) 373 | (unix-accept sock)) 374 | 375 | (def (unix-read fd nbytes) 376 | (unix-read fd nbytes)) 377 | 378 | (def (unix-write fd data) 379 | (unix-write fd data)) 380 | 381 | (def (unix-recvfrom sock nbytes flags) 382 | (unix-recvfrom sock nbytes flags)) 383 | 384 | (def (unix-sendto sock data flags addr) 385 | (unix-sendto sock data flags addr)) 386 | 387 | (def (unix-mount source target fstype flags data) 388 | (unix-mount source target fstype flags data)) 389 | 390 | (def (unix-umount target) 391 | (unix-umount target)) 392 | 393 | (def (unix-usleep usecs) 394 | (unix-usleep usecs)) 395 | 396 | (def (unix-errno) 397 | (unix-errno)) 398 | 399 | (def (unix-tcgetattr fd) 400 | (unix-tcgetattr fd)) 401 | 402 | (def (unix-tcsetattr fd acts termios) 403 | (unix-tcsetattr fd acts termios)) 404 | 405 | (def (unix-tcdrain fd) 406 | (unix-tcdrain fd)) 407 | 408 | (def (unix-tcflush fd queue) 409 | (unix-tcflush fd queue)) 410 | 411 | (def (unix-tcflow fd action) 412 | (unix-tcflow fd action)) 413 | 414 | (def (unix-cfmakeraw termios) 415 | (unix-cfmakeraw termios)) 416 | 417 | (def (unix-cfgetispeed termios) 418 | (unix-cfgetispeed termios)) 419 | 420 | (def (unix-cfgetospeed termios) 421 | (unix-cfgetospeed termios)) 422 | 423 | (def (unix-cfsetispeed termios speed) 424 | (unix-cfsetispeed termios speed)) 425 | 426 | (def (unix-cfsetospeed termios speed) 427 | (unix-cfsetospeed termios speed)) 428 | 429 | #endif 430 | -------------------------------------------------------------------------------- /prelude.d/200-unit-testing.hl: -------------------------------------------------------------------------------- 1 | ;; This file is part of Hedgehog LISP standard library. 2 | ;; Copyright (C) 2003, 2004 Oliotalo Ltd. 3 | ;; See file LICENSE.BSD for pertinent licensing conditions. 4 | ;; 5 | ;; Author: Lars Wirzenius 6 | 7 | 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;; Section: Unit testing 10 | ;; 11 | ;; The functions in this section provide for a simple form of automatic 12 | ;; unit testing. They are used extensively within the standard library 13 | ;; implementation. Eventually it will be possible to turn running of 14 | ;; the unit tests on and off with a compiler command line option. 15 | ;; Always write your unit tests so that it doesn't matter for the 16 | ;; execution of the library or application whether they are actually 17 | ;; executed. 18 | 19 | 20 | #ifdef DEBUG 21 | 22 | ;; Abort program unless `expr' is true. 23 | 24 | (def-syntax (fail-unless ?expr) 25 | (if (not ?expr) 26 | (panic "\nERROR: Condition " (quote ?expr) " failed.\n"))) 27 | 28 | #else 29 | 30 | (def-syntax (fail-unless ?expr) nil) 31 | 32 | #endif 33 | 34 | (fail-unless (equal? nil nil)) 35 | (fail-unless (equal? 'a 'a)) 36 | (fail-unless (equal? 42 42)) 37 | (fail-unless (equal? "hello" "hello")) 38 | (fail-unless (equal? '(a b) '(a b))) 39 | (fail-unless (equal? '(a (b c) d) '(a (b c) d))) 40 | 41 | (fail-unless (not (equal? '(a (b c) d) '(a b c d)))) 42 | 43 | 44 | #ifdef DEBUG 45 | 46 | ;; Abort program unless `a' equals `b'. 47 | 48 | (def-syntax (fail-unless-equal ?a ?b) 49 | (let 50 | ??a ?a 51 | (if (not (equal? ??a ?b)) 52 | (panic "\nERROR: " (quote ?a) " is " ??a 53 | " but should have been " (quote ?b) "\n")))) 54 | 55 | #else 56 | 57 | (def-syntax (fail-unless-equal ?a ?b) nil) 58 | 59 | #endif 60 | -------------------------------------------------------------------------------- /prelude.d/400-avl.hl: -------------------------------------------------------------------------------- 1 | ;; This file is part of Hedgehog LISP standard library. 2 | ;; Copyright (C) 2003, 2004, 2005 Oliotalo Ltd. 3 | ;; See file LICENSE.BSD for pertinent licensing conditions. 4 | ;; 5 | ;; Author: Kenneth Oksanen 6 | 7 | 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;; Section: AVL-trees 10 | ;; 11 | ;; AVL-trees are an efficient balanced binary tree. 12 | ;; 13 | ;; You probably want to use the dict routines instead. They wrap around 14 | ;; the AVL routines to provide a nicer interface. 15 | 16 | (def (avl-make-node key value left right) 17 | (avl-make-node key value left right)) 18 | 19 | (def (avl-height node) 20 | (avl-height node)) 21 | 22 | (def (avl-key node) 23 | (avl-key node)) 24 | 25 | (def (avl-value node) 26 | (avl-value node)) 27 | 28 | (def (avl-left node) 29 | (avl-left node)) 30 | 31 | (def (avl-right node) 32 | (avl-right node)) 33 | 34 | ;; Perform a search in the given tree using the given comparison 35 | ;; function. Return the value stored for the given key, or 36 | ;; `default-value' if not found. Prefer the built-in 37 | ;; `default-avl-get' for performance reasons if the default comparison 38 | ;; function suffices. 39 | 40 | (def (avl-get tree cmpfun key default-value) 41 | (if tree 42 | (do (set cmp (cmpfun key (avl-key tree))) 43 | (if (< cmp 0) 44 | (tailcall (avl-get (avl-left tree) cmpfun key default-value)) 45 | (if (> cmp 0) 46 | (tailcall (avl-get (avl-right tree) cmpfun key 47 | default-value)) 48 | (avl-value tree)))) 49 | default-value)) 50 | 51 | ;; Perform insertion/replacement in the given tree using the default 52 | ;; comparison function. Return the new tree. Prefer the built-in 53 | ;; `default-avl-put' for performance reasons if the default comparison 54 | ;; function suffices. 55 | 56 | (def (avl-put tree cmpfun key value) 57 | (if tree 58 | (do (set cmp (cmpfun key (avl-key tree))) 59 | (if (< cmp 0) 60 | (avl-make-node (avl-key tree) 61 | (avl-value tree) 62 | (avl-put (avl-left tree) cmpfun key value) 63 | (avl-right tree)) 64 | (if (> cmp 0) 65 | (avl-make-node (avl-key tree) 66 | (avl-value tree) 67 | (avl-left tree) 68 | (avl-put (avl-right tree) cmpfun key value)) 69 | (avl-make-node key 70 | value 71 | (avl-left tree) 72 | (avl-right tree))))) 73 | (avl-make-node key 74 | value 75 | nil 76 | nil))) 77 | 78 | ;; Fold the given operation over all key-value pairs in the AVL-tree. 79 | ;; The operation takes three arguments: the key and value found in the 80 | ;; AVL-tree and the previously returned value of the operation. 81 | 82 | (def (avl-fold tree operation zero) 83 | (if tree 84 | (avl-fold (avl-right tree) 85 | operation 86 | (operation (avl-key tree) 87 | (avl-value tree) 88 | (avl-fold (avl-left tree) operation zero))) 89 | zero)) 90 | 91 | ;; Similar to avl-fold, but the operation can update the values in the 92 | ;; tree. The operation returns a cons cell whose car is the new value 93 | ;; and cdr is the return value of the operation. The entire 94 | ;; fold-update returns a cons whose car is the tree with updated 95 | ;; values and cdr the value of the last operation. 96 | 97 | (def (avl-fold-update tree operation zero) 98 | (if tree 99 | (let left (avl-fold-update (avl-left tree) operation zero) 100 | mid (operation (avl-key tree) (avl-value tree) (cdr left)) 101 | right (avl-fold-update (avl-right tree) operation (cdr mid)) 102 | (cons (avl-make-node (avl-key tree) 103 | (car mid) 104 | (car left) 105 | (car right)) 106 | (cdr right))) 107 | (cons tree zero))) 108 | 109 | 110 | (def (default-cmpfun a b) 111 | (default-cmpfun a b)) 112 | 113 | (def (default-avl-get tree key default-value) 114 | (default-avl-get tree key default-value)) 115 | 116 | (def (default-avl-put tree key default-value) 117 | (default-avl-put tree key default-value)) 118 | -------------------------------------------------------------------------------- /prelude.d/400-dict.hl: -------------------------------------------------------------------------------- 1 | ;; This file is part of Hedgehog LISP standard library. 2 | ;; Copyright (C) 2003, 2004, 2005 Oliotalo Ltd. 3 | ;; See file LICENSE.BSD for pertinent licensing conditions. 4 | ;; 5 | ;; Author: Kenneth Oksanen 6 | ;; Lars Wirzenius 7 | 8 | 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | ;; Section: A Python-like dictionary 11 | ;; 12 | ;; In Python, a dictionary maps a key (of some suitable type) to a value 13 | ;; (of any type). In other languages, it might be called a hash table, 14 | ;; hash map. 15 | ;; 16 | ;; The functions in this section implement a fairly efficient dictionary 17 | ;; using AVL tree routines (but this implementation detail is invisible 18 | ;; to the caller). The key MUST be an integer, a symbol, or a string. 19 | 20 | ;; Add a new value to the dictionary, replacing any old one for KEY. 21 | ;; Return a new dict. 22 | 23 | (def (dict-set dict key value) 24 | (default-avl-put dict key value)) 25 | 26 | ; Let's define a macro version as well, to avoid the function call overhead. 27 | ; Tests show that this has a small, but significant effect, when there 28 | ; would be a lot of function calls otherwise. 29 | 30 | (def-syntax (dict-set ?dict ?key ?value) 31 | (default-avl-put ?dict ?key ?value)) 32 | 33 | ;; Get the value corresponding to a key in a dictionary. 34 | ;; Return nil if the key had no value. 35 | 36 | (def (dict-get dict key) 37 | (default-avl-get dict key nil)) 38 | 39 | (def-syntax (dict-get ?dict ?key) 40 | (default-avl-get ?dict ?key nil)) 41 | 42 | ;; Remove a value corresponding to a key. Return new dictionary. 43 | 44 | (def (dict-remove dict key) 45 | (dict-set dict key nil)) 46 | 47 | (def-syntax (dict-remove ?dict ?key) 48 | (dict-set ?dict ?key nil)) 49 | 50 | ;; Set many key-value pairs in a dictionary at once. The pairs are given 51 | ;; as a list. 52 | 53 | (def (dict-set-from-list dict pairs) 54 | (if (nil? pairs) 55 | dict 56 | (tailcall (dict-set-from-list (dict-set dict 57 | (car (car pairs)) 58 | (cdr (car pairs))) 59 | (cdr pairs))))) 60 | 61 | ;; Set many key-value pairs in a dictionary at once. The pairs are given 62 | ;; as separate arguments. This function is useful for initializing a 63 | ;; dictionary with default values for many keys. 64 | 65 | (def (dict-set-many dict ... pairs) 66 | (dict-set-from-list dict pairs)) 67 | 68 | ;; Create a new dictionary. If the variable argument list is empty, the 69 | ;; new dictionary will also be empty. Otherwise the argument list shall 70 | ;; contain pairs (cons cells) where the first element is a key and the 71 | ;; second element is the value. The new dictionary will then contain 72 | ;; these key-value pairs. 73 | ;; 74 | ;; You can also use a plain nil value for an empty dictionary. 75 | 76 | (def (dict-create ... pairs) 77 | (dict-set-from-list nil pairs)) 78 | 79 | ;; This is similar to dict-set, but the value to be set is done by calling 80 | ;; '(fun old-value)'. Returns a new dict. 81 | 82 | (def (dict-update dict key fun) 83 | (set x (dict-get dict key)) 84 | (dict-set dict key (fun x))) 85 | 86 | ;; If the dictionary empty? 87 | 88 | (def (dict-empty? dict) 89 | (nil? dict)) 90 | 91 | ;; Return the smallest key in the dict, or nil if the dict is empty. 92 | 93 | (def (dict-smallest-key dict) 94 | (if dict 95 | (if (avl-left dict) 96 | (tailcall (dict-smallest-key (avl-left dict))) 97 | (avl-key dict)) 98 | nil)) 99 | 100 | ;; Return the largest key in the dict, or nil if the dict is empty. 101 | 102 | (def (dict-largest-key dict) 103 | (if dict 104 | (if (avl-right dict) 105 | (tailcall (dict-largest-key (avl-right dict))) 106 | (avl-key dict)) 107 | nil)) 108 | 109 | ;; Get a value from a dictionary within a dictionary. That is, 110 | ;; 'dict1' at key 'key1' is a dictionary, and that one is indexed with 111 | ;; 'key2'. 112 | 113 | (def (dict-get2 dict1 key1 key2) 114 | (let 115 | dict2 (dict-get dict1 key1) 116 | (if (nil? dict2) 117 | nil 118 | (dict-get dict2 key2)))) 119 | 120 | ;; Set a value in a dictionary within a dictionary. See dict-get2. 121 | 122 | (def (dict-set2 dict1 key1 key2 value) 123 | (let 124 | dict2 (dict-get dict1 key1) 125 | dict2 (dict-set dict2 key2 value) 126 | (dict-set dict1 key1 dict2))) 127 | 128 | ; Unit tests for dict. 129 | 130 | (fail-unless-equal (dict-create) nil) 131 | (fail-unless (not (nil? (dict-create (cons 'a 1) (cons 'b 2))))) 132 | 133 | (fail-unless-equal (dict-get (dict-create) 'a) nil) 134 | (fail-unless-equal (dict-get (dict-create (cons 'a 'b)) 'a) 'b) 135 | (fail-unless-equal (dict-get (dict-set (dict-create) 'a 'b) 'a) 'b) 136 | (fail-unless-equal (dict-get (dict-set (dict-create) 'a 'b) 'b) nil) 137 | 138 | (fail-unless-equal (dict-get (dict-set (dict-create (cons 'a 'b)) 'a 'c) 'a) 'c) 139 | (fail-unless-equal (dict-get (dict-set (dict-create (cons 'a 'b)) 'b 'c) 'a) 'b) 140 | (fail-unless-equal (dict-get (dict-set (dict-create (cons 'a 'b)) 'b 'c) 'b) 'c) 141 | (fail-unless-equal (dict-get (dict-remove (dict-create (cons 'a 'b)) 'a) 'a) nil) 142 | -------------------------------------------------------------------------------- /prelude.d/400-getput.hl: -------------------------------------------------------------------------------- 1 | ;; This file is part of Hedgehog LISP standard library. 2 | ;; Copyright (C) 2005 Oliotalo Ltd. 3 | ;; See file LICENSE.BSD for pertinent licensing conditions. 4 | ;; 5 | ;; Author: Kenneth Oksanen 6 | 7 | 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;; Section: Manipulating byte orders and integers in C structs as Lisp strings. 10 | ;; 11 | 12 | ;; These are mostly auxiliary routines for the automatically generated 13 | ;; file 300-unix.hl 14 | 15 | ;; Swap the byte order of a 16-bit integer x. 16 | 17 | (def (c-swap-short x) 18 | (bitwise-or (>> x 8) 19 | (<< (bitwise-and x 0xFF) 8))) 20 | 21 | ;; Swap the byte order of a 32-bit integer x. 22 | 23 | (def (c-swap-int x) 24 | (bitwise-or (>> x 24) 25 | (<< x 24) 26 | (bitwise-and (>> x 8) 0xFF00) 27 | (<< (bitwise-and x 0xFF00) 8))) 28 | 29 | #ifdef HH_MOST_SIGNIFICANT_BYTE_FIRST 30 | ;; Convert a 32-bit integer into a 4-character Lisp string in the host 31 | ;; byte order. 32 | 33 | (def (c-int-to-string4 v) 34 | (strcat (chr (>> v 24)) 35 | (chr (bitwise-and (>> v 16) 0xFF)) 36 | (chr (bitwise-and (>> v 8) 0xFF)) 37 | (chr (bitwise-and v 0xFF)))) 38 | #endif 39 | #ifdef HH_LEAST_SIGNIFICANT_BYTE_FIRST 40 | (def (c-int-to-string4 v) 41 | (strcat (chr (bitwise-and v 0xFF)) 42 | (chr (bitwise-and (>> v 8) 0xFF)) 43 | (chr (bitwise-and (>> v 16) 0xFF)) 44 | (chr (>> v 24)))) 45 | #endif 46 | 47 | 48 | #ifdef HH_MOST_SIGNIFICANT_BYTE_FIRST 49 | ;; Convert a 16-bit integer into a 2-character Lisp string in the host 50 | ;; byte order. 51 | 52 | (def (c-short-to-string2 v) 53 | (strcat (chr (bitwise-and (>> v 8) 0xFF)) 54 | (chr (bitwise-and v 0xFF)))) 55 | #endif 56 | #ifdef HH_LEAST_SIGNIFICANT_BYTE_FIRST 57 | (def (c-short-to-string2 v) 58 | (strcat (chr (bitwise-and v 0xFF)) 59 | (chr (bitwise-and (>> v 8) 0xFF)))) 60 | #endif 61 | 62 | 63 | #ifdef HH_MOST_SIGNIFICANT_BYTE_FIRST 64 | ;; Read a 32-bit integer from a 4-byte (or longer) Lisp string in the 65 | ;; host byte order. 66 | 67 | (def (c-string4-to-int s) 68 | (bitwise-or (ord (substr s 3 1)) 69 | (<< (ord (substr s 2 1)) 8) 70 | (<< (ord (substr s 1 1)) 16) 71 | (<< (ord (substr s 0 1)) 24))) 72 | #endif 73 | #ifdef HH_LEAST_SIGNIFICANT_BYTE_FIRST 74 | (def (c-string4-to-int s) 75 | (bitwise-or (ord (substr s 0 1)) 76 | (<< (ord (substr s 1 1)) 8) 77 | (<< (ord (substr s 2 1)) 16) 78 | (<< (ord (substr s 3 1)) 24))) 79 | #endif 80 | 81 | 82 | #ifdef HH_MOST_SIGNIFICANT_BYTE_FIRST 83 | ;; Read a 16-bit integer from a 4-byte (or longer) Lisp string in 84 | ;; big-endian, or network byte order. 85 | 86 | (def (c-string2-to-short s) 87 | (bitwise-or (ord (substr s 1 1)) 88 | (<< (ord (substr s 0 1)) 8))) 89 | #endif 90 | #ifdef HH_LEAST_SIGNIFICANT_BYTE_FIRST 91 | (def (c-string2-to-short s) 92 | (bitwise-or (ord (substr s 0 1)) 93 | (<< (ord (substr s 1 1)) 8))) 94 | #endif 95 | 96 | 97 | #ifdef HH_MOST_SIGNIFICANT_BYTE_FIRST 98 | ;; Equivalent of the C library function htons. 99 | 100 | (def-syntax (c-htons ?x) 101 | ?x) 102 | #endif 103 | #ifdef HH_LEAST_SIGNIFICANT_BYTE_FIRST 104 | (def-syntax (c-htons ?x) 105 | (c-swap-short ?x)) 106 | #endif 107 | 108 | #ifdef HH_MOST_SIGNIFICANT_BYTE_FIRST 109 | ;; Equivalent of the C library function ntohs. 110 | 111 | (def-syntax (c-ntohs ?x) 112 | ?x) 113 | #endif 114 | #ifdef HH_LEAST_SIGNIFICANT_BYTE_FIRST 115 | (def-syntax (c-ntohs ?x) 116 | (c-swap-short ?x)) 117 | #endif 118 | 119 | #ifdef HH_MOST_SIGNIFICANT_BYTE_FIRST 120 | ;; Equivalent of the C library function htonl. 121 | 122 | (def-syntax (c-htonl ?x) 123 | ?x) 124 | #endif 125 | #ifdef HH_LEAST_SIGNIFICANT_BYTE_FIRST 126 | (def-syntax (c-htonl ?x) 127 | (c-swap-int ?x)) 128 | #endif 129 | 130 | #ifdef HH_MOST_SIGNIFICANT_BYTE_FIRST 131 | ;; Equivalent of the C library function ntohl. 132 | 133 | (def-syntax (c-ntohl ?x) 134 | ?x) 135 | #endif 136 | #ifdef HH_LEAST_SIGNIFICANT_BYTE_FIRST 137 | (def-syntax (c-ntohl ?x) 138 | (c-swap-int ?x)) 139 | #endif 140 | 141 | 142 | ;; Read a 32-bit integer from the given offset in the string. 143 | 144 | (def-syntax (c-get-int ?string ?offset) 145 | (c-string4-to-int (substr ?string ?offset 4))) 146 | 147 | ;; Read a 16-bit integer from the given offset in the string. 148 | 149 | (def-syntax (c-get-short ?string ?offset) 150 | (c-string2-to-short (substr ?string ?offset 2))) 151 | 152 | ;; Return a new string, identical to the given one, where the given 153 | ;; 32-bit integer value has been placed in the given offset. 154 | 155 | (def (c-set-int string offset value) 156 | (let hd (substr string 0 offset) 157 | tl (substr string (+ offset 4) -1) 158 | (strcat hd 159 | (c-int-to-string4 value) 160 | tl))) 161 | 162 | ;; Return a new string, identical to the given one, where the given 163 | ;; 16-bit integer value has been placed in the given offset. 164 | 165 | (def (c-set-short string offset value) 166 | (let hd (substr string 0 offset) 167 | tl (substr string (+ offset 2) -1) 168 | (strcat hd 169 | (c-short-to-string2 value) 170 | tl))) 171 | -------------------------------------------------------------------------------- /prelude.d/400-ip.hl: -------------------------------------------------------------------------------- 1 | ;; This file is part of Hedgehog LISP standard library. 2 | ;; Copyright (C) 2005 Oliotalo Ltd. 3 | ;; See file LICENSE.BSD for pertinent licensing conditions. 4 | ;; 5 | ;; Author: Kenneth Oksanen 6 | ;; 7 | 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;; Section: IP 10 | ;; 11 | ;; Functions and values that are useful for IP-programming. 12 | 13 | ;; TCP ports. 14 | 15 | (def-syntax ip-IPPORT_ECHO 7) ; Echo service. 16 | (def-syntax ip-IPPORT_DISCARD 9) ; Discard transmissions service. 17 | (def-syntax ip-IPPORT_SYSTAT 11) ; System status service. 18 | (def-syntax ip-IPPORT_DAYTIME 13) ; Time of day service. 19 | (def-syntax ip-IPPORT_NETSTAT 15) ; Network status service. 20 | (def-syntax ip-IPPORT_FTP 21) ; File Transfer Protocol. 21 | (def-syntax ip-IPPORT_TELNET 23) ; Telnet protocol. 22 | (def-syntax ip-IPPORT_SMTP 25) ; Simple Mail Transfer Protocol. 23 | (def-syntax ip-IPPORT_TIMESERVER 37) ; Timeserver service. 24 | (def-syntax ip-IPPORT_NAMESERVER 42) ; Domain Name Service. 25 | (def-syntax ip-IPPORT_WHOIS 43) ; Internet Whois service. 26 | (def-syntax ip-IPPORT_MTP 57) 27 | (def-syntax ip-IPPORT_TFTP 69) ; Trivial File Transfer Protocol. 28 | (def-syntax ip-IPPORT_RJE 77) 29 | (def-syntax ip-IPPORT_FINGER 79) ; Finger service. 30 | (def-syntax ip-IPPORT_TTYLINK 87) 31 | (def-syntax ip-IPPORT_SUPDUP 95) ; SUPDUP protocol. 32 | (def-syntax ip-IPPORT_EXECSERVER 512) ; execd service. 33 | (def-syntax ip-IPPORT_LOGINSERVER 513) ; rlogind service. 34 | (def-syntax ip-IPPORT_CMDSERVER 514) 35 | 36 | ;; UDP ports. 37 | 38 | (def-syntax ip-IPPORT_EFSSERVER 520) 39 | (def-syntax ip-IPPORT_BIFFUDP 512) 40 | (def-syntax ip-IPPORT_WHOSERVER 513) 41 | (def-syntax ip-IPPORT_ROUTESERVER 520) 42 | (def-syntax ip-IPPORT_RESERVED 1024) ; Smaller port nums for root procs. 43 | (def-syntax ip-IPPORT_USERRESERVED 5000) ; Greater ports for user procs. 44 | 45 | 46 | ;; Make a Lisp-string that corresponds to the C struct sockaddr_in 47 | ;; from the specified port and ip numbers. 48 | 49 | (def (ip-sockaddr_in port ip) 50 | (let s_in unix-sockaddr 51 | s_in (unix-sockaddr_in-set-sin_family s_in unix-AF_INET) 52 | s_in (unix-sockaddr_in-set-sin_port s_in (c-htons port)) 53 | s_in (unix-sockaddr_in-set-sin_addr.s_addr s_in (c-htonl ip)) 54 | s_in)) 55 | -------------------------------------------------------------------------------- /prelude.d/400-list.hl: -------------------------------------------------------------------------------- 1 | ;; This file is part of Hedgehog LISP standard library. 2 | ;; Copyright (C) 2003, 2004 Oliotalo Ltd. 3 | ;; See file LICENSE.BSD for pertinent licensing conditions. 4 | ;; 5 | ;; Authors: Lars Wirzenius 6 | ;; Kenneth Oksanen 7 | ;; 8 | 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | ;; Section: List processing library functions 12 | ;; 13 | ;; The functions in this section do things with lists. Lists are assumed 14 | ;; to be constructed from cons cells in the usual manner. 15 | 16 | ;; Return a list that contains all the values given as arguments. 17 | 18 | (def (list ... args) 19 | args) 20 | 21 | ;; Return item number `n' in a list or nil if item `n' is outside the list. 22 | ;; Counting starts at zero. 23 | ;; 24 | ;; Arguments: 25 | ;; `list' the list of items 26 | ;; `n' index into the list 27 | 28 | (def (nth list n) 29 | (cond 30 | (or (< n 0) (not list)) 31 | nil 32 | (= n 0) 33 | (car list) 34 | (tailcall (nth (cdr list) (- n 1))))) 35 | 36 | (fail-unless-equal (nth nil -1) nil) 37 | (fail-unless-equal (nth nil 0) nil) 38 | (fail-unless-equal (nth nil 1) nil) 39 | 40 | (fail-unless-equal (nth '(0) -1) nil) 41 | (fail-unless-equal (nth '(0 1) -1) nil) 42 | (fail-unless-equal (nth '(0 1 2) -1) nil) 43 | 44 | (fail-unless-equal (nth '(0) 0) 0) 45 | (fail-unless-equal (nth '(0 1) 0) 0) 46 | (fail-unless-equal (nth '(0 1 2) 0) 0) 47 | 48 | (fail-unless-equal (nth '(0) 1) nil) 49 | (fail-unless-equal (nth '(0 1) 1) 1) 50 | (fail-unless-equal (nth '(0 1 2) 1) 1) 51 | 52 | (fail-unless-equal (nth '(0) 2) nil) 53 | (fail-unless-equal (nth '(0 1) 2) nil) 54 | (fail-unless-equal (nth '(0 1 2) 2) 2) 55 | 56 | 57 | ;; Is `list' equal to nil? 58 | 59 | (def (nil? list) 60 | (eq? list nil)) 61 | 62 | ; Macro to make things faster, when possible. 63 | 64 | (def-syntax (nil? ?list) 65 | (eq? ?list nil)) 66 | 67 | (fail-unless (nil? nil)) 68 | (fail-unless (not (nil? t))) 69 | (fail-unless (not (nil? 0))) 70 | 71 | 72 | ;; Accumulate a value by calling `op' on each item in `items'. The first call 73 | ;; to `op' gets `so-far' and the first item as its arguments, successive calls 74 | ;; get the previous call's return value and next item. The return value of the 75 | ;; last call to `op' is the return value of the function. If `items' is empty, 76 | ;; `op' is never called and `so-far' is returned. 77 | 78 | (def (accumulate op so-far items) 79 | (cond 80 | (not items) 81 | so-far 82 | (tailcall (accumulate op 83 | (op so-far (car items)) 84 | (cdr items))))) 85 | 86 | ;;(fail-unless-equal (accumulate + 0 '()) 0) 87 | ;;(fail-unless-equal (accumulate + 0 '(1 2 3)) 6) 88 | 89 | 90 | ;; Reverse items in a list. 91 | 92 | (def (reverse items) 93 | (accumulate 94 | (fn (so-far item) 95 | (cons item so-far)) 96 | nil 97 | items)) 98 | 99 | (fail-unless-equal (reverse '(1 2 3)) '(3 2 1)) 100 | 101 | 102 | ;; Return list containing elements of `a' and then those of `b'. 103 | 104 | (def (append a b) 105 | (cond 106 | (nil? a) b 107 | (nil? b) a 108 | (accumulate 109 | (fn (so-far item) 110 | (cons item so-far)) 111 | b 112 | (reverse a)))) 113 | 114 | (fail-unless-equal (append '(a b c) '(d e f)) '(a b c d e f)) 115 | 116 | 117 | 118 | ;; Call `func' on each item, return list of return values. 119 | 120 | (def (map func items) 121 | (reverse (accumulate (fn (so-far item) 122 | (cons (func item) so-far)) 123 | nil 124 | items))) 125 | 126 | (fail-unless-equal (map (fn (x) x) '()) '()) 127 | (fail-unless-equal (map (fn (x) (+ x 1)) '(1 2 3)) '(2 3 4)) 128 | (fail-unless-equal (map (fn (x) (* x x)) '(1 2 3)) '(1 4 9)) 129 | 130 | 131 | ;; Return items for which `pred?' returns true. 132 | 133 | (def (filter pred? items) 134 | (reverse (accumulate (fn (so-far item) 135 | (cond (pred? item) 136 | (cons item so-far) 137 | so-far)) 138 | nil 139 | items))) 140 | 141 | (fail-unless-equal (filter (fn (x) (% x 2)) '(1 2 3 4)) '(1 3)) 142 | (fail-unless-equal (filter (fn (x) (% x 2)) '(1 2 3 4)) '(1 3)) 143 | 144 | 145 | ;; Call `func' for each item. Return value of last call. 146 | 147 | (def (for-each func items) 148 | (accumulate (fn (so-far item) (func item)) nil items)) 149 | 150 | (fail-unless-equal (for-each (fn (x) x) '(1 2 3)) 3) 151 | 152 | 153 | ;; Return number of items in `list'. 154 | 155 | (def (len list) 156 | (accumulate (fn (so-far item) (+ so-far 1)) 0 list)) 157 | 158 | (fail-unless-equal (len '()) 0) 159 | (fail-unless-equal (len '(1 2 3)) 3) 160 | 161 | 162 | ;; Return the 'count' first items in a list. 163 | 164 | (def (head items count) 165 | (def (helper so-far items count) 166 | (if (or (nil? items) (<= count 0)) 167 | so-far 168 | (tailcall (helper (cons (car items) so-far) 169 | (cdr items) 170 | (- count 1))))) 171 | (reverse (helper nil items count))) 172 | 173 | (fail-unless-equal (head nil 0) nil) 174 | (fail-unless-equal (head nil 1) nil) 175 | (fail-unless-equal (head '(1 2 3) 1) '(1)) 176 | (fail-unless-equal (head '(1 2 3) 2) '(1 2)) 177 | (fail-unless-equal (head '(1 2 3) 3) '(1 2 3)) 178 | (fail-unless-equal (head '(1 2 3) 4) '(1 2 3)) 179 | 180 | 181 | ;; Skip 'n' items from the beginning of a list and return the tail. 182 | ;; For example, (nth-cdr '(1 2 3) 2) would return (3). 183 | 184 | (def (nth-cdr items n) 185 | (if (or (nil? items) (<= n 0)) 186 | items 187 | (tailcall (nth-cdr (cdr items) (- n 1))))) 188 | 189 | (fail-unless-equal (nth-cdr nil -1) nil) 190 | (fail-unless-equal (nth-cdr nil 0) nil) 191 | (fail-unless-equal (nth-cdr nil 1) nil) 192 | (fail-unless-equal (nth-cdr '(1 2 3) 0) '(1 2 3)) 193 | (fail-unless-equal (nth-cdr '(1 2 3) 1) '(2 3)) 194 | (fail-unless-equal (nth-cdr '(1 2 3) 2) '(3)) 195 | (fail-unless-equal (nth-cdr '(1 2 3) 3) nil) 196 | (fail-unless-equal (nth-cdr '(1 2 3) 4) nil) 197 | 198 | 199 | ;; Split a list into two: one with the items for which 'pred?' returns true, 200 | ;; one with the rest. Return a pair containing the two lists. 201 | 202 | (def (split pred? items) 203 | (def (helper true false items) 204 | (cond 205 | (nil? items) 206 | (cons (reverse true) (reverse false)) 207 | (pred? (car items)) 208 | (tailcall (helper (cons (car items) true) false (cdr items))) 209 | (tailcall (helper true (cons (car items) false) (cdr items))))) 210 | (helper nil nil items)) 211 | 212 | (fail-unless-equal 213 | (split int? '(1 a 2 b)) 214 | (cons '(1 2) '(a b))) 215 | 216 | 217 | ;; Rotate items in a list. For example, (rotate '(1 2 3) 1) would 218 | ;; return (2 3 1). 219 | 220 | (def (rotate items steps) 221 | (let 222 | items-len (len items) 223 | num-items (if (eq? items-len 0) 1 items-len) 224 | steps2 (% steps num-items) 225 | a (head items steps2) 226 | b (nth-cdr items steps2) 227 | (append b a))) 228 | 229 | (fail-unless-equal (rotate nil 0) nil) 230 | (fail-unless-equal (rotate nil 1) nil) 231 | (fail-unless-equal (rotate '(1 2 3) 1) '(2 3 1)) 232 | (fail-unless-equal (rotate '(1 2 3) 2) '(3 1 2)) 233 | (fail-unless-equal (rotate '(1 2 3) 3) '(1 2 3)) 234 | (fail-unless-equal (rotate '(1 2 3) 4) '(2 3 1)) 235 | 236 | 237 | ;; Return the first item in list for which `pred' returns true, nil if none. 238 | 239 | (def (list-search pred items) 240 | (cond 241 | (not items) 242 | nil 243 | (pred (car items)) 244 | (car items) 245 | (tailcall (list-search pred (cdr items))))) 246 | 247 | (fail-unless-equal (list-search (fn (x) (= x 2)) '(1 2 3)) 2) 248 | (fail-unless-equal (list-search (fn (x) (= x 4)) '(1 2 3)) nil) 249 | 250 | 251 | ;; Mergesort a list. `less-than' is called to compare to elements in 252 | ;; the list. 253 | 254 | (def (sort items less-than) 255 | 256 | (def (split items) 257 | (def (helper head tail p) 258 | (if (or (nil? p) (nil? (cdr p))) 259 | (cons head tail) 260 | (tailcall (helper (cons (car tail) head) 261 | (cdr tail) 262 | (cdr (cdr p)))))) 263 | (helper nil items items)) 264 | 265 | (def (reverse-and-append unreversed tail) 266 | (if (nil? unreversed) 267 | tail 268 | (tailcall (reverse-and-append (cdr unreversed) 269 | (cons (car unreversed) tail))))) 270 | 271 | (def (merge so-far x y) 272 | (cond 273 | (and (nil? x) (nil? y)) 274 | (reverse so-far) 275 | (nil? x) 276 | (reverse-and-append so-far y) 277 | (nil? y) 278 | (reverse-and-append so-far x) 279 | (less-than (car x) (car y)) 280 | (merge (cons (car x) so-far) 281 | (cdr x) 282 | y) 283 | (tailcall (merge (cons (car y) so-far) 284 | x 285 | (cdr y))))) 286 | 287 | (if (or (nil? items) (nil? (cdr items))) 288 | items 289 | (let 290 | pair (split items) 291 | dummy (fail-unless (<= (len (car pair)) (len (cdr pair)))) 292 | head (sort (car pair) less-than) 293 | tail (sort (cdr pair) less-than) 294 | (merge nil head tail)))) 295 | 296 | 297 | (fail-unless-equal (sort nil <) nil) 298 | 299 | (fail-unless-equal (sort '(1) <) '(1)) 300 | 301 | (fail-unless-equal (sort '(1 1) <) '(1 1)) 302 | 303 | (fail-unless-equal (sort '(1 2) <) '(1 2)) 304 | (fail-unless-equal (sort '(2 1) <) '(1 2)) 305 | 306 | (fail-unless-equal (sort '(1 1 1) <) '(1 1 1)) 307 | 308 | (fail-unless-equal (sort '(1 1 2) <) '(1 1 2)) 309 | (fail-unless-equal (sort '(1 2 1) <) '(1 1 2)) 310 | (fail-unless-equal (sort '(2 1 1) <) '(1 1 2)) 311 | -------------------------------------------------------------------------------- /prelude.d/400-math.hl: -------------------------------------------------------------------------------- 1 | ;; This file is part of Hedgehog LISP standard library. 2 | ;; Copyright (C) 2003, 2004, 2005 Oliotalo Ltd. 3 | ;; See file LICENSE.BSD for pertinent licensing conditions. 4 | ;; 5 | ;; Authors: Lars Wirzenius 6 | ;; Kenneth Oksanen 7 | ;; 8 | 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | ;; Section: Math 12 | ;; 13 | ;; This section contains functions that have to do with mathematics. 14 | 15 | 16 | ;; Constants for the largest and smallest numbers in our integer type. 17 | 18 | (def-syntax INT_MAX 2147483647) 19 | (def-syntax INT_MIN -2147483648) 20 | 21 | 22 | ;; Return the largest of its arguments (which must be integers). 23 | 24 | (def (max a ... args) 25 | (def (helper max items) 26 | (cond 27 | (nil? items) 28 | max 29 | (> (car items) max) 30 | (tailcall (helper (car items) (cdr items))) 31 | (tailcall (helper max (cdr items))))) 32 | (helper a args)) 33 | 34 | (def-syntax (max ?a ?b) 35 | (do (set ?aa ?a) 36 | (set ?bb ?b) 37 | (if (> ?aa ?bb) ?aa ?bb))) 38 | 39 | (fail-unless-equal (max 0) 0) 40 | (fail-unless-equal (max 0 1 2) 2) 41 | (fail-unless-equal (apply max '(0 3 1)) 3) 42 | 43 | 44 | ;; Return the smallest of its arguments (which must be integers). 45 | 46 | (def (min a ... args) 47 | (def (helper min items) 48 | (cond 49 | (nil? items) 50 | min 51 | (< (car items) min) 52 | (tailcall (helper (car items) (cdr items))) 53 | (tailcall (helper min (cdr items))))) 54 | (helper a args)) 55 | 56 | (def-syntax (min ?a ?b) 57 | (do (set ?aa ?a) 58 | (set ?bb ?b) 59 | (if (< ?aa ?bb) ?aa ?bb))) 60 | 61 | (fail-unless-equal (min 0) 0) 62 | (fail-unless-equal (min 0 1 2) 0) 63 | 64 | 65 | ;; Return the absolute value of the argument, which must be an integer. 66 | 67 | (def (abs n) 68 | (if (< n 0) 69 | (- n) 70 | n)) 71 | 72 | (fail-unless-equal (abs 0) 0) 73 | (fail-unless-equal (abs 1) 1) 74 | (fail-unless-equal (abs -1) 1) 75 | 76 | 77 | ;; Subtract two values returned by unix-gettimeofday, as usecs. Note 78 | ;; that should the difference be over approximately four minutes, 79 | ;; integer overflow will result. 80 | 81 | (def (unix-gettimeofday-subtract stop start) 82 | (+ (* 1000000 (- (car stop) (car start))) 83 | (- (cdr stop) (cdr start)))) 84 | -------------------------------------------------------------------------------- /prelude.d/400-misc.hl: -------------------------------------------------------------------------------- 1 | ;; This file is part of Hedgehog LISP standard library. 2 | ;; Copyright (C) 2003, 2004 Oliotalo Ltd. 3 | ;; See file LICENSE.BSD for pertinent licensing conditions. 4 | ;; 5 | ;; Author: Lars Wirzenius 6 | ;; Kenneth Oksanen 7 | 8 | 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | ;; Section: Miscellaenous 11 | ;; 12 | ;; This section contains functions that have no better section. 13 | 14 | 15 | ;; Check that the version of the interpreter we're running under is 16 | ;; compatible with the application. If not, panic. 17 | 18 | (def (require-version required) 19 | (def (parse-version string) 20 | (map (fn (s) (atoi s 10)) (strsplit string "."))) 21 | (def (acceptable-version? version-parts required-parts) 22 | (and (= (abs (nth version-parts 0)) (nth required-parts 0)) 23 | (>= (abs (nth version-parts 1)) (nth required-parts 1)) 24 | (>= (abs (nth version-parts 2)) (nth required-parts 2)))) 25 | (set version-parts (parse-version (hedgehog-version))) 26 | (set required-parts (parse-version required)) 27 | (if (not (acceptable-version? version-parts required-parts)) 28 | (panic "\nAt least version " 29 | required 30 | " is required and the interpreter is version " 31 | (hedgehog-version) ".\n\n"))) 32 | 33 | ;; Print out the values of the arguments and then a final newline. 34 | ;; This differs from the built-in print function only in that the 35 | ;; final newline is implicit. 36 | 37 | (def (pr ... args) 38 | (def (pr-helper args) 39 | (if (nil? args) 40 | (print "\n") 41 | (do (print (car args)) 42 | (tailcall (pr-helper (cdr args)))))) 43 | (pr-helper args)) 44 | 45 | 46 | ;; If 'trace?' is true, write a log message, prefixed with 'prefix' and 47 | ;; consisting of the values in 'values'. No space is printed between 48 | ;; values. 49 | 50 | (def (trace trace? prefix values) 51 | (if trace? 52 | (do (print prefix) 53 | (for-each print values) 54 | (print "\n")))) 55 | -------------------------------------------------------------------------------- /prelude.d/400-queue.hl: -------------------------------------------------------------------------------- 1 | ;; This file is part of Hedgehog LISP standard library. 2 | ;; Copyright (C) 2003, 2004, 2005 Oliotalo Ltd. 3 | ;; See file LICENSE.BSD for pertinent licensing conditions. 4 | ;; 5 | ;; Author: Lars Wirzenius 6 | 7 | 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;; Section: Queues 10 | ;; 11 | ;; The functions in this section implement simple functional queues. 12 | ;; A queue is a data structure that can contain elements so that the 13 | ;; first element added to the queue is the first element removed from 14 | ;; the queue. First in, first out, that is. A functional queue is one 15 | ;; that works without changing a data structure (it is impossible in 16 | ;; Hedgehog, anyway). The queue, as implemented here, is O(1) for 17 | ;; adding elements, and O(1) or O(n) for removing elements. In a 18 | ;; sequence of operations, the O(n) is amortized so that the average 19 | ;; operation is O(1), even if there is an occasional O(n). 20 | 21 | ; A queue is implemented as a pair of two lists. The first list contains 22 | ; items so that the most recently added item is the first item in the list. 23 | ; The second list contains items so that the least recently item is the 24 | ; first item in the list. 25 | ; 26 | ; This way, when we add an item to the queue, we can add it to the 27 | ; beginning of the first list. When we remove an item from the queue, 28 | ; we can remove the first item in the second list. When the second 29 | ; list becomes empty, we reverse the first list and make it the new 30 | ; second list. 31 | 32 | 33 | ;; Create a new, empty queue. 34 | 35 | (def (queue-make) 36 | (cons nil nil)) 37 | 38 | ;; Is a queue empty? 39 | 40 | (def (queue-empty? queue) 41 | (and (nil? (car queue)) (nil? (cdr queue)))) 42 | 43 | (fail-unless (queue-empty? (queue-make))) 44 | 45 | ;; How many items are there in the queue? 46 | 47 | (def (queue-length queue) 48 | (+ (len (car queue)) (len (cdr queue)))) 49 | 50 | ;; Add an item to a queue. Return the new queue. 51 | 52 | (def (queue-add queue item) 53 | (cons (cons item (car queue)) 54 | (cdr queue))) 55 | 56 | (fail-unless (not (queue-empty? (queue-add (queue-make) 'a)))) 57 | 58 | ;; Remove the oldest item from a queue. Return a pair (item, new queue). 59 | 60 | (def (queue-remove queue) 61 | 62 | (def (juggle-lists queue) 63 | (cons nil (reverse (car queue)))) 64 | 65 | (cond 66 | (queue-empty? queue) 67 | (cons nil queue) 68 | (nil? (cdr queue)) 69 | (tailcall (queue-remove (juggle-lists queue))) 70 | (cons (car (cdr queue)) 71 | (cons (car queue) (cdr (cdr queue)))))) 72 | 73 | (fail-unless-equal (car (queue-remove (queue-add (queue-make) 'a))) 'a) 74 | (fail-unless (queue-empty? (cdr (queue-remove (queue-add (queue-make) 'a))))) 75 | -------------------------------------------------------------------------------- /prelude.d/500-state-machine.hl: -------------------------------------------------------------------------------- 1 | ;; This file is part of Hedgehog LISP standard library. 2 | ;; Copyright (C) 2005 Oliotalo Ltd. 3 | ;; See file LICENSE.BSD for pertinent licensing conditions. 4 | ;; 5 | ;; Authors: Kenneth Oksanen 6 | ;; 7 | 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;; Section: State machines 10 | ;; 11 | ;; Many applications can be written in terms of one or more finite 12 | ;; state machines. This library provides a framework for implementing 13 | ;; them. 14 | ;; 15 | ;; Each state is a function that takes two arguments: the state 16 | ;; machine's private data item (typically a dict, but could be 17 | ;; anything) and either a message received by the machine, or nil if 18 | ;; no message was received. The function has to be written as a 19 | ;; sequence of variable bindings, goto "statements" indicating state 20 | ;; change, wait "statements" indicating suspension of execution until 21 | ;; the machine receives more input (or messages), send "statements" 22 | ;; which send messages to other machines, and when "statements" to 23 | ;; expression conditional "statement" sequences. The goto and wait 24 | ;; statements do not allow the execution to preceed to the next 25 | ;; statement, but send does. 26 | ;; 27 | ;; The machine may be woken up at any time before the desired timeout 28 | ;; expires with the 'timeout message. When a state machine enters a 29 | ;; new state (either from system start or after a goto), the machine 30 | ;; receives an 'enter message. Readable and writable file descriptors 31 | ;; are indicated with a message like '(readable ...) and '(writable ...) 32 | ;; respectively. 33 | ;; 34 | ;; The framework takes care of running the state machines, calling the 35 | ;; proper functions and keeping track of the message passing between 36 | ;; individual machines. 37 | 38 | ;; 39 | 40 | (def-record sm-msg 41 | to nil 42 | data nil) 43 | 44 | (def-syntax (sm-msg ?to ?data) 45 | (tuple-make ?to ?data)) 46 | 47 | (def-record sm-machine 48 | name nil 49 | state nil 50 | data nil 51 | readables nil writables nil timeout nil) 52 | 53 | ;; Create a state machine record instance. The arguments indicate the 54 | ;; name of the state machine (an integer, symbol, or string), the 55 | ;; (initial) state, the state machine's private data, lists of file 56 | ;; descriptors the machine would like to read and write, and a maximum 57 | ;; timeout before the framework sends a 'timeout message. 58 | 59 | (def-syntax (sm-machine ?name ?state ?data ?readables ?writables ?timeout) 60 | (tuple-make ?name ?state ?data ?readables ?writables ?timeout)) 61 | 62 | (def-syntax (sm-wait ?new-data ?readables ?writables ?timeout) 63 | (sm-machine nil nil ?new-data ?readables ?writables ?timeout)) 64 | 65 | (def-syntax (sm-goto ?new-state ?new-data) 66 | (sm-machine nil ?new-state ?new-data nil nil nil)) 67 | 68 | 69 | ;; The maximum timeout. Timeouts given to sm-machine larger than this 70 | ;; value are silently capped to this value. 71 | ;; 72 | ;; This value is arbitrary, used mainly to prevent integer overflow 73 | ;; should some machine wish to wait for more than 3 minutes. Use 15 74 | ;; seconds for now - it also forces programmers to test that 'timeout 75 | ;; messages are handled properly (perhaps just ignored). 76 | 77 | (def-syntax sm-max-timeout 15000000) 78 | 79 | ;; We send the machine a 'timeout message even if the entire time has 80 | ;; not passed, but instead if the duration is less than this value. 81 | ;; This prevents a little excess computation because most unix 82 | ;; select's don't consume the entire timeout. 83 | 84 | (def-syntax sm-timeout-slop 1000) 85 | 86 | 87 | (def (sm-pre-select name machine timeout) 88 | (map unix-add-to-read-fds (sm-machine-readables machine)) 89 | (map unix-add-to-write-fds (sm-machine-writables machine)) 90 | (let machine-timeout (sm-machine-timeout machine) 91 | (if (or (nil? machine-timeout) (> machine-timeout timeout)) 92 | timeout 93 | machine-timeout))) 94 | 95 | (def (sm-post-select machine msgs duration select-retval) 96 | ; (print "sm-post-select: machine = " machine "\n") 97 | (let timeout (sm-machine-timeout machine) 98 | timeout-left (max 0 (- timeout duration)) 99 | machine (if timeout 100 | (sm-machine-with-timeout machine timeout-left) 101 | machine) 102 | n (sm-machine-name machine) 103 | (cons machine 104 | (if (= 0 select-retval) 105 | (if (< timeout-left sm-timeout-slop) 106 | (queue-add msgs (sm-msg n 'timeout)) 107 | msgs) 108 | (let fds (filter unix-fd-is-readable 109 | (sm-machine-readables machine)) 110 | (if fds 111 | (queue-add msgs (sm-msg n (cons 'readable fds))) 112 | (let fds (filter unix-fd-is-writable 113 | (sm-machine-writables machine)) 114 | (if fds 115 | (queue-add msgs 116 | (sm-msg n (cons 'writable fds))) 117 | msgs)))))))) 118 | 119 | ;; Run the machines forever. The argument machines contains a dict of 120 | ;; sm-machine records keyed by the name of the machine. The argument 121 | ;; msgs is a queue of messages to be delivered. 122 | 123 | (def (sm-run-machines machines msgs) 124 | (if (queue-empty? msgs) 125 | ;; No messages to deliver, no machines to run, go to unix-select. 126 | (let _ (unix-clr-fdsets) 127 | start (unix-gettimeofday) 128 | timeout (avl-fold machines sm-pre-select sm-max-timeout) 129 | ; ; _ (print "unix-select: timeout = " timeout "\n") 130 | ; This provokes out more errors: timeout (/ timeout 1000) 131 | select-retval (unix-select (/ timeout 1000000) 132 | (% timeout 1000000)) 133 | duration (unix-gettimeofday-subtract (unix-gettimeofday) start) 134 | ; _ (print "unix-select: select-retval = " select-retval 135 | ; ", duration = " duration "\n") 136 | ;; Send the message '(readable fd ...) or 137 | ;; '(writable fd ...) to machines which now have a 138 | ;; readable or writable fd, respectively. Decrement all 139 | ;; timeouts with `duration', but not to negative. Send 140 | ;; all machines with zero timeouts the 'timeout message. 141 | x (avl-fold-update machines 142 | (fn (name machine msgs) 143 | (sm-post-select machine msgs 144 | duration select-retval)) 145 | msgs) 146 | (tailcall (sm-run-machines (car x) (cdr x)))) 147 | (let ; _ (print "msgs = " msgs "\n") 148 | x (queue-remove msgs) 149 | msg (car x) 150 | msgs (cdr x) 151 | to (dict-get machines (sm-msg-to msg)) 152 | msg (sm-msg-data msg) 153 | (if to 154 | (tailcall (sm-handle-actions to 155 | ((sm-machine-state to) 156 | (sm-machine-data to) 157 | msg) 158 | machines msgs)) 159 | ;; The recipient of the message does not exist. 160 | (tailcall (sm-run-machines machines msgs)))))) 161 | 162 | (def (sm-handle-actions machine actions machines msgs) 163 | 164 | (def (enqueue to-list data queue) 165 | (if (nil? to-list) 166 | queue 167 | (enqueue (cdr to-list) 168 | data 169 | (queue-add queue (sm-msg (car to-list) data))))) 170 | 171 | (if (cons? actions) 172 | ;; A send action, containing an sm-msg record. 173 | (tailcall 174 | (sm-handle-actions machine (cdr actions) machines 175 | (let to (sm-msg-to (car actions)) 176 | data (sm-msg-data (car actions)) 177 | (if (cons? to) 178 | (enqueue to data msgs) 179 | (queue-add msgs (car actions)))))) 180 | (let s (sm-machine-state actions) 181 | (if s 182 | ;; A goto action. 183 | (tailcall 184 | (sm-handle-actions 185 | ;; Copy name from old machine 186 | (sm-machine-with-name actions (sm-machine-name machine)) 187 | (s (sm-machine-data actions) 'enter) 188 | machines msgs)) 189 | ;; A wait action. 190 | (let new-machine 191 | (sm-machine-with-state actions (sm-machine-state machine)) 192 | n (sm-machine-name machine) 193 | new-machine (sm-machine-with-name new-machine n) 194 | (tailcall (sm-run-machines (dict-set machines n new-machine) 195 | msgs))))))) 196 | 197 | 198 | (def-syntax (def-state-body ?name ?value ... ?stmts) 199 | (do (set ?name ?value) 200 | (def-state-body ... ?stmts))) 201 | 202 | (def-syntax (def-state-body (send ?list-of-machines ?data) 203 | ... ?stmts) 204 | (set ?t (def-state-body ... ?stmts)) 205 | (set ?lom ?list-of-machines) 206 | (if ?lom 207 | (cons (sm-msg ?lom ?data) ?t) 208 | ?t)) 209 | 210 | (def-syntax (def-state-body (wait ?new-data ?readables ?writables ?timeout)) 211 | (sm-wait ?new-data ?readables ?writables ?timeout)) 212 | 213 | (def-syntax (def-state-body (goto ?new-state ?new-data)) 214 | (sm-goto ?new-state ?new-data)) 215 | 216 | (def-syntax (def-state-body (when ?cond ... ?then-stmts) ... ?stmts) 217 | (if ?cond 218 | (do (def-state-body ... ?then-stmts)) 219 | (do (def-state-body ... ?stmts)))) 220 | 221 | (def-syntax (def-state-body) 222 | (panic "\nNo state transfer defined.\n")) 223 | 224 | ;; A macro used to create the state function. The function takes two 225 | ;; arguments, the private data which is associated to this particular 226 | ;; instance of the machine and passed from state to state by 227 | ;; sm-run-machines. The second argument, msg, is a message delivered 228 | ;; by the framework to this state function. The body of the function 229 | ;; is a sequence of either variable bindings as in let-statements, 230 | ;; (send list-of-machines msg) -statements to send the given msgs to 231 | ;; the given list of machines (nil if none, a single machine name is 232 | ;; also ok), (goto new-state cond new-data) -statements to make a 233 | ;; conditional transition to the a new state with a corresponding new 234 | ;; version of the private data, and (wait cond new-data readables 235 | ;; writables timeout) to stay in the same state until either one of 236 | ;; the file descriptors in the readables-list has become readable, one 237 | ;; of the file descriptors in the writables-list has become writable, 238 | ;; or until a specified timeout has occurred. 239 | 240 | (def-syntax (def-state (?state-name ?private-data ?msg) ... ?body) 241 | (def (?state-name ?private-data ?msg) 242 | (def-state-body ... ?body))) 243 | -------------------------------------------------------------------------------- /prelude.d/interface-gen.c: -------------------------------------------------------------------------------- 1 | /* This file is part of Hedgehog LISP. 2 | * Copyright (C) 2004, 2005 Oliotalo Ltd. 3 | * See file LICENSE.LGPL for pertinent licensing conditions. 4 | * 5 | * Author: Kenneth Oksanen 6 | */ 7 | 8 | /* This file is #included into the C program generated by the the 9 | script interface-gen.pl. */ 10 | 11 | #include 12 | #include 13 | 14 | static void gen_int_flag(const char *prefix, const char *flag, 15 | int value) 16 | { 17 | /* printf("#ifdef %s\n", flag); */ 18 | printf("(def-syntax %s%s %d)\n", prefix, flag, value); 19 | /* printf("#endif\n"); */ 20 | } 21 | 22 | static void gen_int_flag_have(const char *prefix, const char *flag, 23 | int value) 24 | { 25 | /* printf("#ifdef %s\n", flag); */ 26 | printf("#define %sHAVE-%s\n", prefix, flag); 27 | /* printf("#endif\n"); */ 28 | } 29 | 30 | static void gen_struct(const char *prefix, const char *struct_name, 31 | size_t size) 32 | { 33 | int i; 34 | 35 | printf(";; Definitions for the size and field offsets, sizes and types for the C struct %s%s\n\n", prefix, struct_name); 36 | printf("(def-syntax %s%s \"", prefix, struct_name); 37 | for (i = 0; i < size; i++) 38 | printf("\\0"); 39 | printf("\")\n"); 40 | } 41 | 42 | #define OFFSETOF(s, f) (((char *) &(s.f)) - ((char *) &(s))) 43 | 44 | static void gen_field(const char *prefix, 45 | const char *struct_name, 46 | const char *type, 47 | const char *field, 48 | int offset, 49 | int size) 50 | { 51 | printf("(def-syntax %s%s-%s-offset %d)\n", 52 | prefix, struct_name, field, offset); 53 | printf("(def-syntax %s%s-%s-size %d)\n", 54 | prefix, struct_name, field, size); 55 | printf("(def-syntax %s%s-%s-type \"%s\")\n", 56 | prefix, struct_name, field, type); 57 | 58 | if (strcmp(type, "int ") == 0 59 | || strcmp(type, "unsigned int ") == 0) { 60 | printf("(def-syntax (%s%s-get-%s ?x)\n (c-get-int ?x %d))\n", 61 | prefix, struct_name, field, offset); 62 | printf("(def-syntax (%s%s-set-%s ?x ?v)\n (c-set-int ?x %d ?v))\n", 63 | prefix, struct_name, field, offset); 64 | } else if (strcmp(type, "short ") == 0 65 | || strcmp(type, "unsigned short ") == 0) { 66 | printf("(def-syntax (%s%s-get-%s ?x)\n (c-get-short ?x %d))\n", 67 | prefix, struct_name, field, offset); 68 | printf("(def-syntax (%s%s-set-%s ?x ?v)\n (c-set-short ?x %d ?v))\n", 69 | prefix, struct_name, field, offset); 70 | } 71 | } 72 | 73 | 74 | static void gen_byteorder(void) 75 | { 76 | union { 77 | unsigned char c[4]; 78 | unsigned int ui; 79 | } u4; 80 | 81 | u4.ui = 0xAABBCCDD; 82 | if (u4.c[0] == 0xAA 83 | && u4.c[1] == 0xBB 84 | && u4.c[2] == 0xCC 85 | && u4.c[3] == 0xDD) 86 | /* Most significant byte first. */ 87 | printf("#define HH_MOST_SIGNIFICANT_BYTE_FIRST\n"); 88 | else if (u4.c[0] == 0xDD 89 | && u4.c[1] == 0xCC 90 | && u4.c[2] == 0xBB 91 | && u4.c[3] == 0xAA) 92 | printf("#define HH_LEAST_SIGNIFICANT_BYTE_FIRST\n"); 93 | else 94 | printf(";; Unrecognized byte order.\n"); 95 | } 96 | 97 | 98 | -------------------------------------------------------------------------------- /prelude.d/interface-gen.pl: -------------------------------------------------------------------------------- 1 | # This file is part of Hedgehog LISP. 2 | # Copyright (C) 2004, 2005 Oliotalo Ltd. 3 | # See file LICENSE.LGPL for pertinent licensing conditions. 4 | # 5 | # Author: Kenneth Oksanen 6 | # 7 | 8 | ($prefix) = @ARGV; 9 | 10 | print "/* This file has been automatically generated by interface-gen.pl. */"; 11 | print "\n\n"; 12 | 13 | while () { 14 | chop; 15 | if (/^include/) { 16 | print "#", $_, "\n" 17 | } elsif (/^define (\S+)$/) { 18 | push @defines, $1 19 | } elsif (/^struct (\S+)$/) { 20 | push @structs, $1 21 | } elsif (/^field ([^.]+[ *])(\S+)\.(\S+)$/) { 22 | $fs = [$1, $2, $3]; 23 | # ($t, $s, $f) = @$fs; 24 | push @fields, $fs 25 | } elsif (/^subfield ([^.]+[ *])(\S+)\.(.+)\.(\S+)$/) { 26 | $fs = [$1, $2, $3, $4]; 27 | # ($t, $s, $f) = @$fs; 28 | push @subfields, $fs 29 | } 30 | } 31 | 32 | print "#include \"prelude.d/interface-gen.c\"\n\n"; 33 | 34 | print "int main(void)\n"; 35 | print "{\n"; 36 | foreach (@structs) { 37 | print " struct $_ $_;\n"; 38 | } 39 | print "\n"; 40 | print " printf(\";; This file has been automatically generated\\n\");\n"; 41 | print " printf(\";; by a program generated by interface-gen.pl\\n\\n\");\n"; 42 | print " printf(\";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\\n\");\n"; 43 | print " printf(\";; Section: Operating system services\\n\");\n"; 44 | print " printf(\";;\\n\");\n"; 45 | print " printf(\";; This section contains definitions automatically generated from the operating system's C include files.\\n\");\n"; 46 | print " printf(\"\\n\");\n"; 47 | print "\n"; 48 | print " printf(\";; Flags defined in the C include files. For any flag ", $prefix, "X there is a #define ", $prefix, "HAVE-X\\n\");\n"; 49 | print " printf(\"\\n\");\n"; 50 | foreach (@defines) { 51 | print "#ifdef $_\n"; 52 | print " gen_int_flag(\"$prefix\", \"$_\", $_);\n"; 53 | print "#endif\n"; 54 | } 55 | foreach (@defines) { 56 | print "#ifdef $_\n"; 57 | print " gen_int_flag_have(\"$prefix\", \"$_\", $_);\n"; 58 | print "#endif\n"; 59 | } 60 | foreach (@structs) { 61 | print " gen_struct(\"$prefix\", \"$_\", sizeof($_));\n"; 62 | $ss = $_; 63 | foreach (@fields) { 64 | ($t, $s, $f) = @$_; 65 | next if $s ne $ss; 66 | print " gen_field(\"$prefix\", \"$s\", \"$t\", \"$f\", "; 67 | print "OFFSETOF($s, $f), sizeof($s.$f));\n"; 68 | } 69 | foreach (@subfields) { 70 | ($t, $s, $i, $f) = @$_; 71 | next if $s ne $ss; 72 | print " gen_field(\"$prefix\", \"$s\", \"$t\", \"$i.$f\", "; 73 | print "OFFSETOF($s, $i.$f), sizeof($s.$i.$f));\n"; 74 | } 75 | } 76 | print " gen_byteorder();\n"; 77 | print " return 0;\n"; 78 | print "}\n"; 79 | -------------------------------------------------------------------------------- /tests/apply.hl: -------------------------------------------------------------------------------- 1 | ;; Tests that apply works. 2 | ;; 3 | 4 | (def (fun0 ... args) 5 | (print "fun0: " args "\n")) 6 | 7 | (def (fun2 a1 a2 ... args) 8 | (print "fun2: " a1 ", " a2 ", " args "\n")) 9 | 10 | (apply fun0 '()) 11 | (apply fun0 '(a)) 12 | (apply fun0 '(a b)) 13 | (apply fun0 '(a b c)) 14 | (apply fun0 '(a b c d)) 15 | 16 | ;The first two shouldn't work: 17 | ;(apply fun2 '()) 18 | ;(apply fun2 '(a)) 19 | (apply fun2 '(a b)) 20 | (apply fun2 '(a b c)) 21 | (apply fun2 '(a b c d)) 22 | 23 | -------------------------------------------------------------------------------- /tests/atoi.hl: -------------------------------------------------------------------------------- 1 | ;; This tests atoi and itoa in varying bases. This is also a 2 | ;; relatively good test for tail calls. This test predates local 3 | ;; variables, and therefore doesn't use them. 4 | 5 | (def (test x xs base next_base delta rnd) 6 | (print "next_base = " next_base "\n") 7 | (if (= (atoi xs base) x) 8 | (let r1 (+ (* rnd 777138309) 4) 9 | r2 (+ (* r1 777138309) 4) 10 | rnd (+ (* r2 777138309) 4) 11 | _ (print (itoa x base) " in base " (itoa base 10) " is ok\n") 12 | (test (+ x delta) 13 | (itoa (+ x delta) next_base) 14 | next_base 15 | (+ 2 (% (abs r1) 34)) 16 | r2 17 | rnd)) 18 | (do (print x " in base " (itoa base 10) " failed!\n") 19 | (print "string is '" xs "'\n") 20 | (print "atoi'd " (atoi xs base) "\n") 21 | (print "converted back is " (itoa (atoi xs base) base) "\n")))) 22 | 23 | (test 0 "0" 10 16 1 31893) 24 | -------------------------------------------------------------------------------- /tests/avl.hl: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sbp/hedgehog/d3d34c093f4c3ddc68a8e3c45fbca472ef7f194b/tests/avl.hl -------------------------------------------------------------------------------- /tests/catch.hl: -------------------------------------------------------------------------------- 1 | ;; Some tests for catch & throw. 2 | 3 | (def (foo) 4 | (print "In foo\n") 5 | (throw foo-exception) 6 | (print "This shouldn't be reached\n")) 7 | 8 | (catch (do (foo) 9 | (print "This shouldn't be reached\n")) 10 | foo-exception 11 | (print "Caught foo-exception\n")) 12 | 13 | (def (bar x) 14 | (print "In bar, x = " x "\n") 15 | (if (> x 4) 16 | (throw bar-exception) 17 | (fib x))) 18 | 19 | (def (fib x) 20 | (if (< x 2) 21 | 1 22 | (+ (fib (- x 1)) 23 | (catch (bar (- x 2)) 24 | bar-exception 25 | (fib (- x 2)))))) 26 | 27 | (print (fib 10) "\n") 28 | -------------------------------------------------------------------------------- /tests/crypto.hl: -------------------------------------------------------------------------------- 1 | (print "shared secret = " (hex (shared-secret)) "\n") 2 | (set test-message "To thine own self be true!") 3 | (print "test message = " test-message "\n") 4 | (print "hash of test message = " (hex (crypto-hash test-message)) "\n") 5 | (set encrypted-message (crypto-cipher test-message t (shared-secret))) 6 | (print "encrypted test message = " (hex encrypted-message) "\n") 7 | (print "back to plaintext = " 8 | (crypto-cipher encrypted-message nil (shared-secret)) 9 | "\n") 10 | -------------------------------------------------------------------------------- /tests/fib.hl: -------------------------------------------------------------------------------- 1 | ;; The ubiquitous recursive fibonacci test. 2 | ;; 3 | ;; fib(30) = 1346269 4 | 5 | (def (fib x) 6 | (if (< x 2) 7 | 1 8 | (+ (fib (- x 1)) (fib (- x 2))))) 9 | 10 | (def (fib-test x) 11 | (print "fib(" (itoa x 10) ") = " (itoa (fib x) 10) "\n")) 12 | 13 | (fib-test 30) 14 | -------------------------------------------------------------------------------- /tests/fork.hl: -------------------------------------------------------------------------------- 1 | (if (= (unix-fork) 0) 2 | (do (print "Child here\n") 3 | (unix-exec "/bin/touch" '("touch" "foo" "bar") nil) 4 | (print "Oh shit!!!\n"))) 5 | (print "Sleeping\n") 6 | (unix-usleep 10000000) 7 | (if (unix-wait) 8 | (print "Waited\n")) 9 | (if (unix-wait) 10 | (print "Oh bugger!!!\n")) 11 | (print "Done\n") 12 | -------------------------------------------------------------------------------- /tests/gc-catch.hl: -------------------------------------------------------------------------------- 1 | ;; A little test for catching out-of-memory-exceptions. 2 | 3 | (print (unix-gettimeofday) "\n") 4 | 5 | ; A function that consumes progressively more memory, ad infinitum. 6 | (def (consume-memory s) 7 | (print "consume-memory " (strlen s) "\n") 8 | (consume-memory (strcat s s))) 9 | 10 | (catch (do ; The memory exhaustion in this expression is caught, whereafter 11 | ; the execution returns to the top-level. 12 | (consume-memory "foo") 13 | (print "This shouldn't be reached\n")) 14 | out-of-memory-exception 15 | (print "Caught out-of-memory-exception\n")) 16 | 17 | ; The memory exhaustion below is not caught, which causes the whole Lisp 18 | ; program to exit with error code HH_ERROR_HEAP_FULL. 19 | (consume-memory "bar") 20 | (print "This shouldn't be reached either\n") 21 | -------------------------------------------------------------------------------- /tests/hello.hl: -------------------------------------------------------------------------------- 1 | (pr "hello, world") 2 | -------------------------------------------------------------------------------- /tests/ifdef.hl: -------------------------------------------------------------------------------- 1 | ;; This tests #defines and #ifdefs. 2 | 3 | #define FOO 4 | 5 | (print "Before #ifdef.\n") 6 | 7 | #ifdef BAR 8 | 9 | (print "BAR defined.\n") 10 | 11 | #ifdef FOO 12 | (print "FOO defined.\n") 13 | #else 14 | (print "FOO not defined.\n") 15 | #endif 16 | 17 | #else 18 | 19 | (print "BAR not defined.\n") 20 | 21 | #ifndef FOO 22 | (print "FOO not defined.\n") 23 | #else 24 | (print "FOO defined.\n") 25 | #endif 26 | 27 | #endif 28 | 29 | (print "After #endif.\n") 30 | -------------------------------------------------------------------------------- /tests/ip-srv-test.hl: -------------------------------------------------------------------------------- 1 | ;; Accept an incoming connection, reply to PINGs with PONGs, and 2 | ;; return to accept new connections when the previous connection 3 | ;; breaks. Note that this is /NOT/ an exemplary way to do this - 4 | ;; better use the state machine abstraction. 5 | 6 | (set listen-port 5555) 7 | 8 | (set listen-fd (unix-socket unix-AF_INET unix-SOCK_STREAM 0)) 9 | (if (< listen-fd 0) 10 | (panic "Failed to open listening socket, errno = " (unix-errno) "\n")) 11 | (set sockaddr_in (ip-sockaddr_in 5555 unix-INADDR_ANY)) 12 | (if (< (unix-bind listen-fd sockaddr_in) 0) 13 | (panic "Failed to bind socket, errno = " (unix-errno) "\n")) 14 | (if (< (unix-listen listen-fd 5) 0) 15 | (panic "Failed to listen to socket, errno = " (unix-errno) "\n")) 16 | ;; This is what we would do if we would if we wanted a non-blocking accept. 17 | ;;(if (< (unix-fcntl listen-fd unix-F_SETFL unix-O_NONBLOCK) 0) 18 | ;; (panic "Failed to fcntl socket, errno = " (unix-errno) "\n")) 19 | 20 | (def (accept-loop) 21 | (print "accepting...\n") 22 | (let accept-result (unix-accept listen-fd) 23 | (if (nil? accept-result) 24 | (if (= (unix-errno) unix-EAGAIN) 25 | (accept-loop) 26 | (panic "Failed to accept, errno = " (unix-errno) "\n")) 27 | (do (ping-pong-loop (car accept-result)) 28 | (accept-loop))))) 29 | 30 | (def (ping-pong-loop fd) 31 | (let s (unix-read fd 80) 32 | (if (or (nil? s) (eq? s "quit\r\n")) 33 | (do (print "Closed connection.\n") 34 | (unix-close fd)) 35 | (do (print "read -> " (list s) "\n") 36 | (unix-write fd "PONG\n") 37 | (ping-pong-loop fd))))) 38 | 39 | (accept-loop) 40 | ;; This line is not reached, otherwise we should do also 41 | ;; (unix-close listen-fd) 42 | -------------------------------------------------------------------------------- /tests/lambda.hl: -------------------------------------------------------------------------------- 1 | ;; Some tests for the lambda lifting pass in the compiler. 2 | 3 | ;; This demonstrates how the compiler works internally when it creates 4 | ;; and uses environments. 5 | 6 | (def (f1 y) 7 | (+ y (.get_env 0))) 8 | (def (mkf1 x) 9 | (.make_new_env 2) 10 | (.put_new_env 0 x) 11 | (.bind_env f1)) 12 | (print ((mkf1 1) 2) "\n") 13 | 14 | 15 | ;; Let's try the same with automatic lambdas. 16 | 17 | (def (mkf2 x) 18 | (fn (y) (+ y x))) 19 | (print ((mkf2 1) 2) "\n") 20 | 21 | 22 | ;; Check that the local `set' or `fn' argument shadows the variable 23 | ;; otherwise in closure. 24 | 25 | (def (mkf3 x) 26 | (fn (y) (+ y x (do (set x 3) x)))) 27 | (print ((mkf3 1) 2) "\n") 28 | (def (mkf4 x) 29 | (fn (y) (+ y x ((fn (x) x) 3)))) 30 | (print ((mkf4 1) 2) "\n") 31 | 32 | 33 | ;; This tests mutually recursive local functions. Note the rebinding 34 | ;; of `x' in before `pong'. 35 | 36 | (def (pingpong x) 37 | (def (ping y) 38 | (print "ping" x y "\n") 39 | (if (< y 10) 40 | (pong (+ y 1)))) 41 | (set x " ? ") 42 | (def (pong y) 43 | (print "pong" x y "\n") 44 | (ping (+ y 1))) 45 | 46 | (ping 0)) 47 | 48 | (pingpong " = ") 49 | 50 | ;; Although not demonstrated above, note also, that calling a function 51 | ;; before it has been demonstrated may result in run-time errors. For 52 | ;; example if you would move `(ping 0)' before `(def (ping ..) ..)', 53 | ;; the program would probably crash. Similarly, since `ping' calls 54 | ;; `pong', the call `(ping 0)' must be after the definition of `pong'. 55 | 56 | 57 | ;; Finally a little test to ensure environments are saved properly by 58 | ;; lifted functions. Should print three lines, first and last one 59 | ;; having "FOO", and middlemost having "BAR". 60 | 61 | (def (sv x) 62 | (fn (f) 63 | (print x "\n") 64 | (f) 65 | (print x "\n"))) 66 | (do (set x "BAR") 67 | ((sv "FOO") 68 | (fn () (print x "\n")))) 69 | -------------------------------------------------------------------------------- /tests/liw-test.hl: -------------------------------------------------------------------------------- 1 | ;; Tests written by Lars Wirzenius 2 | ;; hedgehog-test-and-benchmark-1.1/test.lisp 3 | ;; Enabled some tests that failed for the old lisp // Cessu 4 | 5 | ; Helper functions for testing. 6 | 7 | (def-syntax (fail-if ?expr) 8 | (if ?expr 9 | (panic "\nERROR: Condition " (quote ?expr) " true.\n"))) 10 | 11 | 12 | ; Test basic arithmetic and bitwise operations. 13 | 14 | 15 | (fail-unless-equal (+ 0) 0) 16 | (fail-unless-equal (+ 0 1) 1) 17 | (fail-unless-equal (+ 0 1 2) 3) 18 | (fail-unless-equal (+ 0 1 2 -1) 2) 19 | (fail-unless-equal (+ 0 1 2 0x3) 6) 20 | 21 | (fail-unless-equal (- 1) -1) 22 | (fail-unless-equal (- 0 1) -1) 23 | (fail-unless-equal (- 0 1 2) -3) 24 | (fail-unless-equal (- 0 1 2 -1) -2) 25 | (fail-unless-equal (- 0 1 2 0x3) -6) 26 | 27 | (fail-unless-equal (* 1) 1) 28 | (fail-unless-equal (* 0 1) 0) 29 | (fail-unless-equal (* 1 2) 2) 30 | (fail-unless-equal (* 1 2 -1) -2) 31 | (fail-unless-equal (* 1 2 0x3) 6) 32 | 33 | (fail-unless-equal (/ 8 2) 4) 34 | (fail-unless-equal (/ 8 2 2) 2) 35 | 36 | (fail-unless-equal (% 8 2) 0) 37 | (fail-unless-equal (% 8 3) 2) 38 | (fail-unless-equal (% 8 7) 1) 39 | 40 | (fail-unless-equal (<< 1 0) 1) 41 | (fail-unless-equal (<< 1 1) 2) 42 | (fail-unless-equal (<< 2 1) 4) 43 | (fail-unless-equal (<< 1 3) 8) 44 | 45 | (fail-unless-equal (>> 1 0) 1) 46 | (fail-unless-equal (>> 1 1) 0) 47 | (fail-unless-equal (>> 2 1) 1) 48 | 49 | ; Old hoglisp doesn't guarantee this. New one will. 50 | (fail-unless-equal (>> 0xffffffff 1) 0x7fffffff) 51 | 52 | (fail-unless-equal (| 0 0) 0) 53 | (fail-unless-equal (| 0 1) 1) 54 | (fail-unless-equal (| 1 1) 1) 55 | (fail-unless-equal (| 1 2) 3) 56 | 57 | (fail-unless-equal (& 0 0) 0) 58 | (fail-unless-equal (& 0 1) 0) 59 | (fail-unless-equal (& 1 1) 1) 60 | (fail-unless-equal (& 1 2) 0) 61 | (fail-unless-equal (& 1 3) 1) 62 | 63 | (fail-unless-equal (^ 0 0) 0) 64 | (fail-unless-equal (^ 0 1) 1) 65 | (fail-unless-equal (^ 1 1) 0) 66 | (fail-unless-equal (^ 1 2) 3) 67 | (fail-unless-equal (^ 1 3) 2) 68 | 69 | (fail-unless-equal (~ 0) 0xffffffff) 70 | (fail-unless-equal (~ 0xffffffff) 0) 71 | (fail-unless-equal (~ 1) 0xfffffffe) 72 | 73 | 74 | 75 | ; Boolean operations. 76 | 77 | (fail-if nil) 78 | (fail-if 0) 79 | 80 | ; The old implementation treats "" as false, the new as true. This 81 | ; difference is OK. 82 | ; (fail-unless "") 83 | 84 | (fail-unless (cons 0 0)) 85 | (fail-unless 1) 86 | (fail-unless "foo") 87 | 88 | (fail-if (and 0 0)) 89 | (fail-if (and 0 1)) 90 | (fail-if (and 1 0)) 91 | (fail-unless (and 1 1)) 92 | 93 | (fail-if (or 0 0)) 94 | (fail-unless (or 0 1)) 95 | (fail-unless (or 1 0)) 96 | (fail-unless (or 1 1)) 97 | 98 | (fail-unless (not 0)) 99 | (fail-if (not 1)) 100 | 101 | 102 | 103 | ; Misc. builtin operations. 104 | 105 | (fail-unless-equal (list) nil) 106 | (fail-unless-equal (list 0) '(0)) 107 | (fail-unless-equal (list 0 1) '(0 1)) 108 | (fail-unless-equal (list 0 1 2) '(0 1 2)) 109 | 110 | 111 | 112 | ; Comparison functions. 113 | 114 | (fail-if (< 0 0)) 115 | (fail-unless (< 0 1)) 116 | (fail-if (< 0 -1)) 117 | 118 | (fail-unless (<= 0 0)) 119 | (fail-unless (<= 0 1)) 120 | (fail-if (<= 0 -1)) 121 | 122 | (fail-unless (= 0 0)) 123 | (fail-if (= 0 1)) 124 | (fail-if (= 0 -1)) 125 | 126 | (fail-if (> 0 0)) 127 | (fail-if (> 0 1)) 128 | (fail-unless (> 0 -1)) 129 | 130 | (fail-unless (>= 0 0)) 131 | (fail-if (>= 0 1)) 132 | (fail-unless (>= 0 -1)) 133 | 134 | (fail-if (!= 0 0)) 135 | (fail-unless (!= 0 1)) 136 | (fail-unless (!= 0 -1)) 137 | 138 | 139 | ; List functions. 140 | 141 | (fail-unless-equal (cons 0 nil) '(0)) 142 | (fail-unless-equal (cons 0 (cons 1 nil)) '(0 1)) 143 | 144 | (fail-unless-equal (car (cons 0 1)) 0) 145 | (fail-unless-equal (cdr (cons 0 1)) 1) 146 | 147 | (fail-unless-equal (nth '(1 2 3 4) 0) 1) 148 | (fail-unless-equal (nth '(1 2 3 4) 1) 2) 149 | (fail-unless-equal (nth '(1 2 3 4) 2) 3) 150 | (fail-unless-equal (nth '(1 2 3 4) 3) 4) 151 | (fail-unless-equal (nth '(1 2 3 4) 4) nil) 152 | 153 | 154 | ; String operations. 155 | 156 | (fail-unless-equal (strlen "") 0) 157 | (fail-unless-equal (strlen "a") 1) 158 | (fail-unless-equal (strlen "ab") 2) 159 | (fail-unless-equal (strlen "abc") 3) 160 | (fail-unless-equal (strlen "abcd") 4) 161 | (fail-unless-equal (strlen "abcde") 5) 162 | 163 | (fail-unless-equal (substr "" 0 0) "") 164 | (fail-unless-equal (substr "" 0 1) "") 165 | (fail-unless-equal (substr "" 1 1) "") 166 | 167 | (fail-unless-equal (substr "abcdef" 0 0) "") 168 | (fail-unless-equal (substr "abcdef" 0 1) "a") 169 | (fail-unless-equal (substr "abcdef" 0 2) "ab") 170 | (fail-unless-equal (substr "abcdef" 0 3) "abc") 171 | (fail-unless-equal (substr "abcdef" 0 4) "abcd") 172 | (fail-unless-equal (substr "abcdef" 0 5) "abcde") 173 | (fail-unless-equal (substr "abcdef" 0 6) "abcdef") 174 | (fail-unless-equal (substr "abcdef" 0 7) "abcdef") 175 | (fail-unless-equal (substr "abcdef" 0 -1) "abcdef") 176 | 177 | (fail-unless-equal (substr "abcdef" 3 0) "") 178 | (fail-unless-equal (substr "abcdef" 3 1) "d") 179 | (fail-unless-equal (substr "abcdef" 3 2) "de") 180 | (fail-unless-equal (substr "abcdef" 3 3) "def") 181 | (fail-unless-equal (substr "abcdef" 3 4) "def") 182 | (fail-unless-equal (substr "abcdef" 3 5) "def") 183 | (fail-unless-equal (substr "abcdef" 3 6) "def") 184 | (fail-unless-equal (substr "abcdef" 3 7) "def") 185 | (fail-unless-equal (substr "abcdef" 3 -1) "def") 186 | 187 | (fail-unless-equal (substr "abcdef" 9 0) "") 188 | (fail-unless-equal (substr "abcdef" 9 1) "") 189 | (fail-unless-equal (substr "abcdef" 9 2) "") 190 | (fail-unless-equal (substr "abcdef" 9 -1) "") 191 | 192 | (fail-unless-equal (strcmp "" "") 0) 193 | (fail-unless-equal (strcmp "" "a") -1) 194 | (fail-unless-equal (strcmp "" "ab") -1) 195 | (fail-unless-equal (strcmp "" "\xff") -1) 196 | 197 | (fail-unless-equal (strcmp "a" "") 1) 198 | (fail-unless-equal (strcmp "a" "a") 0) 199 | (fail-unless-equal (strcmp "a" "ab") -1) 200 | (fail-unless-equal (strcmp "a" "\xff") -1) 201 | 202 | (fail-unless-equal (strcmp "ab" "") 1) 203 | (fail-unless-equal (strcmp "ab" "a") 1) 204 | (fail-unless-equal (strcmp "ab" "ab") 0) 205 | 206 | ; The following fail on the old implentation, though they shouldn't. 207 | (fail-unless-equal (strcmp "ab" "\xff") -1) 208 | (fail-unless-equal (strcmp "\xff" "ab") 1) 209 | 210 | (fail-unless-equal (strcmp "\xff" "") 1) 211 | (fail-unless-equal (strcmp "\xff" "a") 1) 212 | (fail-unless-equal (strcmp "\xff" "\xff") 0) 213 | 214 | 215 | (fail-unless-equal (ord "abc") 97) 216 | (fail-unless-equal (ord "\xff") 255) 217 | 218 | 219 | (fail-unless-equal (chr 97) "a") 220 | (fail-unless-equal (chr 255) "\xff") 221 | 222 | 223 | (fail-unless-equal (strcat) "") 224 | (fail-unless-equal (strcat "a") "a") 225 | (fail-unless-equal (strcat "a" "b") "ab") 226 | (fail-unless-equal (strcat "a" "b" "c") "abc") 227 | 228 | 229 | (print "All tests completed.\n") 230 | -------------------------------------------------------------------------------- /tests/mount.hl: -------------------------------------------------------------------------------- 1 | ;; Tests for UNIX mount and umount. 2 | 3 | ;; The actual tests, this mounts a USB memory stick containing a vfat 4 | ;; file system in read-only mode from /dev/sdb to /mnt. 5 | 6 | (print "mount: " (unix-mount "/dev/sdb" "/mnt" "vfat" unix-MS_RDONLY nil) "\n") 7 | 8 | (print "errno: " (unix-errno) "\n") 9 | 10 | (print "dir-list: " (unix-dir-list "/mnt") "\n") 11 | 12 | (print "errno: " (unix-errno) "\n") 13 | 14 | (print "umount: " (unix-umount "/mnt") "\n") 15 | 16 | (print "errno: " (unix-errno) "\n") 17 | -------------------------------------------------------------------------------- /tests/quote.hl: -------------------------------------------------------------------------------- 1 | ;; This tests quoting and symbols. 2 | 3 | (print '(1 ("zap" 3) 2 "foo" "\n")) (print "\n") 4 | 5 | (print 'foo) (print "\n") 6 | 7 | (print (string? 'foo)) (print "\n") 8 | 9 | (print (strcat (symboltostring 'foo) "bar\n")) 10 | -------------------------------------------------------------------------------- /tests/set.hl: -------------------------------------------------------------------------------- 1 | ;; Some tests for the `set' expression. 2 | ;; Should print something like 3 | ;; x = 1 4 | ;; x = 3 5 | ;; x = 3, y = 0 6 | ;; x = 666, y = 0 7 | ;; x = 3, y = 0 8 | ;; x = 3, y = 4 9 | ;; x = 7, y = 4 10 | ;; x = 3, y = 4 11 | 12 | (set x 1) 13 | (print "x = " x "\n") 14 | (set x (+ x 2)) 15 | (print "x = " x "\n") 16 | 17 | (def (test y) 18 | (print "x = " x ", y = " y "\n") 19 | (if y 20 | (do (set x (+ x y)) 21 | (print "x = " x ", y = " y "\n")) 22 | (do (set x (+ x y 663)) 23 | (print "x = " x ", y = " y "\n"))) 24 | (print "x = " x ", y = " y "\n")) 25 | 26 | (test 0) 27 | (test 4) 28 | -------------------------------------------------------------------------------- /tests/sm.hl: -------------------------------------------------------------------------------- 1 | ;; A test for the state machine system. This starts eight concurrent 2 | ;; state machines, including a small IRC-like socket server and one 3 | ;; which follows a fifo. 4 | 5 | ;; A one-state machine which simply prints out any message it gets and 6 | ;; sleeps a second (ergo, it prints the symbol 'timeout once every 10 7 | ;; seconds). 8 | 9 | (def-state (print-and-sleep _ msg) 10 | _ (print "PRINT-AND-SLEEP: msg = " msg "\n") 11 | (wait nil nil nil 10000000)) 12 | 13 | ;; A one-state machine which sends 'hello to another machine whenever 14 | ;; it receives a message, i.e. at least every third second when it 15 | ;; gets a 'timeout message. 16 | (def-state (print-send-and-sleep recipients msg) 17 | _ (print "PRINT-SEND-AND-SLEEP: msg = " msg "\n") 18 | (send recipients 'hello) 19 | (wait recipients nil nil 3000000)) 20 | 21 | 22 | ;; A little state machine trying to open a fifo (man fifo(4)) in file 23 | ;; /tmp/FIFO, reads whatever some other process writes to that fifo, 24 | ;; and writes those strings with the default print function. While 25 | ;; running this state machine you could issue e.g. 26 | ;; > mkfifo /tmp/FIFO 27 | ;; > echo FOO >> /tmp/FIFO 28 | ;; > echo BAR >> /tmp/FIFO 29 | ;; > rm /tmp/FIFO 30 | ;; from the shell command line. 31 | 32 | (def-state (open-file _ msg) 33 | _ (print "OPEN-FILE: msg = " msg "\n") 34 | fd (unix-open "/tmp/FIFO" (bitwise-or unix-O_RDONLY unix-O_NONBLOCK)) 35 | (when (< fd 0) 36 | (wait _ nil nil 5000000)) 37 | (goto read-fd fd)) 38 | 39 | (def-state (read-fd fd msg) 40 | _ (print "READ-FD: msg = " msg "\n") 41 | (when (or (eq? msg 'enter) (eq? msg 'timeout)) 42 | (wait fd (list fd) nil 5000000)) 43 | data (unix-read fd 256) 44 | _ (print "READ-FD: data = '" data "'\n") 45 | (when (or (nil? data) (eq? data "")) 46 | (goto close-file fd)) 47 | (wait fd (list fd) nil 5000000)) 48 | 49 | (def-state (close-file fd msg) 50 | _ (print "CLOSE-FD: msg = " msg "\n") 51 | _ (unix-close fd) 52 | (goto open-file nil)) 53 | 54 | 55 | ;; A TCP/IP-based IRC-mockup, with at most four concurrenct 56 | ;; connections each handled by their own state machine and a fifth 57 | ;; machine in accept loop. Any message seen by one of the hander 58 | ;; machines is sent to all other machines which will attempt to print 59 | ;; the message to their respective connections. 60 | 61 | (set irc-slaves '(irc-slave-1 irc-slave-2 irc-slave-3 irc-slave-4)) 62 | 63 | (def (make-machines machine-names initial-state initial-data machines) 64 | (if machine-names 65 | (let name (car machine-names) 66 | machine (sm-machine name initial-state (initial-data name) 67 | nil nil 0) 68 | machines (dict-set machines name machine) 69 | (make-machines (cdr machine-names) initial-state 70 | initial-data machines)) 71 | machines)) 72 | 73 | (def-record slave-data 74 | name "" 75 | fd 0) 76 | 77 | (def-state (irc-slave-idle data msg) 78 | ;; Ignore enter and timeout msgs in this state. 79 | (when (or (eq? msg 'enter) (eq? msg 'timeout)) 80 | (wait data nil nil sm-max-timeout)) 81 | ;; Ignore messages sent by other slaves, i.e. strings written to them. 82 | (when (string? msg) 83 | (wait data nil nil sm-max-timeout)) 84 | ;; The msg should now be a file descriptor for a socket, sent to us by 85 | ;; the accept thread. 86 | fd msg 87 | data (slave-data-with-fd data fd) 88 | _ (print "IRC-SLAVE-IDLE: " (slave-data-name data) ", fd = " fd "\n") 89 | ;; Write a hello string to the new connection. 90 | msg (strcat "Hello, I'm " (symboltostring (slave-data-name data)) 91 | " and I'm very happy to serve you.\r\n") 92 | r (unix-write fd msg) 93 | (when (< r 0) 94 | (goto irc-slave-close data)) 95 | (goto irc-slave-loop data)) 96 | 97 | (def-state (irc-slave-loop data msg) 98 | fd (slave-data-fd data) 99 | ;; Ignore enter and timeout msgs in this state. 100 | (when (or (eq? msg 'enter) (eq? msg 'timeout)) 101 | (wait data (list fd) nil sm-max-timeout)) 102 | _ (print "IRC-SLAVE-LOOP: " (slave-data-name data) ", msg = " msg "\n") 103 | ;; If the msg is a unix string, then it is something we should write to 104 | ;; our socket. Goto irc-slave-close on failure, loop back on success. 105 | (when (and (string? msg) (< (unix-write fd msg) 0)) 106 | (goto irc-slave-close data)) 107 | (when (string? msg) 108 | (wait data (list fd) nil sm-max-timeout)) 109 | ;; The msg is a '(readable fd). Read something from the socket and 110 | ;; send it to all other machines, or in case of failure, close the socket. 111 | s (unix-read fd 256) 112 | (when (nil? s) 113 | (goto irc-slave-close data)) 114 | (send (if (eq? s "") 115 | ;; Don't send an empty string. 116 | nil 117 | ;; Don't send to ourselves. 118 | (cdr (split (fn (name) (eq? name (slave-data-name data))) 119 | irc-slaves))) 120 | s) 121 | (wait data (list fd) nil sm-max-timeout)) 122 | 123 | (def-state (irc-slave-close data msg) 124 | _ (print "IRC-SLAVE-CLOSE: " (slave-data-name data) ", msg = " msg "\n") 125 | _ (unix-close (slave-data-fd data)) 126 | ;; Inform the accept loop we're free again. 127 | (send 'irc-accept (slave-data-name data)) 128 | ;; Go to the idle state. 129 | (goto irc-slave-idle data)) 130 | 131 | 132 | ;; The accept loop. 133 | 134 | (def-syntax irc-port 5555) 135 | 136 | (def-record master-data 137 | fd -1 138 | free-slaves irc-slaves) 139 | 140 | (def-state (irc-master-start data msg) 141 | _ (print "IRC-MASTER-STARTing\n") 142 | ;; Make a socket, restart if failed. 143 | fd (unix-socket unix-AF_INET unix-SOCK_STREAM 0) 144 | _ (if (< fd 0) 145 | (print "socket() failed, errno = " (unix-errno) "\n")) 146 | (when (< fd 0) 147 | (wait data nil nil 1000000)) 148 | ;; Bind the socket to the port. Close and restart if failed. 149 | sockaddr_in (ip-sockaddr_in irc-port unix-INADDR_ANY) 150 | x (unix-bind fd sockaddr_in) 151 | _ (if (< x 0) 152 | (do (print "bind() failed, errno = " (unix-errno) "\n") 153 | (unix-close fd))) 154 | (when (< x 0) 155 | (wait data nil nil 1000000)) 156 | ;; Listen to the socket. Close and restart if failed. 157 | x (unix-listen fd 5) 158 | _ (if (< x 0) 159 | (do (print "listen() failed, errno = " (unix-errno) "\n") 160 | (unix-close fd))) 161 | (when (< x 0) 162 | (wait data nil nil 1000000)) 163 | ;; Just for safety, make the accept non-blocking. 164 | x (unix-fcntl fd unix-F_SETFL unix-O_NONBLOCK) 165 | _ (if (< x 0) 166 | (do (print "fcntl(fd, F_SETFL, O_NONBLOCK) failed, errno = " 167 | (unix-errno) "\n") 168 | (unix-close fd))) 169 | (when (< x 0) 170 | (wait data nil nil 1000000)) 171 | ;; Ok, now we're ready to fly! 172 | _ (print "IRC-MASTER-STARTed on port " irc-port "\n") 173 | (goto irc-master-accept (master-data-with-fd data fd))) 174 | 175 | (def-state (irc-master-accept data msg) 176 | fd (master-data-fd data) 177 | free-slaves (master-data-free-slaves data) 178 | ;; Ignore enter and timeout msgs in this state. 179 | (when (or (eq? msg 'enter) (eq? msg 'timeout)) 180 | (wait data (list fd) nil sm-max-timeout)) 181 | _ (print "IRC-MASTER-ACCEPT: data = " data ", msg = " msg "\n") 182 | ;; If the message is a slave name, it is sent to us to indicate that 183 | ;; the slave is now free for new clients. 184 | (when (symbol? msg) 185 | (wait (master-data-with-free-slaves data (cons msg free-slaves)) 186 | (list fd) nil sm-max-timeout)) 187 | ;; If the message was '(readable ...), which we're here a little 188 | ;; lazy to check, then we have a new connection. 189 | acc (unix-accept fd) 190 | _ (print "accept() = " acc "\n") 191 | (when (and (nil? acc) (= (unix-errno) unix-EAGAIN)) 192 | (wait data (list fd) nil sm-max-timeout)) 193 | (when (nil? acc) 194 | (goto irc-master-close data)) 195 | ;; Send a free slave the accepted file descriptor. 196 | (send (if free-slaves (car free-slaves) nil) (car acc)) 197 | free-slaves (if (nil? free-slaves) 198 | ;; Had no free slaves, so write an apology and close 199 | ;; the socket. 200 | (do (unix-write (car acc) "Too many connections, sorry\r\n") 201 | (unix-close (car acc)) 202 | free-slaves) 203 | (cdr free-slaves)) 204 | (wait (master-data-with-free-slaves data free-slaves) 205 | (list fd) nil sm-max-timeout)) 206 | 207 | (def-state (irc-master-close data msg) 208 | _ (print "IRC-MASTER-CLOSE\n") 209 | _ (unix-close (master-data-fd data)) 210 | (goto irc-master-start data)) 211 | 212 | 213 | (let machines nil 214 | 215 | name 'print-and-sleep-0 216 | machine (sm-machine name print-and-sleep nil nil nil 0) 217 | machines (dict-set machines name machine) 218 | 219 | name 'print-send-and-sleep-0 220 | machine (sm-machine name print-send-and-sleep '(print-and-sleep-0) 221 | nil nil 0) 222 | machines (dict-set machines name machine) 223 | 224 | name 'read-file-0 225 | machine (sm-machine name open-file nil nil nil 0) 226 | machines (dict-set machines name machine) 227 | 228 | machines (make-machines irc-slaves 229 | irc-slave-idle 230 | (fn (machine-name) 231 | (slave-data-with-name slave-data-default 232 | machine-name)) 233 | machines) 234 | 235 | name 'irc-accept-0 236 | machine (sm-machine name irc-master-start master-data-default nil nil 0) 237 | machines (dict-set machines name machine) 238 | 239 | (sm-run-machines machines (queue-make))) 240 | -------------------------------------------------------------------------------- /tests/snprint.hl: -------------------------------------------------------------------------------- 1 | (print (list (snprint -1 -1 '(1 "foo" (42)))) "\n") 2 | 3 | (set a (avl-make-node 1 1 nil nil)) 4 | 5 | (print (list (snprint -1 -1 (avl-make-node 2 2 a nil))) "\n") 6 | -------------------------------------------------------------------------------- /tests/strings.hl: -------------------------------------------------------------------------------- 1 | ;; Some random string tests 2 | 3 | (print (hex "hedgehog") "\n") 4 | 5 | (print (strstr "hedgehog" "eh") "\n") 6 | 7 | (print (strrstr "hedgehog" "eh") "\n") 8 | 9 | (print (strstr "hedgehog" "h") "\n") 10 | 11 | (print (strrstr "hedgehog" "h") "\n") 12 | -------------------------------------------------------------------------------- /tests/time.hl: -------------------------------------------------------------------------------- 1 | ;; Test some special builtins 2 | 3 | (print "available mem = " (available-mem) " bytes\n") 4 | (print (unix-gettimeofday) "\n") 5 | (print "available mem = " (available-mem) "\n") 6 | (gc) 7 | (print "available mem = " (available-mem) " bytes\n") 8 | -------------------------------------------------------------------------------- /tests/tuple.hl: -------------------------------------------------------------------------------- 1 | ;; Some tuple tests 2 | 3 | (def (test x i) 4 | (print "tuple = " x "\n") 5 | (print "tuple-arity = " (tuple-arity x) "\n") 6 | (print "tuple-index " i " = " (tuple-index x i) "\n")) 7 | 8 | (test (tuple-make 1 2 3 4) 0) 9 | (test (tuple-make 1 2 3 4) 2) 10 | (test (tuple-make 1 2 3 4) 3) 11 | ;; This should fail, the tuple is not wide enough: 12 | (test (tuple-make 1 2 3 4) 4) 13 | 14 | -------------------------------------------------------------------------------- /tests/varargs.hl: -------------------------------------------------------------------------------- 1 | ;; This variable argument passing. It uses fibonacci function to 2 | ;; stress the stack correctness. 3 | 4 | (def (fib x) 5 | (if (< x 2) 6 | 1 7 | (+ (fib (- x 1)) (fib (- x 2))))) 8 | 9 | (def (fib-test x) 10 | (print "fib(" (itoa x 10) ") = " (itoa (fib x) 10) "\n")) 11 | 12 | (def (vararg-test1 head ... tail) 13 | (print head "\n" tail "\n") 14 | ; Non-tail-call 15 | (fib-test 10) 16 | ; Tail-call 17 | (fib-test 11)) 18 | 19 | (print "\n\n") 20 | (fib-test 9) 21 | (print "\n\n") 22 | (vararg-test1 0) 23 | (vararg-test1 0 1) 24 | (vararg-test1 0 1 2) 25 | (vararg-test1 0 1 2 3) 26 | (vararg-test1 0 1 2 3 4) 27 | 28 | (def (vararg-test3 a b c ... rest) 29 | (print a "\n" b "\n" c "\n" rest "\n") 30 | ; Non-tail-call 31 | (fib-test 10) 32 | ; Tail-call 33 | (fib-test 11)) 34 | 35 | (print "\n\n") 36 | (vararg-test3 0 1 2) 37 | (vararg-test3 0 1 2 3) 38 | (vararg-test3 0 1 2 3 4) 39 | (vararg-test3 0 1 2 3 4 5) 40 | (vararg-test3 0 1 2 3 4 5 6) 41 | (vararg-test3 0 1 2 3 4 5 6 7) 42 | (vararg-test3 0 1 2 3 4 5 6 7 8) 43 | (vararg-test3 0 1 2 3 4 5 6 7 8 9) 44 | --------------------------------------------------------------------------------