├── docs └── xt16 │ ├── .gitignore │ ├── resources │ ├── images │ │ ├── asmone.jpg │ │ ├── tiobe.png │ │ ├── devpac3mk.jpg │ │ ├── devpac3backbox.jpg │ │ ├── devpac3frontbox.jpg │ │ ├── guru-meditation.gif │ │ ├── borland-turbo-assembler.jpg │ │ └── devpac3diskwalletinside.jpg │ ├── fonts │ │ ├── Gruppo │ │ │ ├── Gruppo-Regular.ttf │ │ │ └── OFL.txt │ │ ├── Raleway_Dots │ │ │ ├── RalewayDots-Regular.ttf │ │ │ └── OFL.txt │ │ └── Ubuntu_Mono │ │ │ ├── UbuntuMono-Regular.ttf │ │ │ └── UFL.txt │ ├── js │ │ └── main.js │ └── css │ │ └── styles.css │ ├── index.html │ ├── Makefile │ └── talk.md ├── .gitignore ├── akeem.supp ├── Dockerfile ├── benchmarks-prelude.scm ├── LICENSE ├── init.scm ├── Makefile ├── constants.s ├── tests.out ├── README.md ├── boot.scm ├── macros.s ├── tests.scm └── r7rs.scm /docs/xt16/.gitignore: -------------------------------------------------------------------------------- 1 | *.tgz 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.o 3 | akeem 4 | tests 5 | jit_code 6 | -------------------------------------------------------------------------------- /akeem.supp: -------------------------------------------------------------------------------- 1 | { 2 | 3 | Memcheck:Value8 4 | ... 5 | fun:gc_mark_queue_stack 6 | } 7 | -------------------------------------------------------------------------------- /docs/xt16/resources/images/asmone.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hraberg/akeem/HEAD/docs/xt16/resources/images/asmone.jpg -------------------------------------------------------------------------------- /docs/xt16/resources/images/tiobe.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hraberg/akeem/HEAD/docs/xt16/resources/images/tiobe.png -------------------------------------------------------------------------------- /docs/xt16/resources/images/devpac3mk.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hraberg/akeem/HEAD/docs/xt16/resources/images/devpac3mk.jpg -------------------------------------------------------------------------------- /docs/xt16/resources/images/devpac3backbox.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hraberg/akeem/HEAD/docs/xt16/resources/images/devpac3backbox.jpg -------------------------------------------------------------------------------- /docs/xt16/resources/images/devpac3frontbox.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hraberg/akeem/HEAD/docs/xt16/resources/images/devpac3frontbox.jpg -------------------------------------------------------------------------------- /docs/xt16/resources/images/guru-meditation.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hraberg/akeem/HEAD/docs/xt16/resources/images/guru-meditation.gif -------------------------------------------------------------------------------- /docs/xt16/resources/fonts/Gruppo/Gruppo-Regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hraberg/akeem/HEAD/docs/xt16/resources/fonts/Gruppo/Gruppo-Regular.ttf -------------------------------------------------------------------------------- /docs/xt16/resources/images/borland-turbo-assembler.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hraberg/akeem/HEAD/docs/xt16/resources/images/borland-turbo-assembler.jpg -------------------------------------------------------------------------------- /docs/xt16/resources/images/devpac3diskwalletinside.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hraberg/akeem/HEAD/docs/xt16/resources/images/devpac3diskwalletinside.jpg -------------------------------------------------------------------------------- /docs/xt16/resources/fonts/Raleway_Dots/RalewayDots-Regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hraberg/akeem/HEAD/docs/xt16/resources/fonts/Raleway_Dots/RalewayDots-Regular.ttf -------------------------------------------------------------------------------- /docs/xt16/resources/fonts/Ubuntu_Mono/UbuntuMono-Regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hraberg/akeem/HEAD/docs/xt16/resources/fonts/Ubuntu_Mono/UbuntuMono-Regular.ttf -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ubuntu:14.04 2 | 3 | RUN apt-get update && apt-get install -y gcc make rlwrap && apt-get clean && rm -rf /tmp/* /var/lib/apt/lists/* /var/tmp/ 4 | 5 | WORKDIR /usr/src/akeem 6 | COPY . /usr/src/akeem 7 | 8 | RUN make release 9 | 10 | CMD ["rlwrap", "./akeem"] 11 | -------------------------------------------------------------------------------- /docs/xt16/resources/js/main.js: -------------------------------------------------------------------------------- 1 | document.addEventListener('DOMContentLoaded', function () { 2 | var talk = {sourceUrl: 'talk.md', 3 | ratio: '16:9', 4 | slideNumberFormat: '', 5 | highlightLanguage: 'no-highlight'}; 6 | window.slideshow = remark.create(talk); 7 | document.title = slideshow.getSlides()[0].properties.name; 8 | }); 9 | -------------------------------------------------------------------------------- /docs/xt16/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 8 | 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /docs/xt16/Makefile: -------------------------------------------------------------------------------- 1 | TALK_PREFIX = the-search-for-simplicity 2 | TALK_ARCHIVE = $(TALK_PREFIX).tgz 3 | 4 | run: 5 | google-chrome http://localhost:8000 & 6 | python -m SimpleHTTPServer 7 | 8 | $(TALK_PREFIX).tgz: $(shell git ls-files) 9 | git archive --format=tar.gz --prefix=$(TALK_PREFIX)/ HEAD > $(TALK_ARCHIVE) 10 | 11 | archive: $(TALK_PREFIX).tgz 12 | 13 | clean: 14 | rm -f $(TALK_PREFIX).tgz 15 | 16 | .PHONY: run, archive, clean 17 | -------------------------------------------------------------------------------- /benchmarks-prelude.scm: -------------------------------------------------------------------------------- 1 | ;;; Racket Benchmarks Prelude 2 | 3 | (define inexact->exact exact) 4 | 5 | (define (milliseconds z) 6 | (inexact->exact (* 1000 z))) 7 | 8 | (define-syntax time 9 | (syntax-rules () 10 | ((time body ...) 11 | (let* ((real-start (current-second)) 12 | (cpu-start (current-jiffy)) 13 | (result (begin body ...)) 14 | (real-time (milliseconds (- (current-second) real-start))) 15 | (cpu-time (milliseconds (/ (- (current-jiffy) cpu-start) 16 | (jiffies-per-second)))) 17 | (gc-start (current-second)) 18 | (gc-time (begin 19 | (gc) 20 | (milliseconds (- (current-second) gc-start))))) 21 | (display "cpu time: ") 22 | (display cpu-time) 23 | (display " real time: ") 24 | (display real-time) 25 | (display " gc time: ") 26 | (display gc-time) 27 | (newline) 28 | (unless (eq? (if #f #f) result) 29 | (display result) 30 | (newline)) 31 | result)))) 32 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 Håkan Råberg 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining 6 | a copy of this software and associated documentation files (the 7 | "Software"), to deal in the Software without restriction, including 8 | without limitation the rights to use, copy, modify, merge, publish, 9 | distribute, sublicense, and/or sell copies of the Software, and to 10 | permit persons to whom the Software is furnished to do so, subject to 11 | the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be 14 | included in all copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 20 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 21 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 22 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 23 | -------------------------------------------------------------------------------- /init.scm: -------------------------------------------------------------------------------- 1 | (define (repl) 2 | (display "Welcome to Akeem Scheme.") 3 | (newline) 4 | 5 | (let ((restart-loop (call/cc (lambda (exit) 6 | exit)))) 7 | (with-exception-handler 8 | (lambda (error) 9 | (default-exception-handler error) 10 | (restart-loop restart-loop)) 11 | (lambda () 12 | (let loop () 13 | (display "> ") 14 | (let ((input (read))) 15 | (unless (eof-object? input) 16 | (let ((result (call-with-values 17 | (lambda () 18 | (eval input (interaction-environment))) 19 | list))) 20 | (when (> (length result) 1) 21 | (display "; ") 22 | (display (length result)) 23 | (display " values") 24 | (newline)) 25 | (for-each 26 | (lambda (x) 27 | (unless (eq? (if #f #f) x) 28 | (write x) 29 | (newline))) 30 | result)) 31 | (loop)))))))) 32 | 33 | (define (main args) 34 | (let ((files (cdr args))) 35 | (if (null? files) 36 | (repl) 37 | (for-each load files)))) 38 | 39 | (main (command-line)) 40 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ASFLAGS += -g --64 -march=generic64+sse4.2 2 | LDLIBS = -lm -ldl 3 | 4 | AKEEM_HOME = $(PWD) 5 | AKEEM = $(AKEEM_HOME)/akeem 6 | 7 | RACKET = `which racket` 8 | RACKET_HOME = ../racket 9 | RACKET_BENCHMARKS_HOME = $(RACKET_HOME)/pkgs/racket-benchmarks/tests/racket/benchmarks/common 10 | RACKET_BENCHMARKS = ctak nboyer nfa nothing nqueens puzzle scheme-c2 scheme-c takr2 tak takr 11 | RUN_RACKET_BENCHMARKS = true 12 | 13 | LARCENY_HOME = ../larceny 14 | LARCENY_BENCHMARKS_HOME = $(LARCENY_HOME)/test/Benchmarking/R7RS 15 | LARCENY_BENCHMARKS = ack array1 string sum1 cat tail wc 16 | 17 | default: akeem 18 | 19 | %.o: %.s constants.s macros.s boot.scm r7rs.scm init.scm Makefile 20 | $(AS) $< $(ASFLAGS) -o $@ 21 | 22 | akeem: lisp.o 23 | $(CC) $^ $(CFLAGS) $(LDLIBS) -o $@ 24 | 25 | # based on http://unix.stackexchange.com/a/79137 26 | run-tests: akeem 27 | ./$< tests.scm 2>&1 | diff -y -W250 tests.out - | expand | grep --color=always -nEC1 '^.{123} [|<>]( |$$)'; \ 28 | if [ $$? -eq 0 ] ; then \ 29 | echo Tests FAILED ; false ; \ 30 | else \ 31 | echo `cat tests.out | grep -v ';;;' | wc -l` Tests PASSED ; \ 32 | fi 33 | 34 | run-tests-catchsegv: akeem 35 | catchsegv ./$< tests.scm 36 | 37 | /usr/bin/rlwrap: 38 | sudo apt-get install -y rlwrap 39 | 40 | run-repl: akeem /usr/bin/rlwrap 41 | @rlwrap -nm -q "\"" ./$< 42 | 43 | /usr/bin/entr: 44 | sudo apt-get install -y entr 45 | 46 | retest: /usr/bin/entr 47 | while true; do find . -name '*.s' -o -name '*.scm' -o -name Makefile -o -name tests.out | \ 48 | $< -r $(MAKE) -s run-tests ; done 49 | 50 | valgrind: clean akeem 51 | if [ -n "`which valgrind`" ] ; then \ 52 | echo "(exit 0)" | valgrind --suppressions=akeem.supp --error-exitcode=1 -q $(AKEEM) > /dev/null ; \ 53 | else \ 54 | echo "valgrind not found, skipping." ; \ 55 | fi 56 | 57 | benchmark: clean akeem 58 | cd $(RACKET_BENCHMARKS_HOME) ; \ 59 | for test in $(RACKET_BENCHMARKS) ; do \ 60 | test -n '$(RUN_RACKET_BENCHMARKS)' && (echo $$test.rkt ; $(RACKET) $$test.rkt) ; \ 61 | echo $$test.sch ; $(AKEEM) $(AKEEM_HOME)/benchmarks-prelude.scm $$test.sch ; \ 62 | done 63 | 64 | larceny-benchmark: clean akeem 65 | cd $(LARCENY_BENCHMARKS_HOME) ; \ 66 | mkdir outputs ; \ 67 | for test in $(LARCENY_BENCHMARKS) ; do \ 68 | echo $$test.scm ; $(AKEEM) src/$$test.scm src/common.scm < inputs/$$test.input ; \ 69 | done 70 | 71 | profile: RACKET_BENCHMARKS = nqueens 72 | profile: RUN_RACKET_BENCHMARKS = 73 | profile: CFLAGS += -pg 74 | profile: benchmark 75 | gprof -b $(AKEEM) $(RACKET_BENCHMARKS_HOME)/gmon.out 76 | 77 | profile-clean: 78 | rm -f $(RACKET_BENCHMARKS_HOME)/gmon.out 79 | 80 | jit-dissassmble: 81 | objdump -b binary -D -mi386:x86-64 jit_code/jit_code_*.bin 82 | 83 | jit-clean: 84 | rm -rf jit_code 85 | 86 | release: clean akeem run-tests valgrind 87 | strip $(AKEEM) 88 | 89 | clean: jit-clean profile-clean 90 | rm -f $(AKEEM) *.o 91 | 92 | check: run-tests 93 | 94 | docker: 95 | docker build -t akeem . 96 | 97 | run-docker: docker 98 | docker run --rm -i -t akeem 99 | 100 | run-docker-shell: docker 101 | docker run --rm -i -t akeem bash 102 | 103 | .PHONY: run-tests run-tests-catchsegv run-repl retest benchmark profile jit-clean jit-dissassmble clean check release docker run-docker run-docker-shell 104 | .SILENT: run-tests retest benchmark larceny-benchmark profile valgrind 105 | -------------------------------------------------------------------------------- /docs/xt16/resources/css/styles.css: -------------------------------------------------------------------------------- 1 | @font-face { 2 | font-family: 'Gruppo'; 3 | src: url('../fonts/Gruppo/Gruppo-Regular.ttf') format('truetype'); 4 | } 5 | @font-face { 6 | font-family: 'Raleway Dots'; 7 | src: url('../fonts/Raleway_Dots/RalewayDots-Regular.ttf') format('truetype'); 8 | } 9 | @font-face { 10 | font-family: 'Ubuntu Mono'; 11 | src: url('../fonts/Ubuntu_Mono/UbuntuMono-Regular.ttf') format('truetype'); 12 | } 13 | body { 14 | font-family: 'Gruppo'; 15 | } 16 | h1, h2, h3, h4, h5 { 17 | color: #77cc88; 18 | font-family: 'Raleway Dots'; 19 | font-weight: normal; 20 | text-transform: uppercase; 21 | margin-bottom: 0; 22 | text-shadow: 2px 2px 8px darkgreen, -2px -2px 8px green, 12px 0px 8px darkgreen; 23 | } 24 | h4, h5 { 25 | color: lightblue; 26 | font-weight: bold; 27 | margin-bottom: 0.5em; 28 | text-shadow: 2px 2px 8px darkgreen, -2px -2px 8px darkgreen; 29 | position: relative; 30 | } 31 | ol { 32 | list-style-type: none; 33 | padding-left: 0; 34 | } 35 | li:not(:last-child) { 36 | opacity: 0.5; 37 | } 38 | li:nth-last-child(2) { 39 | animation: fade-out 0.5s; 40 | } 41 | li:last-child { 42 | font-size: 2em; 43 | animation: fade-in 1s; 44 | } 45 | li:last-child:before { 46 | content: ">"; 47 | position: absolute; 48 | margin-top: -0.1em; 49 | margin-left: -0.75em; 50 | } 51 | li:last-child:after { 52 | animation: blink 1s step-start 0s infinite; 53 | content: "_"; 54 | position: absolute; 55 | margin-top: 0.1em; 56 | margin-left: 0.2em; 57 | } 58 | .list-listing li { 59 | display: inline; 60 | white-space: pre; 61 | } 62 | @keyframes blink { 63 | 50% { 64 | opacity: 0.0; 65 | } 66 | } 67 | @keyframes fade-in { 68 | from { opacity: 0.4; } 69 | to { opacity: 1; } 70 | } 71 | @keyframes fade-out { 72 | from { opacity: 0.7; } 73 | to { opacity: 0.5; } 74 | } 75 | pre { 76 | margin-top: 0em; 77 | text-shadow: none; 78 | } 79 | .remark-slide-content { 80 | zoom: 2; 81 | color: #5fa; 82 | background-color: #080808; 83 | text-shadow: 1px 0px 1px green, 3px 1px 8px green, 12px 0px 12px darkgreen; 84 | } 85 | .raster:before, .listing .remark-code:before { 86 | content: ""; 87 | position: absolute; 88 | width: 100%; 89 | height: 100%; 90 | background:url( 91 | data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAIAAAACCAYAAABytg0kAAAAEklEQVQIW2NkgAJGBgaG/yA2AAUoAQL8e2DiAAAAAElFTkSuQmCC 92 | ) repeat; 93 | opacity: 0.4; 94 | } 95 | .small-listing .remark-code { 96 | zoom: 0.45; 97 | } 98 | .remark-code { 99 | zoom: 0.85; 100 | } 101 | .raster .remark-code { 102 | zoom: 1.3; 103 | } 104 | .remark-code, .remark-inline-code { 105 | font-family: 'Ubuntu Mono'; 106 | color: lightblue; 107 | text-shadow: 1px 0px 1px green, 2px 1px 8px green, 12px 0px 12px darkgreen; 108 | z-index: 1; 109 | } 110 | a { 111 | color: inherit; 112 | text-decoration: none; 113 | } 114 | .full, .top { 115 | background-color: black; 116 | } 117 | .full img { 118 | position: absolute; 119 | top: 2.5%; 120 | width: auto; 121 | height: 95%; 122 | max-width: 95%; 123 | left: 50%; 124 | transform: translateX(-50%); 125 | } 126 | .top img { 127 | transform: translateY(0), translateX(0); 128 | height: auto; 129 | } 130 | -------------------------------------------------------------------------------- /docs/xt16/resources/fonts/Gruppo/OFL.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010, 2011 vernon adams (vern@newtypography.co.uk), 2 | with Reserved Font Name Gruppo. 3 | This Font Software is licensed under the SIL Open Font License, Version 1.1. 4 | This license is copied below, and is also available with a FAQ at: 5 | http://scripts.sil.org/OFL 6 | 7 | 8 | ----------------------------------------------------------- 9 | SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007 10 | ----------------------------------------------------------- 11 | 12 | PREAMBLE 13 | The goals of the Open Font License (OFL) are to stimulate worldwide 14 | development of collaborative font projects, to support the font creation 15 | efforts of academic and linguistic communities, and to provide a free and 16 | open framework in which fonts may be shared and improved in partnership 17 | with others. 18 | 19 | The OFL allows the licensed fonts to be used, studied, modified and 20 | redistributed freely as long as they are not sold by themselves. The 21 | fonts, including any derivative works, can be bundled, embedded, 22 | redistributed and/or sold with any software provided that any reserved 23 | names are not used by derivative works. The fonts and derivatives, 24 | however, cannot be released under any other type of license. The 25 | requirement for fonts to remain under this license does not apply 26 | to any document created using the fonts or their derivatives. 27 | 28 | DEFINITIONS 29 | "Font Software" refers to the set of files released by the Copyright 30 | Holder(s) under this license and clearly marked as such. This may 31 | include source files, build scripts and documentation. 32 | 33 | "Reserved Font Name" refers to any names specified as such after the 34 | copyright statement(s). 35 | 36 | "Original Version" refers to the collection of Font Software components as 37 | distributed by the Copyright Holder(s). 38 | 39 | "Modified Version" refers to any derivative made by adding to, deleting, 40 | or substituting -- in part or in whole -- any of the components of the 41 | Original Version, by changing formats or by porting the Font Software to a 42 | new environment. 43 | 44 | "Author" refers to any designer, engineer, programmer, technical 45 | writer or other person who contributed to the Font Software. 46 | 47 | PERMISSION & CONDITIONS 48 | Permission is hereby granted, free of charge, to any person obtaining 49 | a copy of the Font Software, to use, study, copy, merge, embed, modify, 50 | redistribute, and sell modified and unmodified copies of the Font 51 | Software, subject to the following conditions: 52 | 53 | 1) Neither the Font Software nor any of its individual components, 54 | in Original or Modified Versions, may be sold by itself. 55 | 56 | 2) Original or Modified Versions of the Font Software may be bundled, 57 | redistributed and/or sold with any software, provided that each copy 58 | contains the above copyright notice and this license. These can be 59 | included either as stand-alone text files, human-readable headers or 60 | in the appropriate machine-readable metadata fields within text or 61 | binary files as long as those fields can be easily viewed by the user. 62 | 63 | 3) No Modified Version of the Font Software may use the Reserved Font 64 | Name(s) unless explicit written permission is granted by the corresponding 65 | Copyright Holder. This restriction only applies to the primary font name as 66 | presented to the users. 67 | 68 | 4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font 69 | Software shall not be used to promote, endorse or advertise any 70 | Modified Version, except to acknowledge the contribution(s) of the 71 | Copyright Holder(s) and the Author(s) or with their explicit written 72 | permission. 73 | 74 | 5) The Font Software, modified or unmodified, in part or in whole, 75 | must be distributed entirely under this license, and must not be 76 | distributed under any other license. The requirement for fonts to 77 | remain under this license does not apply to any document created 78 | using the Font Software. 79 | 80 | TERMINATION 81 | This license becomes null and void if any of the above conditions are 82 | not met. 83 | 84 | DISCLAIMER 85 | THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 86 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF 87 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT 88 | OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE 89 | COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 90 | INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL 91 | DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 92 | FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM 93 | OTHER DEALINGS IN THE FONT SOFTWARE. 94 | -------------------------------------------------------------------------------- /constants.s: -------------------------------------------------------------------------------- 1 | .equ NULL, 0 2 | .equ EOF, -1 3 | .equ PAGE_SIZE, 4096 4 | 5 | ## setjmp.h 6 | .equ JMP_BUF_SIZE, 200 7 | 8 | ## sys/mman.h 9 | .equ PROT_READ, 0x1 10 | .equ PROT_WRITE, 0x2 11 | .equ PROT_EXEC, 0x4 12 | .equ MAP_PRIVATE, 0x02 13 | .equ MAP_ANONYMOUS, 0x20 14 | 15 | ## stdio.h 16 | .equ SEEK_SET, 0 17 | 18 | ## time.h 19 | .equ CLOCKS_PER_SEC, 1000000 20 | 21 | ## unistd.h 22 | .equ F_OK, 0 23 | .equ STDERR_FILENO, 2 24 | 25 | ## signal.h 26 | .equ SIGSEGV, 11 27 | 28 | ## dlfcn.h 29 | .equ RTLD_DEFAULT, 0 30 | .equ RTLD_LAZY, 1 31 | 32 | .equ ROUNDING_MODE_TRUNCATE, 0b11 33 | 34 | .equ CPUID_FEATURE_INFORMATION, 1 35 | .equ SSE4_1, 1 << 19 36 | .equ SSE4_2, 1 << 20 37 | 38 | .equ STACKTRACE_SIZE, 10 39 | 40 | .equ BYTE_SIZE, 1 41 | .equ WORD_SIZE, BYTE_SIZE * 2 42 | .equ INT_SIZE, WORD_SIZE * 2 43 | .equ POINTER_SIZE, INT_SIZE * 2 44 | 45 | .equ POINTER_SIZE_SHIFT, 3 46 | 47 | .equ NAN_MASK, 0x7FF8000000000000 48 | .equ TAG_SHIFT, 45 49 | .equ TAG_MASK, (1 << 6) - 1 50 | .equ POINTER_TAG_MASK, ~(TAG_SYMBOL - 1) 51 | 52 | .equ PAYLOAD_SHIFT, 64 - 48 53 | .equ SIGN_BIT, 63 54 | 55 | .equ TAG_DOUBLE, 0 56 | 57 | .equ TAG_BOOLEAN, 1 58 | .equ TAG_BYTE, 2 59 | .equ TAG_CHAR, 3 60 | .equ TAG_INT, 4 61 | 62 | .equ TAG_SYMBOL, 8 63 | .equ TAG_PROCEDURE, 16 64 | .equ TAG_PORT, 24 65 | 66 | .equ TAG_STRING, 32 67 | .equ TAG_PAIR, 40 68 | .equ TAG_VECTOR, 48 69 | .equ TAG_OBJECT, 56 70 | 71 | .equ TAG_BYTEVECTOR, 64 72 | .equ TAG_CONTINUATION, 65 73 | .equ TAG_VALUES, 66 74 | .equ TAG_HANDLE, 67 75 | .equ TAG_C_PROCEDURE, 68 76 | 77 | .equ C_TRUE, 1 78 | .equ C_FALSE, 0 79 | .equ FALSE, (NAN_MASK | (TAG_BOOLEAN << TAG_SHIFT)) 80 | .equ TRUE, (FALSE | C_TRUE) 81 | 82 | .equ NIL, (NAN_MASK | (TAG_PAIR << TAG_SHIFT) | NULL) 83 | .equ VOID, (NAN_MASK | (TAG_OBJECT << TAG_SHIFT) | NULL) 84 | 85 | .equ EOF_OBJECT, (NAN_MASK | (TAG_CHAR << TAG_SHIFT) | 0xffffffff) 86 | .equ NEWLINE_CHAR, (NAN_MASK | (TAG_CHAR << TAG_SHIFT) | 10) 87 | .equ SPACE_CHAR, (NAN_MASK | (TAG_CHAR << TAG_SHIFT) | 32) 88 | 89 | .equ ZERO_INT, (NAN_MASK | (TAG_INT << TAG_SHIFT) | 0) 90 | .equ ONE_INT, (NAN_MASK | (TAG_INT << TAG_SHIFT) | 1) 91 | 92 | .equ BINARY_RADIX_INT, (NAN_MASK | (TAG_INT << TAG_SHIFT) | 2) 93 | .equ OCTAL_RADIX_INT, (NAN_MASK | (TAG_INT << TAG_SHIFT) | 8) 94 | .equ DECIMAL_RADIX_INT, (NAN_MASK | (TAG_INT << TAG_SHIFT) | 10) 95 | .equ HEX_RADIX_INT, (NAN_MASK | (TAG_INT << TAG_SHIFT) | 16) 96 | 97 | .equ MAX_NUMBER_OF_SYMBOLS, 1024 98 | .equ POINTER_STACK_INITIAL_SIZE, 8 * 1024 99 | 100 | .equ CODE_SPACE_SIZE, 512 * 1024 * 1024 101 | 102 | .equ CHAR_TABLE_SIZE, 256 103 | .equ CHAR_PREFIX_LENGTH, 2 104 | 105 | .equ BINARY_OP_SHIFT, 4 106 | .equ BINARY_OP_MASK, 4 - 1 107 | .equ BINARY_OP_INT_INT, (1 << 1 | 1) 108 | 109 | .equ FFI_APPLY_DOUBLES_JUMP_ALIGNMENT, 8 110 | .equ VARARGS_JUMP_ALIGNMENT, 16 111 | .equ VARARGS_JUMP_ALIGNMENT_SHIFT, 4 112 | 113 | .equ GC_MARK_BIT, 0 114 | 115 | .equ NUMBER_OF_REGISTERS, 16 116 | .equ MAX_REGISTER_ARGS, 6 117 | .equ MAX_REGISTER_DOUBLE_ARGS, 8 118 | 119 | .equ MAX_CLOSURE_ENVIRONMENT_SIZE, 64 120 | 121 | .equ CONTINUATION_SAVED_VALUES, 4 122 | 123 | .equ RET_SIZE, 1 124 | 125 | .equ RAX, 0 126 | .equ RCX, 1 127 | .equ RDX, 2 128 | .equ RBX, 3 129 | .equ RSP, 4 130 | .equ RBP, 5 131 | .equ RSI, 6 132 | .equ RDI, 7 133 | .irp reg, 8, 9, 10, 11, 12, 13, 14, 15 134 | .equ R\reg, \reg 135 | .endr 136 | 137 | .equ MICROSECONDS_PER_SEC, 1000000 138 | 139 | .equ LOG_JIT, C_FALSE 140 | .equ ASSERTIONS, C_TRUE 141 | 142 | .struct 0 143 | header_object_mark: 144 | .struct . + WORD_SIZE 145 | header_object_type: 146 | .struct . + WORD_SIZE 147 | header_object_size: 148 | .struct . + INT_SIZE 149 | header_size: 150 | 151 | .struct header_size 152 | pair_car: 153 | .struct . + POINTER_SIZE 154 | pair_cdr: 155 | .struct . + POINTER_SIZE 156 | pair_size: 157 | 158 | .struct 0 159 | stack_bottom: 160 | .struct . + POINTER_SIZE 161 | stack_top_offset: 162 | .struct . + POINTER_SIZE 163 | stack_max_size: 164 | .struct . + POINTER_SIZE 165 | stack_size: 166 | -------------------------------------------------------------------------------- /docs/xt16/resources/fonts/Raleway_Dots/OFL.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010, Matt McInerney (matt@pixelspread.com), Copyright (c) 2012, Pablo Impallari (www.impallari.com|impallari@gmail.com), Copyright (c) 2012, Brenda Gallo. (gbrenda1987@gmail.com), Copyright (c) 2012, Rodrigo Fuenzalida (www.rfuenzalida.com|hello@rfuenzalida.com), with Reserved Font Name "Raleway" 2 | This Font Software is licensed under the SIL Open Font License, Version 1.1. 3 | This license is copied below, and is also available with a FAQ at: 4 | http://scripts.sil.org/OFL 5 | 6 | 7 | ----------------------------------------------------------- 8 | SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007 9 | ----------------------------------------------------------- 10 | 11 | PREAMBLE 12 | The goals of the Open Font License (OFL) are to stimulate worldwide 13 | development of collaborative font projects, to support the font creation 14 | efforts of academic and linguistic communities, and to provide a free and 15 | open framework in which fonts may be shared and improved in partnership 16 | with others. 17 | 18 | The OFL allows the licensed fonts to be used, studied, modified and 19 | redistributed freely as long as they are not sold by themselves. The 20 | fonts, including any derivative works, can be bundled, embedded, 21 | redistributed and/or sold with any software provided that any reserved 22 | names are not used by derivative works. The fonts and derivatives, 23 | however, cannot be released under any other type of license. The 24 | requirement for fonts to remain under this license does not apply 25 | to any document created using the fonts or their derivatives. 26 | 27 | DEFINITIONS 28 | "Font Software" refers to the set of files released by the Copyright 29 | Holder(s) under this license and clearly marked as such. This may 30 | include source files, build scripts and documentation. 31 | 32 | "Reserved Font Name" refers to any names specified as such after the 33 | copyright statement(s). 34 | 35 | "Original Version" refers to the collection of Font Software components as 36 | distributed by the Copyright Holder(s). 37 | 38 | "Modified Version" refers to any derivative made by adding to, deleting, 39 | or substituting -- in part or in whole -- any of the components of the 40 | Original Version, by changing formats or by porting the Font Software to a 41 | new environment. 42 | 43 | "Author" refers to any designer, engineer, programmer, technical 44 | writer or other person who contributed to the Font Software. 45 | 46 | PERMISSION & CONDITIONS 47 | Permission is hereby granted, free of charge, to any person obtaining 48 | a copy of the Font Software, to use, study, copy, merge, embed, modify, 49 | redistribute, and sell modified and unmodified copies of the Font 50 | Software, subject to the following conditions: 51 | 52 | 1) Neither the Font Software nor any of its individual components, 53 | in Original or Modified Versions, may be sold by itself. 54 | 55 | 2) Original or Modified Versions of the Font Software may be bundled, 56 | redistributed and/or sold with any software, provided that each copy 57 | contains the above copyright notice and this license. These can be 58 | included either as stand-alone text files, human-readable headers or 59 | in the appropriate machine-readable metadata fields within text or 60 | binary files as long as those fields can be easily viewed by the user. 61 | 62 | 3) No Modified Version of the Font Software may use the Reserved Font 63 | Name(s) unless explicit written permission is granted by the corresponding 64 | Copyright Holder. This restriction only applies to the primary font name as 65 | presented to the users. 66 | 67 | 4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font 68 | Software shall not be used to promote, endorse or advertise any 69 | Modified Version, except to acknowledge the contribution(s) of the 70 | Copyright Holder(s) and the Author(s) or with their explicit written 71 | permission. 72 | 73 | 5) The Font Software, modified or unmodified, in part or in whole, 74 | must be distributed entirely under this license, and must not be 75 | distributed under any other license. The requirement for fonts to 76 | remain under this license does not apply to any document created 77 | using the Font Software. 78 | 79 | TERMINATION 80 | This license becomes null and void if any of the above conditions are 81 | not met. 82 | 83 | DISCLAIMER 84 | THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 85 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF 86 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT 87 | OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE 88 | COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 89 | INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL 90 | DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 91 | FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM 92 | OTHER DEALINGS IN THE FONT SOFTWARE. 93 | -------------------------------------------------------------------------------- /docs/xt16/resources/fonts/Ubuntu_Mono/UFL.txt: -------------------------------------------------------------------------------- 1 | ------------------------------- 2 | UBUNTU FONT LICENCE Version 1.0 3 | ------------------------------- 4 | 5 | PREAMBLE 6 | This licence allows the licensed fonts to be used, studied, modified and 7 | redistributed freely. The fonts, including any derivative works, can be 8 | bundled, embedded, and redistributed provided the terms of this licence 9 | are met. The fonts and derivatives, however, cannot be released under 10 | any other licence. The requirement for fonts to remain under this 11 | licence does not require any document created using the fonts or their 12 | derivatives to be published under this licence, as long as the primary 13 | purpose of the document is not to be a vehicle for the distribution of 14 | the fonts. 15 | 16 | DEFINITIONS 17 | "Font Software" refers to the set of files released by the Copyright 18 | Holder(s) under this licence and clearly marked as such. This may 19 | include source files, build scripts and documentation. 20 | 21 | "Original Version" refers to the collection of Font Software components 22 | as received under this licence. 23 | 24 | "Modified Version" refers to any derivative made by adding to, deleting, 25 | or substituting -- in part or in whole -- any of the components of the 26 | Original Version, by changing formats or by porting the Font Software to 27 | a new environment. 28 | 29 | "Copyright Holder(s)" refers to all individuals and companies who have a 30 | copyright ownership of the Font Software. 31 | 32 | "Substantially Changed" refers to Modified Versions which can be easily 33 | identified as dissimilar to the Font Software by users of the Font 34 | Software comparing the Original Version with the Modified Version. 35 | 36 | To "Propagate" a work means to do anything with it that, without 37 | permission, would make you directly or secondarily liable for 38 | infringement under applicable copyright law, except executing it on a 39 | computer or modifying a private copy. Propagation includes copying, 40 | distribution (with or without modification and with or without charging 41 | a redistribution fee), making available to the public, and in some 42 | countries other activities as well. 43 | 44 | PERMISSION & CONDITIONS 45 | This licence does not grant any rights under trademark law and all such 46 | rights are reserved. 47 | 48 | Permission is hereby granted, free of charge, to any person obtaining a 49 | copy of the Font Software, to propagate the Font Software, subject to 50 | the below conditions: 51 | 52 | 1) Each copy of the Font Software must contain the above copyright 53 | notice and this licence. These can be included either as stand-alone 54 | text files, human-readable headers or in the appropriate machine- 55 | readable metadata fields within text or binary files as long as those 56 | fields can be easily viewed by the user. 57 | 58 | 2) The font name complies with the following: 59 | (a) The Original Version must retain its name, unmodified. 60 | (b) Modified Versions which are Substantially Changed must be renamed to 61 | avoid use of the name of the Original Version or similar names entirely. 62 | (c) Modified Versions which are not Substantially Changed must be 63 | renamed to both (i) retain the name of the Original Version and (ii) add 64 | additional naming elements to distinguish the Modified Version from the 65 | Original Version. The name of such Modified Versions must be the name of 66 | the Original Version, with "derivative X" where X represents the name of 67 | the new work, appended to that name. 68 | 69 | 3) The name(s) of the Copyright Holder(s) and any contributor to the 70 | Font Software shall not be used to promote, endorse or advertise any 71 | Modified Version, except (i) as required by this licence, (ii) to 72 | acknowledge the contribution(s) of the Copyright Holder(s) or (iii) with 73 | their explicit written permission. 74 | 75 | 4) The Font Software, modified or unmodified, in part or in whole, must 76 | be distributed entirely under this licence, and must not be distributed 77 | under any other licence. The requirement for fonts to remain under this 78 | licence does not affect any document created using the Font Software, 79 | except any version of the Font Software extracted from a document 80 | created using the Font Software may only be distributed under this 81 | licence. 82 | 83 | TERMINATION 84 | This licence becomes null and void if any of the above conditions are 85 | not met. 86 | 87 | DISCLAIMER 88 | THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 89 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF 90 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT OF 91 | COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE 92 | COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 93 | INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL 94 | DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 95 | FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM OTHER 96 | DEALINGS IN THE FONT SOFTWARE. 97 | -------------------------------------------------------------------------------- /tests.out: -------------------------------------------------------------------------------- 1 | ;;; R7RS 2 | ;;; 1. Overview of Scheme 3 | ;;; 1.3. Notation and terminology 4 | ;;; 1.3.4. Evaluation examples 5 | 40 6 | ";;; 2. Lexical conventions" 7 | ";;; 2.2. Whitespace and comments" 8 | 3628800 9 | ;;; 4. Expressions 10 | ;;; 4.1. Primitive expression types 11 | ;;; 4.1.1. Variable references 12 | 28 13 | ;;; 4.1.2. Literal expressions 14 | a 15 | #(a b c) 16 | (+ 1 2) 17 | a 18 | #(a b c) 19 | () 20 | (+ 1 2) 21 | (quote a) 22 | (quote a) 23 | 145932 24 | 145932 25 | "abc" 26 | "abc" 27 | #(a 10) 28 | #(a 10) 29 | #u8(64 65) 30 | #u8(64 65) 31 | #t 32 | #t 33 | ;;; 4.1.3. Procedure calls 34 | 7 35 | 12 36 | ;;; 4.1.4. Procedures 37 | # 38 | 8 39 | 3 40 | 10 41 | (3 4 5 6) 42 | (5 6) 43 | ;;; 4.1.5. Conditionals 44 | yes 45 | no 46 | 1 47 | ;;; 4.1.6. Assignments 48 | 3 49 | # 50 | 5 51 | ;;; 4.2. Derived expression types 52 | ;;; 4.2.1. Conditionals 53 | greater 54 | equal 55 | 2 56 | composite 57 | # 58 | c 59 | #t 60 | #f 61 | (f g) 62 | #t 63 | #t 64 | #t 65 | #f 66 | (b c) 67 | 12 68 | # 69 | # 70 | ;;; 4.2.2. Binding constructs 71 | 6 72 | 35 73 | 70 74 | #t 75 | 35 76 | (x y x y) 77 | ;;; 4.2.3. Sequencing 78 | 6 79 | 4 plus 1 equals 5 80 | ;;; 4.2.4. Iteration 81 | #(0 1 2 3 4) 82 | 25 83 | ((6 1 3) (-5 -2)) 84 | ;;; 4.2.5. Delayed evaluation 85 | 3 86 | (3 3) 87 | 2 88 | 5 89 | # 90 | 6 91 | # 92 | 6 93 | #f 94 | #f 95 | # 96 | ;;; 4.2.6. Dynamic bindings 97 | "12" 98 | "c" 99 | "12" 100 | ;;; 4.2.7. Exception handling 101 | 42 102 | (b . 23) 103 | ;;; 4.2.8. Quasiquotation 104 | (list 3 4) 105 | (list a (quote a)) 106 | (a 3 4 5 6 b) 107 | ((foo 7) . cons) 108 | #(10 5 2 4 3 8) 109 | (list 3 4) 110 | (quasiquote (list (unquote (+ 1 2)) 4)) 111 | ;;; 4.2.9. Case-lambda 112 | (0 1 2) 113 | (3 4) 114 | ;;; 4.3. Macros 115 | ;;; 4.3.1. Binding constructs for syntactic keywords 116 | ;;; 4.3.2. Pattern language 117 | ok 118 | ;;; 5. Program structure 119 | ;;; 5.1. Programs 120 | ;;; 5.3. Variable definitions 121 | ;;; 5.3.1. Top level definitions 122 | 6 123 | 1 124 | ;;; 5.3.3. Multiple-value definitions 125 | (4 1) 126 | 3 127 | ;;; 5.5. Record-type definitions 128 | #t 129 | #f 130 | 1 131 | 2 132 | 3 133 | ;;; 6. Standard procedures 134 | ;;; 6.1. Equivalence predicates 135 | #t 136 | #f 137 | #t 138 | #f 139 | #t 140 | #t 141 | #t 142 | #f 143 | #f 144 | #t 145 | #f 146 | #t 147 | #f 148 | #f 149 | #f 150 | #t 151 | #f 152 | #t 153 | #f 154 | #f 155 | #f 156 | #f 157 | #f 158 | #f 159 | #t 160 | #t 161 | #f 162 | #f 163 | #f 164 | #t 165 | #t 166 | #t 167 | #t 168 | #t 169 | #t 170 | #t 171 | #t 172 | #t 173 | #t 174 | #t 175 | #t 176 | #t 177 | #t 178 | #t 179 | #f 180 | ;;; 6.2. Numbers 181 | ;;; 6.2.6. Numerical operations 182 | #t 183 | #t 184 | #t 185 | #t 186 | #f 187 | #t 188 | #f 189 | #f 190 | #t 191 | #f 192 | #t 193 | #f 194 | 4 195 | 4.000000 196 | 7 197 | -1 198 | 7 199 | #t 200 | 1 201 | 1 202 | 3 203 | -1 204 | -3 205 | 1 206 | -1 207 | -1 208 | -1.000000 209 | 2 1 210 | -3 1 211 | -3 -1 212 | 2 -1 213 | 2 1 214 | -2 -1 215 | -2 1 216 | 2 -1 217 | 2.000000 -1.000000 218 | 4 219 | 0 220 | 288 221 | 288.000000 222 | 1 223 | -5.000000 224 | -4.000000 225 | -4.000000 226 | -4.000000 227 | 3.000000 228 | 4.000000 229 | 3.000000 230 | 4.000000 231 | 7 232 | 1764 233 | 4.000000 234 | 2 0 235 | 2 1 236 | ;;; 6.2.7. Numerical input and output 237 | #t 238 | 100 239 | 256 240 | 100.000000 241 | ;;; 6.3. Booleans 242 | #t 243 | #f 244 | #f 245 | #f 246 | #f 247 | #f 248 | #t 249 | #f 250 | #f 251 | #f 252 | #t 253 | #f 254 | #f 255 | ;;; 6.4. Pairs and lists 256 | (a b c) 257 | #t 258 | # 259 | (a . 4) 260 | #t 261 | (a . 4) 262 | #f 263 | # 264 | #t 265 | #t 266 | #f 267 | #f 268 | (a) 269 | ((a) b c d) 270 | ("a" b c) 271 | (a . 3) 272 | ((a b) . c) 273 | a 274 | (a) 275 | 1 276 | (b c d) 277 | 2 278 | # 279 | #t 280 | #t 281 | #f 282 | (3 3) 283 | (a 7 c) 284 | () 285 | 3 286 | 3 287 | 0 288 | (x y) 289 | (a b c d) 290 | (a (b) (c)) 291 | (a b c . d) 292 | a 293 | (c b a) 294 | ((e (f)) d (b c) a) 295 | c 296 | c 297 | (one two three) 298 | (a b c) 299 | (b c) 300 | #f 301 | #f 302 | ((a) c) 303 | ("b" "c") 304 | (101 102) 305 | (101 102) 306 | (a 1) 307 | (b 2) 308 | #f 309 | #f 310 | ((a)) 311 | (2 4) 312 | (5 7) 313 | (5 7) 314 | (3 8 2 8) 315 | (1 8 2 8) 316 | ;;; 6.5. Symbols 317 | #t 318 | #t 319 | #f 320 | #t 321 | #f 322 | #f 323 | "flying-fish" 324 | "Martin" 325 | "Malvina" 326 | mISSISSIppi 327 | #t 328 | #t 329 | #t 330 | ;;; 6.6. Characters 331 | #t 332 | 3 333 | #f 334 | ;;; 6.7. Strings 335 | "The word \"recursion\" has many meanings." 336 | "Another example:\ntwo lines of text" 337 | "Here's text containing just one line" 338 | "a is named GREEK SMALL LETTER ALPHA." 339 | # 340 | "a12de" 341 | ;;; 6.8. Vectors 342 | #(0 (2 2 2 2) "Anna") 343 | #(a b c) 344 | 8 345 | 13 346 | #(0 ("Sue" "Sue") "Anna") 347 | (dah dah didah) 348 | (dah) 349 | #(dididit dah) 350 | #(#\A #\B #\C) 351 | "123" 352 | #(3 8 2 8) 353 | #(8 2) 354 | #(10 1 2 40 50) 355 | #(a b c d e f) 356 | #(1 2 smash smash 5) 357 | ;;; 6.9. Bytevectors 358 | #u8(12 12) 359 | #u8(1 3 5 1 3 5) 360 | #u8() 361 | 8 362 | #u8(1 3 3 4) 363 | #u8(3 4) 364 | #u8(10 1 2 40 50) 365 | #u8(0 1 2 3 4 5) 366 | "A" 367 | #u8(65) 368 | ;;; 6.10. Control features 369 | #t 370 | #f 371 | #t 372 | #f 373 | #t 374 | 7 375 | 30 376 | (b e h) 377 | (1 4 27 256 3125) 378 | (5 7 9) 379 | (1 2) 380 | "IBM" 381 | #(b e h) 382 | #(1 4 27 256 3125) 383 | #(5 7 9) 384 | #(1 2) 385 | #(0 1 4 9 16) 386 | (101 100 99 98 97) 387 | (0 1 4 9 16) 388 | -3 389 | 4 390 | #f 391 | 5 392 | (connect talk1 disconnect connect talk2 disconnect) 393 | ;;; 6.11. Exceptions 394 | condition: an-error 395 | exception 396 | should be a number 397 | 65 398 | ;;; 6.12. Environments and evaluation 399 | 21 400 | 20 401 | ;;; Example 402 | #(1 0) 403 | #(0.998951 0.000010) 404 | #(0.997802 0.000020) 405 | -------------------------------------------------------------------------------- /docs/xt16/talk.md: -------------------------------------------------------------------------------- 1 | class: center, middle 2 | name: The Search for Simplicity 3 | 4 | # The Search for Simplicity 5 | Håkan Råberg 6 | 7 | --- 8 | 9 | ### Background 10 | -- 11 | 12 | 1. Worked on a RDF / Semantic web project 13 | -- 14 | 15 | 2. Decided to regain sanity 16 | -- 17 | 18 | 3. By writing a Scheme R7RS compiler in x86-64 assembler 19 | -- 20 | 21 | 4. SEGMENTATION FAULT 22 | 23 | --- 24 | 25 | ### History 26 | -- 27 | 28 | 1. Wrote 68k assembler on the Amiga in the early 90s 29 | -- 30 | 31 | 2. Wrote some x86 assembler in the mid 90s 32 | -- 33 | 34 | 3. ... working as a programmer for ~20 years 35 | -- 36 | 37 | 4. What has changed? 38 | 39 | --- 40 | class: full 41 | ![AsmOne](resources/images/asmone.jpg) 42 | 43 | --- 44 | class: full, top 45 | ![Guru Meditation](resources/images/guru-meditation.gif) 46 | 47 | --- 48 | class: full 49 | ![Devpac 3](resources/images/devpac3frontbox.jpg) 50 | 51 | --- 52 | class: full 53 | ![Devpac 3](resources/images/devpac3backbox.jpg) 54 | 55 | --- 56 | class: full 57 | ![Devpac 3](resources/images/devpac3mk.jpg) 58 | 59 | --- 60 | class: full 61 | ![Devpac 3](resources/images/devpac3diskwalletinside.jpg) 62 | 63 | --- 64 | class: full 65 | ![Turbo Assembler](resources/images/borland-turbo-assembler.jpg) 66 | 67 | --- 68 | class: full 69 | ![Tiobe Index July 2016](resources/images/tiobe.png) 70 | 71 | --- 72 | class: center 73 | ## *When you think of garbage, think of Akeem* 74 | 75 | -- 76 | 1. [Prince Akeem of Zamunda](http://www.imdb.com/title/tt0094898/) 77 | 78 | --- 79 | 80 | ### Akeem Scheme 81 | -- 82 | 83 | 1. [Scheme R7RS small](http://trac.sacrideo.us/wg/raw-attachment/wiki/WikiStart/r7rs.pdf) 84 | -- 85 | 86 | 2. Template-based JIT: code as data 87 | -- 88 | 89 | 3. 5636 LOC x86-64 assembler 90 | -- 91 | 92 | 4. 1611 LOC Scheme 93 | -- 94 | 95 | 5. Uses glibc 96 | -- 97 | 98 | 6. Testing using diff and [entr](http://entrproject.org/) 99 | -- 100 | 101 | 7. TCO, call/cc, varargs, FFI 102 | -- 103 | 104 | 8. Mark and sweep GC 105 | -- 106 | 107 | 9. 2 months full time work 108 | 109 | --- 110 | 111 | ### x86-64 Asm 112 | -- 113 | 114 | 1. 16 registers + 16 XMM registers 115 | -- 116 | 117 | 2. CISC, 1-2k instructions 118 | -- 119 | 120 | 3. mov, jmp, add, xor, bts, lea, shl, jle, mulsd, popcnt, comisd, cvtsd2si ... 121 | -- 122 | 123 | 4. Stack grows downwards 124 | -- 125 | 126 | 5. Arguments in rdi, rsi, rdx, rcx, r8, r8 + stack 127 | -- 128 | 129 | 6. Return in rax, rdx 130 | -- 131 | 132 | 7. Calls own rbp, rbx, r12-r15 133 | 134 | --- 135 | class: raster 136 | 137 | #### Register layout 138 | ``` 139 | 64-bit %rax 140 | 32-bit %eax 141 | 16-bit %ax 142 | 8-bit %ah %al 143 | |---------------|-------|---|---| 144 | 145 | ``` 146 | 147 | --- 148 | class: listing 149 | 150 | #### Scheme Primitives 151 | ``` 152 | length: # list 153 | prologue 154 | assert_arity 1 155 | assert_tag TAG_PAIR, %rdi, not_a_pair_string 156 | mov %rdi, %rax 157 | xor %ebx, %ebx 158 | 159 | 1: is_nil_internal %rax 160 | je 2f 161 | 162 | call_scm cdr, %rax 163 | inc %rbx 164 | jmp 1b 165 | 166 | 2: box_int_internal %ebx 167 | return 168 | ``` 169 | 170 | --- 171 | class: listing 172 | 173 | #### Code as Data 174 | ``` 175 | .data 176 | 177 | .align 16 178 | jit_prologue: 179 | push %rbp 180 | mov %rsp, %rbp 181 | sub $0x11223344, %rsp 182 | jit_prologue_size: 183 | .quad (. - jit_prologue) 184 | 185 | .align 16 186 | jit_epilogue: 187 | mov %rbp, %rsp 188 | pop %rbp 189 | jit_epilogue_size: 190 | .quad (. - jit_epilogue) 191 | ``` 192 | 193 | --- 194 | class: list-listing 195 | 196 | ### Code Gen 197 | -- 198 | 199 | 1. (lambda (x) 200 | (+ 2 x)) 201 | 202 | --- 203 | class: raster 204 | 205 | ##### Store caller frame 206 | 207 | ``` 208 | 00: push %rbp 209 | ``` 210 | 211 | -- 212 | 213 | ##### Establish new frame 214 | 215 | ``` 216 | 01: mov %rsp,%rbp 217 | ``` 218 | 219 | -- 220 | 221 | ##### Allocate 8 bytes for x (rounded to 16) 222 | 223 | ``` 224 | 04: sub $0x10,%rsp 225 | ``` 226 | 227 | --- 228 | class: listing 229 | 230 | #### Stack frame layout 231 | ``` 232 | ^ ^ higher 233 | | | 234 | | (previous frame) | 235 | |-----------|----------------| 236 | | %rbp + 8 | return address | 237 | |-----------|----------------| 238 | | %rbp | saved %rbp | <- %rbp . (current frame) 239 | |-----------|----------------| . 240 | | %rbp - 8 | x, from %rdi | . 241 | | %rbp - 16 | (padding) | <- %rsp . 242 | |-----------|----------------| 243 | | (red zone) | 244 | : : 245 | . . lower 246 | ``` 247 | 248 | --- 249 | class: raster 250 | 251 | ##### Expected arity is 1 252 | ``` 253 | 0b: movabs $0x1,%r10 254 | ``` 255 | 256 | -- 257 | 258 | ##### Did caller provide correct arity? 259 | ``` 260 | 15: cmp %r10b,%al 261 | 18: je 0x24 262 | ``` 263 | 264 | -- 265 | 266 | ##### Throw arity error 267 | ``` 268 | 1a: mov $0x40e7ab,%r11 269 | 21: callq *%r11 270 | ``` 271 | 272 | --- 273 | class: raster 274 | 275 | ##### First argument as local x 276 | ``` 277 | 24: mov %rdi,-0x8(%rbp) 278 | ``` 279 | 280 | -- 281 | 282 | ##### x as second argument to + 283 | ``` 284 | 2b: mov -0x8(%rbp),%rsi 285 | ``` 286 | 287 | -- 288 | 289 | ##### 2 with tag as first argument to + 290 | ``` 291 | 32: movabs $0x7ff8800000000002,%rdi 292 | ``` 293 | 294 | --- 295 | class: raster 296 | 297 | #### Tag layout 298 | 299 | ``` 300 | $0x7ff8000000000000 NaN 301 | $0x0000800000000000 32-bit integer tag 302 | + $0x0000000000000002 value 303 | ---------------------- 304 | $0x7ff8800000000002 tagged Scheme value 305 | 306 | ``` 307 | 308 | --- 309 | class: raster 310 | 311 | ##### Clear multiple returns 312 | ``` 313 | 3c: xor %edx,%edx 314 | ``` 315 | 316 | --- 317 | class: raster 318 | 319 | ##### Symbol + id with tag 320 | ``` 321 | 3e: movabs $0x7ff9000000000060,%rax 322 | ``` 323 | 324 | -- 325 | 326 | ##### Value of + in the symbol table 327 | ``` 328 | 48: mov 0x627120(,%eax,8),%r10 329 | ``` 330 | 331 | -- 332 | 333 | ##### () with tag 334 | ``` 335 | 51: movabs $0x7fff000000000000,%r11 336 | ``` 337 | 338 | --- 339 | class: raster 340 | 341 | ##### Is the value of + null? 342 | ``` 343 | 5b: cmp %r10,%r11 344 | 5e: jne 0x6d 345 | ``` 346 | 347 | -- 348 | 349 | ##### Throw symbol not defined, id as first argument 350 | ``` 351 | 60: mov $0x40e5e3,%r11 352 | 67: mov %rax,%rdi 353 | 6a: callq *%r11 354 | ``` 355 | 356 | --- 357 | class: raster 358 | 359 | ##### + is defined 360 | ``` 361 | 6d: mov %r10,%rax 362 | ``` 363 | 364 | -- 365 | 366 | ##### Remove tag by shifting 367 | ``` 368 | 70: mov %rax,%r11 369 | 73: shl $0x10,%r11 370 | 77: shr $0x10,%r11 371 | ``` 372 | 373 | --- 374 | class: raster 375 | 376 | ##### Set number of arguments 377 | ``` 378 | 7b: xor %eax,%eax 379 | 7d: mov $0x2,%al 380 | ``` 381 | 382 | -- 383 | 384 | ##### Restore stack and frame for TCO 385 | ``` 386 | 7f: mov %rbp,%rsp 387 | 82: pop %rbp 388 | ``` 389 | 390 | -- 391 | 392 | ##### Tail call to + 393 | ``` 394 | 83: jmpq *%r11 395 | ``` 396 | 397 | --- 398 | class: raster 399 | 400 | ##### Normal epilogue, never reached 401 | ``` 402 | 86: mov %rbp,%rsp 403 | 89: pop %rbp 404 | 8a: retq 405 | ``` 406 | 407 | --- 408 | class: small-listing, listing 409 | 410 | ##### Recap (lambda (x) (+ 2 x)) 411 | ``` 412 | 00: push %rbp # Prologue 413 | 01: mov %rsp,%rbp 414 | 04: sub $0x10,%rsp 415 | 0b: movabs $0x1,%r10 # Arity check 416 | 15: cmp %r10b,%al 417 | 18: je 0x24 418 | 1a: mov $0x40e7ab,%r11 # Arity error 419 | 21: callq *%r11 420 | 24: mov %rdi,-0x8(%rbp) # Store argument x 421 | 2b: mov -0x8(%rbp),%rsi # x as argument 2 of + 422 | 32: movabs $0x7ff8800000000002,%rdi # 2 as argument 1 of + 423 | 3c: xor %edx,%edx 424 | 3e: movabs $0x7ff9000000000060,%rax # Load value of + 425 | 48: mov 0x627120(,%eax,8),%r10 426 | 51: movabs $0x7fff000000000000,%r11 # Check for null? 427 | 5b: cmp %r10,%r11 428 | 5e: jne 0x6d 429 | 60: mov $0x40e5e3,%r11 # Symbol not defined 430 | 67: mov %rax,%rdi 431 | 6a: callq *%r11 432 | 6d: mov %r10,%rax # Remove tag for call 433 | 70: mov %rax,%r11 434 | 73: shl $0x10,%r11 435 | 77: shr $0x10,%r11 436 | 7b: xor %eax,%eax # Set number of arguments 437 | 7d: mov $0x2,%al 438 | 7f: mov %rbp,%rsp # Restore stack for TCO 439 | 82: pop %rbp 440 | 83: jmpq *%r11 # Tail call to + 441 | 86: mov %rbp,%rsp # Dead code 442 | 89: pop %rbp 443 | 8a: retq 444 | ``` 445 | 446 | --- 447 | 448 | ### Reflection 449 | -- 450 | 451 | 1. Closeness to hardware mainly an illusion 452 | -- 453 | 454 | 2. Strictness about im/mutability extremely important 455 | -- 456 | 457 | 3. Patterns and conventional register use key 458 | -- 459 | 460 | 4. Testing is fundamental 461 | -- 462 | 463 | 5. Keep a few layers clean and simple 464 | -- 465 | 466 | 6. Cut losses and throw away changes 467 | -- 468 | 469 | 7. Commit all the time 470 | 471 | --- 472 | 1. (simple?) 473 | 474 | -- 475 | 2. \#f 476 | 477 | --- 478 | class: center, middle 479 | 480 | #### [github.com/hraberg/akeem](https://github.com/hraberg/akeem) 481 | 482 | --- 483 | class: center, middle 484 | 485 | ## Extra Slides 486 | 487 | --- 488 | class: listing 489 | 490 | #### Assembler Macros 491 | ``` 492 | .macro box_int_internal value=%eax, tmp=%r11 493 | mov \value, %eax 494 | tag TAG_INT, %rax, %rax, \tmp 495 | .endm 496 | 497 | .macro tag tag value=%rax, target=%rax, tmp=%r11 498 | mov_reg \value, \target 499 | mov $(NAN_MASK | \tag << TAG_SHIFT), \tmp 500 | or \tmp, \target 501 | .endm 502 | 503 | .macro cdr from, to=%rax 504 | unbox_pointer_internal \from \to 505 | mov pair_cdr(\to), \to 506 | .endm 507 | ``` 508 | 509 | --- 510 | class: listing 511 | 512 | #### NaN Boxing 513 | ``` 514 | .equ NAN_MASK, 0x7FF8000000000000 515 | .equ TAG_SHIFT, 45 516 | .equ TAG_MASK, (1 << 6) - 1 517 | .equ POINTER_TAG_MASK, ~(TAG_SYMBOL - 1) 518 | 519 | .equ TAG_DOUBLE, 0 520 | 521 | .equ TAG_BOOLEAN, 1 522 | .equ TAG_BYTE, 2 523 | .equ TAG_CHAR, 3 524 | .equ TAG_INT, 4 525 | 526 | .equ TAG_SYMBOL, 8 527 | ... 528 | ``` 529 | 530 | --- 531 | class: listing 532 | 533 | #### Tagging 534 | ``` 535 | .macro extract_tag from=%rdi 536 | is_double_internal \from, store=false 537 | mov $TAG_DOUBLE, %eax 538 | cmovg \from, %rax 539 | shr $TAG_SHIFT, %rax 540 | and $TAG_MASK, %eax 541 | mov $POINTER_TAG_MASK, %r11b 542 | mov $TAG_MASK, %r9b 543 | test %r11b, %al 544 | cmovnz %r11w, %r9w 545 | and %r9b, %al 546 | .endm 547 | ``` 548 | 549 | --- 550 | class: listing 551 | 552 | #### boot.scm 553 | ``` 554 | ;;; R7RS Boot 555 | 556 | ;;; 4. Expressions 557 | 558 | ;;; 4.2. Derived expression types 559 | 560 | ;;; 4.2.1. Conditionals 561 | 562 | (define-syntax and 563 | (lambda (form env) 564 | (append (cons 'if (cdr form)) '(#f)))) 565 | 566 | (define-syntax or 567 | (lambda (form env) 568 | (let ((form (cdr form))) 569 | (cons 'if (cons (car form) (cons #t (cdr form))))))) 570 | 571 | ``` 572 | 573 | --- 574 | class: listing 575 | 576 | #### r7rs.scm 577 | 578 | ``` 579 | (define-syntax and 580 | (syntax-rules () 581 | ((and) #t) 582 | ((and test) test) 583 | ((and test1 test2 ...) 584 | (if test1 (and test2 ...) #f)))) 585 | 586 | (define-syntax or 587 | (syntax-rules () 588 | ((or) #f) 589 | ((or test) test) 590 | ((or test1 test2 ...) 591 | (let ((x test1)) 592 | (if x x (or test2 ...)))))) 593 | ``` 594 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Akeem 2 | 3 | *When you think of garbage, think of Akeem.* — 4 | [Prince Akeem of Zamunda](http://www.imdb.com/title/tt0094898/) 5 | 6 | [Talk](https://www.youtube.com/watch?v=lAWVcN5FMmg) at [JUXT XT16](https://juxt.pro/XT16.html) Milton Keynes, 2016-10-06 | [Slides](https://hraberg.github.io/akeem/xt16) 7 | 8 | Akeem is a small JIT-ed subset of 9 | [R7RS Scheme](http://trac.sacrideo.us/wg/raw-attachment/wiki/WikiStart/r7rs.pdf) 10 | ("small") written in x86-64 assembler as an experiment. 11 | 12 | Written in [GNU Assembler](https://sourceware.org/binutils/docs/as/) 13 | using AT&T syntax. Only builds on Linux as Apple has their own version 14 | of `as`. 15 | 16 | Akeem depends on 17 | [glibc](https://www.gnu.org/software/libc/manual/html_mono/libc.html). 18 | 19 | 20 | ## Usage 21 | 22 | ``` bash 23 | make 24 | `which rlwrap` ./akeem # or make run-repl 25 | ``` 26 | 27 | ### Emacs 28 | 29 | ``` el 30 | (setq scheme-program-name "/path/to/akeem") 31 | (run-scheme) 32 | ``` 33 | 34 | See [this tutorial](http://community.schemewiki.org/?emacs-tutorial). 35 | 36 | ### Docker 37 | 38 | ``` bash 39 | make run-docker 40 | ``` 41 | 42 | The 43 | [`Dockerfile`](https://github.com/hraberg/akeem/blob/master/Dockerfile) 44 | will create a development container than can both run and compile 45 | Akeem. Running under Docker should work on Mac as well. 46 | 47 | If `rlwrap` crashes, the above command usually works when 48 | trying again. 49 | 50 | 51 | ## What Works? 52 | 53 | * Subset of R7RS "small" procedures. 54 | * JIT for `if`, `lambda`, `set!`, `let`, `letrec` and `begin` 55 | * Syntax for `and`, `or`, `cond`, `case`, `when`, `unless`, 56 | `cond-expand`, `let*`, "named `let`", , `let-values` or 57 | `let*-values`, `do`, `delay`, `define`, `define-values`, 58 | `parameterize`, `guard`, `case-lambda` and `define-record-type`. 59 | * Basic support for `define-syntax` / `syntax-rules` and `quasiquote`. 60 | * Basic support for R7RS Exceptions and `dynamic-wind`. 61 | * NaN-boxed 32-bit integers and 64-bit doubles 62 | * Function application up to 6 named arguments with varargs support. 63 | * Multiple return values using `values` and `call-with-values`. 64 | * TCO for calls in tail position across functions. 65 | * The bootstrap Scheme code is embedded in the executable. 66 | * Mark and Sweep GC. 67 | * Simple FFI. 68 | 69 | 70 | ## What Doesn't Work? 71 | 72 | * No hygienic macro expansion. 73 | * No GC for functions or their constant literals. 74 | * Max arity is currently 6, higher requires the use of the stack. 75 | * Stack-alignment of 16-bytes at function call isn't always maintained 76 | in compiled code. 77 | * No register allocation. 78 | * No `let-syntax`, `letrec-syntax`, `letrec*`. 79 | * No `define-library`. 80 | * The JIT is static, once a function is generated its done. 81 | * Not full support for Scheme numbers in the reader. 82 | * No support for converting internal `define` to `letrec`. 83 | * No mutation of closed over variables (needs array boxing). 84 | * Closures needlessly capture variables shadowed by inner `let` 85 | expressions. 86 | * No support for passing structs or functions in FFI calls. Calls are 87 | limited to 6 integer and 8 double arguments and won't pass arguments 88 | on the stack. 89 | * Limited numeric tower, see above. 90 | 91 | Most of the above is intended to be solved at some point, in roughly 92 | the order listed. The focus is slightly geared towards hacking on and 93 | exploring the JIT more than aiming for full R7RS compliance. 94 | 95 | 96 | ## Implementation Notes 97 | 98 | Akeem is a template based JIT which copies snippets of its own 99 | assembled source to compile functions at runtime - code is data. 100 | 101 | It's worth noting that John Aycock in his 102 | [A Brief History of Just-In-Time](http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.97.3985&rep=rep1&type=pdf) 103 | doesn't consider template based compilers to be proper JIT compilers: 104 | 105 | > As just described, template-based systems arguably do not fit our 106 | > description of JIT compilers, since there would appear to be no 107 | > nontrivial translation aspect. 108 | 109 | Akeem is somewhat inspired by Abdulaziz Ghuloum's classic paper 110 | [An Incremental Approach to Compiler Construction](http://scheme2006.cs.uchicago.edu/11-ghuloum.pdf) 111 | and Ian Piumarta's 112 | [PEG-based transformer provides front-, middle and back-end stages in a simple compiler](http://www.vpri.org/pdf/tr2010003_PEG.pdf) 113 | and his related work on [Maru](http://piumarta.com/software/maru/). 114 | 115 | Unlike these Lisps Akeem does not generate assembly in text 116 | form. Akeem is inspired by Clojure in the sense that there's only a 117 | JIT compiler to simplify the overall implementation — there's no 118 | interpreter. Also, like Clojure, the compiler is planned to stay close 119 | to a normal procedural language, with limited TCO and no CPS. 120 | 121 | ### Development 122 | 123 | Most of the implementation is in 124 | [`lisp.s`](https://github.com/hraberg/akeem/blob/master/lisp.s). It 125 | relies heavily on 126 | [`macros.s`](https://github.com/hraberg/akeem/blob/master/macros.s) to 127 | make the code less verbose. The 128 | [`tests.scm`](https://github.com/hraberg/akeem/blob/master/tests.scm) 129 | are compared to 130 | [`tests.out`](https://github.com/hraberg/akeem/blob/master/tests.out) 131 | for simple unit testing. To run and keep watching the tests (uses 132 | [entr](http://entrproject.org/)): 133 | 134 | ``` bash 135 | make retest 136 | ``` 137 | 138 | Parts of the implementation are in 139 | [`boot.scm`](https://github.com/hraberg/akeem/blob/master/boot.scm), 140 | [`r7rs.scm`](https://github.com/hraberg/akeem/blob/master/r7rs.scm) 141 | and 142 | [`init.scm`](https://github.com/hraberg/akeem/blob/master/init.scm), 143 | which are embedded as strings during compilation and are loaded at 144 | startup in this order. 145 | 146 | While running, the result of the JIT can be logged into `jit_code` and 147 | can be inspected using `objdump` via: 148 | 149 | ``` bash 150 | make jit-dissassmble 151 | ``` 152 | This can be turned on by setting `LOG_JIT` to `1` in 153 | [`constants.s`](https://github.com/hraberg/akeem/blob/master/constants.s). 154 | 155 | Too simplify debugging you can wrap the tests using `catchsegv` which 156 | will give you a register dump when Akeem crashes and occasionally even 157 | a stack trace: 158 | 159 | ``` bash 160 | make run-tests-catchsegv 161 | ``` 162 | 163 | ### Benchmarks 164 | 165 | You can run a small subset of the Racket benchmarks using: 166 | 167 | ``` bash 168 | make RACKET_HOME=/path/to/racket benchmarks 169 | ``` 170 | 171 | The `racket` executable itself is assumed to be on the path. Akeem can 172 | currently run about 10% of the benchmarks, and is quite a bit slower 173 | than Racket. 174 | 175 | ### Profiling 176 | 177 | You can run a single benchmark followed by 178 | [`gprof`](https://sourceware.org/binutils/docs/gprof/) using: 179 | 180 | ``` bash 181 | make RACKET_BENCHMARKS=nqueens profile 182 | ``` 183 | 184 | Only functions written in assembler will show up in the profile 185 | report. 186 | 187 | 188 | ### Architecture 189 | 190 | #### Garbage Collector 191 | 192 | The garbage collector is a basic mark and sweep. It doesn't handle 193 | functions or any literal constants in the code. The garbage collector 194 | is stop-the-world and called when `malloc` fails. 195 | 196 | #### JIT Compiler 197 | 198 | As mentioned above, the compiler pieces together parts snippets of 199 | code which already has been assembled by GNU assembler. Some snippets 200 | have a dynamic part that will be patched by the compiler. The compiler 201 | uses `glibc` in-memory streams to generate the code. 202 | 203 | All code sits in one static block allocated using `mmap` at start-up. 204 | 205 | #### Tagged Data 206 | 207 | Akeem uses NaN-boxed 64-bit values to represent everything. Integers, 208 | chars and symbol ids are stored in the lower 32-bits. Symbols are 209 | represented as unique ids pointing into a symbol table where the 210 | global values (and its name) are stored. Cons-cells, strings, vectors, 211 | bytevectors and records are allocated on the heap with a small header. 212 | 213 | As there are limited tags available in the NaN-boxed value, the 214 | highest tag is for objects. It's currently used by records and 215 | bytevectors. These objects have their real tag stored in the header on 216 | the heap. The tag's id is the symbol id of its type. Doubles have no 217 | tag, so the symbol `double` has id 0. 218 | 219 | Ports are C streams. They and procedures use tagged pointers to their 220 | actual values. They have no extra header on the heap and they don't 221 | participate in the garbage collection. 222 | 223 | #### Closures 224 | 225 | Closures are represented using two functions, where the body is 226 | compiled once, and the other one acts as a bridge function created 227 | each time a lambda is referenced and sets up the local variables on 228 | the stack based on the current environment before jumping to the body. 229 | 230 | Closures don't support mutable local variables using this compilation 231 | model, as the closed over variables are compiled into the code. Boxing 232 | via lists or vectors is necessary. 233 | 234 | #### TCO 235 | 236 | Calls in tail position are simply converted to jumps when 237 | compiling. This works across functions. Calls using the stack to pass 238 | more than 6 arguments are always compiled as normal calls and not 239 | optimized. 240 | 241 | #### FFI 242 | 243 | Basic FFI built on `dlopen` and `dlsym` is provided via `ffi-call`. No 244 | support for passing structs or functions to native code. Passing 245 | bytevectors and strings as pointers work. 246 | 247 | 248 | ### Implementation 249 | 250 | #### Calling Conventions 251 | 252 | In general Akeem uses the normal 253 | [x86-64 ABI](http://www.x86-64.org/documentation/abi.pdf), with a few 254 | extensions. 255 | 256 | All compiled calls use `al` to pass the number of arguments down to 257 | enable variable argument lists and arity checking to work. This is 258 | inspired by the way the ABI uses `al` to pass the number of floating 259 | point arguments. 260 | 261 | Some internal calls, like during `call/cc`, when checking arity and 262 | when collecting variable arguments use `rax` (for arity) and `r10` 263 | between calls to pass extra information about how to deal with the 264 | actual arguments without clobbering them. 265 | 266 | When returning multiple values from a continuation, either by using 267 | `call/cc` or `values`, the first value is placed in `rax` and the tail 268 | is placed in `rdx` (the second return register according to the ABI), 269 | and normally ignored. `call-with-values` will recreate the full 270 | argument list by consing `rax` to `rdx` and applying the result to its 271 | consumer. 272 | 273 | #### Use of Registers and Stack 274 | 275 | See 276 | [Stack frame layout on x86-64 ](http://eli.thegreenplace.net/2011/09/06/stack-frame-layout-on-x86-64/) 277 | for a better explanation. Akeem uses two different styles. 278 | 279 | The handwritten parts of Akeem itself refers to local variables 280 | allocated above of `rsp` and doesn't use `rbp` to establish a 281 | frame. Only in some cases it will push and pop the actual stack, and 282 | then there will be no local variables in use, as there's no stable 283 | reference point to them. The code uses `rbx` and `r12` as callee saved 284 | registers. Some simpler functions are written without or with a 285 | minimal prologue and epilogue that doesn't use or save `rbx` and `r12`. 286 | 287 | The generated code does establish a frame base pointer in `rbp` and 288 | refers to local variables relative below of `rbp`. `rsp` initially 289 | sits below the local variables and is free to move during 290 | execution. The generated code must use the stack to load the registers 291 | for calls properly without clobbering them. There's no register 292 | allocation implemented, all locals live on the stack. 293 | 294 | When calling a function, the non-literal arguments are evaluated 295 | first, and pushed onto the stack, after which the literal arguments 296 | are loaded directly into their argument registers and the results on 297 | the stack are popped into the right place. Arguments above 6 always go 298 | on the stack as per the ABI. 299 | 300 | For floating point operations, the `xmm0` to `xmm2` registers are used 301 | for calculations, but all values are passed using regular registers 302 | between functions. 303 | 304 | 305 | ## References 306 | 307 | ### Assembler 308 | 309 | * http://www.intel.com/content/www/us/en/processors/architectures-software-developer-manuals.html 310 | * http://ref.x86asm.net/coder64-abc.html 311 | * http://www.x86-64.org/documentation/abi.pdf 312 | * https://sourceware.org/binutils/docs/as/ 313 | * http://rayseyfarth.com/asm/ 314 | * http://bob.cs.sonoma.edu/IntroCompOrg/book.html 315 | * http://www.agner.org/optimize/ 316 | * http://www.avabodh.com/cin/cin.html 317 | * http://github.com/nineties/amber 318 | * https://rwmj.wordpress.com/2010/08/07/jonesforth-git-repository/ 319 | * http://lemick.sourceforge.net/papers/JIT_design.pdf 320 | * http://piumarta.com/doc/dcg-1992.pdf 321 | * http://nickdesaulniers.github.io/blog/2014/04/18/lets-write-some-x86-64/ 322 | * http://eli.thegreenplace.net/2011/09/06/stack-frame-layout-on-x86-64/ 323 | * http://blog.reverberate.org/2012/12/hello-jit-world-joy-of-simple-jits.html 324 | * http://cs.lmu.edu/~ray/notes/gasexamples/ 325 | * https://github.com/yrp604/rappel 326 | 327 | ### Lisp 328 | 329 | * http://piumarta.com/software/maru/ 330 | * http://piumarta.com/papers/S3-2010.pdf 331 | * http://scheme2006.cs.uchicago.edu/11-ghuloum.pdf 332 | * http://library.readscheme.org/page1.html 333 | * https://dspace.mit.edu/handle/1721.1/5600 334 | * http://www.schemers.org/Documents/Standards/R5RS/r5rs.pdf 335 | * http://trac.sacrideo.us/wg/raw-attachment/wiki/WikiStart/r7rs.pdf 336 | * http://srfi.schemers.org/final-srfis.html 337 | * http://www.phyast.pitt.edu/~micheles/syntax-rules.pdf 338 | * https://github.com/kanaka/mal 339 | * http://shenlanguage.org/ 340 | 341 | 342 | ## License 343 | 344 | Copyright © 2016 Håkan Råberg 345 | 346 | Distributed under the MIT License. 347 | -------------------------------------------------------------------------------- /boot.scm: -------------------------------------------------------------------------------- 1 | ;;; R7RS Boot 2 | 3 | ;;; 4. Expressions 4 | 5 | ;;; 4.2. Derived expression types 6 | 7 | ;;; 4.2.1. Conditionals 8 | 9 | (define-syntax and 10 | (lambda (form env) 11 | (append (cons 'if (cdr form)) '(#f)))) 12 | 13 | (define-syntax or 14 | (lambda (form env) 15 | (let ((form (cdr form))) 16 | (cons 'if (cons (car form) (cons #t (cdr form))))))) 17 | 18 | ;;; 4.2.8. Quasiquotation 19 | 20 | (set! list (lambda obj obj)) 21 | 22 | ;; Based on https://github.com/mishoo/SLip/blob/master/lisp/compiler.lisp#L25 23 | (define-syntax quasiquote 24 | (lambda (qq-template env) 25 | (letrec ((qq (lambda (x) 26 | (if (pair? x) 27 | (if (eq? 'unquote (car x)) 28 | (car (cdr x)) 29 | (if (eq? 'quasiquote (car x)) 30 | (qq (qq (car (cdr x)))) 31 | (if (and (pair? (car x)) 32 | (eq? 'unquote-splicing (car (car x)))) 33 | (list 'append (car (cdr (car x))) (qq (cdr x))) 34 | (list 'cons (qq (car x)) (qq (cdr x)))))) 35 | (if (vector? x) 36 | (list 'list->vector (qq (vector->list x))) 37 | (list 'quote x)))))) 38 | (qq (car (cdr qq-template)))))) 39 | 40 | ;;; 4.3. Macros 41 | 42 | ;;; 4.3.2. Pattern language 43 | 44 | (set! equal? 45 | (lambda (obj1 obj2) 46 | (if (and (pair? obj1) (pair? obj2)) 47 | (and (equal? (car obj1) (car obj2)) 48 | (equal? (cdr obj1) (cdr obj2))) 49 | (eqv? obj1 obj2)))) 50 | 51 | (set! memv 52 | (lambda (obj list) 53 | (and (pair? list) 54 | (if (eqv? (car list) obj) 55 | list 56 | (memv obj (cdr list)))))) 57 | 58 | (set! syntax-pattern-variable? 59 | (lambda (literals pattern) 60 | (and (symbol? pattern) 61 | (not (memv pattern (cons '... literals)))))) 62 | 63 | (set! collect-syntax-variables 64 | (lambda (literals pattern match idxs) 65 | (if (pair? pattern) 66 | (collect-syntax-variables literals (car pattern) 67 | (collect-syntax-variables literals (cdr pattern) match idxs) 68 | idxs) 69 | (if (syntax-pattern-variable? literals pattern) 70 | (cons (cons 'transcribe-failure (cons pattern (cons 0 idxs))) match) 71 | match)))) 72 | 73 | (set! syntax-ellipsis? 74 | (lambda (pattern) 75 | (and (pair? pattern) 76 | (eq? '... (car pattern))))) 77 | 78 | (set! match-syntax-rule 79 | (lambda (literals pattern form match idxs env) 80 | (if (not (pair? pattern)) 81 | (if (null? pattern) 82 | (and (null? form) match) 83 | (match-syntax-rule literals (cons pattern '()) (cons form '()) match idxs env)) 84 | (if (and (not (null? form)) (not (pair? form))) 85 | (match-syntax-rule literals (cons pattern '()) (cons form '()) match idxs env) 86 | (let ((first-pattern (car pattern)) 87 | (rest-pattern (cdr pattern))) 88 | (if (pair? first-pattern) 89 | (if (null? form) 90 | (and (syntax-ellipsis? rest-pattern) 91 | (collect-syntax-variables literals first-pattern match idxs)) 92 | (and (and (pair? form) 93 | (or (pair? (car form)) 94 | (null? (car form)))) 95 | (if (syntax-ellipsis? rest-pattern) 96 | (letrec ((loop 97 | (lambda (form match idx) 98 | (if (null? form) 99 | match 100 | (let ((match (match-syntax-rule literals first-pattern (car form) match (cons idx idxs) env))) 101 | (and match (loop (cdr form) match (+ 1 idx)))))))) 102 | (loop form match 0)) 103 | (let ((match (match-syntax-rule literals first-pattern (car form) match idxs env))) 104 | (and match (match-syntax-rule literals rest-pattern (cdr form) match idxs env)))))) 105 | (if (syntax-pattern-variable? literals first-pattern) 106 | (if (syntax-ellipsis? rest-pattern) 107 | (letrec ((loop (lambda (form match idx) 108 | (if (null? form) 109 | (cons (cons 'transcribe-failure (cons first-pattern (cons idx idxs))) match) 110 | (and (pair? form) 111 | (loop (cdr form) 112 | (cons (cons (car form) (cons first-pattern (cons idx idxs))) match) 113 | (+ 1 idx))))))) 114 | (loop form match 0)) 115 | (and (pair? form) 116 | (match-syntax-rule literals rest-pattern (cdr form) 117 | (cons (cons (car form) (cons first-pattern idxs)) match) idxs env))) 118 | (and (and (pair? form) (equal? first-pattern (car form))) 119 | (and (not (memv first-pattern env)) 120 | (match-syntax-rule literals rest-pattern (cdr form) match idxs env)))))))))) 121 | 122 | (set! syntax-template-pattern-variable? 123 | (lambda (match template) 124 | (and (pair? match) 125 | (or (eqv? (car (cdr (car match))) template) 126 | (syntax-template-pattern-variable? (cdr match) template))))) 127 | 128 | (set! transcribe-syntax-template 129 | (lambda (match template-idxs) 130 | (if (null? match) 131 | 'transcribe-failure 132 | (if (equal? (cdr (car match)) template-idxs) 133 | (car (car match)) 134 | (transcribe-syntax-template (cdr match) template-idxs))))) 135 | 136 | (set! transcribe-syntax-rule 137 | (lambda (match template idxs) 138 | (if (not (pair? template)) 139 | (if (syntax-template-pattern-variable? match template) 140 | (transcribe-syntax-template match (cons template idxs)) 141 | template) 142 | (let ((first-template (car template)) 143 | (rest-template (cdr template))) 144 | (if (syntax-ellipsis? rest-template) 145 | (append 146 | (letrec ((loop (lambda (transcribed new-idx) 147 | (let ((new-transcribed (transcribe-syntax-rule match first-template (cons new-idx idxs)))) 148 | (if (eq? 'transcribe-failure new-transcribed) 149 | transcribed 150 | (loop (append transcribed (cons new-transcribed '())) 151 | (+ new-idx 1))))))) 152 | (loop '() 0)) 153 | (transcribe-syntax-rule match (cdr rest-template) idxs)) 154 | (let ((first-new-transcribed (transcribe-syntax-rule match first-template idxs)) 155 | (rest-new-transcribed (transcribe-syntax-rule match rest-template idxs))) 156 | (if (or (eq? 'transcribe-failure first-new-transcribed) 157 | (eq? 'transcribe-failure rest-new-transcribed)) 158 | 'transcribe-failure 159 | (cons first-new-transcribed rest-new-transcribed)))))))) 160 | 161 | (set! transform-syntax-rules 162 | (lambda (literals syntax-rules form env) 163 | (if (null? syntax-rules) 164 | 'transform-failure 165 | (let ((pattern (cdr (car (car syntax-rules)))) 166 | (template (cdr (car syntax-rules)))) 167 | (let ((match (match-syntax-rule literals pattern form '() '() env))) 168 | (if match 169 | (transcribe-syntax-rule (reverse match) template '()) 170 | (transform-syntax-rules literals (cdr syntax-rules) form env))))))) 171 | 172 | (set! syntax-error? 173 | (lambda (transformed) 174 | (and (pair? transformed) 175 | (and (pair? (car transformed)) 176 | (eq? 'syntax-error (car (car transformed))))))) 177 | 178 | (set! transform-syntax 179 | (lambda (transformer-spec form env) 180 | (let ((literals (car (cdr transformer-spec))) 181 | (syntax-rules (cdr (cdr transformer-spec)))) 182 | (let ((transformed (transform-syntax-rules literals syntax-rules (cdr form) env))) 183 | (if (eq? 'transform-failure transformed) 184 | (error "Bad syntax:" form) 185 | (if (syntax-error? transformed) 186 | (apply error (cdr (car transformed))) 187 | (cons 'begin transformed))))))) 188 | 189 | (define-syntax syntax-rules 190 | (lambda (transformer-spec env) 191 | (cons 'lambda (cons (cons 'form (cons 'env '())) 192 | (cons (cons 'transform-syntax 193 | (cons (cons 'quote (cons transformer-spec '())) 194 | (cons 'form (cons 'env '())))) 195 | '()))))) 196 | 197 | 198 | (define-syntax assert-predicate 199 | (syntax-rules () 200 | ((assert-predicate pred value) 201 | (assert-predicate pred 'value value)) 202 | ((assert-predicate pred name value) 203 | (if (not (pred value)) 204 | (error "Bad syntax:" name value "doesn't satisfy" 'pred))))) 205 | 206 | ;;; 4.1.2. Literal expressions 207 | 208 | (define-syntax quote 209 | (syntax-rules () 210 | ((quote datum) 211 | (quote-internal datum)))) 212 | 213 | ;;; 4.1.4. Procedures 214 | 215 | (define-syntax lambda 216 | (lambda (form env) 217 | (if (not (>= (length form) 2)) 218 | (error "Bad syntax:" form) 219 | (let ((formals (car (cdr form))) 220 | (body (cdr (cdr form)))) 221 | (if (not (or (symbol? formals) (null? formals))) 222 | (begin 223 | (assert-predicate pair? formals) 224 | (let ((arity (letrec ((loop (lambda (formals arity) 225 | (if (null? formals) 226 | arity 227 | (if (pair? formals) 228 | (let ((formal (car formals))) 229 | (assert-predicate symbol? formal) 230 | (loop (cdr formals) (+ 1 arity))) 231 | (begin 232 | (assert-predicate symbol? formals) 233 | (+ 1 arity))))))) 234 | (loop formals 0)))) 235 | (if (> arity 6) 236 | (error "Maximum arity is 6:" formals))))) 237 | `(lambda-internal ,formals ,@body))))) 238 | 239 | ;;; 4.1.5. Conditionals 240 | 241 | (define-syntax if 242 | (syntax-rules () 243 | ((if test consequent alternate) 244 | (if-internal test consequent alternate)) 245 | ((if test consequent) 246 | (if-internal test consequent)))) 247 | 248 | ;;; 4.1.6. Assignments 249 | 250 | (define-syntax set! 251 | (lambda (form env) 252 | (if (not (= 3 (length form))) 253 | (error "Bad syntax:" form) 254 | (let ((variable (car (cdr form))) 255 | (expression (car (cdr (cdr form))))) 256 | (assert-predicate symbol? variable) 257 | `(set!-internal ,variable ,expression))))) 258 | 259 | ;;; 4.2.2. Binding constructs 260 | 261 | (set! assert-bindings 262 | (lambda (bindings) 263 | (if (pair? bindings) 264 | (let ((binding (car bindings))) 265 | (if (not (= 2 (length binding))) 266 | (error "Bad syntax: binding" binding)) 267 | (let ((var (car binding))) 268 | (assert-predicate symbol? var) 269 | (assert-bindings (cdr bindings))))))) 270 | 271 | (define-syntax let 272 | (lambda (form env) 273 | (if (not (<= 3 (length form))) 274 | (error "Bad syntax:" form) 275 | (let ((bindings (car (cdr form))) 276 | (body (cdr (cdr form)))) 277 | (if (or (pair? bindings) (null? bindings)) 278 | (begin 279 | (assert-bindings bindings) 280 | `(let-internal ,bindings ,@body)) 281 | ((syntax-rules () 282 | ((let tag ((name val) ...) body1 body2 ...) 283 | ((letrec ((tag (lambda (name ...) 284 | body1 body2 ...))) 285 | tag) 286 | val ...))) form env)))))) 287 | 288 | (define-syntax letrec 289 | (lambda (form env) 290 | (if (not (<= 3 (length form))) 291 | (error "Bad syntax:" form) 292 | (let ((bindings (car (cdr form))) 293 | (body (cdr (cdr form)))) 294 | (begin 295 | (assert-bindings bindings) 296 | `(letrec-internal ,bindings ,@body)))))) 297 | 298 | ;;; 5. Program structure 299 | 300 | ;;; 5.3. Variable definitions 301 | 302 | (define-syntax define 303 | (syntax-rules () 304 | ((define (variable . formal) body ...) 305 | (define variable (lambda formal body ...))) 306 | ((define (variable formals ...) body ...) 307 | (define variable (lambda (formals ...) body ...))) 308 | ((define variable expression) 309 | (set! variable expression)))) 310 | 311 | ;;; 5.4. Syntax definitions 312 | 313 | (define-syntax define-syntax 314 | (lambda (form env) 315 | (if (not (= 3 (length form))) 316 | (error "Bad syntax:" form) 317 | (let ((keyword (car (cdr form))) 318 | (transformer-spec (car (cdr (cdr form))))) 319 | (assert-predicate symbol? keyword) 320 | (assert-predicate pair? transformer-spec) 321 | `(define-syntax-internal ,keyword ,transformer-spec))))) 322 | -------------------------------------------------------------------------------- /macros.s: -------------------------------------------------------------------------------- 1 | .include "constants.s" 2 | 3 | .macro mov_reg from, to 4 | .ifnb \from 5 | .equ current_arity, current_arity + 1 6 | .ifnc \from, \to 7 | movq \from, \to 8 | .endif 9 | .endif 10 | .endm 11 | 12 | .macro call_fn fn, arg1, arg2, arg3, arg4, arg5, arg6 13 | .equ current_arity, 0 14 | mov_reg \arg6, %r9 15 | mov_reg \arg5, %r8 16 | mov_reg \arg4, %rcx 17 | mov_reg \arg3, %rdx 18 | mov_reg \arg2, %rsi 19 | mov_reg \arg1, %rdi 20 | call \fn 21 | .endm 22 | 23 | .macro call_scm fn, arg1, arg2, arg3, arg4, arg5, arg6 24 | .equ current_arity, 0 25 | mov_reg \arg6, %r9 26 | mov_reg \arg5, %r8 27 | mov_reg \arg4, %rcx 28 | mov_reg \arg3, %rdx 29 | mov_reg \arg2, %rsi 30 | mov_reg \arg1, %rdi 31 | mov $current_arity, %eax 32 | call \fn 33 | .endm 34 | 35 | .macro local_variables local:req, locals:vararg 36 | .equ \local, local_offset 37 | .equ local_offset, local_offset + POINTER_SIZE 38 | .ifnb \locals 39 | local_variables \locals 40 | .endif 41 | .endm 42 | 43 | .macro prologue locals:vararg 44 | .equ local_offset, 0 45 | .equ callee_saved_size, POINTER_SIZE * 2 46 | .ifnb \locals 47 | local_variables \locals 48 | .endif 49 | .equ stack_frame_size, (POINTER_SIZE + (callee_saved_size + POINTER_SIZE + local_offset) & -(2 * POINTER_SIZE)) 50 | .if stack_frame_size > POINTER_SIZE 51 | sub $stack_frame_size, %rsp 52 | .endif 53 | mov %rbx, local_offset(%rsp) 54 | mov %r12, local_offset+POINTER_SIZE(%rsp) 55 | .endm 56 | 57 | .macro minimal_prologue 58 | .equ stack_frame_size, POINTER_SIZE 59 | .equ callee_saved_size, 0 60 | sub $stack_frame_size, %rsp 61 | .endm 62 | 63 | .macro return value1=%rax, value2=%rdx 64 | mov_reg \value1, %rax 65 | mov_reg \value2, %rdx 66 | .if callee_saved_size > 0 67 | mov local_offset+POINTER_SIZE(%rsp), %r12 68 | mov local_offset(%rsp), %rbx 69 | .endif 70 | add $stack_frame_size, %rsp 71 | ret 72 | .endm 73 | 74 | .macro unbox_pointer_internal ptr, to=%rax 75 | mov_reg \ptr, \to 76 | shl $PAYLOAD_SHIFT, \to 77 | shr $PAYLOAD_SHIFT, \to 78 | .endm 79 | 80 | .macro car from, to=%rax 81 | unbox_pointer_internal \from \to 82 | mov pair_car(\to), \to 83 | .endm 84 | 85 | .macro cdr from, to=%rax 86 | unbox_pointer_internal \from \to 87 | mov pair_cdr(\to), \to 88 | .endm 89 | 90 | .macro eq_internal x, y, store=true 91 | cmp \x, \y 92 | .ifc \store, true 93 | sete %al 94 | and $C_TRUE, %eax 95 | .endif 96 | .endm 97 | 98 | .macro box_int_internal value=%eax, tmp=%r11 99 | mov \value, %eax 100 | tag TAG_INT, %rax, %rax, \tmp 101 | .endm 102 | 103 | .macro box_boolean_internal value=%rax 104 | tag TAG_BOOLEAN, \value 105 | .endm 106 | 107 | .macro tag tag value=%rax, target=%rax, tmp=%r11 108 | mov_reg \value, \target 109 | mov $(NAN_MASK | \tag << TAG_SHIFT), \tmp 110 | or \tmp, \target 111 | .endm 112 | 113 | .macro has_tag tag, value=%rax, store=true 114 | mov_reg \value, %rax 115 | shr $TAG_SHIFT, %rax 116 | .if (\tag >= TAG_SYMBOL) 117 | and $POINTER_TAG_MASK, %al 118 | .endif 119 | eq_internal $(\tag | NAN_MASK >> TAG_SHIFT), %eax, \store 120 | .endm 121 | 122 | .macro is_double_internal value, tmp=%r11, tmp2=%rax, store=true 123 | mov \value, \tmp 124 | btr $SIGN_BIT, \tmp 125 | mov $NAN_MASK, \tmp2 126 | cmp \tmp2, \tmp 127 | .ifc \store, true 128 | setle %al 129 | and $C_TRUE, %eax 130 | cmp $C_TRUE, %eax 131 | .endif 132 | .endm 133 | 134 | .macro assert_tag tag, value, error 135 | .if ASSERTIONS == C_TRUE 136 | has_tag \tag, \value, store=false 137 | je .L_\@_1 138 | mov $internal_error, %r11 139 | call_scm *%r11, \error, \value 140 | .L_\@_1: 141 | .endif 142 | .endm 143 | 144 | .macro assert_pair value, error=not_a_pair_string 145 | .if ASSERTIONS == C_TRUE 146 | is_nil_internal \value 147 | je .L_\@_1 148 | has_tag TAG_PAIR, \value, store=false 149 | je .L_\@_2 150 | .L_\@_1: 151 | mov $internal_error, %r11 152 | call_scm *%r11, \error, \value 153 | .L_\@_2: 154 | .endif 155 | .endm 156 | 157 | .macro assert_object value, class, error 158 | .if ASSERTIONS == C_TRUE 159 | has_tag TAG_OBJECT, \value, store=false 160 | jne .L_\@_1 161 | unbox_pointer_internal \value, %r11 162 | test %r11, %r11 163 | jz .L_\@_1 164 | mov header_object_type(%r11), %ax 165 | cmp $\class, %ax 166 | je .L_\@_2 167 | .L_\@_1: 168 | mov $internal_error, %r11 169 | call_scm *%r11, \error, \value 170 | .L_\@_2: 171 | .endif 172 | .endm 173 | 174 | .macro assert_bounds unboxed_value, idx, shift=0, size_adjust=0, tmp=%r11d 175 | .if ASSERTIONS == C_TRUE 176 | cmp $0, \idx 177 | jl .L_\@_1 178 | mov header_object_size(\unboxed_value), \tmp 179 | .ifnc \shift, 0 180 | shr $\shift, \tmp 181 | .endif 182 | .ifnc \size_adjust, 0 183 | add $\size_adjust, \tmp 184 | .endif 185 | cmp \tmp, \idx 186 | jl .L_\@_2 187 | box_int_internal \idx 188 | mov $internal_error, %r11 189 | call_scm *%r11, index_out_of_bounds_string, %rax 190 | .L_\@_1: 191 | box_int_internal \idx 192 | mov $internal_error, %r11 193 | call_scm *%r11, negative_index_string, %rax 194 | .L_\@_2: 195 | .endif 196 | .endm 197 | 198 | .macro assert_arity arity, success=je 199 | .if ASSERTIONS == C_TRUE 200 | cmp $\arity, %al 201 | \success .L_\@_1 202 | mov $\arity, %r10d 203 | mov $jit_rt_lambda_arity_check_error, %r11 204 | call *%r11 205 | .L_\@_1: 206 | .endif 207 | .endm 208 | 209 | .macro lookup_global_symbol_internal symbol_id 210 | mov symbol_table_values(,\symbol_id,POINTER_SIZE), %rax 211 | .endm 212 | 213 | .macro register_for_gc ptr=%rax 214 | call_fn push_pointer_on_stack, $object_space, \ptr 215 | .endm 216 | 217 | .macro perror success=jg 218 | cmp $NULL, %rax 219 | \success .L_\@_1 220 | call_fn perror, $NULL 221 | call_fn exit, $1 222 | .L_\@_1: 223 | .endm 224 | 225 | .macro is_nil_internal value, tmp=%r11, store=false 226 | mov $NIL, \tmp 227 | eq_internal \value, \tmp, store=\store 228 | .endm 229 | 230 | .macro is_void_internal value, tmp=%r11, store=false 231 | mov $VOID, \tmp 232 | eq_internal \value, \tmp, store=\store 233 | .endm 234 | 235 | .macro is_eof_object_internal value, tmp=%r11, store=false 236 | mov $EOF_OBJECT, \tmp 237 | eq_internal \value, \tmp, store=\store 238 | .endm 239 | 240 | .macro store_pointer idx, ptr=%rax, at=%rbx 241 | mov \idx, %ecx 242 | mov \ptr, %rax 243 | movq %rax, (\at,%rcx,POINTER_SIZE) 244 | .endm 245 | 246 | .macro extract_tag from=%rdi 247 | is_double_internal \from, store=false 248 | mov $TAG_DOUBLE, %eax 249 | cmovg \from, %rax 250 | shr $TAG_SHIFT, %rax 251 | and $TAG_MASK, %eax 252 | mov $POINTER_TAG_MASK, %r11b 253 | mov $TAG_MASK, %r9b 254 | test %r11b, %al 255 | cmovnz %r11w, %r9w 256 | and %r9b, %al 257 | .endm 258 | 259 | .macro tagged_jump table receiver=%rdi 260 | extract_tag \receiver 261 | call *\table(,%rax,POINTER_SIZE) 262 | .endm 263 | 264 | .macro extract_binary_op 265 | has_tag TAG_INT, %rdi, store=false 266 | sete %r11b 267 | has_tag TAG_INT, %rsi, store=false 268 | sete %al 269 | shl %al 270 | or %r11b, %al 271 | and $BINARY_OP_MASK, %eax 272 | .endm 273 | 274 | .macro binary_op_jump name 275 | extract_binary_op 276 | shl $BINARY_OP_SHIFT, %al 277 | lea \name\()_double_double(%eax), %rax 278 | jmp *%rax 279 | .align (1 << BINARY_OP_SHIFT) 280 | \name\()_double_double: 281 | movq %rdi, %xmm0 282 | movq %rsi, %xmm1 283 | jmp \name\()_op 284 | .align (1 << BINARY_OP_SHIFT) 285 | \name\()_int_double: 286 | cvtsi2sd %edi, %xmm0 287 | movq %rsi, %xmm1 288 | jmp \name\()_op 289 | .align (1 << BINARY_OP_SHIFT) 290 | \name\()_double_int: 291 | movq %rdi, %xmm0 292 | cvtsi2sd %esi, %xmm1 293 | jmp \name\()_op 294 | .align (1 << BINARY_OP_SHIFT) 295 | .endm 296 | 297 | .macro binary_op name, double_op, integer_op 298 | assert_arity 2 299 | binary_op_jump \name 300 | \name\()_int_int: 301 | mov %edi, %eax 302 | \integer_op %esi, %eax 303 | box_int_internal 304 | jmp \name\()_return 305 | \name\()_op: 306 | \double_op %xmm1, %xmm0 307 | movq %xmm0, %rax 308 | \name\()_return: 309 | ret 310 | .endm 311 | 312 | .macro binary_comparsion name, double_setter, integer_setter 313 | assert_arity 2 314 | binary_op_jump \name 315 | \name\()_int_int: 316 | xor %eax, %eax 317 | cmp %esi, %edi 318 | \integer_setter %al 319 | jmp \name\()_return 320 | \name\()_op: 321 | xor %eax, %eax 322 | comisd %xmm1, %xmm0 323 | \double_setter %al 324 | \name\()_return: 325 | box_boolean_internal 326 | ret 327 | .endm 328 | 329 | .macro integer_division 330 | has_tag TAG_INT, %rdi, store=false 331 | je .L_\@_1 332 | movd %rdi, %xmm0 333 | cvtsd2si %xmm0, %rdi 334 | .L_\@_1: 335 | has_tag TAG_INT, %rsi, store=false 336 | je .L_\@_2 337 | movq %rsi, %xmm0 338 | cvtsd2si %xmm0, %rsi 339 | .L_\@_2: 340 | mov %edi, %eax 341 | cdq 342 | idiv %esi 343 | .endm 344 | 345 | .macro maybe_round_to_int from=%xmm0, tmp=%xmm1 346 | roundsd $ROUNDING_MODE_TRUNCATE, \from, \tmp 347 | ucomisd \from, \tmp 348 | je .L_\@_1 349 | movq \from, %rax 350 | jmp .L_\@_2 351 | .L_\@_1: 352 | cvtsd2si \tmp, %rax 353 | box_int_internal 354 | .L_\@_2: 355 | .endm 356 | 357 | .macro math_library_unary_call name, round=false, return_int=false 358 | minimal_prologue 359 | assert_arity 1 360 | movq %rdi, %xmm0 361 | has_tag TAG_INT, %rdi, store=false 362 | jne \name\()_double 363 | \name\()_int: 364 | .ifc \return_int, true 365 | mov %rdi, %rax 366 | jmp \name\()_return 367 | .else 368 | cvtsi2sd %edi, %xmm0 369 | .endif 370 | \name\()_double: 371 | call_fn \name 372 | movq %xmm0, %rax 373 | .ifc \round, true 374 | maybe_round_to_int 375 | .endif 376 | \name\()_return: 377 | return 378 | .endm 379 | 380 | .macro math_library_binary_call name, round=false 381 | minimal_prologue 382 | assert_arity 2 383 | binary_op_jump \name 384 | \name\()_int_int: 385 | cvtsi2sd %edi, %xmm0 386 | cvtsi2sd %esi, %xmm1 387 | \name\()_op: 388 | call_fn \name 389 | .ifc \round, true 390 | maybe_round_to_int 391 | .else 392 | movq %xmm0, %rax 393 | .endif 394 | return 395 | .endm 396 | 397 | .macro open_input_buffer_template tag, error, size_adjust=0 398 | prologue empty_stream, empty_stream_size 399 | assert_arity 1 400 | assert_tag \tag, %rdi, \error 401 | unbox_pointer_internal %rdi 402 | mov header_object_size(%rax), %esi 403 | .ifnc \size_adjust, 0 404 | add $\size_adjust, %esi 405 | .endif 406 | test %esi, %esi 407 | jz .L_\@_1 408 | add $header_size, %rax 409 | call_fn fmemopen, %rax, %rsi, $read_mode 410 | perror 411 | tag TAG_PORT, %rax 412 | return 413 | 414 | .L_\@_1: 415 | lea empty_stream(%rsp), %rdi 416 | lea empty_stream_size(%rsp), %rsi 417 | call_fn open_memstream, %rdi, %rsi 418 | perror 419 | tag TAG_PORT, %rax 420 | return 421 | .endm 422 | 423 | .macro patch_jump stream, target, origin, offset 424 | call_fn ftell, \stream 425 | mov %rax, \target 426 | sub \origin, %rax 427 | mov %eax, \offset 428 | mov \origin, %rax 429 | sub $INT_SIZE, %rax 430 | call_fn fseek, \stream, %rax, $SEEK_SET 431 | lea \offset, %rax 432 | call_fn fwrite, %rax, $1, $INT_SIZE, \stream 433 | call_fn fseek, \stream, \target, $SEEK_SET 434 | .endm 435 | 436 | .macro optional_arg arity, default, target 437 | cmp $\arity, %al 438 | je .L_\@_1 439 | assert_arity (\arity - 1) 440 | mov \default, \target 441 | .L_\@_1: 442 | .endm 443 | 444 | .macro optional_parameter_arg arity, parameter, target 445 | cmp $\arity, %al 446 | je .L_\@_1 447 | assert_arity (\arity - 1) 448 | parameter_value \parameter 449 | mov %rax, \target 450 | .L_\@_1: 451 | .endm 452 | 453 | .macro parameter_value parameter, tmp=%r11 454 | mov \parameter, \tmp 455 | unbox_pointer_internal \tmp, \tmp 456 | mov symbol_table_values(,\tmp,POINTER_SIZE), \tmp 457 | unbox_pointer_internal \tmp, \tmp 458 | call_scm *\tmp 459 | .endm 460 | 461 | .macro read_number_template radix unget=false 462 | prologue 463 | mov %rdi, %rbx 464 | mov %rsi, %rdi 465 | .ifc \unget, true 466 | call_fn ungetc, %rdi, %rbx 467 | .endif 468 | call_fn read_token, %rbx 469 | register_for_gc 470 | call_scm string_to_number, %rax, \radix 471 | return 472 | .endm 473 | 474 | .macro open_string_buffer str, size, stream 475 | lea \str, %rdi 476 | lea \size, %rsi 477 | call_fn open_memstream, %rdi, %rsi 478 | perror 479 | mov %rax, \stream 480 | call_fn fseek, \stream, $header_size, $SEEK_SET 481 | .endm 482 | 483 | .macro string_buffer_to_string str, size, stream 484 | call_fn fclose, \stream 485 | perror je 486 | mov \str, %rax 487 | movw $TAG_STRING, header_object_type(%rax) 488 | mov \size, %r11d 489 | sub $(header_size - 1), %r11d 490 | mov %r11d, header_object_size(%rax) 491 | tag TAG_STRING, %rax 492 | .endm 493 | 494 | .macro read_byte_jump table, stream=%rbx byte=%rax, tmp=%r11 495 | mov \table(,\byte,POINTER_SIZE), \tmp 496 | test \tmp, \tmp 497 | jnz .L_\@_1 498 | mov_reg \byte, %rax 499 | tag TAG_CHAR, %rax 500 | call_fn read_error, %rax 501 | jmp .L_\@_2 502 | .L_\@_1: 503 | call_fn *\tmp, \stream, \byte 504 | .L_\@_2: 505 | .endm 506 | 507 | .macro intern_string var, name 508 | .section .rodata 509 | .align 16 510 | \var\()_c: 511 | .string "\name" 512 | .align 16 513 | .data 514 | \var: 515 | .quad 0 516 | .text 517 | call_fn box_string, $\var\()_c 518 | mov %rax, \var 519 | .endm 520 | 521 | .macro intern_symbol var, name, id= 522 | intern_string \var, "\name" 523 | .ifnb \id 524 | mov $\id, %r11 525 | mov %rax, symbol_table_names(,%r11,POINTER_SIZE) 526 | .endif 527 | call_scm string_to_symbol, %rax 528 | mov %rax, \var 529 | .endm 530 | 531 | .macro define name, value, tag=TAG_PROCEDURE 532 | .section .rodata 533 | .align 16 534 | tmp_string_\@: 535 | .string "\name" 536 | .text 537 | call_fn box_string, $tmp_string_\@ 538 | call_scm string_to_symbol, %rax 539 | .ifnb \tag 540 | tag \tag, \value, target=%rcx 541 | .endif 542 | mov %rcx, symbol_table_values(,%eax,POINTER_SIZE) 543 | .endm 544 | 545 | .macro update_max_locals max_locals, value=%rax, tmp=%r11 546 | mov \max_locals, \tmp 547 | cmp \value, \tmp 548 | cmovl \value, \tmp 549 | mov \tmp, \max_locals 550 | .endm 551 | 552 | .macro string_comparator comparator, setter, string1=%rdi, string2=%rsi 553 | prologue 554 | assert_arity 2 555 | assert_tag TAG_STRING, %rdi, not_a_string_string 556 | assert_tag TAG_STRING, %rsi, not_a_string_string 557 | unbox_pointer_internal \string1 558 | add $header_size, %rax 559 | mov %rax, %rdi 560 | unbox_pointer_internal \string2, %rsi 561 | add $header_size, %rsi 562 | 563 | xor %ebx, %ebx 564 | call_fn \comparator, %rdi, %rsi 565 | \setter %bl 566 | box_boolean_internal %rbx 567 | return 568 | .endm 569 | -------------------------------------------------------------------------------- /tests.scm: -------------------------------------------------------------------------------- 1 | (define (assert x) 2 | (write x) 3 | (newline)) 4 | 5 | (define-syntax assert-values 6 | (syntax-rules () 7 | ((assert-values expression) 8 | (let ((result (call-with-values 9 | (lambda () 10 | expression) 11 | vector))) 12 | (do ((idx 0 (+ 1 idx))) 13 | ((= idx (vector-length result))) 14 | (display (vector-ref result idx)) 15 | (when (< idx (- (vector-length result) 1)) 16 | (display " ")))) 17 | (newline)))) 18 | 19 | (define (spec x) 20 | (display x) 21 | (newline)) 22 | 23 | (spec ";;; R7RS") 24 | (spec ";;; 1. Overview of Scheme") 25 | (spec ";;; 1.3. Notation and terminology") 26 | (spec ";;; 1.3.4. Evaluation examples") 27 | 28 | (assert (* 5 8)) 29 | 30 | (assert ";;; 2. Lexical conventions") 31 | (assert ";;; 2.2. Whitespace and comments") 32 | 33 | ;;; The FACT procedure computes the factorial 34 | ;;; of a non-negative integer. 35 | (define fact 36 | (lambda (n) 37 | (if (= n 0) 38 | 1 ;Base case: return 1 39 | (* n (fact (- n 1)))))) 40 | (assert (fact 10)) ;; not an actual example 41 | 42 | (spec ";;; 4. Expressions") 43 | (spec ";;; 4.1. Primitive expression types") 44 | (spec ";;; 4.1.1. Variable references") 45 | 46 | (define x 28) 47 | (assert x) 48 | 49 | (spec ";;; 4.1.2. Literal expressions") 50 | 51 | (assert (quote a)) 52 | (assert (quote #(a b c))) 53 | (assert (quote (+ 1 2))) 54 | 55 | (assert 'a) 56 | (assert '#(a b c)) 57 | (assert '()) 58 | (assert '(+ 1 2)) 59 | (assert '(quote a)) 60 | (assert ''a) 61 | 62 | (assert '145932) 63 | (assert 145932) 64 | (assert '"abc") 65 | (assert "abc") 66 | ;; (assert '#) 67 | ;; (assert #) 68 | (assert '#(a 10)) 69 | (assert #(a 10)) 70 | (assert '#u8(64 65)) 71 | (assert #u8(64 65)) 72 | (assert '#t) 73 | (assert #t) 74 | 75 | (spec ";;; 4.1.3. Procedure calls") 76 | 77 | (assert (+ 3 4)) 78 | (assert ((if #f + *) 3 4)) 79 | 80 | (spec ";;; 4.1.4. Procedures") 81 | 82 | (assert (lambda (x) (+ x x))) 83 | (assert ((lambda (x) (+ x x)) 4)) 84 | 85 | (define reverse-subtract 86 | (lambda (x y) (- y x))) 87 | (assert (reverse-subtract 7 10)) 88 | 89 | (define add4 90 | (let ((x 4)) 91 | (lambda (y) (+ x y)))) 92 | (assert (add4 6)) 93 | 94 | (assert ((lambda x x) 3 4 5 6)) 95 | (assert ((lambda (x y . z) z) 96 | 3 4 5 6)) 97 | 98 | (spec ";;; 4.1.5. Conditionals") 99 | 100 | (assert (if (> 3 2) 'yes 'no)) 101 | (assert (if (> 2 3) 'yes 'no)) 102 | (assert (if (> 3 2) 103 | (- 3 2) 104 | (+ 3 2))) 105 | 106 | (spec ";;; 4.1.6. Assignments") 107 | 108 | (define x 2) 109 | (assert (+ x 1)) 110 | (assert (set! x 4)) 111 | (assert (+ x 1)) 112 | 113 | (spec ";;; 4.2. Derived expression types") 114 | (spec ";;; 4.2.1. Conditionals") 115 | 116 | (assert (cond ((> 3 2) 'greater) 117 | ((< 3 2) 'less))) 118 | (assert (cond ((> 3 3) 'greater) 119 | ((< 3 3) 'less) 120 | (else 'equal))) 121 | (assert (cond ((assv 'b '((a 1) (b 2))) => cadr) 122 | (else #f))) 123 | 124 | (assert (case (* 2 3) 125 | ((2 3 5 7) 'prime) 126 | ((1 4 6 8 9) 'composite))) 127 | (assert (case (car '(c d)) 128 | ((a) 'a) 129 | ((b) 'b))) 130 | (assert (case (car '(c d)) 131 | ((a e i o u) 'vowel) 132 | ((w y) 'semivowel) 133 | (else => (lambda (x) x)))) 134 | 135 | (assert (and (= 2 2) (> 2 1))) 136 | (assert (and (= 2 2) (< 2 1))) 137 | (assert (and 1 2 'c '(f g))) 138 | (assert (and)) 139 | 140 | (assert (or (= 2 2) (> 2 1))) 141 | (assert (or (= 2 2) (< 2 1))) 142 | (assert (or #f #f #f)) 143 | (assert (or (memq 'b '(a b c)) 144 | (/ 3 0))) 145 | 146 | (assert (when (= 1 1.0) 147 | (display "1") 148 | (display "2") 149 | (newline))) 150 | 151 | (assert (unless (= 1 1.0) 152 | (display "1") 153 | (display "2") 154 | (newline))) 155 | 156 | (spec ";;; 4.2.2. Binding constructs") 157 | 158 | (assert (let ((x 2) (y 3)) 159 | (* x y))) 160 | 161 | (assert (let ((x 2) (y 3)) 162 | (let ((x 7) 163 | (z (+ x y))) 164 | (* z x)))) 165 | 166 | (assert (let ((x 2) (y 3)) 167 | (let* ((x 7) 168 | (z (+ x y))) 169 | (* z x)))) 170 | 171 | (assert (letrec ((even? 172 | (lambda (n) 173 | (if (zero? n) 174 | #t 175 | (odd? (- n 1))))) 176 | (odd? 177 | (lambda (n) 178 | (if (zero? n) 179 | #f 180 | (even? (- n 1)))))) 181 | (even? 88))) 182 | 183 | ;; (assert (letrec* ((p 184 | ;; (lambda (x) 185 | ;; (+ 1 (q (- x 1))))) 186 | ;; (q 187 | ;; (lambda (y) 188 | ;; (if (zero? y) 189 | ;; 0 190 | ;; (+ 1 (p (- y 1)))))) 191 | ;; (x (p 5)) 192 | ;; (y x)) 193 | ;; y)) 194 | 195 | (assert (let-values (((root rem) (exact-integer-sqrt 32))) 196 | (* root rem))) 197 | 198 | (assert (let ((a 'a) (b 'b) (x 'x) (y 'y)) 199 | (let*-values (((a b) (values x y)) 200 | ((x y) (values a b))) 201 | (list a b x y)))) 202 | 203 | (spec ";;; 4.2.3. Sequencing") 204 | 205 | (define x 0) 206 | (assert (begin (set! x 5) 207 | (+ x 1))) 208 | (begin (display "4 plus 1 equals ") 209 | (display (+ 4 1))) 210 | (newline) 211 | 212 | (spec ";;; 4.2.4. Iteration") 213 | 214 | (assert (do ((vec (make-vector 5)) 215 | (i 0 (+ i 1))) 216 | ((= i 5) vec) 217 | (vector-set! vec i i))) 218 | 219 | (assert (let ((x '(1 3 5 7 9))) 220 | (do ((x x (cdr x)) 221 | (sum 0 (+ sum (car x)))) 222 | ((null? x) sum)))) 223 | 224 | (assert (let loop ((numbers '(3 -2 1 6 -5)) 225 | (nonneg '()) 226 | (neg '())) 227 | (cond ((null? numbers) (list nonneg neg)) 228 | ((>= (car numbers) 0) 229 | (loop (cdr numbers) 230 | (cons (car numbers) nonneg) 231 | neg)) 232 | ((< (car numbers) 0) 233 | (loop (cdr numbers) 234 | nonneg 235 | (cons (car numbers) neg)))))) 236 | 237 | (spec ";;; 4.2.5. Delayed evaluation") 238 | 239 | (assert (force (delay (+ 1 2)))) 240 | (assert (let ((p (delay (+ 1 2)))) 241 | (list (force p) (force p)))) 242 | 243 | (define integers 244 | (letrec ((next 245 | (lambda (n) 246 | (delay (cons n (next (+ n 1))))))) 247 | (next 0))) 248 | (define head 249 | (lambda (stream) (car (force stream)))) 250 | (define tail 251 | (lambda (stream) (cdr (force stream)))) 252 | (assert (head (tail (tail integers)))) 253 | 254 | (define (stream-filter p? s) 255 | (delay-force 256 | (if (null? (force s)) 257 | (delay '()) 258 | (let ((h (car (force s))) 259 | (t (cdr (force s)))) 260 | (if (p? h) 261 | (delay (cons h (stream-filter p? t))) 262 | (stream-filter p? t)))))) 263 | (assert (head (tail (tail (stream-filter odd? integers))))) 264 | 265 | (define count 0) 266 | (define p 267 | (delay (begin (set! count (+ count 1)) 268 | (if (> count x) 269 | count 270 | (force p))))) 271 | (define x 5) 272 | (assert p) 273 | (assert (force p)) 274 | (assert p) 275 | (assert (begin (set! x 10) 276 | (force p))) 277 | 278 | (assert (eqv? (delay 1) 1)) 279 | (assert (pair? (delay (cons 1 2)))) 280 | 281 | (assert (car 282 | (list (delay (* 3 7)) 13))) 283 | 284 | (spec ";;; 4.2.6. Dynamic bindings") 285 | 286 | (define radix 287 | (make-parameter 288 | 10 289 | (lambda (x) 290 | (if (and (exact-integer? x) (<= 2 x) (<= x 16)) ;; should be single <= 291 | x 292 | (error "invalid radix"))))) 293 | 294 | (define (f n) (number->string n (radix))) 295 | 296 | (assert (f 12)) 297 | (assert (parameterize ((radix 16)) ;;; should be 2 298 | (f 12))) 299 | (assert (f 12)) 300 | 301 | (spec ";;; 4.2.7. Exception handling") 302 | 303 | (assert (guard (condition 304 | ((assq 'a condition) => cdr) 305 | ((assq 'b condition))) 306 | (raise (list (cons 'a 42))))) 307 | 308 | (assert (guard (condition 309 | ((assq 'a condition) => cdr) 310 | ((assq 'b condition))) 311 | (raise (list (cons 'b 23))))) 312 | 313 | (spec ";;; 4.2.8. Quasiquotation") 314 | 315 | (assert `(list ,(+ 1 2) 4)) 316 | (assert (let ((name 'a)) `(list ,name ',name))) 317 | (assert `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) 318 | (assert `(( foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))) 319 | (assert `#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8)) 320 | 321 | ;; (assert `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) 322 | ;; (assert (let ((name1 'x) 323 | ;; (name2 'y)) 324 | ;; `(a `(b ,,name1 ,',name2 d) e))) 325 | 326 | (assert (quasiquote (list (unquote (+ 1 2)) 4))) 327 | (assert '(quasiquote (list (unquote (+ 1 2)) 4))) 328 | 329 | (spec ";;; 4.2.9. Case-lambda") 330 | 331 | (define range 332 | (case-lambda 333 | ((e) (range 0 e)) 334 | ((b e) (do ((r '() (cons e r)) 335 | (e (- e 1) (- e 1))) 336 | ((< e b) r))))) 337 | 338 | (assert (range 3)) 339 | (assert (range 3 5)) 340 | 341 | (spec ";;; 4.3. Macros") 342 | (spec ";;; 4.3.1. Binding constructs for syntactic keywords") 343 | 344 | ;; (assert (let-syntax ((when (syntax-rules () 345 | ;; ((when test stmt1 stmt2 ...) 346 | ;; (if test 347 | ;; (begin stmt1 348 | ;; stmt2 ...)))))) 349 | ;; (let ((if #t)) 350 | ;; (when if (set! if ’now)) 351 | ;; if))) 352 | 353 | ;; (assert (let ((x ’outer)) 354 | ;; (let-syntax ((m (syntax-rules () ((m) x)))) 355 | ;; (let ((x ’inner)) 356 | ;; (m))))) 357 | 358 | ;; (assert (letrec-syntax 359 | ;; ((my-or (syntax-rules () 360 | ;; ((my-or) #f) 361 | ;; ((my-or e) e) 362 | ;; ((my-or e1 e2 ...) 363 | ;; (let ((temp e1)) 364 | ;; (if temp 365 | ;; temp 366 | ;; (my-or e2 ...))))))) 367 | ;; (let ((x #f) 368 | ;; (y 7) 369 | ;; (temp 8) 370 | ;; (let odd?) 371 | ;; (if even?)) 372 | ;; (my-or x 373 | ;; (let temp) 374 | ;; (if y) 375 | ;; y)))) 376 | 377 | (spec ";;; 4.3.2. Pattern language") 378 | 379 | (assert (let ((=> #f)) 380 | (cond (#t => 'ok)))) 381 | 382 | (spec ";;; 5. Program structure") 383 | (spec ";;; 5.1. Programs") 384 | (spec ";;; 5.3. Variable definitions") 385 | (spec ";;; 5.3.1. Top level definitions") 386 | 387 | (define add3 388 | (lambda (x) (+ x 3))) 389 | (assert (add3 3)) 390 | (define first car) 391 | (assert (first '(1 2))) 392 | 393 | ;; (assert ";;;5.3.2. Internal definitions") 394 | ;; (assert (let ((x 5)) 395 | ;; (define foo (lambda (y) (bar x y))) 396 | ;; (define bar (lambda (a b) (+ (* a b) a))) 397 | ;; (foo (+ x 3)))) 398 | 399 | (spec ";;; 5.3.3. Multiple-value definitions") 400 | 401 | (define-values (x y) (exact-integer-sqrt 17)) 402 | (assert (list x y)) 403 | 404 | (assert (let () 405 | (define-values (x y) (values 1 2)) ;; should create local definitions 406 | (+ x y))) 407 | 408 | (spec ";;; 5.5. Record-type definitions") 409 | 410 | (define-record-type 411 | (kons x y) 412 | pare? 413 | (x kar set-kar!) 414 | (y kdr)) 415 | 416 | (assert (pare? (kons 1 2))) 417 | (assert (pare? (cons 1 2))) 418 | (assert (kar (kons 1 2))) 419 | (assert (kdr (kons 1 2))) 420 | (assert (let ((k (kons 1 2))) 421 | (set-kar! k 3) 422 | (kar k))) 423 | 424 | (spec ";;; 6. Standard procedures") 425 | (spec ";;; 6.1. Equivalence predicates") 426 | 427 | (assert (string=? (symbol->string 'foo) 428 | (symbol->string 'foo))) 429 | 430 | (assert (string=? (symbol->string 'obj1) 431 | (symbol->string 'obj2))) 432 | 433 | (assert (eqv? 'a 'a)) 434 | (assert (eqv? 'a 'b)) 435 | (assert (eqv? 2 2)) 436 | (assert (eqv? '() '())) 437 | (assert (eqv? 100000000 100000000)) 438 | (assert (eqv? (cons 1 2) (cons 1 2))) 439 | (assert (eqv? (lambda () 1) 440 | (lambda () 2))) 441 | (assert (let ((p (lambda (x) x))) 442 | (eqv? p p))) 443 | (assert (eqv? #f 'nil)) 444 | 445 | (assert (eqv? "" "")) 446 | (assert (eqv? '#() '#())) 447 | (assert (eqv? (lambda (x) x) 448 | (lambda (x) x))) 449 | (assert (eqv? (lambda (x) x) 450 | (lambda (y) y))) 451 | 452 | (define gen-counter 453 | (lambda () 454 | (let ((n 0)) 455 | (lambda () (set! n (+ n 1)) n)))) 456 | (assert (let ((g (gen-counter))) 457 | (eqv? g g))) 458 | (assert (eqv? (gen-counter) (gen-counter))) 459 | 460 | (define gen-loser 461 | (lambda () 462 | (let ((n 0)) 463 | (lambda () (set! n (+ n 1)) 27)))) 464 | (assert (let ((g (gen-loser))) 465 | (eqv? g g))) 466 | (assert (eqv? (gen-loser) (gen-loser))) 467 | 468 | (assert (letrec ((f (lambda () (if (eqv? f g) 'both 'f))) 469 | (g (lambda () (if (eqv? f g) 'both 'g)))) 470 | (eqv? f g))) 471 | 472 | (assert (letrec ((f (lambda () (if (eqv? f g) 'f 'both))) 473 | (g (lambda () (if (eqv? f g) 'g 'both)))) 474 | (eqv? f g))) 475 | 476 | (assert (eqv? '(a) '(a))) 477 | (assert (eqv? "a" "a")) 478 | (assert (eqv? '(b) (cdr '(a b)))) 479 | (assert (let ((x '(a))) 480 | (eqv? x x))) 481 | 482 | (assert (eq? 'a 'a)) 483 | (assert (eq? '(a) '(a))) 484 | (assert (eq? (list 'a) (list 'a))) 485 | (assert (eq? "a" "a")) 486 | (assert (eq? "" "")) 487 | (assert (eq? '() '())) 488 | (assert (eq? 2 2)) 489 | (assert (eq? #\A #\A)) 490 | (assert (eq? car car)) 491 | (assert (let ((n (+ 2 3))) 492 | (eq? n n))) 493 | (assert (let ((x '(a))) 494 | (eq? x x))) 495 | (assert (let ((x '#())) 496 | (eq? x x))) 497 | (assert (let ((p (lambda (x) x))) 498 | (eq? p p))) 499 | 500 | (assert (equal? 'a 'a)) 501 | (assert (equal? '(a) '(a))) 502 | (assert (equal? '(a (b) c) 503 | '(a (b) c))) 504 | (assert (equal? "abc" "abc")) 505 | (assert (equal? 2 2)) 506 | (assert (equal? (make-vector 5 'a) 507 | (make-vector 5 'a))) 508 | (assert (equal? (lambda (x) x) 509 | (lambda (y) y))) 510 | 511 | (spec ";;; 6.2. Numbers") 512 | (spec ";;; 6.2.6. Numerical operations") 513 | 514 | ;; (assert (complex? 3+4i)) 515 | (assert (complex? 3)) 516 | (assert (real? 3)) 517 | ;; (assert (real? -2.5+0.0i)) 518 | ;; (assert (real? #e1e10)) 519 | ;; (assert (rational? 6/10)) 520 | ;; (assert (rational? 6/3)) 521 | ;; (assert (integer? 3+0i)) 522 | (assert (integer? 3.0)) 523 | ;; (assert (integer? 8/4)) 524 | 525 | (assert (exact-integer? 32)) 526 | (assert (exact-integer? 32.0)) 527 | 528 | (assert (finite? 3)) 529 | (assert (finite? (/ 1.0 0.0))) ;; should be +inf.0 530 | ;; (assert (finite? 3.0+inf.0i)) 531 | 532 | (assert (infinite? 3)) 533 | (assert (infinite? (/ 1.0 0.0))) ;; should be +inf.0 534 | (assert (infinite? (/ 0.0 0.0))) ;; should be +nan.0 535 | ;; (assert (infinite? 3.0+inf.0i)) 536 | 537 | (assert (nan? (/ 0.0 0.0))) ;; should be +nan.0 538 | (assert (nan? 32)) 539 | ;; (assert (nan? +nan.0+5.0i)) 540 | ;; (assert (nan? 1+2i)) 541 | 542 | (assert (max 3 4)) 543 | (assert (max 3.9 4)) 544 | 545 | (assert (+ 3 4)) 546 | ;; (assert (+ 3)) 547 | ;; (assert (+)) 548 | ;; (assert (* 4)) 549 | ;; (assert (*)) 550 | 551 | (assert (- 3 4)) 552 | ;; (assert (- 3 4 5)) 553 | ;; (assert (- 3)) 554 | ;; (assert (/ 3 4 5)) 555 | ;; (aasert (/ 3)) 556 | 557 | (assert (abs -7)) 558 | 559 | ;;; These are from R5RS, R7RS specifies truncate-remainder, floor/ etc. 560 | (assert (let ((n1 2) (n2 4)) 561 | (= n1 (+ (* n2 (quotient n1 n2)) 562 | (remainder n1 n2))))) 563 | 564 | (assert (modulo 13 4)) 565 | (assert (remainder 13 4)) 566 | (assert (modulo -13 4)) 567 | (assert (remainder -13 4)) 568 | (assert (modulo 13 -4)) 569 | (assert (remainder 13 -4)) 570 | (assert (modulo -13 -4)) 571 | (assert (remainder -13 -4)) 572 | (assert (remainder -13 -4.0)) 573 | 574 | (assert-values (floor/ 5 2)) 575 | (assert-values (floor/ -5 2)) 576 | (assert-values (floor/ 5 -2)) 577 | (assert-values (floor/ -5 -2)) 578 | (assert-values (truncate/ 5 2)) 579 | (assert-values (truncate/ -5 2)) 580 | (assert-values (truncate/ 5 -2)) 581 | (assert-values (truncate/ -5 -2)) 582 | (assert-values (truncate/ -5.0 -2)) 583 | 584 | (assert (gcd 32 -36)) 585 | (assert (gcd)) 586 | (assert (lcm 32 -36)) 587 | (assert (lcm 32.0 -36)) 588 | (assert (lcm)) 589 | 590 | ;; (assert (numerator (/ 6 4))) 591 | ;; (assert (denominator (/ 6 4))) 592 | ;; (assert (denominator 593 | ;; (inexact (/ 6 4)))) 594 | 595 | (assert (floor -4.3)) 596 | (assert (ceiling -4.3)) 597 | (assert (truncate -4.3)) 598 | (assert (round -4.3)) 599 | (assert (floor 3.5)) 600 | (assert (ceiling 3.5)) 601 | (assert (truncate 3.5)) 602 | (assert (round 3.5)) 603 | ;; (assert (round 7/2)) 604 | (assert (round 7)) 605 | 606 | ;; (assert (rationalize 607 | ;; (exact .3) 1/10)) 608 | ;; (assert (rationalize .3 1/10)) 609 | 610 | (assert (square 42)) 611 | (assert (square 2.0)) 612 | 613 | (assert-values (exact-integer-sqrt 4)) 614 | (assert-values (exact-integer-sqrt 5)) 615 | 616 | (spec ";;; 6.2.7. Numerical input and output") 617 | 618 | (assert (let ((number 20) 619 | (radix 16)) 620 | (eqv? number 621 | (string->number (number->string number 622 | radix) 623 | radix)))) 624 | 625 | (assert (string->number "100")) 626 | (assert (string->number "100" 16)) 627 | (assert (string->number "1e2")) 628 | ;; (assert (string->number "15##")) 629 | 630 | (spec ";;; 6.3. Booleans") 631 | 632 | (assert #t) 633 | (assert #f) 634 | (assert '#f) 635 | 636 | (assert (not #t)) 637 | (assert (not 3)) 638 | (assert (not (list 3))) 639 | (assert (not #f)) 640 | (assert (not '())) 641 | (assert (not (list))) 642 | (assert (not 'nil)) 643 | 644 | (assert (boolean? #f)) 645 | (assert (boolean? 0)) 646 | (assert (boolean? '())) 647 | 648 | (spec ";;; 6.4. Pairs and lists") 649 | 650 | (define x (list 'a 'b 'c)) 651 | (define y x) 652 | (assert y) 653 | (assert (list? y)) 654 | (assert (set-cdr! x 4)) 655 | (assert x) 656 | (assert (eqv? x y)) 657 | (assert y) 658 | (assert (list? y)) 659 | (assert (set-cdr! x x)) 660 | ;; (assert (list? x)) 661 | 662 | (assert (pair? '(a . b))) 663 | (assert (pair? '(a b c))) 664 | (assert (pair? '())) 665 | (assert (pair? '#(a b))) 666 | 667 | (assert (cons 'a '())) 668 | (assert (cons '(a) '(b c d))) 669 | (assert (cons "a" '(b c))) 670 | (assert (cons 'a 3)) 671 | (assert (cons '(a b) 'c)) 672 | 673 | (assert (car '(a b c))) 674 | (assert (car '((a) b c d))) 675 | (assert (car '(1 . 2))) 676 | ;; (assert (car '())) 677 | 678 | (assert (cdr '((a) b c d))) 679 | (assert (cdr '(1 . 2))) 680 | ;; (assert (cdr '())) 681 | 682 | (define (f) (list 'not-a-constant-list)) 683 | ;; (define (g) '(constant-list)) 684 | (assert (set-car! (f) 3)) 685 | ;; (assert (set-car! (g) 3)) 686 | 687 | (assert (list? '(a b c))) 688 | (assert (list? '())) 689 | (assert (list? '(a . b))) 690 | ;; (assert (let ((x '(a))) 691 | ;; (set-cdr! x x) 692 | ;; (list? x))) 693 | 694 | (assert (make-list 2 3)) 695 | 696 | (assert (list 'a (+ 3 4) 'c)) 697 | (assert (list)) 698 | 699 | (assert (length '(a b c))) 700 | (assert (length '(a (b) (c d e)))) 701 | (assert (length '())) 702 | 703 | (assert (append '(x) '(y))) 704 | (assert (append '(a) '(b c d))) 705 | (assert (append '(a (b)) '((c)))) 706 | 707 | (assert (append '(a b) '(c . d))) 708 | (assert (append '() 'a)) 709 | 710 | (assert (reverse '(a b c))) 711 | (assert (reverse '(a (b c) d (e (f))))) 712 | 713 | (assert (list-ref '(a b c d) 2)) 714 | (assert (list-ref '(a b c d) 715 | (exact (round 1.8)))) 716 | 717 | (assert (let ((ls (list 'one 'two 'five!))) 718 | (list-set! ls 2 'three) 719 | ls)) 720 | 721 | (assert (memq 'a '(a b c))) 722 | (assert (memq 'b '(a b c))) 723 | (assert (memq 'a '(b c d))) 724 | (assert (memq (list 'a) '(b (a) c))) 725 | (assert (member (list 'a) 726 | '(b (a) c))) 727 | (assert (member "B" 728 | '("a" "b" "c") 729 | string-ci=?)) 730 | (assert (memq 101 '(100 101 102))) 731 | (assert (memv 101 '(100 101 102))) 732 | 733 | (define e '((a 1) (b 2) (c 3))) 734 | (assert (assq 'a e)) 735 | (assert (assq 'b e)) 736 | (assert (assq 'd e)) 737 | (assert (assq (list 'a) '(((a)) ((b)) ((c))))) 738 | (assert (assoc (list 'a) '(((a)) ((b)) ((c))))) 739 | (assert (assoc 2.0 '((1 1) (2 4) (3 9)) =)) 740 | (assert (assq 5 '((2 3) (5 7) (11 13)))) 741 | (assert (assv 5 '((2 3) (5 7) (11 13)))) 742 | 743 | (define a '(1 8 2 8)) 744 | (define b (list-copy a)) 745 | (set-car! b 3) 746 | (assert b) 747 | (assert a) 748 | 749 | (spec ";;; 6.5. Symbols") 750 | 751 | (assert (symbol? 'foo)) 752 | (assert (symbol? (car '(a b)))) 753 | (assert (symbol? "bar")) 754 | (assert (symbol? 'nil)) 755 | (assert (symbol? '())) 756 | (assert (symbol? #f)) 757 | 758 | (assert (symbol->string 'flying-fish)) 759 | (assert (symbol->string 'Martin)) 760 | (assert (symbol->string 761 | (string->symbol "Malvina"))) 762 | 763 | (assert (string->symbol "mISSISSIppi")) 764 | (assert (eq? 'bitBlt (string->symbol "bitBlt"))) 765 | (assert (eq? 'JollyWog 766 | (string->symbol 767 | (symbol->string 'JollyWog)))) 768 | (assert (string=? "K. Harper, M.D." 769 | (symbol->string 770 | (string->symbol "K. Harper, M.D.")))) 771 | 772 | (spec ";;; 6.6. Characters") 773 | 774 | (assert (char-ci=? #\A #\a)) 775 | 776 | (assert (digit-value #\3)) 777 | ;; (assert (digit-value #\x0664)) 778 | ;; (assert (digit-value #\x0AE6)) 779 | (assert (digit-value #\a)) ;; should be #\x0EA6 780 | 781 | (spec ";;; 6.7. Strings") 782 | 783 | (assert "The word \"recursion\" has many meanings.") 784 | (assert "Another example:\ntwo lines of text") 785 | (assert "Here's text \ 786 | containing just one line") 787 | (assert "\x061; is named GREEK SMALL LETTER ALPHA.") ;; should be \x03B1; 788 | 789 | (define (f) (make-string 3 #\*)) 790 | ;; (define (g) "***") 791 | (assert (string-set! (f) 0 #\?)) 792 | ;; (assert (string-set! (g) 0 #\?)) 793 | ;; (assert (string-set! (symbol->string 'immutable) 794 | ;; 0 795 | ;; #\?)) 796 | 797 | (define a "12345") 798 | (define b (string-copy "abcde")) 799 | (string-copy! b 1 a 0 2) 800 | (assert b) 801 | 802 | (spec ";;; 6.8. Vectors") 803 | 804 | (assert '#(0 (2 2 2 2) "Anna")) 805 | 806 | (assert (vector 'a 'b 'c)) 807 | 808 | (assert (vector-ref '#(1 1 2 3 5 8 13 21) 809 | 5)) 810 | (assert (vector-ref '#(1 1 2 3 5 8 13 21) 811 | (let ((i (round (* 2 (acos -1))))) 812 | (if (inexact? i) 813 | (exact i) 814 | i)))) 815 | 816 | (assert (let ((vec (vector 0 '(2 2 2 2) "Anna"))) 817 | (vector-set! vec 1 '("Sue" "Sue")) 818 | vec)) 819 | ;; (assert (vector-set! '#(0 1 2) 1 "doe")) 820 | 821 | (assert (vector->list '#(dah dah didah))) 822 | (assert (vector->list '#(dah dah didah) 1 2)) 823 | (assert (list->vector '(dididit dah))) 824 | 825 | (assert (string->vector "ABC")) 826 | (assert (vector->string 827 | #(#\1 #\2 #\3))) 828 | 829 | (define a #(1 8 2 8)) 830 | (define b (vector-copy a)) 831 | (vector-set! b 0 3) 832 | (assert b) 833 | 834 | (define c (vector-copy b 1 3)) 835 | (assert c) 836 | 837 | (define a (vector 1 2 3 4 5)) 838 | (define b (vector 10 20 30 40 50)) 839 | (vector-copy! b 1 a 0 2) 840 | (assert b) 841 | 842 | (assert (vector-append #(a b c) #(d e f))) 843 | 844 | (define a (vector 1 2 3 4 5)) 845 | (vector-fill! a 'smash 2 4) 846 | (assert a) 847 | 848 | (spec ";;; 6.9. Bytevectors") 849 | 850 | (assert (make-bytevector 2 12)) 851 | 852 | (assert (bytevector 1 3 5 1 3 5)) 853 | (assert (bytevector)) 854 | 855 | (assert (bytevector-u8-ref '#u8(1 1 2 3 5 8 13 21) 5)) 856 | 857 | (assert (let ((bv (bytevector 1 2 3 4))) 858 | (bytevector-u8-set! bv 1 3) 859 | bv)) 860 | 861 | (define a #u8(1 2 3 4 5)) 862 | (assert (bytevector-copy a 2 4)) 863 | 864 | (define a (bytevector 1 2 3 4 5)) 865 | (define b (bytevector 10 20 30 40 50)) 866 | (bytevector-copy! b 1 a 0 2) 867 | (assert b) 868 | 869 | (assert (bytevector-append #u8(0 1 2) #u8(3 4 5))) 870 | 871 | (assert (utf8->string #u8(#x41))) 872 | (assert (string->utf8 "A")) ;; should be λ 873 | 874 | (spec ";;; 6.10. Control features") 875 | 876 | (assert (procedure? car)) 877 | (assert (procedure? 'car)) 878 | (assert (procedure? (lambda (x) (* x x)))) 879 | (assert (procedure? '(lambda (x) (* x x)))) 880 | (assert (call-with-current-continuation procedure?)) 881 | 882 | (assert (apply + '(3 4))) 883 | (define compose 884 | (lambda (f g) 885 | (lambda args 886 | (f (apply g args))))) 887 | (assert ((compose sqrt *) 12 75)) 888 | 889 | (assert (map cadr '((a b) (d e) (g h)))) 890 | 891 | (assert (map (lambda (n) (expt n n)) 892 | '(1 2 3 4 5))) 893 | (assert (map + '(1 2 3) '(4 5 6))) 894 | (assert (let ((count (list 0))) ;; should be 0 895 | (map (lambda (ignored) 896 | (set-car! count (+ (car count) 1)) 897 | (car count)) 898 | '(a b)))) 899 | 900 | (assert (string-map 901 | (lambda (c) (integer->char (+ 1 (char->integer c)))) 902 | "HAL")) 903 | 904 | (assert (vector-map cadr '#((a b) (d e) (g h)))) 905 | 906 | (assert (vector-map (lambda (n) (expt n n)) 907 | '#(1 2 3 4 5))) 908 | 909 | (assert (vector-map + '#(1 2 3) '#(4 5 6 7))) 910 | 911 | (assert (let ((count (list 0))) 912 | (vector-map 913 | (lambda (ignored) 914 | (set-car! count (+ (car count) 1)) 915 | (car count)) 916 | '#(a b)))) 917 | 918 | (assert (let ((v (make-vector 5))) 919 | (for-each (lambda (i) 920 | (vector-set! v i (* i i))) 921 | '(0 1 2 3 4)) 922 | v)) 923 | 924 | (assert (let ((v (list '()))) ;; should be '() 925 | (string-for-each 926 | (lambda (c) (set-car! v (cons (char->integer c) (car v)))) 927 | "abcde") 928 | (car v))) 929 | 930 | (assert (let ((v (make-list 5))) 931 | (vector-for-each 932 | (lambda (i) (list-set! v i (* i i))) 933 | '#(0 1 2 3 4)) 934 | v)) 935 | 936 | ;; (assert (+ (delay (* 3 7)) 13)) 937 | 938 | (assert (call-with-current-continuation 939 | (lambda (exit) 940 | (for-each (lambda (x) 941 | (if (negative? x) 942 | (exit x))) 943 | '(54 0 37 -3 245 19)) 944 | #t))) 945 | 946 | (define list-length 947 | (lambda (obj) 948 | (call-with-current-continuation 949 | (lambda (return) 950 | (letrec ((r 951 | (lambda (obj) 952 | (cond ((null? obj) 0) 953 | ((pair? obj) 954 | (+ (r (cdr obj)) 1)) 955 | (else (return #f)))))) 956 | (r obj)))))) 957 | (assert (list-length '(1 2 3 4))) 958 | (assert (list-length '(a b . c))) 959 | 960 | (assert (call-with-values (lambda () (values 4 5)) 961 | (lambda (a b) b))) 962 | ;; (assert (call-with-values * -)) 963 | 964 | (assert (let ((path (list '())) ;; these should not be boxed 965 | (c (list #f))) 966 | (let ((add (lambda (s) 967 | (set-car! path (cons s (car path)))))) 968 | (dynamic-wind 969 | (lambda () (add 'connect)) 970 | (lambda () 971 | (add (call-with-current-continuation 972 | (lambda (c0) 973 | (set-car! c c0) 974 | 'talk1)))) 975 | (lambda () (add 'disconnect))) 976 | (if (< (length (car path)) 4) 977 | ((car c) 'talk2) 978 | (reverse (car path)))))) 979 | 980 | (spec ";;; 6.11. Exceptions") 981 | 982 | (assert (call-with-current-continuation 983 | (lambda (k) 984 | (with-exception-handler 985 | (lambda (x) 986 | (display "condition: ") 987 | (write x) 988 | (newline) 989 | (k 'exception)) 990 | (lambda () 991 | (+ 1 (raise 'an-error))))))) 992 | 993 | ;; (with-exception-handler 994 | ;; (lambda (x) 995 | ;; (display "something went wrong\n")) 996 | ;; (lambda () 997 | ;; (+ 1 (raise 'an-error)))) 998 | 999 | (assert (with-exception-handler 1000 | (lambda (con) 1001 | (cond 1002 | ((string? con) 1003 | (display con)) 1004 | (else 1005 | (display "a warning has been issued\n"))) 1006 | 42) 1007 | (lambda () 1008 | (+ (raise-continuable "should be a number\n") 1009 | 23)))) 1010 | 1011 | (spec ";;; 6.12. Environments and evaluation") 1012 | 1013 | (assert (eval '(* 7 3) (environment '(scheme base)))) 1014 | (assert (let ((f (eval '(lambda (f x) (f x x)) 1015 | (environment '(scheme base))))) 1016 | (f + 10))) 1017 | 1018 | 1019 | (spec ";;; Example") 1020 | 1021 | (define (integrate-system system-derivative 1022 | initial-state 1023 | h) 1024 | (let ((next (runge-kutta-4 system-derivative h))) 1025 | (letrec ((states (list initial-state))) ;; should be one line without set-cdr! 1026 | (set-cdr! states 1027 | (delay (map-streams next 1028 | states))) 1029 | states))) 1030 | 1031 | (define (runge-kutta-4 f h) 1032 | (let ((*h (scale-vector h)) 1033 | (*2 (scale-vector 2)) 1034 | (*1/2 (scale-vector (/ 1 2))) 1035 | (*1/6 (scale-vector (/ 1 6)))) 1036 | (lambda (y) 1037 | ;; y is a system state 1038 | (let* ((k0 (*h (f y))) 1039 | (k1 (*h (f (add-vectors y (*1/2 k0))))) 1040 | (k2 (*h (f (add-vectors y (*1/2 k1))))) 1041 | (k3 (*h (f (add-vectors y k2))))) 1042 | (add-vectors y 1043 | (*1/6 (add-vectors (add-vectors k0 ;; should be single add-vectors 1044 | (*2 k1)) 1045 | (add-vectors (*2 k2) 1046 | k3)))))))) 1047 | 1048 | (define (elementwise f) 1049 | (lambda vectors 1050 | (generate-vector 1051 | (vector-length (car vectors)) 1052 | (lambda (i) 1053 | (apply f 1054 | (map (lambda (v) (vector-ref v i)) 1055 | vectors)))))) 1056 | 1057 | (define (generate-vector size proc) 1058 | (let ((ans (make-vector size))) 1059 | (letrec ((loop 1060 | (lambda (i) 1061 | (cond ((= i size) ans) 1062 | (else 1063 | (vector-set! ans i (proc i)) 1064 | (loop (+ i 1))))))) 1065 | (loop 0)))) 1066 | 1067 | (define add-vectors (elementwise +)) 1068 | 1069 | (define (scale-vector s) 1070 | (elementwise (lambda (x) (* x s)))) 1071 | 1072 | (define (map-streams f s) 1073 | (cons (f (head s)) 1074 | (delay (map-streams f (tail s))))) 1075 | 1076 | (define head car) 1077 | (define (tail stream) 1078 | (force (cdr stream))) 1079 | 1080 | (define (damped-oscillator R L C) 1081 | (lambda (state) 1082 | (let ((Vc (vector-ref state 0)) 1083 | (Il (vector-ref state 1))) 1084 | (vector (- 0 (+ (/ Vc (* R C)) (/ Il C))) 1085 | (/ Vc L))))) 1086 | 1087 | (define the-states 1088 | (integrate-system 1089 | (damped-oscillator 10000 1000 .001) 1090 | '#(1 0) 1091 | .01)) 1092 | 1093 | (assert (head the-states)) 1094 | (assert (head (tail the-states))) 1095 | (assert (head (tail (tail the-states)))) 1096 | -------------------------------------------------------------------------------- /r7rs.scm: -------------------------------------------------------------------------------- 1 | ;;; R7RS 2 | 3 | ;;; 4. Expressions 4 | 5 | ;;; 4.2. Derived expression types 6 | 7 | ;;; 4.2.1. Conditionals 8 | 9 | (define-syntax cond 10 | (syntax-rules (else =>) 11 | ((cond (else result1 result2 ...)) 12 | (begin result1 result2 ...)) 13 | ((cond (test => result)) 14 | (let ((temp test)) 15 | (if temp (result temp)))) 16 | ((cond (test => result) clause1 clause2 ...) 17 | (let ((temp test)) 18 | (if temp 19 | (result temp) 20 | (cond clause1 clause2 ...)))) 21 | ((cond (test)) test) 22 | ((cond (test) clause1 clause2 ...) 23 | (let ((temp test)) 24 | (if temp 25 | temp 26 | (cond clause1 clause2 ...)))) 27 | ((cond (test result1 result2 ...)) 28 | (if test (begin result1 result2 ...))) 29 | ((cond (test result1 result2 ...) 30 | clause1 clause2 ...) 31 | (if test 32 | (begin result1 result2 ...) 33 | (cond clause1 clause2 ...))))) 34 | 35 | (define-syntax case 36 | (syntax-rules (else =>) 37 | ((case (key ...) 38 | clauses ...) 39 | (let ((atom-key (key ...))) 40 | (case atom-key clauses ...))) 41 | ((case key 42 | (else => result)) 43 | (result key)) 44 | ((case key 45 | (else result1 result2 ...)) 46 | (begin result1 result2 ...)) 47 | ((case key 48 | ((atoms ...) => result)) 49 | (if (memv key '(atoms ...)) 50 | (result key))) 51 | ((case key 52 | ((atoms ...) => result) 53 | clause clauses ...) 54 | (if (memv key '(atoms ...)) 55 | (result key) 56 | (case key clause clauses ...))) 57 | ((case key 58 | ((atoms ...) result1 result2 ...)) 59 | (if (memv key '(atoms ...)) 60 | (begin result1 result2 ...))) 61 | ((case key 62 | ((atoms ...) result1 result2 ...) 63 | clause clauses ...) 64 | (if (memv key '(atoms ...)) 65 | (begin result1 result2 ...) 66 | (case key clause clauses ...))))) 67 | 68 | (define-syntax and 69 | (syntax-rules () 70 | ((and) #t) 71 | ((and test) test) 72 | ((and test1 test2 ...) 73 | (if test1 (and test2 ...) #f)))) 74 | 75 | (define-syntax or 76 | (syntax-rules () 77 | ((or) #f) 78 | ((or test) test) 79 | ((or test1 test2 ...) 80 | (let ((x test1)) 81 | (if x x (or test2 ...)))))) 82 | 83 | (define-syntax when 84 | (syntax-rules () 85 | ((when test result1 result2 ...) 86 | (if test 87 | (begin result1 result2 ...))))) 88 | 89 | (define-syntax unless 90 | (syntax-rules () 91 | ((unless test result1 result2 ...) 92 | (if (not test) 93 | (begin result1 result2 ...))))) 94 | 95 | (define-syntax cond-expand 96 | (syntax-rules (and or not else) 97 | ((cond-expand (else body ...)) 98 | (begin body ...)) 99 | ((cond-expand ((and) body ...) more-clauses ...) 100 | (begin body ...)) 101 | ((cond-expand ((and req1 req2 ...) body ...) more-clauses ...) 102 | (cond-expand 103 | (req1 104 | (cond-expand 105 | ((and req2 ...) body ...) 106 | more-clauses ...)) 107 | more-clauses ...)) 108 | ((cond-expand ((or) body ...) more-clauses ...) 109 | (cond-expand more-clauses ...)) 110 | ((cond-expand ((or req1 req2 ...) body ...) more-clauses ...) 111 | (cond-expand 112 | (req1 113 | (begin body ...)) 114 | (else 115 | (cond-expand 116 | ((or req2 ...) body ...) 117 | more-clauses ...)))) 118 | ((cond-expand ((not req) body ...) more-clauses ...) 119 | (cond-expand 120 | (req 121 | (cond-expand more-clauses ...)) 122 | (else body ...))) 123 | ((cond-expand (feature-id body ...)) 124 | (if (memv 'feature-id (features)) 125 | (begin body ...))) 126 | ((cond-expand (feature-id body ...) more-clauses ...) 127 | (if (memv 'feature-id (features)) 128 | (begin body ...) 129 | (cond-expand more-clauses ...))))) 130 | 131 | ;;; 4.2.2. Binding constructs 132 | 133 | (define-syntax let* 134 | (syntax-rules () 135 | ((let* () body1 body2 ...) 136 | (let () body1 body2 ...)) 137 | ((let* ((name1 val1) (name2 val2) ...) 138 | body1 body2 ...) 139 | (let ((name1 val1)) 140 | (let* ((name2 val2) ...) 141 | body1 body2 ...))))) 142 | 143 | (define-syntax let-values 144 | (lambda (form env) 145 | (let* ((mv-binding-spec (cadr form)) 146 | (body (cddr form)) 147 | (destructure 148 | (let loop ((mv-binding-spec mv-binding-spec) 149 | (acc '()) 150 | (idx (- (length mv-binding-spec) 1))) 151 | (if (negative? idx) 152 | acc 153 | (let ((tmp (string->symbol (string-append "tmp_" (number->string idx)))) 154 | (formals (reverse (caar mv-binding-spec))) 155 | (init (cdar mv-binding-spec))) 156 | (loop (cdr mv-binding-spec) 157 | (cons `((,tmp (call-with-values 158 | (lambda () 159 | ,@init) 160 | vector)) 161 | ,@(let loop ((formals formals) 162 | (acc '()) 163 | (idx (- (length formals) 1))) 164 | (if (negative? idx) 165 | acc 166 | (loop (cdr formals) 167 | (cons `(,(car formals) (vector-ref ,tmp ,idx)) acc) 168 | (- idx 1))))) 169 | acc) 170 | (- idx 1))))))) 171 | `(let* ,@destructure 172 | ,@body)))) 173 | 174 | (define-syntax let*-values 175 | (syntax-rules () 176 | ((let*-values () body0 body1 ...) 177 | (let () body0 body1 ...)) 178 | ((let*-values (binding0 binding1 ...) 179 | body0 body1 ...) 180 | (let-values (binding0) 181 | (let*-values (binding1 ...) 182 | body0 body1 ...))))) 183 | 184 | ;;; 4.2.4. Iteration 185 | 186 | (define-syntax do 187 | (syntax-rules () 188 | ((do ((var init step ...) ...) 189 | (test expr ...) 190 | command ...) 191 | (let loop ((var init) ...) 192 | (if test 193 | (begin 194 | (if #f #f) 195 | expr ...) 196 | (begin 197 | command 198 | ... 199 | (loop (do "step" var step ...) 200 | ...))))) 201 | ((do "step" x) 202 | x) 203 | ((do "step" x y) 204 | y))) 205 | 206 | ;;; 4.2.5. Delayed evaluation 207 | 208 | (define-syntax delay-force 209 | (syntax-rules () 210 | ((delay-force expression) 211 | (make-promise #f (lambda () expression))))) 212 | 213 | (define-syntax delay 214 | (syntax-rules () 215 | ((delay expression) 216 | (delay-force (make-promise #t expression))))) 217 | 218 | (define (force promise) 219 | (if (promise-done? promise) 220 | (promise-value promise) 221 | (let ((promise* ((promise-value promise)))) 222 | (unless (promise-done? promise) 223 | (promise-update! promise* promise)) 224 | (force promise)))) 225 | 226 | (define promise-update! 227 | (lambda (new old) 228 | (set-promise-done! old (promise-done? new)) 229 | (set-promise-value! old (promise-value new)) 230 | (set-promise-value! new (promise-value old)) 231 | (set-promise-done! new (promise-done? old)))) 232 | 233 | ;;; 4.2.6. Dynamic bindings 234 | 235 | (define (make-parameter init . o) 236 | (let* ((converter 237 | (if (pair? o) (car o) (lambda (x) x))) 238 | (value (cons (converter init) '()))) 239 | (lambda args 240 | (cond 241 | ((null? args) 242 | (car value)) 243 | ((eq? (car args) ') 244 | (set-car! value (cadr args))) 245 | ((eq? (car args) ') 246 | converter) 247 | ((eq? 1 (length args)) 248 | (set-car! value (converter (car args)))) 249 | (else 250 | (error "bad parameter syntax")))))) 251 | 252 | (define-syntax parameterize 253 | (lambda (form env) 254 | (let ((bindings (cadr form)) 255 | (body (cddr form))) 256 | `(let ((old (list ,@(map (lambda (p) 257 | `(cons (,(car p)) ,(car p))) 258 | bindings)))) 259 | (dynamic-wind 260 | (lambda () 261 | ,@(map (lambda (p) 262 | `(,(car p) ' ((,(car p) ') ,(cadr p)))) 263 | bindings)) 264 | (lambda () 265 | ,@body) 266 | (lambda () 267 | (for-each (lambda (p) 268 | ((cdr p) ' (car p))) 269 | old))))))) 270 | 271 | ;;; 4.2.7. Exception handling 272 | 273 | (define-syntax guard 274 | (lambda (form env) 275 | (let ((condition (caadr form)) 276 | (guard (cdadr form)) 277 | (body (cddr form))) 278 | `(call/cc (lambda (continue) 279 | (with-exception-handler 280 | (lambda (,condition) 281 | (let ((result (cond ,@guard))) 282 | (if result 283 | (continue result) 284 | (raise ,condition)))) 285 | (lambda () 286 | ,@body))))))) 287 | 288 | ;;; 4.2.9. Case-lambda 289 | 290 | (define-syntax case-lambda 291 | (syntax-rules () 292 | ((case-lambda (params body0 ...) ...) 293 | (lambda args 294 | (let ((len (length args))) 295 | (case-lambda len (params body0 ...) ...)))) 296 | ((case-lambda len) 297 | (error "no matching clause")) 298 | ((case-lambda len ((p ...) . body) . rest) 299 | (if (= len (length '(p ...))) 300 | (apply (lambda (p ...) 301 | . body) 302 | args) 303 | (case-lambda len . rest))) 304 | ((case-lambda len ((p ... . tail) . body) 305 | . rest) 306 | (if (>= len (length '(p ...))) 307 | (apply 308 | (lambda (p ... . tail) 309 | . body) 310 | args) 311 | (case-lambda len . rest))))) 312 | 313 | ;;; 5.2. Import Declarations 314 | 315 | (define-syntax import 316 | (syntax-rules () 317 | ((import import-set ...)))) 318 | 319 | ;;; 5.3. Variable definitions 320 | 321 | ;;; 5.3.3. Multiple-value definitions 322 | 323 | (define-syntax define-values 324 | (syntax-rules () 325 | ((define-values (formals ...) expression) 326 | (let-values (((formals ...) expression)) 327 | (eval `(define formals ,formals) (environment '(scheme base))) ...)))) 328 | 329 | ;;; 5.5. Record-type definitions 330 | 331 | (define-syntax define-record-type 332 | (syntax-rules () 333 | ((define-record-type name 334 | (constructor fields ...) 335 | pred 336 | (field-name accessor modifier ...) ...) 337 | 338 | (define (constructor fields ...) 339 | (make-record 340 | (let ((arguments (list (cons 'fields fields) ...))) 341 | (map (lambda (x) 342 | (let ((v (assoc x arguments))) 343 | (if v (cdr v) #f))) 344 | '(field-name ...))) 345 | 'name)) 346 | 347 | (define (pred obj) 348 | (eq? 'name (class-of obj))) 349 | 350 | (let ((fs '(field-name ...)) 351 | (type 'name)) 352 | (define-record-type "field" fs type (field-name accessor modifier ...)) ...)) 353 | 354 | ((define-record-type "field" fields type (field-name accessor)) 355 | (let ((field-idx (- (length fields) (length (memq 'field-name fields))))) 356 | (define (accessor record) 357 | (if (eq? type (class-of record)) 358 | (record-ref record field-idx) 359 | (error (string-append "Not a " (symbol->string type) ":") record))))) 360 | 361 | ((define-record-type "field" fields type (field-name accessor modifier)) 362 | (define-record-type "field" fields type (field-name accessor)) 363 | (let ((field-idx (- (length fields) (length (memq 'field-name fields))))) 364 | (define (modifier record value) 365 | (if (eq? type (class-of record)) 366 | (record-set! record field-idx value) 367 | (error (string-append "Not a " (symbol->string type) ":") record))))))) 368 | 369 | ;;; 6. Standard procedures 370 | 371 | ;;; 6.1. Equivalence predicates 372 | 373 | (define (pair=? pair1 pair2) 374 | (let loop ((pair1 pair1) 375 | (pair2 pair2)) 376 | (if (and (pair? pair1) (pair? pair2)) 377 | (and (equal? (car pair1) (car pair2)) 378 | (loop (cdr pair1) (cdr pair2))) 379 | (equal? pair1 pair2)))) 380 | 381 | (define (vector=? vector1 vector2) 382 | (and (= (vector-length vector1) (vector-length vector2)) 383 | (let loop ((idx (- (vector-length vector1) 1))) 384 | (cond ((negative? idx) #t) 385 | ((equal? (vector-ref vector1 idx) 386 | (vector-ref vector2 idx)) 387 | (loop (- idx 1))) 388 | (else #f))))) 389 | 390 | (define (bytevector=? bytevector1 bytevector2) 391 | (and (= (bytevector-length bytevector1) (bytevector-length bytevector2)) 392 | (let loop ((idx (- (bytevector-length bytevector1) 1))) 393 | (cond ((negative? idx) #t) 394 | ((eq? (bytevector-u8-ref bytevector1 idx) 395 | (bytevector-u8-ref bytevector2 idx)) 396 | (loop (- idx 1))) 397 | (else #f))))) 398 | 399 | (define (equal? obj1 obj2) 400 | (cond ((and (pair? obj1) (pair? obj2)) 401 | (pair=? obj1 obj2)) 402 | ((and (string? obj1) (string? obj2)) 403 | (string=? obj1 obj2)) 404 | ((and (vector? obj1) (vector? obj2)) 405 | (vector=? obj1 obj2)) 406 | ((and (bytevector? obj1) (bytevector? obj2)) 407 | (bytevector=? obj1 obj2)) 408 | (else (eqv? obj1 obj2)))) 409 | 410 | ;;; 4.2.9. Case-lambda 411 | 412 | (define-syntax case-lambda 413 | (lambda (form env) 414 | `(lambda args 415 | (apply (vector-ref ,(do ((form (cdr form) (cdr form)) 416 | (acc (make-vector 6))) 417 | ((null? form) acc) 418 | (vector-set! acc (length (car (car form))) 419 | (eval (cons 'lambda (car form)) 420 | (interaction-environment)))) 421 | (length args)) 422 | args)))) 423 | 424 | ;;; 6.2. Numbers 425 | 426 | ;;; 6.2.6. Numerical operations 427 | 428 | (define (exact-integer? z) 429 | (and (integer? z) (exact? z))) 430 | 431 | (define (finite? z) 432 | (and (number? z) 433 | (not (or (nan? z) (infinite? z))))) 434 | 435 | (define (zero? x) 436 | (= 0 x)) 437 | 438 | (define (positive? x) 439 | (> x 0)) 440 | 441 | (define (negative? x) 442 | (< x 0)) 443 | 444 | (define (odd? n) 445 | (not (even? n))) 446 | 447 | (define (even? n) 448 | (zero? (modulo n 2))) 449 | 450 | (define (min-max-aux test x1 x2) 451 | (if (test x1 x2) 452 | (if (inexact? x1) 453 | (inexact x2) 454 | x2) 455 | (if (inexact? x2) 456 | (inexact x1) 457 | x1))) 458 | 459 | (define (max x1 x2) 460 | (min-max-aux < x1 x2)) 461 | 462 | (define (min x1 x2) 463 | (min-max-aux > x1 x2)) 464 | 465 | (define (abs x) 466 | (if (negative? x) 467 | (- 0 x) 468 | x)) 469 | 470 | (define (floor/ n1 n2) 471 | (let* ((nq (floor (/ n1 n2))) 472 | (nr (- n1 (* nq n2)))) 473 | (if (and (exact? n1) (exact? n2)) 474 | (values (exact nq) (exact nr)) 475 | (values (inexact nq) (inexact nr))))) 476 | 477 | (define (floor-quotient n1 n2) 478 | (floor (quotient n1 n2))) 479 | 480 | (define floor-remainder modulo) 481 | 482 | (define (truncate/ n1 n2) 483 | (let* ((nq (truncate (/ n1 n2))) 484 | (nr (- n1 (* nq n2)))) 485 | (if (and (exact? n1) (exact? n2)) 486 | (values (exact nq) (exact nr)) 487 | (values (inexact nq) (inexact nr))))) 488 | 489 | (define truncate-quotient quotient) 490 | 491 | (define truncate-remainder remainder) 492 | 493 | (define gcd 494 | (case-lambda 495 | (() 0) 496 | ((n1 n2) 497 | (if (zero? n2) 498 | (abs n1) 499 | (gcd n2 (modulo n1 n2)))))) 500 | 501 | (define lcm 502 | (case-lambda 503 | (() 1) 504 | ((n1 n2) 505 | (/ (abs (* n1 n2)) 506 | (gcd n1 n2))))) 507 | 508 | (define atan1 atan) 509 | 510 | (define atan 511 | (case-lambda 512 | ((z) 513 | (atan1 z)) 514 | ((y x) 515 | (atan2 y x)))) 516 | 517 | (define (square z) 518 | (* z z)) 519 | 520 | (define (exact-integer-sqrt k) 521 | (let* ((s (exact (sqrt k))) 522 | (r (exact (- k (* s s))))) 523 | (values s r))) 524 | 525 | ;;; 6.3. Booleans 526 | 527 | (define (boolean? obj) 528 | (or (eq? #t obj) (eq? #f obj))) 529 | 530 | (define boolean=? eqv?) 531 | 532 | ;;; 6.4. Pairs and lists 533 | 534 | (define (caar obj) 535 | (car (car obj))) 536 | 537 | (define (cadr obj) 538 | (car (cdr obj))) 539 | 540 | (define (cdar obj) 541 | (cdr (car obj))) 542 | 543 | (define (cddr obj) 544 | (cdr (cdr obj))) 545 | 546 | (define (caaar obj) 547 | (car (caar obj))) 548 | 549 | (define (caadr obj) 550 | (car (cadr obj))) 551 | 552 | (define (cadar obj) 553 | (car (cdar obj))) 554 | 555 | (define (caddr obj) 556 | (car (cddr obj))) 557 | 558 | (define (cdaar obj) 559 | (cdr (caar obj))) 560 | 561 | (define (cdadr obj) 562 | (cdr (cadr obj))) 563 | 564 | (define (cddar obj) 565 | (cdr (cdar obj))) 566 | 567 | (define (cdddr obj) 568 | (cdr (cddr obj))) 569 | 570 | (define (caaaar obj) 571 | (car (caaar obj))) 572 | 573 | (define (caaadr obj) 574 | (car (caadr obj))) 575 | 576 | (define (caadar obj) 577 | (car (cadar obj))) 578 | 579 | (define (caaddr obj) 580 | (car (caddr obj))) 581 | 582 | (define (cadaar obj) 583 | (car (cdaar obj))) 584 | 585 | (define (cadadr obj) 586 | (car (cdadr obj))) 587 | 588 | (define (caddar obj) 589 | (car (cddar obj))) 590 | 591 | (define (cadddr obj) 592 | (car (cdddr obj))) 593 | 594 | (define (cdaaar obj) 595 | (cdr (caaar obj))) 596 | 597 | (define (cdaadr obj) 598 | (cdr (caadr obj))) 599 | 600 | (define (cdadar obj) 601 | (cdr (cadar obj))) 602 | 603 | (define (cdaddr obj) 604 | (cdr (caddr obj))) 605 | 606 | (define (cddaar obj) 607 | (cdr (cdaar obj))) 608 | 609 | (define (cddadr obj) 610 | (cdr (cdadr obj))) 611 | 612 | (define (cdddar obj) 613 | (cdr (cddar obj))) 614 | 615 | (define (cddddr obj) 616 | (cdr (cdddr obj))) 617 | 618 | (define (list? obj) 619 | (let loop ((obj obj)) 620 | (cond ((null? obj) #t) 621 | ((pair? obj) (loop (cdr obj))) 622 | (else #f)))) 623 | 624 | (define make-list 625 | (case-lambda 626 | ((k) 627 | (make-list k (if #f #f))) 628 | ((k fill) 629 | (do ((acc '() (cons fill acc)) 630 | (idx 0 (+ idx 1))) 631 | ((= idx k) acc))))) 632 | 633 | (define (list . obj) 634 | obj) 635 | 636 | (define append-internal append) 637 | 638 | (define (append . lists) 639 | (cond ((null? lists) 640 | '()) 641 | ((null? (cdr lists)) 642 | (car lists)) 643 | (else 644 | (append-internal (car lists) 645 | (apply append (cdr lists)))))) 646 | 647 | (define (list-tail list k) 648 | (let loop ((list list) 649 | (k k)) 650 | (if (zero? k) 651 | list 652 | (loop (cdr list) (- k 1))))) 653 | 654 | (define (list-ref list k) 655 | (car (list-tail list k))) 656 | 657 | (define (list-set! list k obj) 658 | (set-car! (list-tail list k) obj)) 659 | 660 | (define member 661 | (case-lambda 662 | ((obj list) 663 | (member obj list equal?)) 664 | ((obj list compare) 665 | (let loop ((list list)) 666 | (cond ((null? list) #f) 667 | ((compare obj (car list)) list) 668 | (else (loop (cdr list)))))))) 669 | 670 | (define (memq obj list) 671 | (member obj list eq?)) 672 | 673 | (define (memv obj list) 674 | (member obj list eqv?)) 675 | 676 | (define (assq obj alist) 677 | (assoc obj alist eq?)) 678 | 679 | (define (assv obj alist) 680 | (assoc obj alist eqv?)) 681 | 682 | (define assoc 683 | (case-lambda 684 | ((obj list) 685 | (assoc obj list equal?)) 686 | ((obj alist compare) 687 | (let loop ((alist alist)) 688 | (cond ((null? alist) #f) 689 | ((compare obj (caar alist)) (car alist)) 690 | (else (loop (cdr alist)))))))) 691 | 692 | (define (list-copy obj) 693 | (map (lambda (x) x) obj)) 694 | 695 | ;;; 6.5. Symbols 696 | 697 | (define (symbol=? symbol1 symbol2) 698 | (equal? (symbol->string symbol1) (symbol->string symbol2))) 699 | 700 | ;;; 6.6. Characters 701 | 702 | (define (char=? char1 char2) 703 | (= (char->integer char1) (char->integer char2))) 704 | 705 | (define (charinteger char1) (char->integer char2))) 707 | 708 | (define (char>? char1 char2) 709 | (> (char->integer char1) (char->integer char2))) 710 | 711 | (define (char<=? char1 char2) 712 | (<= (char->integer char1) (char->integer char2))) 713 | 714 | (define (char>=? char1 char2) 715 | (>= (char->integer char1) (char->integer char2))) 716 | 717 | (define (char-ci=? char1 char2) 718 | (= (char->integer (char-downcase char1)) (char->integer (char-downcase char2)))) 719 | 720 | (define (char-ciinteger (char-downcase char1)) (char->integer (char-downcase char2)))) 722 | 723 | (define (char-ci>? char1 char2) 724 | (> (char->integer (char-downcase char1)) (char->integer (char-downcase char2)))) 725 | 726 | (define (char-ci<=? char1 char2) 727 | (<= (char->integer (char-downcase char1)) (char->integer (char-downcase char2)))) 728 | 729 | (define (char-ci>=? char1 char2) 730 | (>= (char->integer (char-downcase char1)) (char->integer (char-downcase char2)))) 731 | 732 | (define (digit-value char) 733 | (if (char-numeric? char) 734 | (- (char->integer char) (char->integer #\0)) 735 | #f)) 736 | 737 | (define char-foldcase char-downcase) 738 | 739 | ;;; 6.7. Strings 740 | 741 | (define (string . char) 742 | (list->string char)) 743 | 744 | (define (string-upcase string) 745 | (string-map char-upcase string)) 746 | 747 | (define (string-downcase string) 748 | (string-map char-downcase string)) 749 | 750 | (define (string-foldcase string) 751 | (string-map char-foldcase string)) 752 | 753 | (define (substring string start end) 754 | (do ((copy (make-string (- end start))) 755 | (idx start (+ idx 1))) 756 | ((= idx end) copy) 757 | (string-set! copy (- idx start) (string-ref string idx)))) 758 | 759 | (define (string-append . strings) 760 | (if (null? strings) 761 | "" 762 | (let* ((string1 (car strings)) 763 | (string2 (apply string-append (cdr strings))) 764 | (length1 (string-length string1)) 765 | (length2 (string-length string2)) 766 | (acc (make-string (+ length1 length2)))) 767 | (do ((idx 0 (+ idx 1))) 768 | ((= idx length1)) 769 | (string-set! acc idx (string-ref string1 idx))) 770 | (do ((idx 0 (+ idx 1))) 771 | ((= idx length2)) 772 | (string-set! acc (+ idx length1) (string-ref string2 idx))) 773 | acc))) 774 | 775 | (define string->list 776 | (case-lambda 777 | ((string) 778 | (string->list string 0)) 779 | ((string start) 780 | (string->list string start (string-length string))) 781 | ((string start end) 782 | (do ((list '() (cons (string-ref string idx) list)) 783 | (idx (- end 1) (- idx 1))) 784 | ((< idx start) list))))) 785 | 786 | (define (list->string list) 787 | (do ((list list (cdr list)) 788 | (string (make-string (length list))) 789 | (idx 0 (+ idx 1))) 790 | ((null? list) string) 791 | (string-set! string idx (car list)))) 792 | 793 | (define string-copy 794 | (case-lambda 795 | ((string) 796 | (string-copy string 0)) 797 | ((string start) 798 | (string-copy string start (string-length string))) 799 | ((string start end) 800 | (string-copy! (make-string (- end start) #\space) 0 string start end)))) 801 | 802 | (define string-copy! 803 | (case-lambda 804 | ((to at from) 805 | (string-copy! to at from 0)) 806 | ((to at from start) 807 | (string-copy! to at from start (string-length string))) 808 | ((to at from start end) 809 | (do ((idx start (+ idx 1))) 810 | ((= idx end) to) 811 | (string-set! to (- (+ idx at) start) (string-ref from idx)))))) 812 | 813 | (define string-fill! 814 | (case-lambda 815 | ((string fill) 816 | (string-fill! string fill 0)) 817 | ((string fill start) 818 | (string-fill! string fill start (string-length string))) 819 | ((string fill start end) 820 | (do ((idx start (+ idx 1))) 821 | ((= idx end)) 822 | (string-set! string idx fill))))) 823 | 824 | ;;; 6.8. Vectors 825 | 826 | (define (vector . obj) 827 | (list->vector obj)) 828 | 829 | (define vector->list 830 | (case-lambda 831 | ((vector) 832 | (vector->list vector 0)) 833 | ((vector start) 834 | (vector->list vector start (vector-length vector))) 835 | ((vector start end) 836 | (do ((list '() (cons (vector-ref vector idx) list)) 837 | (idx (- end 1) (- idx 1))) 838 | ((< idx start) list))))) 839 | 840 | (define vector-copy 841 | (case-lambda 842 | ((vector) 843 | (vector-copy vector 0)) 844 | ((vector start) 845 | (vector-copy vector start (vector-length vector))) 846 | ((vector start end) 847 | (vector-copy! (make-vector (- end start) 0) 0 vector start end)))) 848 | 849 | (define vector-copy! 850 | (case-lambda 851 | ((to at from) 852 | (vector-copy! to at from 0)) 853 | ((to at from start) 854 | (vector-copy! to at from start (vector-length vector))) 855 | ((to at from start end) 856 | (do ((idx start (+ idx 1))) 857 | ((= idx end) to) 858 | (vector-set! to (- (+ idx at) start) (vector-ref from idx)))))) 859 | 860 | (define vector->string 861 | (case-lambda 862 | ((vector) 863 | (vector->string vector 0)) 864 | ((vector start) 865 | (vector->string vector start (vector-length vector))) 866 | ((vector start end) 867 | (do ((acc (make-string (- end start) #\space)) 868 | (idx start (+ idx 1))) 869 | ((= idx end) acc) 870 | (string-set! acc (- idx start) (vector-ref vector idx)))))) 871 | 872 | (define string->vector 873 | (case-lambda 874 | ((string) 875 | (string->vector string 0)) 876 | ((string start) 877 | (string->vector string start (string-length string))) 878 | ((string start end) 879 | (do ((acc (make-vector (- end start))) 880 | (idx start (+ idx 1))) 881 | ((= idx end) acc) 882 | (vector-set! acc (- idx start) (string-ref string idx)))))) 883 | 884 | (define (vector-append . vectors) 885 | (if (null? vectors) 886 | #() 887 | (let* ((vector1 (car vectors)) 888 | (vector2 (apply vector-append (cdr vectors))) 889 | (length1 (vector-length vector1)) 890 | (length2 (vector-length vector2)) 891 | (acc (make-vector (+ length1 length2)))) 892 | (do ((idx 0 (+ idx 1))) 893 | ((= idx length1)) 894 | (vector-set! acc idx (vector-ref vector1 idx))) 895 | (do ((idx 0 (+ idx 1))) 896 | ((= idx length2)) 897 | (vector-set! acc (+ idx length1) (vector-ref vector2 idx))) 898 | acc))) 899 | 900 | (define vector-fill! 901 | (case-lambda 902 | ((vector fill) 903 | (vector-fill! vector fill 0)) 904 | ((vector fill start) 905 | (vector-fill! vector fill start (vector-length vector))) 906 | ((vector fill start end) 907 | (do ((idx start (+ idx 1))) 908 | ((= idx end)) 909 | (vector-set! vector idx fill))))) 910 | 911 | ;;; 6.9. Bytevectors 912 | 913 | (define (bytevector . byte) 914 | (list->bytevector byte)) 915 | 916 | (define bytevector-copy 917 | (case-lambda 918 | ((bytevector) 919 | (bytevector-copy bytevector 0)) 920 | ((bytevector start) 921 | (bytevector-copy bytevector start (bytevector-length bytevector))) 922 | ((bytevector start end) 923 | (bytevector-copy! (make-bytevector (- end start) 0) 0 bytevector start end)))) 924 | 925 | (define bytevector-copy! 926 | (case-lambda 927 | ((to at from) 928 | (bytevector-copy! to at from 0)) 929 | ((to at from start) 930 | (bytevector-copy! to at from start (bytevector-length bytevector))) 931 | ((to at from start end) 932 | (do ((idx start (+ idx 1))) 933 | ((= idx end) to) 934 | (bytevector-u8-set! to (- (+ idx at) start) (bytevector-u8-ref from idx)))))) 935 | 936 | (define (bytevector-append . bytevectors) 937 | (if (null? bytevectors) 938 | (bytevector) 939 | (let* ((bytevector1 (car bytevectors)) 940 | (bytevector2 (apply bytevector-append (cdr bytevectors))) 941 | (length1 (bytevector-length bytevector1)) 942 | (length2 (bytevector-length bytevector2)) 943 | (acc (make-bytevector (+ length1 length2)))) 944 | (do ((idx 0 (+ idx 1))) 945 | ((= idx length1)) 946 | (bytevector-u8-set! acc idx (bytevector-u8-ref bytevector1 idx))) 947 | (do ((idx 0 (+ idx 1))) 948 | ((= idx length2)) 949 | (bytevector-u8-set! acc (+ idx length1) (bytevector-u8-ref bytevector2 idx))) 950 | acc))) 951 | 952 | (define utf8->string 953 | (case-lambda 954 | ((bytevector) 955 | (utf8->string bytevector 0)) 956 | ((bytevector start) 957 | (utf8->string bytevector start (bytevector-length bytevector))) 958 | ((bytevector start end) 959 | (do ((acc (make-string (- end start))) 960 | (idx start (+ idx 1))) 961 | ((= idx end) acc) 962 | (string-set! acc (- idx start) (integer->char (bytevector-u8-ref bytevector idx))))))) 963 | 964 | (define string->utf8 965 | (case-lambda 966 | ((string) 967 | (string->utf8 string 0)) 968 | ((string start) 969 | (string->utf8 string start (string-length string))) 970 | ((string start end) 971 | (do ((acc (make-bytevector (- end start))) 972 | (idx start (+ idx 1))) 973 | ((= idx end) acc) 974 | (bytevector-u8-set! acc (- idx start) (char->integer (string-ref string idx))))))) 975 | 976 | ;;; 6.10. Control features 977 | 978 | (define apply-internal apply) 979 | 980 | (define (apply proc . args) 981 | (let* ((args (reverse args)) 982 | (flat-args (car args))) 983 | (if (list? flat-args) 984 | (do ((args (cdr args) (cdr args)) 985 | (flat-args flat-args (cons (car args) flat-args))) 986 | ((null? args) (apply-internal proc flat-args))) 987 | (error "Not a list:" flat-args)))) 988 | 989 | (define (map proc list . lists) 990 | (if (pair? lists) 991 | (do ((lists (cons list lists) (map cdr lists)) 992 | (acc '() (cons (apply proc (map car lists)) acc))) 993 | ((memv '() lists) (reverse acc))) 994 | (let* ((length (length list)) 995 | (acc (make-list length))) 996 | (do ((from list (cdr from)) 997 | (to acc (cdr to))) 998 | ((null? from) acc) 999 | (set-car! to (proc (car from))))))) 1000 | 1001 | (define (string-map proc string . strings) 1002 | (if (pair? strings) 1003 | (list->string (apply map proc (map string->list (cons string strings)))) 1004 | (let ((length (string-length string))) 1005 | (do ((acc (make-string length)) 1006 | (idx 0 (+ idx 1))) 1007 | ((= idx length) acc) 1008 | (string-set! acc idx (proc (string-ref string idx))))))) 1009 | 1010 | (define (vector-map proc vector . vectors) 1011 | (if (pair? vectors) 1012 | (list->vector (apply map proc (map vector->list (cons vector vectors)))) 1013 | (let ((length (vector-length vector))) 1014 | (do ((acc (make-vector length)) 1015 | (idx 0 (+ idx 1))) 1016 | ((= idx length) acc) 1017 | (vector-set! acc idx (proc (vector-ref vector idx))))))) 1018 | 1019 | (define (for-each proc list . lists) 1020 | (if (pair? lists) 1021 | (do ((lists (cons list lists) (map cdr lists))) 1022 | ((memv '() lists)) 1023 | (apply proc (map car lists))) 1024 | (do ((list list (cdr list))) 1025 | ((null? list)) 1026 | (proc (car list))))) 1027 | 1028 | (define (string-for-each proc string . strings) 1029 | (if (pair? strings) 1030 | (apply for-each proc (map string->list (cons string strings))) 1031 | (let ((length (string-length string))) 1032 | (do ((idx 0 (+ idx 1))) 1033 | ((= idx length)) 1034 | (proc (string-ref string idx)))))) 1035 | 1036 | (define (vector-for-each proc vector . vectors) 1037 | (if (pair? vectors) 1038 | (apply for-each proc (map vector->list (cons vector vectors))) 1039 | (let ((length (vector-length vector))) 1040 | (do ((idx 0 (+ idx 1))) 1041 | ((= idx length)) 1042 | (proc (vector-ref vector idx)))))) 1043 | 1044 | (define call/cc call-with-current-continuation) 1045 | 1046 | (define-record-type promise 1047 | (make-promise done? value) 1048 | promise? 1049 | (done? promise-done? set-promise-done!) 1050 | (value promise-value set-promise-value!)) 1051 | 1052 | (define dynamic-extent-stack (make-parameter '())) 1053 | 1054 | (define (dynamic-wind before thunk after) 1055 | (before) 1056 | (let ((old-dynamic-extent-stack (dynamic-extent-stack)) 1057 | (new-dynamic-extent-stack (dynamic-extent-stack ' 1058 | ((dynamic-extent-stack ') 1059 | (cons (cons before after) (dynamic-extent-stack))))) 1060 | (return (thunk))) 1061 | (dynamic-extent-stack ' old-dynamic-extent-stack) 1062 | (after) 1063 | return)) 1064 | 1065 | ;;; 6.11. Exceptions 1066 | 1067 | (define (default-exception-handler error) 1068 | (if (error-object? error) 1069 | (begin 1070 | (display (error-object-message error) 1071 | (current-error-port)) 1072 | (for-each (lambda (irritant) 1073 | (display #\space (current-error-port)) 1074 | (display irritant (current-error-port))) 1075 | (error-object-irritants error))) 1076 | (display error (current-error-port))) 1077 | (newline (current-error-port))) 1078 | 1079 | (define exception-handler-stack (make-parameter (list default-exception-handler))) 1080 | 1081 | (define exception-handler-continuation (make-parameter (lambda (x)))) 1082 | 1083 | (define (parent-exception-handler) 1084 | (let ((stack (exception-handler-stack))) 1085 | (if (null? stack) 1086 | stack 1087 | (cdr stack)))) 1088 | 1089 | (define (with-exception-handler handler thunk) 1090 | (parameterize ((exception-handler-stack 1091 | (cons (lambda (obj) 1092 | (parameterize ((exception-handler-stack (parent-exception-handler))) 1093 | ((exception-handler-continuation) (handler obj)) 1094 | (raise obj))) 1095 | (exception-handler-stack)))) 1096 | (thunk))) 1097 | 1098 | (define (raise obj) 1099 | (unless (null? (exception-handler-stack)) 1100 | ((car (exception-handler-stack)) obj)) 1101 | (exit 1)) 1102 | 1103 | (define (raise-continuable obj) 1104 | (call/cc (lambda (continue) 1105 | (parameterize ((exception-handler-continuation continue)) 1106 | (raise obj))))) 1107 | 1108 | (define-record-type error-object 1109 | (make-error-object message irritants) 1110 | error-object? 1111 | (message error-object-message) 1112 | (irritants error-object-irritants)) 1113 | 1114 | (define (error message . obj) 1115 | (raise (make-error-object message obj))) 1116 | 1117 | ;; 6.12. Environments and evaluation 1118 | 1119 | (define (environment . list) 1120 | (interaction-environment)) 1121 | 1122 | ;; 6.13. Input and output 1123 | 1124 | ;; 6.13.1. Ports 1125 | 1126 | (define (call-with-input-file string proc) 1127 | (call-with-port (open-input-file string) proc)) 1128 | 1129 | (define (call-with-output-file string proc) 1130 | (call-with-port (open-output-file string) proc)) 1131 | 1132 | (define (port? obj) 1133 | (or (input-port? obj) (output-port? obj))) 1134 | 1135 | (define textual-port? port?) 1136 | (define binary-port? port?) 1137 | 1138 | (define input-port-open? input-port?) 1139 | (define output-port-open? output-port?) 1140 | 1141 | (define current-input-port (make-parameter (current-input-port))) 1142 | (define current-output-port (make-parameter (current-output-port))) 1143 | (define current-error-port (make-parameter (current-error-port))) 1144 | 1145 | (define (with-input-from-file string thunk) 1146 | (let ((in (open-input-file string))) 1147 | (parameterize ((current-input-port in)) 1148 | (dynamic-wind 1149 | (lambda ()) 1150 | thunk 1151 | (lambda () 1152 | (close-input-port in)))))) 1153 | 1154 | (define (with-output-to-file string thunk) 1155 | (let ((out (open-output-file string))) 1156 | (parameterize ((current-output-port out)) 1157 | (dynamic-wind 1158 | (lambda ()) 1159 | thunk 1160 | (lambda () 1161 | (close-output-port out)))))) 1162 | 1163 | (define open-binary-input-file open-input-file) 1164 | (define open-binary-output-file open-output-file) 1165 | 1166 | (define close-input-port close-port) 1167 | (define close-output-port close-port) 1168 | 1169 | ;;; 6.13.2. Input 1170 | 1171 | (define (eof-object? obj) 1172 | (eqv? (eof-object) obj)) 1173 | 1174 | (define read-line 1175 | (case-lambda 1176 | (() 1177 | (read-line (current-input-port))) 1178 | ((port) 1179 | (do ((acc '() (cons char acc)) 1180 | (char (read-char port) (read-char port))) 1181 | ((or (eq? #\newline char) 1182 | (eq? #\return char) 1183 | (eof-object? char)) (list->string (reverse acc))))))) 1184 | 1185 | (define read-string 1186 | (case-lambda 1187 | ((k) 1188 | (read-string k (current-input-port))) 1189 | ((k port) 1190 | (utf8->string (read-bytevector k port) 0 k)))) 1191 | 1192 | (define read-bytevector 1193 | (case-lambda 1194 | ((k) 1195 | (read-bytevector k (current-input-port))) 1196 | ((k port) 1197 | (let ((bytevector (make-bytevector k 0))) 1198 | (read-bytevector! bytevector port 0 k) 1199 | bytevector)))) 1200 | 1201 | (define read-bytevector! 1202 | (case-lambda 1203 | ((bytevector) 1204 | (read-bytevector! bytevector (current-input-port))) 1205 | ((bytevector port) 1206 | (read-bytevector! bytevector port 0)) 1207 | ((bytevector port start) 1208 | (read-bytevector! bytevector port start (bytevector-length bytevector))) 1209 | ((bytevector port start end) 1210 | (do ((idx start (+ idx 1)) 1211 | (byte (read-u8 port) (read-u8 port))) 1212 | ((or (= idx end) (eof-object? byte)) (if (= idx start) 1213 | (eof-object) 1214 | idx)) 1215 | (bytevector-u8-set! bytevector idx byte))))) 1216 | 1217 | ;;; 6.13.3. Output 1218 | 1219 | (define write-string 1220 | (case-lambda 1221 | ((string) 1222 | (write-string string (current-output-port))) 1223 | ((string port) 1224 | (write-string string port 0)) 1225 | ((string port start) 1226 | (write-string string port start (string-length string))) 1227 | ((string port start end) 1228 | (write-bytevector (string->utf8 string start end) port start end)))) 1229 | 1230 | (define write-bytevector 1231 | (case-lambda 1232 | ((bytevector) 1233 | (write-bytevector bytevector (current-output-port))) 1234 | ((bytevector port) 1235 | (write-bytevector bytevector port 0)) 1236 | ((bytevector port start) 1237 | (write-bytevector bytevector port start (bytevector-length bytevector))) 1238 | ((bytevector port start end) 1239 | (do ((idx start (+ idx 1))) 1240 | ((= idx end) (- end start)) 1241 | (write-u8 (bytevector-u8-ref bytevector idx) port))))) 1242 | 1243 | ;;; 6.14. System interface 1244 | 1245 | (define (get-environment-variable name) 1246 | (cond ((assoc name (get-environment-variables)) => cdr) 1247 | (else #f))) 1248 | 1249 | (define (features) 1250 | '(r7rs exact-closed ieee-float posix unix gnu-linux x86-64 little-endian akeem 1251 | srfi-0 srfi-9 srfi-23 srfi-34 srfi-39 srfi-87 srfi-98)) 1252 | --------------------------------------------------------------------------------