├── .gitignore ├── Gemfile ├── Gemfile.lock ├── LICENSE ├── README.md ├── c_parse.rb ├── garlic ├── garlic-internal.h ├── hashmap.c ├── hashmap.h ├── http-test ├── Makefile └── server.scm ├── logo.png ├── logo.svg ├── recursive ├── .gitignore ├── Makefile ├── README.md ├── ast.scm ├── byte-utils.scm ├── codegen.scm ├── color.scm ├── compiler-error.scm ├── compiler_utils.c ├── elf-exploration │ ├── .gitignore │ ├── Makefile │ ├── README.md │ ├── tiny.s │ ├── write-elf.rb │ └── write.s ├── elf-x86-64-linux-gnu.scm ├── evaluator.scm ├── garlic.scm ├── label-resolution.scm ├── lexer.scm ├── location.scm ├── parser.scm ├── result.scm ├── static-analyzer.scm ├── string-utils.scm ├── test-codegen-unsupported.scm ├── test-numbers.scm ├── test.scm ├── test.scm.result └── tokens.scm ├── run-tests.sh ├── runtime.S ├── runtime.c ├── sdl2-test ├── Makefile ├── bob-marley.jpg └── marley.scm ├── stdlib-includes ├── assoc.scm ├── core.c ├── display-helpers.scm ├── file.c ├── garlic.h ├── html.scm ├── http.c ├── rand.c ├── sdl2.c ├── set.scm ├── stdlib.scm └── string.c └── test ├── aux ├── auxillary-module.scm ├── circ1.scm ├── circ2.scm ├── hexdump.c ├── libc_module.c ├── libc_variadic_module.c ├── many-exports-1.scm └── many-exports-2.scm ├── failure-compile ├── begin-no-statements.scm ├── empty-list-no-quoting.scm ├── let-depending-on-last.scm ├── let-depending-on-later.scm ├── let-list-matching-invalid-dotted-list.scm ├── let-star-depending-on-later.scm ├── multiple-require-star-conflict.scm ├── nested-require.scm ├── non-existant-module-ref.scm ├── private-c-module-method.scm ├── private-module-method.scm ├── renamed-require-using-original-name.scm ├── syntax-invalid-boolean-at-eof.scm ├── syntax-invalid-boolean.scm ├── syntax-invalid-integer.scm ├── syntax-too-many-closing-parens.scm ├── syntax-unclosed-paren.scm ├── syntax-unclosed-string.scm └── undefined-var.scm ├── failure-runtime ├── let-list-matching-too-long.scm └── let-list-matching-too-short.scm ├── rb └── c_parse_spec.rb └── success ├── append-in-place.scm ├── append-in-place.scm.result ├── apply.scm ├── apply.scm.result ├── argv.scm ├── argv.scm.result ├── arithmetic.scm ├── arithmetic.scm.result ├── assoc.scm ├── assoc.scm.result ├── begin.scm ├── begin.scm.result ├── boolean-operator.scm ├── boolean-operator.scm.result ├── c-module-variadic.scm ├── c-module-variadic.scm.result ├── c-module.scm ├── c-module.scm.result ├── callback.scm ├── callback.scm.result ├── circular-deps.scm ├── circular-deps.scm.result ├── comments.scm ├── comments.scm.result ├── cond-no-else.scm ├── cond-no-else.scm.result ├── cond-only-else.scm ├── cond-only-else.scm.result ├── cond.scm ├── cond.scm.result ├── core-namespace.scm ├── core-namespace.scm.result ├── create-elf-file.scm ├── create-elf-file.scm.result ├── equal_sign.scm ├── equal_sign.scm.result ├── file-lib.scm ├── file-lib.scm.result ├── float.scm ├── float.scm.result ├── full.scm ├── full.scm.result ├── function-def.scm ├── function-def.scm.result ├── hex.scm ├── hex.scm.result ├── if-else.scm ├── if-else.scm.result ├── label-resolution.scm ├── label-resolution.scm.result ├── let-list-matching.scm ├── let-list-matching.scm.result ├── let-star.scm ├── let-star.scm.result ├── let.scm ├── let.scm.result ├── letrec.scm ├── letrec.scm.result ├── list.scm ├── list.scm.result ├── numerical-tower.scm ├── numerical-tower.scm.result ├── recursive-byte-utils.scm ├── recursive-byte-utils.scm.result ├── recursive-string-utils.scm ├── recursive-string-utils.scm.result ├── renamed-require-c.scm ├── renamed-require-c.scm.result ├── renamed-require.scm ├── renamed-require.scm.result ├── require-relative.scm ├── require-relative.scm.result ├── require-star-c.scm ├── require-star-c.scm.result ├── require-star-using-original-name.scm ├── require-star-using-original-name.scm.result ├── require-star.scm ├── require-star.scm.result ├── require-std.scm ├── require-std.scm.result ├── stdlib-overwrite.scm ├── stdlib-overwrite.scm.result ├── string-lib.scm ├── string-lib.scm.result ├── sub.scm ├── sub.scm.result ├── type-checks.scm ├── type-checks.scm.result ├── variadic.scm └── variadic.scm.result /.gitignore: -------------------------------------------------------------------------------- 1 | main 2 | main.dSYM/ 3 | build/ 4 | -------------------------------------------------------------------------------- /Gemfile: -------------------------------------------------------------------------------- 1 | source 'https://rubygems.org' 2 | 3 | gem 'parslet', '~> 1.5' 4 | gem 'docopt', '~> 0.5' 5 | gem 'rspec', '~> 3.2.x' 6 | -------------------------------------------------------------------------------- /Gemfile.lock: -------------------------------------------------------------------------------- 1 | GEM 2 | remote: https://rubygems.org/ 3 | specs: 4 | blankslate (2.1.2.4) 5 | diff-lcs (1.2.5) 6 | docopt (0.5.0) 7 | parslet (1.5.0) 8 | blankslate (~> 2.0) 9 | rspec (3.2.0) 10 | rspec-core (~> 3.2.0) 11 | rspec-expectations (~> 3.2.0) 12 | rspec-mocks (~> 3.2.0) 13 | rspec-core (3.2.3) 14 | rspec-support (~> 3.2.0) 15 | rspec-expectations (3.2.1) 16 | diff-lcs (>= 1.2.0, < 2.0) 17 | rspec-support (~> 3.2.0) 18 | rspec-mocks (3.2.1) 19 | diff-lcs (>= 1.2.0, < 2.0) 20 | rspec-support (~> 3.2.0) 21 | rspec-support (3.2.2) 22 | 23 | PLATFORMS 24 | ruby 25 | 26 | DEPENDENCIES 27 | docopt (~> 0.5) 28 | parslet (~> 1.5) 29 | rspec (~> 3.2.x) 30 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2019 Avik Das 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this 7 | list of conditions and the following disclaimer. 8 | 9 | 2. Redistributions in binary form must reproduce the above copyright notice, 10 | this list of conditions and the following disclaimer in the documentation 11 | and/or other materials provided with the distribution. 12 | 13 | 3. Neither the name of the copyright holder nor the names of its contributors 14 | may be used to endorse or promote products derived from this software 15 | without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 19 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /c_parse.rb: -------------------------------------------------------------------------------- 1 | require 'parslet' 2 | 3 | module CParser 4 | class CExport < Struct.new(:name, :arity, :is_vararg) 5 | def to_s 6 | "{\"#{name}\", #{arity}, #{is_vararg ? 1 : 0}}" 7 | end 8 | end 9 | 10 | class CExports < Parslet::Parser 11 | rule(:space) { match('\s').repeat(1) } 12 | rule(:space?) { space.maybe } 13 | 14 | rule(:filler) { match('.').repeat(1).maybe } 15 | 16 | rule(:id) { 17 | match('[A-Za-z_]') >> 18 | match('[A-Za-z_0-9]').repeat(1).maybe 19 | } 20 | 21 | rule(:number) { 22 | match('[0-9]').repeat(1) 23 | } 24 | 25 | rule(:string) { 26 | str('"') >> 27 | ( 28 | (str('\\') >> any) | 29 | (str('"').absent? >> any) 30 | ).repeat(1).maybe.as(:string) >> 31 | str('"') 32 | } 33 | 34 | rule(:exports) { 35 | space? >> 36 | str('garlic_native_export_t') >> 37 | space >> 38 | id >> 39 | str('[]') >> 40 | space? >> 41 | str('=') >> 42 | space? >> 43 | str('{') >> 44 | space? >> 45 | 46 | ( 47 | str('{') >> 48 | space? >> 49 | 50 | string.as(:fnname) >> 51 | space? >> 52 | str(',') >> 53 | space? >> 54 | id >> 55 | space? >> 56 | str(',') >> 57 | space? >> 58 | number.as(:arity) >> 59 | space? >> 60 | 61 | ( 62 | str(',') >> 63 | space? >> 64 | number.as(:is_vararg) >> 65 | space? 66 | ).maybe >> 67 | 68 | str('}') >> 69 | space? >> 70 | str(',') >> 71 | space? 72 | ).repeat(1).maybe.as(:exports) >> 73 | 74 | str('0') >> 75 | space? >> 76 | 77 | str('}') >> 78 | space? >> 79 | str(';') >> 80 | filler 81 | } 82 | 83 | root(:exports) 84 | end 85 | 86 | class CExportsTransform < Parslet::Transform 87 | rule(string: simple(:string)) { string.to_s } 88 | 89 | rule(fnname: simple(:fnname), 90 | arity: simple(:arity)) { 91 | CExport.new(fnname, arity.to_i, false) 92 | } 93 | 94 | rule(fnname: simple(:fnname), 95 | arity: simple(:arity), 96 | is_vararg: simple(:is_vararg)) { 97 | CExport.new(fnname, arity.to_i, is_vararg == "1") 98 | } 99 | end 100 | 101 | def self.parse_c_exports_from_string(module_name, src) 102 | src = src.sub(/.*garlic_native_export_t/m, 'garlic_native_export_t') 103 | tree = CExports.new.parse(src) 104 | transformed = CExportsTransform.new.apply(tree) 105 | transformed[:exports] 106 | end 107 | end 108 | 109 | # vim: ts=2 sw=2 : 110 | -------------------------------------------------------------------------------- /garlic-internal.h: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | /* Given a list of strings, concatenate them all together. */ 4 | garlic_value_t garlic_internal_string_concat(garlic_value_t args); 5 | 6 | /* See documentation in runtime.c */ 7 | garlic_value_t garlic_internal_append_in_place( 8 | garlic_value_t l1, 9 | garlic_value_t l2, 10 | garlic_value_t others); 11 | -------------------------------------------------------------------------------- /hashmap.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Generic hashmap manipulation functions 3 | * 4 | * Originally by Elliot C Back - http://elliottback.com/wp/hashmap-implementation-in-c/ 5 | * 6 | * Modified by Pete Warden to fix a serious performance problem, support strings as keys 7 | * and removed thread synchronization - http://petewarden.typepad.com 8 | */ 9 | #ifndef __HASHMAP_H__ 10 | #define __HASHMAP_H__ 11 | 12 | #define MAP_MISSING -3 /* No such element */ 13 | #define MAP_FULL -2 /* Hashmap is full */ 14 | #define MAP_OMEM -1 /* Out of Memory */ 15 | #define MAP_OK 0 /* OK */ 16 | 17 | /* 18 | * any_t is a pointer. This allows you to put arbitrary structures in 19 | * the hashmap. 20 | */ 21 | typedef void *any_t; 22 | 23 | /* 24 | * PFany is a pointer to a function that can take two any_t arguments 25 | * and return an integer. Returns status code.. 26 | */ 27 | typedef int (*PFany)(any_t, any_t); 28 | 29 | /* 30 | * map_t is a pointer to an internally maintained data structure. 31 | * Clients of this package do not need to know how hashmaps are 32 | * represented. They see and manipulate only map_t's. 33 | */ 34 | typedef any_t map_t; 35 | 36 | /* 37 | * Return an empty hashmap. Returns NULL if empty. 38 | */ 39 | extern map_t hashmap_new(); 40 | 41 | /* 42 | * Iteratively call f with argument (item, data) for 43 | * each element data in the hashmap. The function must 44 | * return a map status code. If it returns anything other 45 | * than MAP_OK the traversal is terminated. f must 46 | * not reenter any hashmap functions, or deadlock may arise. 47 | */ 48 | extern int hashmap_iterate(map_t in, PFany f, any_t item); 49 | 50 | /* 51 | * Add an element to the hashmap. Return MAP_OK or MAP_OMEM. 52 | */ 53 | extern int hashmap_put(map_t in, char* key, any_t value); 54 | 55 | /* 56 | * Get an element from the hashmap. Return MAP_OK or MAP_MISSING. 57 | */ 58 | extern int hashmap_get(map_t in, char* key, any_t *arg); 59 | 60 | /* 61 | * Remove an element from the hashmap. Return MAP_OK or MAP_MISSING. 62 | */ 63 | extern int hashmap_remove(map_t in, char* key); 64 | 65 | /* 66 | * Get any element. Return MAP_OK or MAP_MISSING. 67 | * remove - should the element be removed from the hashmap 68 | */ 69 | extern int hashmap_get_one(map_t in, any_t *arg, int remove); 70 | 71 | /* 72 | * Free the hashmap 73 | */ 74 | extern void hashmap_free(map_t in); 75 | 76 | /* 77 | * Get the current size of a hashmap 78 | */ 79 | extern int hashmap_length(map_t in); 80 | 81 | #endif // __HASHMAP_H__ 82 | -------------------------------------------------------------------------------- /http-test/Makefile: -------------------------------------------------------------------------------- 1 | CFLAGS = -lmicrohttpd 2 | 3 | server: server.scm 4 | ../garlic -o $@ $< -- $(CFLAGS) 5 | 6 | .PHONY: clean 7 | 8 | clean: 9 | rm -rf build server server.dSYM 10 | -------------------------------------------------------------------------------- /http-test/server.scm: -------------------------------------------------------------------------------- 1 | (require http) 2 | (require html) 3 | 4 | (define *port* 9000) 5 | 6 | (define (handle-request) 7 | (display "handling request") 8 | (newline) 9 | (html:html 10 | (html:head "Garlic HTTP Demo") 11 | (html:body 12 | (html:p 13 | "This web page is served by the HTTP server available in the garlic\n" 14 | "distribution. The HTML is generated by a garlic function.") 15 | (html:p 16 | "If you're interested in learning more about garlic, please visit " 17 | (html:a 18 | 'href "http://github.com/avik-das/garlic" 19 | "the garlic Github repository") 20 | ".") 21 | (html:img 22 | 'src "http://i.imgur.com/NFS0WeC.jpg" 23 | 'width "320" 24 | 'height "427") 25 | (html:p "(image courtesy of imgur)"))) ) 26 | 27 | (http:serve *port* handle-request) 28 | -------------------------------------------------------------------------------- /logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/avik-das/garlic/e8d4303418a4b80bc88366a4011d3250bc3a5667/logo.png -------------------------------------------------------------------------------- /recursive/.gitignore: -------------------------------------------------------------------------------- 1 | garlic 2 | garlic.dSYM 3 | -------------------------------------------------------------------------------- /recursive/Makefile: -------------------------------------------------------------------------------- 1 | SOURCES := $(foreach dir,., $(notdir $(wildcard $(dir)/*.scm))) 2 | OUTPUT := garlic 3 | 4 | $(OUTPUT): garlic.scm $(SOURCES) 5 | ../garlic -o $@ $< 6 | 7 | .PHONY: clean 8 | 9 | clean: 10 | rm -rf build $(OUTPUT) $(OUTPUT).dSYM 11 | -------------------------------------------------------------------------------- /recursive/README.md: -------------------------------------------------------------------------------- 1 | Self-hosted implementation 2 | ========================== 3 | 4 | An attempt at re-implementing Garlic in itself. This would make the name of the language **G**arlic's **A** _**R**ecursive_ **L**isp **I**mplementation **C**ompiler. 5 | 6 | Success for this project entails running the full test suite for the current compiler, only using the self-hosted compiler. This includes all the small language features, like numbers, strings, functions, etc., as well as larger ones such as the full module system. 7 | 8 | Quick Start 9 | ----------- 10 | 11 | ```sh 12 | # From inside the "recursive" directory 13 | 14 | # Build the recursive implementation 15 | make 16 | 17 | # Compile a simple "program" that just outputs an integer 18 | ./garlic test-numbers.scm # Writes a file named "main" 19 | chmod +x main 20 | ./main 21 | echo $? # Should print an integer (will depend on latest state of repo) 22 | ``` 23 | 24 | Note that you can change the name of the output executable: 25 | 26 | ```sh 27 | ./garlic -O executable-name test-numbers.scm 28 | ./garlic --output executable-name test-numbers.scm 29 | ``` 30 | 31 | ### Running in interpreted mode 32 | 33 | The code generation is lagging the furthest behind currently, but the lexer/parser supports many constructs already. To test the latter, the recursive implementation can be run in interpreted mode, which supports all the features the lexer/parser do: 34 | 35 | ```sh 36 | # From inside the "recursive" directory 37 | make 38 | 39 | # Interpret a much more full featured program. The intepreter will output 40 | # anything to be displayed on the standard output. Also output it to a file to 41 | # compare against the reference output. 42 | ./garlic --interpret test.scm | tee out.txt 43 | diff out.txt test.scm.result # Ensure the output is correct 44 | ``` 45 | 46 | Why? 47 | ---- 48 | 49 | One of the goals of Garlic has always been "to implement a compiler that is useful for writing programs." A compiler written in Garlic would demonstrate that the language is useful. Indeed, in developing the self-hosted version, I've found many deficiencies in the language and added support for useful features. 50 | 51 | Current Status 52 | -------------- 53 | 54 | The self-hosted implementation is in its early stages. The current version of the implementation is not a compiler, but a meta-circular interpreter. Support for basic s-expressions, including defining values and functions, as well as calling functions is present. This is sufficient for a simple and powerful, but extremely unwieldy, language. 55 | 56 | Some of the major work to be done: 57 | 58 | - Better error messages. Actually, recent changes to the recursive implementation have yielded clearer error messages than even the Ruby implementation, in certain scenarios. However, more work is required, especially for runtime errors. 59 | 60 | - Support more tokens in the lexer: 61 | 62 | - Floats 63 | - Dotted lists 64 | 65 | - Support a wider variety of language constructs 66 | 67 | - `let` bindings 68 | - `begin` 69 | - Variadic functions 70 | - Recursive functions 71 | 72 | - Implement a module system 73 | 74 | - Implement a compiler backend so that native binaries are produced. One of the goals with such a backend is finally adding macro support. 75 | -------------------------------------------------------------------------------- /recursive/ast.scm: -------------------------------------------------------------------------------- 1 | ;; CONSTRUCTORS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | 3 | (define (module statements) 4 | (cons 'garlic-module statements)) 5 | 6 | (define (var loc name) 7 | (list 'var loc name)) 8 | 9 | (define (int loc val) 10 | (list 'int loc val)) 11 | 12 | (define (atom loc val) 13 | (list 'atom loc val)) 14 | 15 | (define (bool loc val) 16 | (list 'bool loc val)) 17 | 18 | (define (str loc val) 19 | (list 'str loc val)) 20 | 21 | (define (quoted-list loc ls) 22 | (list 'list loc ls)) 23 | 24 | (define (definition loc name body) 25 | (list 'definition loc name body)) 26 | 27 | (define (conditional-clause loc condition body-statements) 28 | (list 'cond-clause loc condition body-statements)) 29 | 30 | (define (conditional-else loc body-statements) 31 | (list 'cond-else loc body-statements)) 32 | 33 | (define (conditional loc clauses) 34 | (list 'conditional loc clauses)) 35 | 36 | ; Represents a lambda 37 | (define (function loc args body) 38 | (list 'function loc args body)) 39 | 40 | (define (function-call loc fn args) 41 | (list 'function-call loc fn args)) 42 | 43 | ;; PREDICATES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 44 | 45 | (define (starts-with-symbol? ast symbol) 46 | (and (list? ast) 47 | (symbol? (car ast)) 48 | (= (car ast) symbol))) 49 | 50 | (define (type-checker type) 51 | (lambda (ast) (starts-with-symbol? ast type)) ) 52 | 53 | (define module? (type-checker 'garlic-module)) 54 | (define var? (type-checker 'var)) 55 | (define int? (type-checker 'int)) 56 | (define atom? (type-checker 'atom)) 57 | (define bool? (type-checker 'bool)) 58 | (define str? (type-checker 'str)) 59 | (define quoted-list? (type-checker 'list)) 60 | (define definition? (type-checker 'definition)) 61 | (define conditional? (type-checker 'conditional)) 62 | (define conditional-clause? (type-checker 'cond-clause)) 63 | (define conditional-else? (type-checker 'cond-else)) 64 | (define function? (type-checker 'function)) 65 | (define function-call? (type-checker 'function-call)) 66 | 67 | ;; GETTERS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 68 | ;; Assumes AST nodes are already validated to be of the correct type 69 | 70 | ;; All AST nodes will have the location in a standardized place within its 71 | ;; representation, so the location can be retrieved without knowing the type of 72 | ;; AST node. 73 | (define get-location (compose car cdr)) 74 | 75 | (define module-get-statements cdr) 76 | (define var-get-name (compose car cdr cdr)) 77 | (define int-get-value (compose car cdr cdr)) 78 | (define atom-get-name (compose car cdr cdr)) 79 | (define bool-get-value (compose car cdr cdr)) 80 | (define str-get-value (compose car cdr cdr)) 81 | (define quoted-list-get-list (compose car cdr cdr)) 82 | 83 | (define definition-get-name (compose car cdr cdr)) 84 | (define definition-get-body (compose car cdr cdr cdr)) 85 | 86 | (define conditional-get-clauses (compose car cdr cdr)) 87 | (define conditional-clause-get-condition (compose car cdr cdr)) 88 | (define conditional-clause-get-body-statements (compose car cdr cdr cdr)) 89 | (define conditional-else-get-body-statements (compose car cdr cdr)) 90 | 91 | (define function-get-args (compose car cdr cdr)) 92 | (define function-get-body (compose car cdr cdr cdr)) 93 | 94 | (define function-call-get-function (compose car cdr cdr)) 95 | (define function-call-get-args (compose car cdr cdr cdr)) 96 | 97 | ;; EXPORTS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 98 | 99 | (module-export 100 | ; Constructors 101 | module 102 | var 103 | int 104 | atom 105 | bool 106 | str 107 | quoted-list 108 | definition 109 | conditional-clause 110 | conditional-else 111 | conditional 112 | function 113 | function-call 114 | 115 | ; Predicates 116 | module? 117 | var? 118 | int? 119 | atom? 120 | bool? 121 | str? 122 | quoted-list? 123 | definition? 124 | conditional-clause? 125 | conditional-else? 126 | conditional? 127 | function? 128 | function-call? 129 | 130 | ; Getters 131 | get-location 132 | 133 | module-get-statements 134 | var-get-name 135 | int-get-value 136 | atom-get-name 137 | bool-get-value 138 | str-get-value 139 | quoted-list-get-list 140 | definition-get-name 141 | definition-get-body 142 | conditional-get-clauses 143 | conditional-clause-get-condition 144 | conditional-clause-get-body-statements 145 | conditional-else-get-body-statements 146 | function-get-args 147 | function-get-body 148 | function-call-get-function 149 | function-call-get-args) 150 | -------------------------------------------------------------------------------- /recursive/byte-utils.scm: -------------------------------------------------------------------------------- 1 | ;; Convert a signed (negative, positive or zero) integer into its twos 2 | ;; complement unsigned counterpart, given a certain byte-length for the final 3 | ;; result. The result is guaranteed to be non-negative. 4 | ;; 5 | ;; Assumes the given integer is in the correct range for the specified byte 6 | ;; length. For example, for one byte conversions, the input integer must be in 7 | ;; the range [-128, 127]. Note that in the range [128, 255], this conversion can 8 | ;; also be thought of keeping an unsigned integer as unsigned, i.e. no 9 | ;; conversion is performed. Thus, for a specified byte range, this function can 10 | ;; handle both signed and unsigned inputs correctly. 11 | ;; 12 | ;; Examples 13 | ;; 14 | ;; 1 byte: 15 | ;; 0 => 0 (= 0x00) 16 | ;; 1 => 1 (= 0x01) 17 | ;; 127 => 127 (= 0x7f) 18 | ;; 255 => 255 (= 0xff) <-- input is unsigned, kept as unsigned 19 | ;; -1 => 255 (= 0xff) 20 | ;; -128 => 128 (= 0x80) 21 | ;; 22 | ;; 4 bytes: 23 | ;; 0 => 0 (= 0x00000000) 24 | ;; 1 => 1 (= 0x00000001) 25 | ;; -1 => 2147483648 (= 0xffffffff) 26 | ;; 27 | ;; @param sint - the signed integer to convert 28 | ;; @param num-bytes - the number of bytes in the two's complement 29 | ;; representation. Relevant especially for negative inputs. 30 | ;; @result a non-negative integer corresponding to the two's-complement 31 | ;; representation of the given signed integer 32 | (define (signed-int->twos-complement sint num-bytes) 33 | (define (compute-base) 34 | (define (helper base remaining-num-bytes) 35 | (if (= remaining-num-bytes 0) 36 | base 37 | (helper 38 | (bitwise-ior (arithmetic-shift base 8) 0xff) 39 | (- remaining-num-bytes 1)) )) 40 | 41 | (helper 0 num-bytes)) 42 | 43 | (if (or (= sint 0) 44 | (> sint 0)) 45 | ; Already positive 46 | sint 47 | 48 | ; Negative -> convert to two's complement 49 | (let ((base (compute-base))) 50 | (- base (- (- sint) 1))) )) 51 | 52 | ;; Convert the given signed integer into a list of bytes representing the 53 | ;; integer in little-endian (least-significant byte first) order. Any negative 54 | ;; integers are first converted to two's complement. 55 | ;; 56 | ;; Assumes the given integer fits into either the signed or unsigned range for 57 | ;; the specified number of bytes. 58 | ;; 59 | ;; Examples (4 bytes): 60 | ;; 61 | ;; 0x12345678 -> 0x78 0x56 0x34 0x12 62 | ;; 0x00005678 -> 0x78 0x56 0x00 0x00 63 | ;; -0x00005678 -> 0x88 0xa9 0xff 0xff 64 | ;; 65 | ;; @param int - the signed integer to convert 66 | ;; @param pad-to-total-bytes - the total number of bytes in the output list 67 | ;; @return a list of bytes corresponding to the little-endian two's complement 68 | ;; representation of `int`. Guaranteed to have `pad-to-total-bytes` 69 | ;; elements. 70 | (define (int->little-endian int pad-to-total-bytes) 71 | (define (convert-remaining-bytes reduced-int num-bytes-left) 72 | (if (= num-bytes-left 0) 73 | '() 74 | (cons 75 | (bitwise-and reduced-int 0xff) 76 | (convert-remaining-bytes 77 | (arithmetic-shift reduced-int -8) 78 | (- num-bytes-left 1)) ) )) 79 | 80 | (convert-remaining-bytes 81 | (signed-int->twos-complement int pad-to-total-bytes) 82 | pad-to-total-bytes)) 83 | 84 | (module-export 85 | int->little-endian) 86 | -------------------------------------------------------------------------------- /recursive/color.scm: -------------------------------------------------------------------------------- 1 | ;; TODO: color output utilities 2 | -------------------------------------------------------------------------------- /recursive/compiler-error.scm: -------------------------------------------------------------------------------- 1 | ;; An error that can be produced by any part of the compilation process. Most 2 | ;; notably, the error contains: 3 | ;; 4 | ;; - A user-visible message. 5 | ;; - The location of the error. 6 | ;; 7 | ;; Thus, no matter how source locations are passed around, however errors are 8 | ;; reported, there is one clear way to actually show the error to the user. 9 | 10 | (require string => str) 11 | 12 | ;; CONSTRUCTORS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | 14 | (define (new loc . msg-parts) 15 | (cons loc (apply str:concat msg-parts)) ) 16 | 17 | ;; GETTERS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 | 19 | (define get-location car) 20 | (define get-message cdr) 21 | 22 | ;; EXPORTS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | (module-export 25 | ; Constructors 26 | new 27 | 28 | ; Getters 29 | get-location 30 | get-message) 31 | -------------------------------------------------------------------------------- /recursive/compiler_utils.c: -------------------------------------------------------------------------------- 1 | /** 2 | * A set of utilities for the recursive compiler that are *not* general purpose 3 | * modules useful for the language's standard library. 4 | * 5 | * This sort of defeats the purpose of the recursive compiler, since the goal 6 | * is for the language to be powerful enough to implement a compiler for itself 7 | * without resorting to C. For that reason, this module should be as minimal as 8 | * possible, with the goal to replace them with in-language implementations in 9 | * the future. 10 | * 11 | * Each function should be documented with its rationale for being implemented 12 | * in this module. 13 | */ 14 | 15 | #include 16 | 17 | #include 18 | #include 19 | 20 | /** 21 | * RATIONALE: this should actually end up in a "path" module. However, I'd 22 | * rather design a proper "path" module, not just a one-off function that won't 23 | * fit into a more cohesive design. 24 | */ 25 | garlic_value_t filename_from_path(garlic_value_t path) { 26 | const char *pathstr = garlic_unwrap_string(path); 27 | if (!pathstr) { 28 | error_and_exit( 29 | "ERROR - filename_from_path: " 30 | "path is not a string\n"); 31 | } 32 | 33 | int len = strlen(pathstr); 34 | if (len == 0) { return garlic_empty_string; } 35 | 36 | int i = len - 1; // Go to the end 37 | while (i > 0 && pathstr[i] != '/') { i--; } // Backtrack to the last '/' 38 | if (pathstr[i] == '/') { i++; } // Go past that '/' 39 | 40 | int result_len = len - i; 41 | char *result = (char *) malloc(sizeof(char) * (result_len + 1)); 42 | if (!result) { 43 | error_and_exit( 44 | "ERROR - filename-from-path: " 45 | "could not allocate memory for result\n"); 46 | } 47 | 48 | strncpy(result, pathstr + i, result_len); 49 | result[result_len] = 0; 50 | return garlic_wrap_string(result); 51 | } 52 | 53 | /** 54 | * RATIONALE: this could be written in garlic, but it would depend heavily on 55 | * string manipulation, which is implemented inefficiently via the not 56 | * well-designed "string" C module. This would be better to reimplement once 57 | * string manipulation is thought out properly. 58 | */ 59 | garlic_value_t line_from_file_contents( 60 | garlic_value_t contents, 61 | garlic_value_t lineno) { 62 | const char *contents_str = garlic_unwrap_string(contents); 63 | if (!contents_str) { 64 | error_and_exit( 65 | "ERROR - line-from-file-contents: contents is not a string\n"); 66 | } 67 | 68 | int64_t lineno_int = garlicval_to_int(lineno); 69 | 70 | int i = 0; 71 | int curr_line = 1; 72 | int line_start = 0; 73 | 74 | // Find start of desired line 75 | while (contents_str[i] && curr_line < lineno_int) { 76 | // TODO - support "\r\n" 77 | if (contents_str[i] == '\n') { 78 | curr_line++; 79 | line_start = i + 1; 80 | } 81 | 82 | i++; 83 | } 84 | 85 | // Find end of that line 86 | while (contents_str[i] && contents_str[i] != '\n') { i++; } 87 | 88 | int result_len = i - line_start; 89 | char *result = (char *) malloc(sizeof(char) * (result_len + 1)); 90 | if (!result) { 91 | error_and_exit( 92 | "ERROR - filename-from-path: " 93 | "could not allocate memory for result\n"); 94 | } 95 | 96 | strncpy(result, contents_str + line_start, result_len); 97 | result[result_len] = 0; 98 | return garlic_wrap_string(result); 99 | } 100 | 101 | garlic_native_export_t compiler_utils_exports[] = { 102 | {"filename-from-path", filename_from_path, 1}, 103 | {"line-from-file-contents", line_from_file_contents, 2}, 104 | 0 105 | }; 106 | -------------------------------------------------------------------------------- /recursive/elf-exploration/.gitignore: -------------------------------------------------------------------------------- 1 | # Compiled or assembled programs 2 | /tiny 3 | /write 4 | 5 | # Programs written "by hand" 6 | /from-scratch 7 | /from-scratch-write 8 | -------------------------------------------------------------------------------- /recursive/elf-exploration/Makefile: -------------------------------------------------------------------------------- 1 | %: %.s 2 | # Don't generate a GNU build-id section 3 | $(CC) -nostdlib -static $< -o $@ -Wl,--build-id=none 4 | strip $@ 5 | 6 | from-scratch: write-elf.rb 7 | ./$< 8 | chmod +x ./$@ 9 | 10 | .PHONY: clean 11 | clean: 12 | rm -f tiny 13 | rm -f from-scratch 14 | rm -f from-scratch-write 15 | -------------------------------------------------------------------------------- /recursive/elf-exploration/README.md: -------------------------------------------------------------------------------- 1 | ELF binary explorations 2 | ======================= 3 | 4 | This folder contains some exploratory programs and explanations for understanding the ELF binary format. Long-term, this content will end up in a few places: 5 | 6 | - Blog content or more permanent documentation. For now, I'll only document what I absolutely need to understand the format, and that too in an ad-hoc manner. 7 | 8 | - Actual code generation by the recursive compiler. 9 | 10 | Usage 11 | ----- 12 | 13 | ### Make a small ELF binary using a real compiler 14 | 15 | ```sh 16 | # Make the binary by invoking a real compiler 17 | make tiny 18 | 19 | # Ensure the binary runs correctly 20 | ./tiny 21 | echo $? # should show "42" 22 | 23 | # Explore the contents of the binary 24 | readelf -a tiny 25 | ``` 26 | 27 | As a reference, it's good to generate a real-world binary to compare against. While it's not easy to build a truly minimal binary using a real compiler, it's still useful to see how far we can take it. The idea is that this binary is guaranteed to work on the current machine. 28 | 29 | Programs available as reference (all buildable using `make `): 30 | 31 | * `tiny` - exit with status code 42 32 | * `write` - print `"Hello, world!\n"` to standard out. Exercises the presence of a `.data` section. 33 | 34 | ### Make a minimal ELF binary "by hand" 35 | 36 | ```sh 37 | # Make the binary by running the script. Make sure you have Ruby installed 38 | ./write-elf.rb 39 | 40 | # Ensure the binary runs correctly 41 | chmod +x from-scratch 42 | ./from-scratch 43 | echo $? # should show "42" 44 | 45 | # Explore the contents of the binary 46 | readelf -a from-scratch 47 | ``` 48 | 49 | Generate a static binary from scratch, by writing out individual bytes to a file. This is the one that shows how to actually generate binaries, instead of outsourcing that work to a production compiler. 50 | 51 | Programs available as reference (all binaries generated by running `./write-elf.rb`): 52 | 53 | * `from-scratch` - exit with status code 42. As minimal as it gets. 54 | * `from-scratch-write` - print `"Hello, world!\n"` to standard out. Exercises the presence of a `.data` section. 55 | -------------------------------------------------------------------------------- /recursive/elf-exploration/tiny.s: -------------------------------------------------------------------------------- 1 | # Define _start directly to avoid needing a compiler to do extra work before 2 | # calling into our program. 3 | .global _start 4 | .text 5 | _start: 6 | mov $60, %rax # Prepare to call exit(2) system call 7 | mov $42, %edi # Return value is 42, just for fun 8 | syscall # Perform the call 9 | -------------------------------------------------------------------------------- /recursive/elf-exploration/write.s: -------------------------------------------------------------------------------- 1 | # Define _start directly to avoid needing a compiler to do extra work before 2 | # calling into our program. 3 | .global _start 4 | .text 5 | _start: 6 | mov $1, %eax # Prepare to call write(2) system call 7 | mov $1, %edi # Write to stdout (fd = 1) 8 | mov $msg, %esi # Write `msg` 9 | mov $14, %edx # Write 14 bytes 10 | syscall # Perform the call 11 | 12 | mov $60, %eax # Prepare to call exit(2) system call 13 | mov $0, %edi # Return 0 as the status code 14 | syscall # Perform the call 15 | 16 | .data 17 | msg: 18 | .asciz "Hello, world!\n" 19 | -------------------------------------------------------------------------------- /recursive/evaluator.scm: -------------------------------------------------------------------------------- 1 | ;; An implementation of an interpreter for an AST with the interfaces provided 2 | ;; by the "ast" module. This AST is assumed to have been produced from some 3 | ;; input source code, but the details of that are irrelevant. The evaluator 4 | ;; simply executes the code represented by the AST. 5 | 6 | (require string => str) 7 | 8 | (require "ast") 9 | 10 | ;; FRAME ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | 12 | (define (make-frame parent symbols) 13 | (cons parent symbols)) 14 | 15 | (define frame-parent car) 16 | (define frame-symbols cdr) 17 | 18 | (define root-frame 19 | (make-frame '() 20 | (list (cons "+" +) 21 | (cons "-" -) 22 | (cons "*" *) 23 | (cons "=" =) 24 | (cons "cons" cons) 25 | (cons "car" car) 26 | (cons "cdr" cdr) 27 | (cons "null?" null?) 28 | (cons "display" display) 29 | (cons "newline" newline))) ) 30 | 31 | (define (find-in-frame frame symbol) 32 | (define (find-in-list ls) 33 | (find 34 | (lambda (entry) (str:string=? (car entry) symbol)) 35 | ls)) 36 | 37 | (if (null? frame) 38 | (error-and-exit "Not found in frame: " symbol) 39 | (let* ((parent (frame-parent frame)) 40 | (symbols (frame-symbols frame)) 41 | (entry (find-in-list symbols))) 42 | (if entry 43 | (cdr entry) 44 | (find-in-frame parent symbol)) )) ) 45 | 46 | (define (add-to-frame frame symbol value) 47 | (let* ((parent (frame-parent frame)) 48 | (symbols (frame-symbols frame)) 49 | (entry (cons symbol value)) 50 | (new-symbols (cons entry symbols))) 51 | (make-frame parent new-symbols) )) 52 | 53 | ;; LAMBDA DATA STRUCTURE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 54 | 55 | (define (create-lambda parent-frame args body) 56 | (list 'lambda parent-frame args body)) 57 | 58 | (define (is-lambda? fn) 59 | (and (list? fn) 60 | (symbol? (car fn)) 61 | (= (car fn) 'lambda))) 62 | 63 | (define lambda-get-parent-frame (compose car cdr)) 64 | (define lambda-get-args (compose car cdr cdr)) 65 | (define lambda-get-body (compose car cdr cdr cdr)) 66 | 67 | ;; EVALUATION ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 68 | 69 | (define (eval-call-function call frame) 70 | (let* ((fn (recursive-eval (ast:function-call-get-function call) frame)) 71 | (args 72 | (map (recursive-eval-with-frame frame) 73 | (ast:function-call-get-args call))) ) 74 | (if (is-lambda? fn) 75 | (eval-call-lambda fn args) 76 | (apply fn args) ))) 77 | 78 | (define (eval-call-lambda fn args) 79 | (define (add-args-to-frame names args frame) 80 | (if (null? names) 81 | frame 82 | (add-args-to-frame 83 | (cdr names) 84 | (cdr args) 85 | (add-to-frame frame (car names) (car args))) )) 86 | 87 | (let* ((parent-frame (lambda-get-parent-frame fn)) 88 | (empty-frame (make-frame parent-frame '())) 89 | (frame-with-args 90 | (add-args-to-frame (lambda-get-args fn) args empty-frame)) 91 | (body (lambda-get-body fn))) 92 | (eval-statement-list body frame-with-args) )) 93 | 94 | (define (eval-conditional conditional frame) 95 | (define (eval-clause-or-next clause rest) 96 | (let* ((condition (ast:conditional-clause-get-condition clause)) 97 | (condition-passed? (recursive-eval condition frame))) 98 | (if condition-passed? 99 | (eval-statement-list 100 | (ast:conditional-clause-get-body-statements clause) 101 | frame) 102 | (eval-rest rest)) )) 103 | 104 | (define (eval-else else-clause) 105 | (eval-statement-list 106 | (ast:conditional-else-get-body-statements else-clause) 107 | frame)) 108 | 109 | (define (eval-rest clauses) 110 | (if (null? clauses) 111 | '() 112 | (let (((clause . rest) clauses)) 113 | (cond 114 | ((ast:conditional-clause? clause) 115 | (eval-clause-or-next clause rest)) 116 | ((ast:conditional-else? clause) 117 | (eval-else clause)) 118 | (else 119 | (display "\033[1;31m" clause "\033[0m") (newline) 120 | (error-and-exit "Invalid expression inside conditional ^")) )) )) 121 | 122 | (eval-rest (ast:conditional-get-clauses conditional))) 123 | 124 | (define (recursive-eval tree frame) 125 | (cond ((ast:var? tree) (find-in-frame frame (ast:var-get-name tree))) 126 | ((ast:int? tree) (ast:int-get-value tree)) 127 | ((ast:bool? tree) (ast:bool-get-value tree)) 128 | ((ast:str? tree) (ast:str-get-value tree)) 129 | ; For now, just treat an atom like a string, i.e. don't share the value 130 | ; across multiple usages. 131 | ((ast:atom? tree) (ast:atom-get-name tree)) 132 | ((ast:quoted-list? tree) 133 | (map 134 | (lambda (subtree) (recursive-eval subtree frame)) 135 | (ast:quoted-list-get-list tree))) 136 | ((ast:conditional? tree) (eval-conditional tree frame)) 137 | ((ast:function? tree) (ast-function-to-lambda tree frame)) 138 | ((ast:function-call? tree) (eval-call-function tree frame)) )) 139 | 140 | (define (recursive-eval-with-frame frame) 141 | (lambda (tree) 142 | (recursive-eval tree frame)) ) 143 | 144 | (define (ast-function-to-lambda fn frame) 145 | (let ((args (ast:function-get-args fn)) 146 | (body (ast:function-get-body fn))) 147 | (create-lambda frame args body) )) 148 | 149 | (define (eval-definitions definitions frame) 150 | (if (null? definitions) 151 | frame 152 | (let* (((first . remaining) definitions) 153 | (symbol (ast:definition-get-name first)) 154 | (value (recursive-eval (ast:definition-get-body first) frame)) 155 | (new-frame (add-to-frame frame symbol value))) 156 | (eval-definitions remaining new-frame)) )) 157 | 158 | (define (eval-statement-list-without-defines statements frame) 159 | (if (null? statements) 160 | '() 161 | (let* (((first . remaining) statements) 162 | (first-result (recursive-eval first frame))) 163 | (if (null? remaining) 164 | first-result 165 | (eval-statement-list-without-defines remaining frame)) ) )) 166 | 167 | (define (eval-statement-list statements frame) 168 | (let* ((definitions (filter ast:definition? statements)) 169 | (non-definitions (reject ast:definition? statements)) 170 | (new-frame (eval-definitions definitions frame))) 171 | (eval-statement-list-without-defines non-definitions new-frame) )) 172 | 173 | (define (eval-module module) 174 | (eval-statement-list 175 | (ast:module-get-statements module) 176 | root-frame)) 177 | 178 | (module-export 179 | eval-module) 180 | -------------------------------------------------------------------------------- /recursive/garlic.scm: -------------------------------------------------------------------------------- 1 | (require string => str) 2 | (require file) 3 | 4 | (require "compiler-error" => err) 5 | (require "location" => loc) 6 | (require "result") 7 | 8 | (require "lexer") 9 | (require "parser") 10 | (require "static-analyzer") 11 | (require "codegen") 12 | (require "elf-x86-64-linux-gnu" => elf) 13 | (require "evaluator") 14 | 15 | (require "compiler_utils" => compiler-utils) 16 | 17 | ;; ARGUMENT PARSING ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 | 19 | (define (parsed-args-intepreted input-filename) 20 | (list 'parsed-args input-filename '() #t)) 21 | 22 | (define (parsed-args-compiled input-filename output-filename) 23 | (list 'parsed-args input-filename output-filename #f)) 24 | 25 | (define parsed-args-get-input-filename (compose car cdr cdr)) 26 | (define parsed-args-get-output-filename (compose car cdr cdr cdr)) 27 | (define parsed-args-get-is-intepreted (compose car cdr cdr cdr cdr)) 28 | 29 | (define (print-usage-and-exit args) 30 | ; The first argument, corresponding to the executable name, is guaranteed to 31 | ; be present 32 | (define name (car args)) 33 | 34 | (display "USAGE:\n") 35 | (newline) 36 | (display " " name " [-O ] \n") 37 | (display " " name " --interpret \n") 38 | (display " " name " (-h|--help)\n") 39 | (newline) 40 | (display "OPTIONS:\n") 41 | (newline) 42 | (display " -O , --output \n") 43 | (display " the output filename of the compiled executable\n") 44 | (display " --interpret run in intepreted mode\n") 45 | (display " -h, --help show this message and exit\n") 46 | (newline) 47 | 48 | (error-and-exit "COMPILATION FAILED")) 49 | 50 | ;; Parse the command line arguments. 51 | ;; 52 | ;; @param args - the unprocessed command line arguments, accessible via *argv* 53 | ;; @return a `result` of either the parsed arguments or an error. The error will 54 | ;; simply be an empty list to indicate failure. 55 | (define (parse-args args) 56 | ; A more scalable approach is to implement an actual tree-based parser, which 57 | ; goes through the different options and branches to different paths. That 58 | ; would allow for options that are, for example, shared across different 59 | ; subcommands. For now, keep it simple by assumpting a few specific 60 | ; combinations of options. 61 | (cond 62 | ; executable --interpret 63 | ((and (= (length args) 3) 64 | (str:string=? (car (cdr args)) "--interpret")) 65 | (result:new-success 66 | (parsed-args-intepreted (car (cdr (cdr args)))))) 67 | 68 | ; executable 69 | ((and (= (length args) 2) 70 | (not (str:string=? (str:at (car (cdr args)) 0) "-"))) 71 | (result:new-success 72 | (parsed-args-compiled (car (cdr args)) "main"))) 73 | 74 | ; executable -O 75 | ; executable --output 76 | ((and (= (length args) 4) 77 | (or (str:string=? (car (cdr args)) "-O") 78 | (str:string=? (car (cdr args)) "--output")) 79 | (not (str:string=? (str:at (car (cdr (cdr args))) 0) "-")) 80 | (not (str:string=? (str:at (car (cdr (cdr (cdr args)))) 0) "-"))) 81 | (result:new-success 82 | (parsed-args-compiled 83 | (car (cdr (cdr (cdr args)))) 84 | (car (cdr (cdr args)))))) 85 | 86 | ; Don't distinguish between explicit "--help" and an error 87 | (else (result:new-error '())) )) 88 | 89 | ;; ERROR DISPLAY ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 90 | 91 | (define (show-errors input errs) 92 | (define (show-repeated-chars n chr) 93 | (if (= n 0) 94 | '() 95 | (begin 96 | (display chr) 97 | (show-repeated-chars (- n 1) chr)) )) 98 | 99 | (define (num-digits-for-positive-int int) 100 | ; Put a limit of 99,999 for the number. This is to avoid needing to 101 | ; implement division and rounding, or other methods of determining the 102 | ; number of digits in a number. 103 | (cond ((> int 9999) 5) 104 | ((> int 999) 4) 105 | ((> int 99) 3) 106 | ((> int 9) 2) 107 | (else 1) )) 108 | 109 | (define (show-single-error err) 110 | (let* ((loc (err:get-location err)) 111 | (line (loc:get-line loc)) 112 | (column (loc:get-column loc)) 113 | 114 | (msg (err:get-message err)) 115 | 116 | (num-chars-in-lineno (num-digits-for-positive-int line))) 117 | (display 118 | " " 119 | "ERROR: " 120 | msg 121 | " (" 122 | (compiler-utils:filename-from-path (loc:get-filename loc)) 123 | ":" 124 | line 125 | ":" 126 | column 127 | ")") 128 | 129 | (newline) 130 | (newline) 131 | 132 | (display 133 | " " 134 | line 135 | "| " 136 | (compiler-utils:line-from-file-contents input line)) 137 | 138 | (newline) 139 | 140 | (display " ") 141 | (show-repeated-chars num-chars-in-lineno " ") 142 | (display " ") 143 | (show-repeated-chars (- column 1) "-") 144 | (display "^") 145 | 146 | (newline))) 147 | 148 | (define (show-remaining-errors errs) 149 | (if (null? errs) 150 | '() 151 | (begin 152 | (newline) 153 | (show-single-error (car errs)) 154 | (show-remaining-errors (cdr errs))) )) 155 | 156 | (let ((num-errors (length errs))) 157 | (display 158 | "Compilation failed (" 159 | num-errors 160 | " " 161 | (if (> num-errors 1) "errors" "error") 162 | ")") 163 | (newline)) 164 | 165 | (show-remaining-errors errs)) 166 | 167 | ;; MAIN LOGIC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 168 | 169 | (define (process-input parsed-args input) 170 | (result:pipeline-successes 171 | (result:new-success input) 172 | (lambda (input) 173 | (lexer:lex (parsed-args-get-input-filename parsed-args) input)) 174 | (lambda (lexed) (parser:parse lexed)) 175 | (lambda (module) (static-analyzer:analyze-module module)) 176 | (lambda (module) 177 | (if (parsed-args-get-is-intepreted parsed-args) 178 | ; Intepret - assume success as long as the evaluator returns 179 | (begin 180 | (evaluator:eval-module module) 181 | (result:new-success '())) 182 | 183 | ; Compile 184 | (codegen:write-executable-elf-from-module 185 | (parsed-args-get-output-filename parsed-args) 186 | module))) )) 187 | 188 | (define parsed-args (parse-args *argv*)) 189 | (if (result:is-error? parsed-args) 190 | (print-usage-and-exit *argv*) 191 | 192 | (let* ((input (file:read-text (parsed-args-get-input-filename parsed-args))) 193 | (final-result (process-input parsed-args input))) 194 | (if (result:is-error? final-result) 195 | (begin 196 | (show-errors input (result:get-errors final-result)) 197 | (newline) 198 | (error-and-exit "COMPILATION FAILED")) 199 | '() ) )) ; Otherwise: continue 200 | -------------------------------------------------------------------------------- /recursive/label-resolution.scm: -------------------------------------------------------------------------------- 1 | (require assoc) 2 | 3 | (require "byte-utils") 4 | 5 | ;; UTILITIES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | 7 | ; Consider moving this to a common location 8 | (define (repeat-value val times) 9 | (define (helper so-far times-left) 10 | (if (= times-left 0) 11 | so-far 12 | (helper (cons val so-far) (- times-left 1)) )) 13 | 14 | (helper '() times)) 15 | 16 | ;; DATA STRUCTURES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 17 | 18 | (define (label-def name) (list 'label-def name)) 19 | (define label-def-get-name (compose car cdr)) 20 | 21 | (define (label-ref generator labels) (list 'label-ref generator labels)) 22 | (define (label-ref->initial-attempt ref) 23 | (let (((tag generator labels) ref)) 24 | (label-ref-attempt 25 | generator 26 | labels 27 | (apply generator (repeat-value 0 (length labels)))) )) 28 | 29 | (define (bytes bs) (list 'bytes bs)) 30 | (define bytes-get-bytes (compose car cdr)) 31 | 32 | (define (label-ref-attempt generator labels bytes) 33 | (list 'label-ref-attempt generator labels bytes)) 34 | (define label-ref-attempt-get-labels (compose car cdr cdr)) 35 | (define label-ref-attempt-get-bytes (compose car cdr cdr cdr)) 36 | (define (label-ref-attempt->next-attempt ref deltas) 37 | (let (((tag generator labels . rest) ref)) 38 | (label-ref-attempt 39 | generator 40 | labels 41 | (apply generator deltas)) )) 42 | 43 | (define (starts-with-symbol? ast symbol) 44 | (and (list? ast) 45 | (symbol? (car ast)) 46 | (= (car ast) symbol))) 47 | 48 | (define (type-checker type) 49 | (lambda (ast) (starts-with-symbol? ast type)) ) 50 | 51 | (define label-def? (type-checker 'label-def)) 52 | (define label-ref? (type-checker 'label-ref)) 53 | (define label-ref-attempt? (type-checker 'label-ref-attempt)) 54 | (define bytes? (type-checker 'bytes)) 55 | 56 | (define (instruction-get-size inst) 57 | (cond 58 | ((label-def? inst) 0) 59 | ((label-ref-attempt? inst) (length (label-ref-attempt-get-bytes inst))) 60 | ((bytes? inst) (length (bytes-get-bytes inst))) 61 | (else (error-and-exit "Unknown instruction: " inst)) )) 62 | 63 | ;; MAIN LOGIC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 64 | 65 | (define (instructions-to-initial-attempts insts) 66 | (define (to-initial-attempt inst) 67 | (cond 68 | ((label-def? inst) inst) 69 | ((bytes? inst) inst) 70 | ((label-ref? inst) (label-ref->initial-attempt inst)) 71 | (else (error-and-exit "Unknown instruction: " inst)) )) 72 | 73 | (map to-initial-attempt insts)) 74 | 75 | (define (compute-label-addrs insts) 76 | (define (state-new addrs curr-addr) (list addrs curr-addr)) 77 | (define (initial-state) (state-new (assoc:empty) 0)) 78 | 79 | (define state-get-addrs car) 80 | 81 | (define (reducer state inst) 82 | (let (((addrs curr-addr) state)) 83 | (if (label-def? inst) 84 | (let ((label (label-def-get-name inst))) 85 | (if (assoc:has-key? addrs label) 86 | (error-and-exit "Duplicate label: " label) 87 | (state-new (assoc:add addrs label curr-addr) curr-addr))) 88 | 89 | (state-new addrs (+ curr-addr (instruction-get-size inst))) ))) 90 | 91 | (state-get-addrs (reduce reducer (initial-state) insts))) 92 | 93 | 94 | (define (iteration-state-new addr has-changed processed-insts) 95 | (list addr has-changed processed-insts)) 96 | (define (initial-iteration-state) (iteration-state-new 0 #f '())) 97 | 98 | (define iteration-state-get-curr-addr car) 99 | (define iteration-state-get-has-changed (compose car cdr)) 100 | (define iteration-state-get-instructions (compose car cdr cdr)) 101 | 102 | (define (attempt-once insts) 103 | (define (list=? l1 l2) 104 | (cond 105 | ((and (null? l1) (null? l2)) #t) 106 | ((null? l1) #f) 107 | ((null? l2) #f) 108 | (else 109 | (and (= (car l1) (car l2)) 110 | (list=? (cdr l1) (cdr l2)))) )) 111 | 112 | (define (iteration-state-evolve-with-attempt state inst prev-inst) 113 | (let (((addr has-changed processed-insts) state)) 114 | (iteration-state-new 115 | (+ addr (instruction-get-size inst)) 116 | (or has-changed 117 | (not (list=? (label-ref-attempt-get-bytes prev-inst) 118 | (label-ref-attempt-get-bytes inst)))) 119 | (append processed-insts (list inst))) )) 120 | 121 | (define (iteration-state-evolve-static state inst) 122 | (let (((addr has-changed processed-insts) state)) 123 | (iteration-state-new 124 | (+ addr (instruction-get-size inst)) 125 | has-changed 126 | (append processed-insts (list inst))) )) 127 | 128 | (define (process-instruction label-addrs state inst) 129 | (define (label-ref-attempt-deltas curr-addr inst) 130 | (define (compute-delta curr-addr label) 131 | (- (assoc:get label-addrs label) 132 | (+ curr-addr (instruction-get-size inst))) ) 133 | 134 | (map 135 | (lambda (label) (compute-delta curr-addr label)) 136 | (label-ref-attempt-get-labels inst)) ) 137 | 138 | (cond 139 | ((label-def? inst) (iteration-state-evolve-static state inst)) 140 | ((bytes? inst) (iteration-state-evolve-static state inst)) 141 | 142 | ((label-ref-attempt? inst) 143 | (iteration-state-evolve-with-attempt 144 | state 145 | (label-ref-attempt->next-attempt 146 | inst 147 | (label-ref-attempt-deltas 148 | (iteration-state-get-curr-addr state) inst)) 149 | inst)) )) 150 | 151 | (let ((label-addrs (compute-label-addrs insts))) 152 | (reduce 153 | (lambda (state inst) (process-instruction label-addrs state inst)) 154 | (initial-iteration-state) 155 | insts) )) 156 | 157 | (define (iterate-until-resolved insts max-iterations) 158 | (define (iterate insts num-iterations) 159 | (if (= num-iterations 0) 160 | insts 161 | 162 | (let* ((new-state (attempt-once insts)) 163 | (has-changed (iteration-state-get-has-changed new-state)) 164 | (new-insts (iteration-state-get-instructions new-state))) 165 | (if has-changed 166 | (iterate new-insts (- num-iterations 1)) 167 | new-insts) ))) 168 | 169 | (iterate insts max-iterations)) 170 | 171 | (define (instructions->bytes insts) 172 | (define (inst->bytes inst) 173 | (cond 174 | ((label-def? inst) '()) 175 | ((bytes? inst) (bytes-get-bytes inst)) 176 | ((label-ref-attempt? inst) (label-ref-attempt-get-bytes inst)) 177 | (else (error-and-exit "Unknown instruction: " inst)) )) 178 | 179 | ; TODO: should actually flatten the list, but right now, I'm keeping the bytes 180 | ; in chunks for easier printing 181 | (reduce 182 | append 183 | '() 184 | (map inst->bytes insts)) ) 185 | 186 | ;; (list 187 | ;; (bytes '(0x01 0x02 0x03 0x03)) 188 | ;; (label-ref (list 'label-else) ...) ; ---+ 189 | ;; 0x04 0x05 0x06 0x07 ; | 190 | ;; (label-ref (list 'label-end) ...) ; ---|--+ 191 | ;; (label-def 'label-else) ; <--+ | 192 | ;; (bytes '(0x08 0x09 0x0a 0x0b)) ; | 193 | ;; (label-def 'label-end) ; <-----+ 194 | ;; 195 | (define (resolve-local-labels insts) 196 | ; 1. Convert instructions to attempts 197 | ; 2. Perform 10 attempts, breaking as soon as stable 198 | ; 1. Compute label addresses 199 | ; 2. Generate attempts based on addresses 200 | ; 3. Convert attempts to bytes 201 | 202 | (let* ((initial-attempt (instructions-to-initial-attempts insts)) 203 | (resolved (iterate-until-resolved initial-attempt 10)) 204 | (bytes (instructions->bytes resolved))) 205 | bytes)) 206 | 207 | (module-export 208 | label-ref 209 | label-def 210 | bytes 211 | 212 | resolve-local-labels) 213 | -------------------------------------------------------------------------------- /recursive/location.scm: -------------------------------------------------------------------------------- 1 | ;; A location of a single character within a source file. Used to track what 2 | ;; part of the source is being processed currently, primarily useful for 3 | ;; reporting errors. 4 | 5 | ;; CONSTRUCTORS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | 7 | ;; Private. Always start with the "start" constructor, then use the 8 | ;; transformation functions to create new locations relative the starting 9 | ;; location. 10 | (define (new filename line column) 11 | (list filename line column)) 12 | 13 | (define (start filename) 14 | (new filename 1 1)) 15 | 16 | ;; GETTERS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 17 | 18 | (define get-filename car) 19 | (define get-line (compose car cdr)) 20 | (define get-column (compose car cdr cdr)) 21 | 22 | ;; TRANSFORMATIONS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | (define (next-column loc) 25 | (new 26 | (get-filename loc) 27 | (get-line loc) 28 | (+ (get-column loc) 1)) ) 29 | 30 | (define (next-line loc) 31 | (new 32 | (get-filename loc) 33 | (+ (get-line loc) 1) 34 | 1) ) 35 | 36 | ;; EXPORTS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | 38 | (module-export 39 | ; Constructors 40 | start 41 | 42 | ; Getters 43 | get-filename 44 | get-line 45 | get-column 46 | 47 | ; Transformations 48 | next-column 49 | next-line) 50 | -------------------------------------------------------------------------------- /recursive/parser.scm: -------------------------------------------------------------------------------- 1 | (require string => str) 2 | 3 | (require "ast") 4 | (require "compiler-error" => err) 5 | (require "result") 6 | (require "tokens" => tok) 7 | 8 | ;; PARSE LOGIC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;; Given a list of tokens, construct an abstract syntax tree. 11 | ;; 12 | ;; @param tokens - a flat list of tokens, as produced by the lexer 13 | ;; @return the abstract syntax tree, with the nesting suggested by the tokens 14 | (define (parse tokens) 15 | (result:transform-success 16 | ; TODO - when tree-to-ast is refactored to return a "result", there will be 17 | ; no need to wrap the return value in a new "result" 18 | (lambda (tree) (result:new-success (tree-to-ast tree))) 19 | (toplevel-list-to-tree tokens))) 20 | 21 | ;; TREE STRUCTURE GENERATION ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | ;; 23 | ;; This phase of the parsing simply arranges the tokens into a tree structure, 24 | ;; without actually interpreting any of the tokens (other than the open and 25 | ;; close parentheses). 26 | 27 | ;; The only exception is the single quote token, which is transformed into a 28 | ;; "quote" special form. This is because the single quote is like a reader 29 | ;; macro that can affect multiple tokens after it (in the case the quote is 30 | ;; followed by a list) and therefore affects the tree structure. 31 | 32 | (define (expression-to-tree tokens) 33 | (let (((fst . rest) tokens)) 34 | (cond 35 | ((tok:open-paren? fst) (list-to-tree (tok:get-location fst) rest)) 36 | 37 | ((tok:single-quote? fst) 38 | (result:transform-success 39 | (lambda (quoted-and-unquoted) 40 | (let (((quoted unquoted) quoted-and-unquoted)) 41 | (result:new-success 42 | (list 43 | (cons (tok:id (tok:get-location fst) "quote") quoted) 44 | unquoted)) )) 45 | (expression-to-tree rest))) 46 | 47 | (else (result:new-success (list fst rest))) ))) 48 | 49 | (define (toplevel-list-to-tree tokens) 50 | (cond 51 | ((null? tokens) (result:new-success '())) 52 | 53 | ((tok:close-paren? (car tokens)) 54 | (result:add-error 55 | (err:new 56 | (tok:get-location (car tokens)) 57 | "unexpected closing parenthesis") 58 | ; Make sure to continue parsing, ignoring the extra close parenthesis. 59 | ; That way, if there are multiple places with too many closing 60 | ; parentheses, they can all be reported in one shot. 61 | (toplevel-list-to-tree (cdr tokens)))) 62 | 63 | (else 64 | ; The only reason 'expression-to-tree' will fail is if we run out of 65 | ; tokens, in which case there won't be any additional parsing to be done 66 | ; in case of a failure. 67 | (result:transform-success 68 | (lambda (fst-and-rest) 69 | (let (((fst rest) fst-and-rest)) 70 | (result:transform-success 71 | (lambda (remainder-list) 72 | (result:new-success (cons fst remainder-list))) 73 | (toplevel-list-to-tree rest)) )) 74 | (expression-to-tree tokens)) ) )) 75 | 76 | (define (list-to-tree open-paren-loc tokens) 77 | (cond 78 | ((null? tokens) 79 | (result:new-with-single-error 80 | (err:new 81 | open-paren-loc 82 | "unterminated list (start position shown)"))) 83 | 84 | ((tok:close-paren? (car tokens)) 85 | (result:new-success (list '() (cdr tokens)))) 86 | 87 | (else 88 | ; The only reason 'expression-to-tree' will fail is if we run out of 89 | ; tokens, in which case there won't be any additional parsing to be done 90 | ; in case of a failure. 91 | (result:transform-success 92 | (lambda (fst-and-rest) 93 | (let (((fst rest) fst-and-rest)) 94 | (result:transform-success 95 | (lambda (list-tail-and-remaining-tokens) 96 | (result:new-success 97 | (list 98 | (cons fst (car list-tail-and-remaining-tokens)) 99 | (car (cdr list-tail-and-remaining-tokens)))) ) 100 | (list-to-tree open-paren-loc rest)) )) 101 | (expression-to-tree tokens)) ) )) 102 | 103 | (define (tree-to-ast tree) 104 | (ast:module (map subtree-to-ast tree))) 105 | 106 | (define (subtree-to-ast tree) 107 | (let ((loc (tok:get-location tree))) 108 | (cond 109 | ((tok:id? tree) (ast:var loc (tok:id-get-name tree))) 110 | ((tok:int? tree) (ast:int loc (tok:int-get-value tree))) 111 | ((tok:bool? tree) (ast:bool loc (tok:bool-get-value tree))) 112 | ((tok:str? tree) (ast:str loc (tok:str-get-value tree))) 113 | ((list? tree) (specialize-subtree tree)) ))) 114 | 115 | (define (specialize-subtree tree) 116 | (define (is-type? type name) 117 | (and (tok:id? type) 118 | (str:string=? (tok:id-get-name type) name)) ) 119 | 120 | ; Assumes `tree` is a list 121 | (let ((type (car tree))) 122 | (cond ((is-type? type "define") (subtree-to-define tree)) 123 | ((is-type? type "lambda") (subtree-to-lambda tree)) 124 | ((is-type? type "quote") (subtree-to-quoted tree)) 125 | ((is-type? type "if") (subtree-if-to-cond tree)) 126 | ((is-type? type "cond") (subtree-cond-to-cond tree)) 127 | (else (subtree-to-function-call tree)) ) )) 128 | 129 | (define (subtree-to-define tree) 130 | (let (((keyword name . body) tree)) 131 | (cond ((tok:id? name) 132 | ; The first case is a simple value definition: 133 | ; 134 | ; (define name body) 135 | ; 136 | ; In this case, only one statement is supported in the "body", so 137 | ; the body is assumed to be a single element list. 138 | (ast:definition 139 | (tok:get-location keyword) 140 | (tok:id-get-name name) 141 | (subtree-to-ast (car body))) ) 142 | 143 | ((and 144 | (list? name) 145 | (not (null? name)) 146 | (tok:id? (car name))) 147 | ; The second case is if the name is a list: 148 | ; 149 | ; (define (function-name arg0 arg1 ...) ...) 150 | ; ^---------- name -----------^ 151 | ; 152 | ; This represents a function definition, and it should be 153 | ; transformed to a value definition in which the value is a lambda: 154 | ; 155 | ; (define function-name (lambda (arg0 arg 1) ...)) 156 | (ast:definition 157 | (tok:get-location keyword) 158 | (tok:id-get-name (car name)) 159 | (subtree-to-lambda 160 | ; Synthesize a list of tokens representing a lambda. Notice that 161 | ; the body, which is a list of trees, is the tail of the lambda 162 | ; list, as opposed to the last element. 163 | (cons 164 | (tok:id (tok:get-location (car name)) "lambda") 165 | (cons (cdr name) body)) )) ) 166 | 167 | (else 168 | (display "\033[1;31m" name "\033[0m") (newline) 169 | (error-and-exit "Invalid definition name ^")) ))) 170 | 171 | (define (subtree-to-lambda tree) 172 | ; Does not support variadic functions yet. Thus, it is assumed the argument 173 | ; list of the lambda is a flat list of identifiers. 174 | (let (((keyword args . statements) tree)) 175 | (ast:function 176 | (tok:get-location keyword) 177 | (map tok:id-get-name args) 178 | (map subtree-to-ast statements)) )) 179 | 180 | (define (subtree-to-quoted tree) 181 | (define (helper outer-loc to-quote) 182 | (cond 183 | ((null? to-quote) (ast:quoted-list outer-loc '())) 184 | ((tok:id? to-quote) (ast:atom outer-loc (tok:id-get-name to-quote))) 185 | ((tok:int? to-quote) (ast:int outer-loc (tok:int-get-value to-quote))) 186 | ((tok:bool? to-quote) (ast:bool outer-loc (tok:bool-get-value to-quote))) 187 | ((list? to-quote) 188 | (ast:quoted-list 189 | outer-loc 190 | (map 191 | (lambda (subtree) (helper (tok:get-location (car to-quote)) subtree)) 192 | to-quote))) 193 | (else (error-and-exit "ERROR - invalid quoted value ^")) )) 194 | 195 | (helper (tok:get-location (car tree)) (cdr tree))) 196 | 197 | (define (subtree-if-to-cond tree) 198 | (let* (((keyword condition true-clause false-clause) tree) 199 | (loc (tok:get-location keyword)) 200 | (true-clause-ast (subtree-to-ast true-clause)) 201 | (false-clause-ast (subtree-to-ast false-clause))) 202 | (ast:conditional 203 | loc 204 | (list 205 | (ast:conditional-clause 206 | (ast:get-location true-clause-ast) 207 | (subtree-to-ast condition) 208 | (list true-clause-ast)) 209 | (ast:conditional-else 210 | (ast:get-location false-clause-ast) 211 | (list false-clause-ast)))) )) 212 | 213 | (define (subtree-cond-to-cond tree) 214 | (define (subtree-to-clause subtree) 215 | (let* (((condition . body-statements) subtree) 216 | (body-statements-ast (map subtree-to-ast body-statements))) 217 | (if (and (tok:id? condition) 218 | (str:string=? (tok:id-get-name condition) "else")) 219 | ; Else clause 220 | (ast:conditional-else 221 | (tok:get-location condition) 222 | body-statements-ast) 223 | 224 | ; Regular clause 225 | (let* ((condition-ast (subtree-to-ast condition)) 226 | (condition-loc (ast:get-location condition-ast))) 227 | (ast:conditional-clause 228 | condition-loc 229 | condition-ast 230 | body-statements-ast))) )) 231 | 232 | (ast:conditional 233 | (tok:get-location (car tree)) 234 | (map subtree-to-clause (cdr tree))) ) 235 | 236 | (define (subtree-to-function-call tree) 237 | (let (((fn . args) (map subtree-to-ast tree))) 238 | (ast:function-call (tok:get-location (car tree)) fn args)) ) 239 | 240 | (module-export 241 | parse) 242 | -------------------------------------------------------------------------------- /recursive/result.scm: -------------------------------------------------------------------------------- 1 | ;; Defines a "result" type that holds one of two values: 2 | ;; 3 | ;; - A successful value; 4 | ;; - Or a list of errors. 5 | ;; 6 | ;; Along with this data structure, this module defines ways to compose and 7 | ;; manipulate results. For example, it's possible to easily transform a 8 | ;; successful value--if present--or to add to the list of errors (wiping out 9 | ;; any successful value if there were previously no errors). 10 | 11 | ;; CONSTRUCTORS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | 13 | (define (new-success value) 14 | (cons 'result-success value)) 15 | 16 | (define (new-error errs) 17 | (cons 'result-error errs)) 18 | 19 | (define (new-with-single-error err) 20 | (new-error (list err))) 21 | 22 | ;; PREDICATES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | ;; 24 | ;; While okay to use directly, consider if it's possible to use a 25 | ;; transformation function, as defined below, to avoid explicit checks. 26 | 27 | (define (is-success? result) 28 | (= (car result) 'result-success)) 29 | 30 | (define (is-error? result) 31 | (= (car result) 'result-error)) 32 | 33 | ;; GETTERS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 34 | ;; 35 | ;; Assumes results are already validated to be of the correct type. Like with 36 | ;; the predicates, favor using transformation functions instead of explicit 37 | ;; destructuring. The exception is at the end of the processing when the goal 38 | ;; is to use the value or show the errors. 39 | 40 | (define (get-value result) 41 | (if (is-success? result) 42 | (cdr result) 43 | '() )) 44 | 45 | (define (get-errors result) 46 | (if (is-error? result) 47 | (cdr result) 48 | '() )) 49 | 50 | ;; TRANSFORMATIONS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 51 | 52 | (define (transform-success transformer result) 53 | (if (is-success? result) 54 | (transformer (get-value result)) 55 | result )) 56 | 57 | ; Given a "result" object, pass it through the given list of transformations, 58 | ; short-circuiting whenever one of the transformations fails (this includes if 59 | ; the original "result" is an error). 60 | (define (pipeline-successes result . transformers) 61 | (define (non-variadic result transformers) 62 | ; This pipeline is a bit hacky if you think about it in terms of types. 63 | ; Each step of the pipeline returns a potentially different type of 64 | ; "result" object, which can be thought of as types like Result, 65 | ; Result, etc. Thus, the end result should always be Result. 66 | ; 67 | ; However, as soon as one of the transformation fails, that error result is 68 | ; returned immediately. So possibly, this pipeline returns Result, 69 | ; where M < N. However, in a dynamically typed language, because Result 70 | ; contains an error, it is indistinguishable from Result. Just 71 | ; something to be aware of. 72 | (if (null? transformers) 73 | result 74 | (transform-success (continuation transformers) result) )) 75 | 76 | (define (continuation transformers) 77 | (let (((fn . rest-fns) transformers)) 78 | (lambda (value) (non-variadic (fn value) rest-fns)) )) 79 | 80 | (non-variadic result transformers)) 81 | 82 | (define (add-error err result) 83 | (if (is-success? result) 84 | (new-with-single-error err) 85 | (new-error (cons err (get-errors result))) )) 86 | 87 | (define (combine-results rs) 88 | (define (combine r1 rest) 89 | (let ((combined-rest (combine-results rest))) 90 | (if (is-success? combined-rest) 91 | (if (is-success? r1) 92 | (new-success (cons (get-value r1) (get-value combined-rest))) 93 | r1) 94 | (if (is-success? r1) 95 | combined-rest 96 | (new-error 97 | (append (get-errors r1) (get-errors combined-rest))) )) )) 98 | 99 | (if (null? rs) 100 | (new-success '()) 101 | (combine (car rs) (cdr rs))) ) 102 | 103 | ;; EXPORTS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 104 | 105 | (module-export 106 | ; Constructors 107 | new-success 108 | new-error 109 | new-with-single-error 110 | 111 | ; Predicates 112 | is-success? 113 | is-error? 114 | 115 | ; Getters 116 | get-value 117 | get-errors 118 | 119 | ; Transformations 120 | transform-success 121 | pipeline-successes 122 | add-error 123 | combine-results) 124 | -------------------------------------------------------------------------------- /recursive/static-analyzer.scm: -------------------------------------------------------------------------------- 1 | (require set) 2 | (require string => str) 3 | 4 | (require "ast") 5 | (require "compiler-error" => err) 6 | (require "result") 7 | 8 | ;; Perform static analysis on the given module, returning a "result" with 9 | ;; either all the errors that were found, or the modified module AST. Examples 10 | ;; of both these scenarios are: 11 | ;; 12 | ;; 1. Errors can occur when a variable references an undefined name. 13 | ;; 2. In the case of a success, "define" statements are hoisted to the top of 14 | ;; their respective scopes so they can execute before any other statements 15 | ;; that reference them. 16 | (define (analyze-module module) 17 | ; These names are defined in every module. In the Ruby implementation, these 18 | ; names are handled by the fact that every module implicitly includes some 19 | ; "core" modules that define these names, but since module support is not yet 20 | ; implemented in the recursive compiler, for now define these names 21 | ; explicitly here in the static analyzer. 22 | ; 23 | ; Keep this in sync with the functions defined in the evaluator. 24 | ; 25 | ; The goal is to eventually remove these altogether (though based on the Ruby 26 | ; implementation, there is still *argv* that needs to be handled this way). 27 | (define toplevel-names 28 | (set:new-with-equality 29 | str:string=? 30 | (list 31 | "=" 32 | "+" 33 | "-" 34 | "*" 35 | "cons" 36 | "car" 37 | "cdr" 38 | "null?" 39 | "display" 40 | "newline"))) 41 | 42 | (result:transform-success 43 | (lambda (analyzed-statements) 44 | (result:new-success (ast:module analyzed-statements))) 45 | (analyze-statement-list 46 | (ast:module-get-statements module) 47 | toplevel-names)) ) 48 | 49 | (define (analyze-statement-list statements names-in-scope) 50 | (define (separate-defines statements) 51 | (let ((defines (filter ast:definition? statements)) 52 | (non-defines (reject ast:definition? statements))) 53 | (list defines non-defines))) 54 | 55 | (let* (((defines non-defines) (separate-defines statements)) 56 | (reordered-statements (append defines non-defines)) 57 | (defined-names (map ast:definition-get-name defines)) 58 | (new-names-in-scope (set:add-all names-in-scope defined-names))) 59 | (result:combine-results 60 | (map 61 | (lambda (statement) (analyze-ast-node statement new-names-in-scope)) 62 | reordered-statements)) )) 63 | 64 | (define (analyze-ast-node node names-in-scope) 65 | (cond 66 | ; The following nodes are self-identifying, meaning they don't reference 67 | ; any names in the scope. Thus, they always succeed the analysis. 68 | ((or (ast:int? node) 69 | (ast:atom? node) 70 | (ast:bool? node) 71 | (ast:str? node) 72 | (ast:quoted-list? node)) 73 | (result:new-success node)) 74 | 75 | ; A variable reference simply needs to check that the referenced name 76 | ; exists in the current scope. 77 | ((ast:var? node) 78 | (let ((name (ast:var-get-name node))) 79 | (if (set:contains? names-in-scope name) 80 | (result:new-success node) 81 | (result:new-with-single-error 82 | (err:new 83 | (ast:get-location node) 84 | "undefined variable '" name "'")) ))) 85 | 86 | ; A definition does define a new name (by definition!), but that name is 87 | ; already added to the current scope by "analyze-statement-list". 88 | ((ast:definition? node) 89 | (result:transform-success 90 | (lambda (analyzed) 91 | (result:new-success 92 | (ast:definition 93 | (ast:get-location node) 94 | (ast:definition-get-name node) 95 | analyzed))) 96 | (analyze-ast-node (ast:definition-get-body node) names-in-scope) ) ) 97 | 98 | ; A conditional does not define any new names 99 | ((ast:conditional? node) 100 | (result:transform-success 101 | (lambda (analyzed-clauses) 102 | (result:new-success 103 | (ast:conditional (ast:get-location node) analyzed-clauses))) 104 | (result:combine-results 105 | (map 106 | (lambda (node) (analyze-ast-node node names-in-scope)) 107 | (ast:conditional-get-clauses node)) ) ) ) 108 | 109 | ; A conditional clause does not define any new names 110 | ((ast:conditional-clause? node) 111 | (result:transform-success 112 | (lambda (analyzed) 113 | (result:new-success 114 | (ast:conditional-clause 115 | (ast:get-location (car analyzed)) 116 | (car analyzed) 117 | (car (cdr analyzed))))) 118 | (result:combine-results 119 | (list 120 | (analyze-ast-node 121 | (ast:conditional-clause-get-condition node) 122 | names-in-scope) 123 | (analyze-statement-list 124 | (ast:conditional-clause-get-body-statements node) 125 | names-in-scope)) ) ) ) 126 | 127 | ; A conditional else does not define any new names 128 | ((ast:conditional-else? node) 129 | (result:transform-success 130 | (lambda (analyzed) 131 | (result:new-success 132 | (ast:conditional-else (ast:get-location node) analyzed))) 133 | (analyze-statement-list 134 | (ast:conditional-else-get-body-statements node) 135 | names-in-scope) ) ) 136 | 137 | ; A function defines new names based on its parameter list 138 | ((ast:function? node) 139 | (let* ((args (ast:function-get-args node)) 140 | (new-names-in-scope (set:add-all names-in-scope args))) 141 | (result:transform-success 142 | (lambda (analyzed) 143 | (result:new-success 144 | (ast:function (ast:get-location node) args analyzed))) 145 | (analyze-statement-list 146 | (ast:function-get-body node) 147 | new-names-in-scope) ) )) 148 | 149 | ; A function call does not define any new names 150 | ((ast:function-call? node) 151 | (result:transform-success 152 | (lambda (analyzed) 153 | (result:new-success 154 | (ast:function-call 155 | (ast:get-location node) 156 | (car analyzed) 157 | (cdr analyzed)))) 158 | (result:combine-results 159 | (map 160 | (lambda (node) (analyze-ast-node node names-in-scope)) 161 | (cons 162 | (ast:function-call-get-function node) 163 | (ast:function-call-get-args node))) ) ) ) 164 | 165 | (else 166 | (display "analyze-ast-node: unhandled node '" node "'") 167 | (newline) 168 | (result:new-success node)) )) 169 | 170 | (module-export 171 | analyze-module) 172 | -------------------------------------------------------------------------------- /recursive/string-utils.scm: -------------------------------------------------------------------------------- 1 | (require string => str) 2 | 3 | (define (ascii-char-to-byte chr) 4 | (cond 5 | ((str:string=? chr "\t") 9) 6 | ((str:string=? chr "\n") 10) 7 | ((str:string=? chr " ") 32) 8 | ((str:string=? chr "!") 33) 9 | ((str:string=? chr "\"") 34) 10 | ((str:string=? chr "#") 35) 11 | ((str:string=? chr "$") 36) 12 | ((str:string=? chr "%") 37) 13 | ((str:string=? chr "&") 38) 14 | ((str:string=? chr "'") 39) 15 | ((str:string=? chr "(") 40) 16 | ((str:string=? chr ")") 41) 17 | ((str:string=? chr "*") 42) 18 | ((str:string=? chr "+") 43) 19 | ((str:string=? chr ",") 44) 20 | ((str:string=? chr "-") 45) 21 | ((str:string=? chr ".") 46) 22 | ((str:string=? chr "/") 47) 23 | ((str:string=? chr "0") 48) 24 | ((str:string=? chr "1") 49) 25 | ((str:string=? chr "2") 50) 26 | ((str:string=? chr "3") 51) 27 | ((str:string=? chr "4") 52) 28 | ((str:string=? chr "5") 53) 29 | ((str:string=? chr "6") 54) 30 | ((str:string=? chr "7") 55) 31 | ((str:string=? chr "8") 56) 32 | ((str:string=? chr "9") 57) 33 | ((str:string=? chr ":") 58) 34 | ((str:string=? chr ";") 59) 35 | ((str:string=? chr "<") 60) 36 | ((str:string=? chr "=") 61) 37 | ((str:string=? chr ">") 62) 38 | ((str:string=? chr "?") 63) 39 | ((str:string=? chr "@") 64) 40 | ((str:string=? chr "A") 65) 41 | ((str:string=? chr "B") 66) 42 | ((str:string=? chr "C") 67) 43 | ((str:string=? chr "D") 68) 44 | ((str:string=? chr "E") 69) 45 | ((str:string=? chr "F") 70) 46 | ((str:string=? chr "G") 71) 47 | ((str:string=? chr "H") 72) 48 | ((str:string=? chr "I") 73) 49 | ((str:string=? chr "J") 74) 50 | ((str:string=? chr "K") 75) 51 | ((str:string=? chr "L") 76) 52 | ((str:string=? chr "M") 77) 53 | ((str:string=? chr "N") 78) 54 | ((str:string=? chr "O") 79) 55 | ((str:string=? chr "P") 80) 56 | ((str:string=? chr "Q") 81) 57 | ((str:string=? chr "R") 82) 58 | ((str:string=? chr "S") 83) 59 | ((str:string=? chr "T") 84) 60 | ((str:string=? chr "U") 85) 61 | ((str:string=? chr "V") 86) 62 | ((str:string=? chr "W") 87) 63 | ((str:string=? chr "X") 88) 64 | ((str:string=? chr "Y") 89) 65 | ((str:string=? chr "Z") 90) 66 | ((str:string=? chr "[") 91) 67 | ((str:string=? chr "\\") 92) 68 | ((str:string=? chr "]") 93) 69 | ((str:string=? chr "^") 94) 70 | ((str:string=? chr "_") 95) 71 | ((str:string=? chr "`") 96) 72 | ((str:string=? chr "a") 97) 73 | ((str:string=? chr "b") 98) 74 | ((str:string=? chr "c") 99) 75 | ((str:string=? chr "d") 100) 76 | ((str:string=? chr "e") 101) 77 | ((str:string=? chr "f") 102) 78 | ((str:string=? chr "g") 103) 79 | ((str:string=? chr "h") 104) 80 | ((str:string=? chr "i") 105) 81 | ((str:string=? chr "j") 106) 82 | ((str:string=? chr "k") 107) 83 | ((str:string=? chr "l") 108) 84 | ((str:string=? chr "m") 109) 85 | ((str:string=? chr "n") 110) 86 | ((str:string=? chr "o") 111) 87 | ((str:string=? chr "p") 112) 88 | ((str:string=? chr "q") 113) 89 | ((str:string=? chr "r") 114) 90 | ((str:string=? chr "s") 115) 91 | ((str:string=? chr "t") 116) 92 | ((str:string=? chr "u") 117) 93 | ((str:string=? chr "v") 118) 94 | ((str:string=? chr "w") 119) 95 | ((str:string=? chr "x") 120) 96 | ((str:string=? chr "y") 121) 97 | ((str:string=? chr "z") 122) 98 | ((str:string=? chr "{") 123) 99 | ((str:string=? chr "|") 124) 100 | ((str:string=? chr "}") 125) 101 | ((str:string=? chr "~") 126) 102 | (else (error-and-exit "Cannot convert ASCII character to byte: " chr)) )) 103 | 104 | ;; Converts a string into a list of integers representing the bytes that make up 105 | ;; the string. It is assumed the string consists only of printable ASCII 106 | ;; characters. 107 | ;; 108 | ;; Includes the NULL terminator at the end. 109 | (define (ascii-string-to-bytes str) 110 | (if (str:null? str) 111 | '(0x00) 112 | (cons 113 | (ascii-char-to-byte (str:at str 0)) 114 | (ascii-string-to-bytes (str:string-tail str 1))) )) 115 | 116 | (module-export 117 | ascii-string-to-bytes) 118 | -------------------------------------------------------------------------------- /recursive/test-codegen-unsupported.scm: -------------------------------------------------------------------------------- 1 | ; This file contains a bunch of constructs that are not supported yet by the 2 | ; codegen. As more support is added, more will be removed from this file and 3 | ; moved into whatever positive test case file is present. 4 | 5 | 102 6 | 7 | (+ 1 2) ; Function calls are not supported 8 | (* 2 3) 9 | (define (a) 2) ; Lambdas and definitions are not supported 10 | (define b 2) 11 | (lambda (a) 2) 12 | 13 | 'atom ; Various atoms are not supported 14 | '(1 2 3) ; List literals are not supported 15 | 16 | (if (= 1 2) (+ 1 2) (* 1 2)) ; Function calls are not supported 17 | (cond 18 | ((= 1 2) (+ 1 2)) 19 | ((= 2 2) (* 1 2)) 20 | (else (- 1 2))) 21 | 22 | 23 | 205 24 | -------------------------------------------------------------------------------- /recursive/test-numbers.scm: -------------------------------------------------------------------------------- 1 | ; This file contains a series of top-level statements that are supported by the 2 | ; codegen. Each statement is codegened in such a way as to leave the result in 3 | ; %rax. Whatever is the last such value in %rax is the returned status code of 4 | ; the entire execution. 5 | ; 6 | ; Thus, only the last top-level statement in this file has any observable 7 | ; behavior. You can simply return comment out any lines after the one you want 8 | ; to observe. 9 | 10 | ; Strings are an exception. Unlike numerical results, strings are immediately 11 | ; printed out to stdout, and the result is a constant `0`. Thus, putting a 12 | ; string at the end of the file will cause the executable to return `0` as the 13 | ; status code. 14 | "abcd\n" 15 | "Hello, world!\n" 16 | 17 | 205 18 | #t ; represented as 2 19 | #f ; represented as 4 20 | '#t ; quoted booleans evaluate to their corresponding booleans 21 | '#f 22 | '() ; represented as 0 23 | 24 | (if #t 1 2) 25 | (cond 26 | (#t 10) 27 | (#f 20) 28 | (else 30)) 29 | -------------------------------------------------------------------------------- /recursive/test.scm: -------------------------------------------------------------------------------- 1 | ;; Adds the three numberical inputs. 2 | (define (addthreenums a b c) 3 | ; Using the function definition syntax here 4 | (+ a (+ b c)) ) 5 | 6 | ;; Adds the four numberical inputs. This demonstrates nested lambdas, and the 7 | ;; fact that variable shadowing works. The four variables are bound in all 8 | ;; manner of ways inside the inner lambdas, but there's no conflict because 9 | ;; each lambda introduces its own scope. 10 | (define addfournums 11 | (lambda (a b c d) 12 | (+ ((lambda (d c) (+ d c)) a b) 13 | ((lambda (b a) (+ b a)) c d)) )) 14 | 15 | ;; Given a number, returns a function that takes in another number and adds the 16 | ;; two numbers together. This demonstrates that lexical scoping works, and that 17 | ;; each lambda references its enclosing scope. 18 | (define closure 19 | (lambda (a) 20 | (lambda (b) (+ a b)) )) 21 | 22 | ;; These variable names are deliberately named in conflict with the various 23 | ;; names that are present as the lambda arguments to prove that these bindings 24 | ;; are not blown away when the lambdas are invoked. 25 | (define a 3) 26 | (define b 2) 27 | (define c 1) 28 | 29 | ;; Defined variables can have all sorts of names 30 | (define ALL-CAPS 111) (display ALL-CAPS) (newline) 31 | (define with-numbers-123 112) (display with-numbers-123) (newline) 32 | (define *with-stars* 113) (display *with-stars*) (newline) 33 | 34 | (newline) 35 | 36 | (display (addthreenums c b a)) (newline) 37 | (display (+ a 9)) (newline) ; Prove that "a" is not blown away by calling 38 | ; addthreenums 39 | 40 | (display (addfournums 1 2 3 4)) (newline) 41 | (display ((closure 1) 2) ) (newline) 42 | 43 | (newline) 44 | 45 | ;; Numerical values 46 | 47 | (display 2) (newline) ; a positive number 48 | (display +2) (newline) ; a positive number with a plus sign 49 | (display -2) (newline) ; a negative number (even) 50 | (display -1) (newline) ; a negative number (odd) 51 | (display (+ 3 -3)) (newline) 52 | (display (+ 9 -3)) (newline) 53 | (display (+ 3 -9)) (newline) 54 | (display (- 3)) (newline) 55 | (display (- 3 1)) (newline) 56 | (display (- 3 4)) (newline) 57 | (display (- 3 1 2 3)) (newline) 58 | (display (* 2 -3)) (newline) 59 | (display (* 2 -3 4)) (newline) 60 | (display (* 2 -3 4 -5)) (newline) 61 | (display (* -1 -3 -5)) (newline) 62 | (display 63 | (* ; comments 64 | 1 ; inside 65 | 2 ; complex 66 | 3 ; expressions 67 | 4 ; ! 68 | )) (newline) 69 | 70 | (display 0x1) (newline) 71 | (display 0x01) (newline) 72 | (display 0xff) (newline) 73 | (display 0x100) (newline) 74 | 75 | (newline) 76 | 77 | (display 0xF) (newline) 78 | (display 0x1A) (newline) 79 | (display 0xDEADBEEF) (newline) 80 | 81 | (newline) 82 | 83 | (display (+ 0xff 1)) (newline) 84 | (display (- 0xff 0xf)) (newline) 85 | 86 | (newline) 87 | 88 | (define (display-with-newline msg) 89 | (display msg) 90 | (newline)) 91 | 92 | (display-with-newline 123) 93 | (display-with-newline 456) 94 | 95 | ;; Quoted values 96 | 97 | (newline) 98 | 99 | (display 'a) (newline) 100 | (display '123) (newline) 101 | (display '#t) (newline) 102 | (display '#f) (newline) 103 | (display '(1 2 3)) (newline) 104 | (display '(1 (2 3) 4)) (newline) 105 | (display '(this is a list)) (newline) 106 | 107 | ;; Nil 108 | 109 | (newline) 110 | 111 | (display '()) (newline) 112 | (display (display 'a)) (newline) 113 | 114 | ;; Booleans and conditionals. 115 | 116 | (newline) 117 | 118 | (define my-not 119 | (lambda (val) (if val #f #t))) 120 | 121 | (display #t) (newline) 122 | (display #f) (newline) 123 | (display (if #t 'correct 'wrong)) (newline) 124 | (display (if #f 'wrong 'correct)) (newline) 125 | (display (if '() 'correct 'wrong)) (newline) 126 | (display (if 0 'correct 'wrong)) (newline) 127 | (display (if 1 'correct 'wrong)) (newline) 128 | (display (if (my-not #f) 'correct 'wrong)) (newline) 129 | (display (if (my-not #t) 'wrong 'correct)) (newline) 130 | (display (if (my-not 0) 'wrong 'correct)) (newline) 131 | (display (if (my-not 1) 'wrong 'correct)) (newline) 132 | (display (= 1 1)) (newline) 133 | (display (= 2 2 (+ 1 1))) (newline) 134 | (display (my-not (= 1 2))) (newline) 135 | (display (my-not (= 1 1 2))) (newline) 136 | 137 | ; Cond expressions 138 | 139 | (newline) 140 | 141 | (define (check-1-2-3 n) 142 | (cond ((= n 1) 'one) 143 | ((= n 2) 'two) 144 | ((= n 3) 'three) 145 | (else 'none-of-the-above)) ) 146 | 147 | (display (check-1-2-3 1)) (newline) 148 | (display (check-1-2-3 2)) (newline) 149 | (display (check-1-2-3 3)) (newline) 150 | (display (check-1-2-3 4)) (newline) 151 | 152 | ;; Strings 153 | 154 | (newline) 155 | 156 | (display "a string") (newline) 157 | (display "some numbers and symbols: 1 2 3 # @ <- cool!") (newline) 158 | (display "a string with a newline afterwards\n") 159 | (display "a string with\n a newline in the middle") (newline) 160 | (display "another string with 161 | a newline in the middle") (newline) 162 | (display "\ta string with an embedded tab") (newline) 163 | (display "a string with \"escaped\" quotes") (newline) 164 | (display "no need to 'escape' single quotes") (newline) 165 | (display "") (newline) 166 | (display "^ empty string above") (newline) 167 | -------------------------------------------------------------------------------- /recursive/test.scm.result: -------------------------------------------------------------------------------- 1 | 111 2 | 112 3 | 113 4 | 5 | 6 6 | 12 7 | 10 8 | 3 9 | 10 | 2 11 | 2 12 | -2 13 | -1 14 | 0 15 | 6 16 | -6 17 | -3 18 | 2 19 | -1 20 | -3 21 | -6 22 | -24 23 | 120 24 | -15 25 | 24 26 | 1 27 | 1 28 | 255 29 | 256 30 | 31 | 15 32 | 26 33 | 3735928559 34 | 35 | 256 36 | 240 37 | 38 | 123 39 | 456 40 | 41 | a 42 | 123 43 | #t 44 | #f 45 | (1 2 3) 46 | (1 (2 3) 4) 47 | (this is a list) 48 | 49 | () 50 | a() 51 | 52 | #t 53 | #f 54 | correct 55 | correct 56 | correct 57 | correct 58 | correct 59 | correct 60 | correct 61 | correct 62 | correct 63 | #t 64 | #t 65 | #t 66 | #t 67 | 68 | one 69 | two 70 | three 71 | none-of-the-above 72 | 73 | a string 74 | some numbers and symbols: 1 2 3 # @ <- cool! 75 | a string with a newline afterwards 76 | a string with 77 | a newline in the middle 78 | another string with 79 | a newline in the middle 80 | a string with an embedded tab 81 | a string with "escaped" quotes 82 | no need to 'escape' single quotes 83 | 84 | ^ empty string above 85 | -------------------------------------------------------------------------------- /recursive/tokens.scm: -------------------------------------------------------------------------------- 1 | ;; CONSTRUCTORS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | 3 | (define (id loc name) 4 | (list 'id loc name)) 5 | 6 | (define (int loc value) 7 | (list 'int loc value)) 8 | 9 | (define (bool loc value) 10 | (list 'bool loc value)) 11 | 12 | (define (str loc value) 13 | (list 'str loc value)) 14 | 15 | (define (open-paren loc) (list 'open-paren loc)) 16 | (define (close-paren loc) (list 'close-paren loc)) 17 | (define (single-quote loc) (list 'single-quote loc)) 18 | 19 | ;; PREDICATES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 20 | 21 | (define (is-token-of-compound-type? token type) 22 | (and (list? token) 23 | (symbol? (car token)) 24 | (= (car token) type)) ) 25 | 26 | (define (id? token) 27 | (is-token-of-compound-type? token 'id) ) 28 | 29 | (define (int? token) 30 | (is-token-of-compound-type? token 'int) ) 31 | 32 | (define (bool? token) 33 | (is-token-of-compound-type? token 'bool) ) 34 | 35 | (define (str? token) 36 | (is-token-of-compound-type? token 'str) ) 37 | 38 | (define (open-paren? token) 39 | (is-token-of-compound-type? token 'open-paren)) 40 | 41 | (define (close-paren? token) 42 | (is-token-of-compound-type? token 'close-paren)) 43 | 44 | (define (single-quote? token) 45 | (is-token-of-compound-type? token 'single-quote)) 46 | 47 | ;; GETTERS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 48 | ;; assumes tokens are already validated to be of the correct type 49 | 50 | (define get-location (compose car cdr)) 51 | 52 | (define id-get-name (compose car cdr cdr)) 53 | (define int-get-value (compose car cdr cdr)) 54 | (define bool-get-value (compose car cdr cdr)) 55 | (define str-get-value (compose car cdr cdr)) 56 | 57 | ;; EXPORTS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 58 | 59 | (module-export 60 | ; Constructors 61 | id 62 | int 63 | bool 64 | str 65 | open-paren 66 | close-paren 67 | single-quote 68 | 69 | ; Predicates 70 | id? 71 | int? 72 | bool? 73 | str? 74 | open-paren? 75 | close-paren? 76 | single-quote? 77 | 78 | ; Getters 79 | get-location 80 | id-get-name 81 | int-get-value 82 | bool-get-value 83 | str-get-value) 84 | -------------------------------------------------------------------------------- /run-tests.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | failed=0 4 | 5 | cleanup() { 6 | rm -f test/tmp.result 7 | rm -f test/tmp.diff 8 | } 9 | 10 | clr_eol=`tput el` 11 | 12 | log_info_clearable() { 13 | msg=$1 14 | # Don't output a newline since the line is meant to be cleared. 15 | printf "\033[1;32m$msg\033[0m" 16 | } 17 | 18 | clear_line() { 19 | printf "\r$clr_eol" 20 | } 21 | 22 | log_info() { 23 | msg=$1 24 | printf "\033[1;32m$msg\033[0m\n" 25 | } 26 | 27 | log_error() { 28 | msg=$1 29 | printf "\033[1;31m$msg\033[0m\n" 30 | } 31 | 32 | fail() { 33 | msg=$1 34 | log_error "$msg" 35 | 36 | failed=`expr $failed + 1` 37 | } 38 | 39 | log_info "Running unit tests" 40 | echo 41 | rspec test/rb 42 | echo 43 | 44 | rm -f test/tmp 45 | 46 | num_success_tests=`ls -1 test/success/*.scm | wc -l` 47 | num_failure_compile_tests=`ls -1 test/failure-compile/*.scm | wc -l` 48 | num_total_tests=`expr $num_success_tests + $num_failure_compile_tests` 49 | 50 | log_info "Running $num_total_tests functional tests" 51 | echo 52 | 53 | for testfile in test/success/*.scm; do 54 | log_info_clearable "Running \"$testfile\"..." 55 | 56 | ./garlic "$testfile" > test/tmp.result 2>&1 57 | 58 | if [ $? -ne 0 ]; then 59 | echo 60 | echo 61 | cat test/tmp.result 62 | 63 | fail "Compiling \"$testfile\" failed" 64 | echo 65 | continue 66 | fi 67 | 68 | ./main > test/tmp.result 69 | 70 | if [ $? -ne 0 ]; then 71 | echo 72 | echo 73 | cat test/tmp.result 74 | 75 | fail "Running \"$testfile\" failed" 76 | echo 77 | continue 78 | fi 79 | 80 | diff test/tmp.result "${testfile}.result" > test/tmp.diff 81 | 82 | if [ $? -ne 0 ]; then 83 | echo 84 | echo 85 | cat test/tmp.diff 86 | fail "Unexpected output running $testfile" 87 | echo 88 | fi 89 | 90 | clear_line 91 | done 92 | 93 | for testfile in test/failure-compile/*.scm; do 94 | log_info_clearable "Running \"$testfile\"..." 95 | 96 | ./garlic "$testfile" > test/tmp.result 2>&1 97 | 98 | if [ $? -eq 0 ]; then 99 | echo 100 | fail "Compiling \"$testfile\" unexpectedly succeeded" 101 | echo 102 | fi 103 | 104 | clear_line 105 | done 106 | 107 | for testfile in test/failure-runtime/*.scm; do 108 | log_info_clearable "Running \"$testfile\"..." 109 | 110 | ./garlic "$testfile" > test/tmp.result 2>&1 111 | 112 | if [ $? -ne 0 ]; then 113 | echo 114 | echo 115 | cat test/tmp.result 116 | 117 | fail "Compiling \"$testfile\" failed" 118 | echo 119 | continue 120 | fi 121 | 122 | ./main > test/tmp.result 2>&1 123 | 124 | if [ $? -eq 0 ]; then 125 | echo 126 | echo 127 | cat test/tmp.result 128 | 129 | fail "Running \"$testfile\" unexpectedly succeeded" 130 | echo 131 | fi 132 | 133 | clear_line 134 | done 135 | 136 | if [ $failed -eq 0 ]; then 137 | log_info "ALL TESTS SUCCEEDED" 138 | else 139 | echo 140 | log_error "$failed TESTS FAILED" 141 | fi 142 | 143 | cleanup 144 | -------------------------------------------------------------------------------- /runtime.S: -------------------------------------------------------------------------------- 1 | #if defined(__WIN32__) || defined(__APPLE__) 2 | # define cdecl(s) _##s 3 | #else 4 | # define cdecl(s) s 5 | #endif 6 | 7 | .global cdecl(garlic_fncall) 8 | .global cdecl(gather_varargs) 9 | .global cdecl(garlic_call_function) 10 | .global cdecl(garlicval_to_int) 11 | 12 | .text 13 | 14 | cdecl(garlic_fncall): 15 | # This function is called with the wrapped lambda, and the number of 16 | # arguments to the lambda as the arguments. A new frame is created 17 | # using the lambda's parent frame as the parent, and the function 18 | # pointer is retrieved and called. 19 | # 20 | # All the arguments to the lambda are stored in the stack right to 21 | # left (i.e. the right-most argument is pushed onto the stack first). 22 | # It is the callee's responsiblity to handle the arguments. 23 | # 24 | # Note that %rsi (number of arguments to the lambda) should be passed 25 | # as is, since it is needed for varargs. 26 | push %rdi # save the lambda on the stack 27 | push %rsi # save the number of arguments 28 | sub $8, %rsp # align the stack 29 | mov 8(%rdi), %rdi # create a new frame using the lambda's 30 | call cdecl(new_frame_with_parent) # stored frame as the parent 31 | mov %rax, %rdi # make room for the lambda 32 | add $8, %rsp # unalign the stack 33 | pop %rsi # grab the number of arguments again 34 | pop %rax # and the lambda 35 | push %rdi # save the new frame 36 | mov 16(%rax), %rax # dereference the lambda's function 37 | jmp *%rax # pointer and call it 38 | 39 | cdecl(gather_varargs): 40 | # %rsi contains the number of arguments to gather. This function is 41 | # called right at the beginning of executing a function body, so the 42 | # stack contains the following elements: 43 | # 44 | # %rsp - return address to caller of gather_varargs 45 | # stack frame pushed by garlic_fncall 46 | # return address to original caller of function 47 | # first argument to original function 48 | # 49 | # The arguments to this function are: 50 | # 51 | # %rdi - number of required parameters for the original function 52 | # %rsi - number of total arguments passed to the original function 53 | # 54 | # Thus, (%rsi - %rdi) is the number of parameters that need to be 55 | # gathered. 56 | 57 | # Given N total arguments, we want to get to %rsp + 24 + ((N - 1) * 8). 58 | # The (N - 1) part accounts for the fact that we want to be just below 59 | # the last argument, not past it. With some algebraic manipulation, we 60 | # get %rsp + 16 + (N * 8). 61 | mov %rsi, %r8 # take the total number of arguments 62 | shlq $3, %r8 # multiply by 8 (# of bytes per arg) 63 | mov %rsp, %r9 # start at the top of the stack 64 | add $16, %r9 # move to the start of the first 65 | add %r8, %r9 # argument put on the stack 66 | 67 | mov %rsi, %r8 # compute the number of arguments that 68 | sub %rdi, %r8 # need to be gathered 69 | 70 | mov $0, %rsi # load nil as the last list element 71 | mov %rsi, %r10 # %rsi will be used to store the list 72 | gather_varargs_begin: # so save the original value too 73 | cmp $0, %r8 # check that we have more arguments 74 | je gather_varargs_done # otherwise we're done 75 | 76 | mov (%r9), %rdi # grab the next argument 77 | push %r8 # save the number of arguments left 78 | push %r9 # and the pseudo-stack pointer 79 | push %r10 # and the total number of arguments 80 | call cdecl(garlic_make_cons) 81 | mov %rax, %rsi # the cons is the next item in the list 82 | pop %r10 83 | pop %r9 84 | pop %r8 85 | sub $8, %r9 # advance to the next argument 86 | sub $1, %r8 # we have one fewer argument to gather 87 | jmp gather_varargs_begin # loop 88 | gather_varargs_done: 89 | mov %rsi, %rax # return the resulting list 90 | mov %r10, %rsi # restore the number of arguments 91 | ret 92 | 93 | cdecl(garlic_call_function): 94 | mov %rdx, %r12 # %r12 is callee-saved 95 | test $1, %r12 # check if the number of arguments... 96 | jnz garlic_call_function_odd_args # ...is even or odd 97 | sub $8, %rsp # align the stack if even 98 | add $1, %r12 # remember that we aligned the stack 99 | garlic_call_function_odd_args: 100 | shlq $3, %r12 # multiply by 8 (# of bytes per arg) 101 | 102 | mov %rdx, %r9 # start with the number of arguments 103 | sub $1, %r9 # subtract one to avoid fence-post 104 | shlq $3, %r9 # multiply by 8 (# of bytes per arg) 105 | add %r9, %rsi # this is the address of the last arg! 106 | mov %rdx, %r8 # counter for number of arguments 107 | garlic_call_function_begin: # we'll push arguments in reverse order 108 | cmp $0, %r8 # when we've exhausted the args... 109 | je garlic_call_function_done # ...finish the loop 110 | 111 | mov (%rsi), %r10 # grab the current argument 112 | push %r10 # push it onto the stack 113 | sub $8, %rsi # go to the previous argument 114 | sub $1, %r8 # decrement the counter 115 | jmp garlic_call_function_begin 116 | garlic_call_function_done: 117 | mov %rdx, %rsi # garlic_fncall expects the second... 118 | call cdecl(garlic_fncall) # ...argument to be the number of args 119 | add %r12, %rsp # remove the arguments from the stack 120 | ret 121 | 122 | cdecl(garlicval_to_int): 123 | # A tagged integer is specified by shifting it to the left by one bit, 124 | # then filling in the least significant bit with "1". When converting 125 | # back to a native integer, however, it is important that we do an 126 | # arithmetic right shift. That is, if the tagged value is negative (the 127 | # most significant bit is "1"), then the native integer should be 128 | # negative as well. 129 | # 130 | # According to http://stackoverflow.com/a/1857965, the bit shift 131 | # operator in C is not required to be an arithmetic shift, so to be 132 | # careful, we should force an arithmetic shift. 133 | sarq $1, %rdi 134 | mov %rdi, %rax 135 | ret 136 | -------------------------------------------------------------------------------- /sdl2-test/Makefile: -------------------------------------------------------------------------------- 1 | OS = $(shell uname) 2 | 3 | ifeq "$(OS)" "Darwin" 4 | CFLAGS = -F ~/Library/Frameworks -framework SDL2 -framework SDL2_image 5 | else # Linux 6 | CFLAGS = -lSDL2 -lSDL2_image 7 | endif 8 | 9 | marley: marley.scm 10 | ../garlic -o $@ $< -- $(CFLAGS) 11 | 12 | .PHONY: clean 13 | 14 | clean: 15 | rm -rf build marley marley.dSYM 16 | -------------------------------------------------------------------------------- /sdl2-test/bob-marley.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/avik-das/garlic/e8d4303418a4b80bc88366a4011d3250bc3a5667/sdl2-test/bob-marley.jpg -------------------------------------------------------------------------------- /sdl2-test/marley.scm: -------------------------------------------------------------------------------- 1 | (require sdl2) 2 | 3 | (define *title* "sdl-from-garlic") 4 | (define *width* 256) 5 | (define *height* 256) 6 | 7 | (define ctx (sdl2:init *title* *width* *height*)) 8 | (define img (sdl2:load-img ctx "bob-marley.jpg")) 9 | (sdl2:show-img ctx img) 10 | (sdl2:free-img img) 11 | 12 | (sdl2:main-loop ctx) 13 | -------------------------------------------------------------------------------- /stdlib-includes/assoc.scm: -------------------------------------------------------------------------------- 1 | ;; A library for working with "association lists", a common data structure in 2 | ;; Scheme. An association list is a list of pairs, where each pair has a key and 3 | ;; a value. The following operations are supported: 4 | ;; 5 | ;; - Constructing a new association list: simply create a list of pairs. 6 | ;; 7 | ;; - Retrieve an entry from an existing association list by key. Given a key, 8 | ;; the first pair with a matching key is returned. Note that lookup takes 9 | ;; linear time in the number of entries in the list. 10 | ;; 11 | ;; - Adding a new entry to an existing association list: simply `cons` a new 12 | ;; pair to the front of the list. Note that if the new entry has the same key 13 | ;; as an existing entry, the newer entry will "shadow" the later one. This 14 | ;; operation is constant time. 15 | ;; 16 | ;; - Removing all entries with a given key from an association list. This 17 | ;; operation takes linear time in the number of entries in the list. 18 | ;; 19 | ;; This module is loosely based on the association lists in standard Scheme 20 | ;; distributions, such as MIT Scheme [1]. The main differences are: 21 | ;; 22 | ;; - Provide constructors for association lists. The reason these are not 23 | ;; usually provided is because association lists are simple lists of pairs, 24 | ;; which Scheme is good at representing. However, I want to expose a more 25 | ;; generic interface that can one day be used to power some other 26 | ;; representation of a key->value mapping, such as a hash map. 27 | ;; 28 | ;; - Support only symbol keys. This is so we can use `=` for key comparisons. To 29 | ;; avoid confusion with standard distributions, I've made sure not use names 30 | ;; for the lookups that are typically associated with specific key comparison 31 | ;; strategies (for example, `assoc` uses `equal?` for its comparisons). 32 | ;; 33 | ;; - Don't support in-place mutations. 34 | ;; 35 | ;; Any operation not implemented has not had a practical use yet. 36 | ;; 37 | ;; [1] https://www.gnu.org/software/mit-scheme/documentation/stable/mit-scheme-ref/Association-Lists.html 38 | 39 | ;; CONSTRUCTORS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 40 | 41 | (define (empty) '()) 42 | (define (singleton key value) (add (empty) key value)) 43 | 44 | ;; GETTERS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 45 | 46 | ;; Find the first pair with the given key (first element in the pair). Returns 47 | ;; #f if no such pair is found. 48 | (define (get-pair alist key) 49 | (find 50 | (lambda (pair) (= (car pair) key)) 51 | alist)) 52 | 53 | ;; Find the value (second element in the pair) with the given key (first element 54 | ;; in the pair). Returns #f if no such pair is found. 55 | (define (get alist key) 56 | (let ((pair (get-pair alist key))) 57 | (if pair 58 | (cdr pair) 59 | pair) )) 60 | 61 | ;; Return a list of all the pairs in the given association list, without 62 | ;; duplicate keys. The order of the returned pairs is undefined, but the order 63 | ;; doesn't matter because there are no duplicate keys. 64 | ;; 65 | ;; The returned list is itself an association list. 66 | (define (pairs alist) 67 | (define (add-if-absent pairs-so-far pair-to-add) 68 | (let* ((keys-so-far (map car pairs-so-far)) 69 | (key-to-add (car pair-to-add)) 70 | (key-is-present (any? (lambda (k) (= k key-to-add)) keys-so-far))) 71 | (if key-is-present 72 | pairs-so-far 73 | (cons pair-to-add pairs-so-far)) )) 74 | 75 | (reduce add-if-absent '() alist)) 76 | 77 | ;; PREDICATES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 78 | 79 | (define (has-key? alist key) 80 | (any? 81 | (lambda (pair) (= (car pair) key)) 82 | alist)) 83 | 84 | ;; OPERATIONS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 85 | 86 | (define (add alist key value) 87 | (cons (cons key value) alist) ) 88 | 89 | ;; Given two association lists, merge the two into a single association list. 90 | ;; If the two input lists have any overlapping keys, the value in the second 91 | ;; list will take precedence over the value in the first. 92 | (define (merge alist1 alist2) 93 | ; Make sure the second list comes earlier, in order for its entries to shadow 94 | ; the entries in the first list 95 | (append alist2 alist1)) 96 | 97 | ;; EXPORTS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 98 | 99 | (module-export 100 | ; Constructors 101 | empty 102 | singleton 103 | 104 | ; Getters 105 | get 106 | pairs 107 | 108 | ; Predicates 109 | has-key? 110 | 111 | ; Operations 112 | add 113 | merge) 114 | -------------------------------------------------------------------------------- /stdlib-includes/display-helpers.scm: -------------------------------------------------------------------------------- 1 | (display "loading display-helpers...") 2 | (newline) 3 | 4 | (define (display-with-tag tag message) 5 | (display "[" tag "] " message) 6 | (newline)) 7 | 8 | (define (display-all-with-tag tag . messages) 9 | (foreach (lambda (msg) (display-with-tag tag msg)) messages) ) 10 | 11 | (define (display-non-null messages) 12 | (foreach (lambda (msg) (display msg) (newline)) 13 | (filter (compose not null?) messages)) ) 14 | 15 | (module-export 16 | display-with-tag 17 | display-all-with-tag 18 | display-non-null) 19 | -------------------------------------------------------------------------------- /stdlib-includes/file.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | 6 | garlic_value_t read_text(garlic_value_t filename) { 7 | FILE *file = fopen(garlic_unwrap_string(filename), "r"); 8 | if (!file) { 9 | return garlic_empty_string; 10 | } 11 | 12 | // Go to the end of the file to figure out how many characters there are in 13 | // the file. Then, go back to the beginning of the file so it can be read. 14 | fseek(file, 0, SEEK_END); 15 | long size = ftell(file); 16 | fseek(file, 0, SEEK_SET); 17 | 18 | // Make sure to allocate space for the null-terminator at the end of the 19 | // contents string. 20 | char *contents = malloc(size + 1); 21 | if (!contents) { 22 | return garlic_empty_string; 23 | } 24 | 25 | fread(contents, size, 1, file); 26 | fclose(file); 27 | 28 | contents[size] = 0; 29 | return garlic_wrap_string(contents); 30 | } 31 | 32 | /** 33 | * Writes the given list of bytes to the specified file. Will overwrite any 34 | * contents in the file of the given filename, if present. 35 | */ 36 | garlic_value_t write_bytes(garlic_value_t filename, garlic_value_t bytes) { 37 | const char *c_filename = garlic_unwrap_string(filename); 38 | FILE *file = fopen(c_filename, "wb"); 39 | if (!file) { 40 | char *err = malloc(sizeof(char) * (50 + strlen(c_filename))); 41 | strcpy(err, "could not open file for writing: "); 42 | strcat(err, c_filename); 43 | 44 | error_and_exit(err); 45 | } 46 | 47 | size_t num_bytes = 0; 48 | garlic_value_t bytes_to_count = bytes; 49 | while (bytes_to_count != NIL_VALUE) { 50 | num_bytes++; 51 | bytes_to_count = garlic_cdr(bytes_to_count); 52 | } 53 | 54 | int8_t *raw_bytes = malloc(sizeof(int8_t) * num_bytes); 55 | if (!raw_bytes) { 56 | error_and_exit("unable to allocate memory for bytes to write"); 57 | } 58 | 59 | size_t i = 0; 60 | while (bytes != NIL_VALUE) { 61 | int64_t byte = garlicval_to_int(garlic_car(bytes)); 62 | bytes = garlic_cdr(bytes); 63 | 64 | raw_bytes[i] = (int8_t) (byte & 0xFF); 65 | i++; 66 | } 67 | 68 | fwrite(raw_bytes, sizeof(int8_t), num_bytes, file); 69 | fclose(file); 70 | 71 | return NIL_VALUE; 72 | } 73 | 74 | garlic_native_export_t file_exports[] = { 75 | {"read-text", read_text, 1}, 76 | {"write-bytes", write_bytes, 2}, 77 | 0 78 | }; 79 | -------------------------------------------------------------------------------- /stdlib-includes/garlic.h: -------------------------------------------------------------------------------- 1 | #ifndef GARLIC_H 2 | #define GARLIC_H 3 | 4 | #include 5 | #include 6 | 7 | typedef struct garlic_native_export { 8 | char *name; 9 | void *fn; 10 | unsigned int arity; 11 | unsigned int variadic; 12 | } garlic_native_export_t; 13 | 14 | /* Print out the given message and exit. */ 15 | void error_and_exit(const char *message); 16 | 17 | typedef void * garlic_value_t; 18 | 19 | enum garlic_value_type { 20 | GARLIC_TYPE_NIL, 21 | GARLIC_TYPE_BOOLEAN, 22 | GARLIC_TYPE_FIXNUM, 23 | GARLIC_TYPE_DOUBLE, 24 | GARLIC_TYPE_LAMBDA, 25 | GARLIC_TYPE_ATOM, 26 | GARLIC_TYPE_STRING, 27 | GARLIC_TYPE_CONS, 28 | GARLIC_TYPE_WRAPPED_NATIVE 29 | }; 30 | 31 | /* Determine the type of a alue of type garlic_value_t. */ 32 | enum garlic_value_type garlic_get_type(garlic_value_t val); 33 | 34 | #define NIL_VALUE ((garlic_value_t) 0) 35 | #define TRUE_VALUE ((garlic_value_t) 2) 36 | #define FALSE_VALUE ((garlic_value_t) 4) 37 | 38 | /* Convert a value of type garlic_value_t into an int64_t. */ 39 | int64_t garlicval_to_int(garlic_value_t n); 40 | 41 | /* Convert an int64_t into a value of type garlic_value_t. */ 42 | #define int_to_garlicval(n) ((garlic_value_t) (((n) << 1) | 1)) 43 | 44 | /* Convert a value of type garlic_value_t into a double. */ 45 | double garlicval_to_double(garlic_value_t val); 46 | 47 | /* Convert a double into a value of type garlic_value_t. */ 48 | garlic_value_t double_to_garlicval(double flt); 49 | 50 | /* Wrap a pointer into a structure that can be passed to Garlic. This value 51 | * will not be usable in Garlic, but it can be passed back to the C module and 52 | * unwrapped using "garlic_unwrap_string" to get back the original pointer. 53 | * 54 | * This is so a native value can be passed around between multiple functions. 55 | */ 56 | garlic_value_t garlic_wrap_native(void *native_val); 57 | 58 | /* Unwrap a value of type garlic_value_t to get back the original native 59 | * pointer. It is assumed the pointer was initially wrapped using 60 | * "garlic_wrap_native". */ 61 | void * garlic_unwrap_native(garlic_value_t wrapped); 62 | 63 | /* Wrap a string into a value of type garlic_value_t. */ 64 | garlic_value_t garlic_wrap_string(const char *contents); 65 | 66 | /* To avoid having to re-allocate a garlic_value_t each time, the wrapped 67 | * empty string is always available as a constant. */ 68 | extern garlic_value_t garlic_empty_string; 69 | 70 | /* Given a value of type garlic_value_t, get back the C string contained 71 | * within. */ 72 | const char * garlic_unwrap_string(garlic_value_t wrapped); 73 | 74 | /* given a value of type garlic_value_t, representing a garlic string, get its 75 | * length. This function is provided because the length is cached in the value, 76 | * making it efficient to look up. */ 77 | size_t garlic_string_length(garlic_value_t string); 78 | 79 | /* Register an atom from the given C string value. This process is known as 80 | * "string interning", in which only one copy of a string is stored. If an atom 81 | * with the same name is already present return that, otherwise return a newly- 82 | * created atom. */ 83 | garlic_value_t garlic_intern_atom(char *name); 84 | 85 | /* Returns a C-string representation of an atom's name. Normally, the name 86 | * should not be used, since the point of an atom is that all occurences of a 87 | * specific atom are stored in the same location in memory. However, getting 88 | * the name is useful for purposes such as displaying the name. */ 89 | const char * garlic_atom_name(garlic_value_t atom); 90 | 91 | /* Create a cons cell with the given elements. */ 92 | garlic_value_t garlic_make_cons(garlic_value_t car_val, garlic_value_t cdr_val); 93 | /* Retrieve the first element of a cons cell. */ 94 | garlic_value_t garlic_car(garlic_value_t cons_val); 95 | /* Retrieve the second element of a cons cell. */ 96 | garlic_value_t garlic_cdr(garlic_value_t cons_val); 97 | 98 | /* Calls the provided lambda with the given arguments. The return value of the 99 | * function call is then returned to the caller. */ 100 | garlic_value_t garlic_call_function( 101 | garlic_value_t lambda, 102 | garlic_value_t *args, 103 | size_t num_args); 104 | 105 | #endif 106 | -------------------------------------------------------------------------------- /stdlib-includes/html.scm: -------------------------------------------------------------------------------- 1 | (require string => str) 2 | 3 | (define (tag-fn name nl) 4 | (lambda args 5 | (if (null? args) 6 | (str:concat "<" name " />") 7 | (format-tag-with-args name nl args))) ) 8 | 9 | (define (gather-attrs args) 10 | (define (add-attr attr-name remaining) 11 | (if (null? remaining) 12 | '() ; should not happen 13 | (cons (cons attr-name (car remaining)) (gather-attrs (cdr remaining))) )) 14 | 15 | (cond 16 | ((null? args) '()) 17 | ((symbol? (car args)) (add-attr (car args) (cdr args))) 18 | (else (gather-attrs (cdr args)))) ) 19 | 20 | (define (tag-children args) 21 | (define (remove-attr remaining) 22 | (let* ((first (car remaining)) 23 | (len-rest (length (cdr remaining))) ) 24 | (if (symbol? first) 25 | (if (= len-rest 0) 26 | '() 27 | (tag-children (cdr (cdr remaining))) ) 28 | (cons first (tag-children (cdr remaining))) ) )) 29 | 30 | (if (null? args) 31 | '() 32 | (remove-attr args)) ) 33 | 34 | (define (format-tag-with-args name nl args) 35 | (define (format-attr attr) 36 | (str:concat 37 | (str:symbol->str (car attr)) 38 | "=\"" 39 | (cdr attr) 40 | "\"")) 41 | 42 | (define (format-attrs attrs) 43 | (map format-attr attrs)) 44 | 45 | (let ((attrs (gather-attrs args)) 46 | (children (tag-children args)) 47 | (sep (if nl "\n" ""))) 48 | (str:concat 49 | "<" 50 | name 51 | (if (null? attrs) "" " ") 52 | (str:concat-list (format-attrs attrs)) 53 | ">" 54 | sep 55 | (str:concat-list children) 56 | sep 57 | "")) ) 60 | 61 | (define html (tag-fn "html" #t)) 62 | (define title (tag-fn "title" #f)) 63 | (define body (tag-fn "body" #t)) 64 | (define p (tag-fn "p" #f)) 65 | (define a (tag-fn "a" #f)) 66 | (define img (tag-fn "img" #f)) 67 | 68 | (define (head title-text . children) 69 | (format-tag-with-args "head" #t (cons (title title-text) children)) ) 70 | 71 | (module-export 72 | html 73 | head 74 | body 75 | p 76 | a 77 | img) 78 | -------------------------------------------------------------------------------- /stdlib-includes/http.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | 7 | int handle_request( 8 | void *cls, 9 | struct MHD_Connection *connection, 10 | const char *url, 11 | const char *method, 12 | const char *version, 13 | const char *upload_data, 14 | size_t *upload_data_size, 15 | void **con_cls) { 16 | static int connection_marker; 17 | 18 | if (strcmp(method, "GET") != 0) { 19 | printf("HTTP server only accepts GET requests for now\n"); 20 | return MHD_NO; 21 | } 22 | 23 | if (*con_cls != &connection_marker) { 24 | // The first time, only the headers are valid. Do not respond in the 25 | // first round. 26 | *con_cls = &connection_marker; 27 | return MHD_YES; 28 | } 29 | 30 | *con_cls = NULL; // clear context pointer 31 | 32 | garlic_value_t callback = cls; 33 | garlic_value_t callback_args[] = {}; 34 | garlic_value_t response_body = garlic_call_function( 35 | callback, 36 | callback_args, 37 | 0); 38 | 39 | const char *response_body_str = garlic_unwrap_string(response_body); 40 | size_t response_body_size = garlic_string_length(response_body); 41 | 42 | struct MHD_Response *response = MHD_create_response_from_buffer( 43 | response_body_size, 44 | (void *)response_body_str, 45 | MHD_RESPMEM_PERSISTENT); 46 | 47 | int ret = MHD_queue_response( 48 | connection, 49 | MHD_HTTP_OK, 50 | response); 51 | 52 | MHD_destroy_response(response); 53 | return ret; 54 | } 55 | 56 | garlic_value_t serve(garlic_value_t port, garlic_value_t callback) { 57 | struct MHD_Daemon *d = MHD_start_daemon( 58 | MHD_USE_THREAD_PER_CONNECTION, 59 | garlicval_to_int(port), 60 | NULL, 61 | NULL, 62 | &handle_request, 63 | callback, 64 | MHD_OPTION_END); 65 | 66 | if (d == NULL) { 67 | printf("Unable to start HTTP server\n"); 68 | return NIL_VALUE; 69 | } 70 | 71 | printf("Started HTTP server on port %" PRId64 "\n", 72 | garlicval_to_int(port)); 73 | 74 | // Wait indefinitely for the user to interrupt the process. 75 | sigset_t mask; 76 | sigemptyset(&mask); 77 | sigsuspend(&mask); 78 | 79 | MHD_stop_daemon(d); 80 | 81 | return NIL_VALUE; 82 | } 83 | 84 | garlic_native_export_t http_exports[] = { 85 | {"serve", serve, 2}, 86 | 0 87 | }; 88 | -------------------------------------------------------------------------------- /stdlib-includes/rand.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #include 4 | #include 5 | 6 | /* Can't be more than 256, as `getentropy` doesn't support larger sizes. */ 7 | static const size_t RAND_BUFFER_LENGTH = 128; 8 | 9 | garlic_value_t rand_atom() { 10 | char *buf = malloc(RAND_BUFFER_LENGTH + 1); // leave room for NULL-terminator 11 | if (!buf) { 12 | error_and_exit("rand_atom: unable to allocate buffer"); 13 | } 14 | 15 | int result = getentropy(buf, RAND_BUFFER_LENGTH); 16 | if (result != 0) { 17 | error_and_exit("rand_atom: unable to get enough random bytes"); 18 | } 19 | 20 | // Convert any non-identifier-style characters into the right ASCII range 21 | for (int i = 0; i < RAND_BUFFER_LENGTH; i++) { 22 | unsigned char b = buf[i]; 23 | 24 | // Alphabetical characters, upper or lowercase are okay 25 | if ((b >= 65 && b <= 90) || 26 | (b >= 97 && b <= 122)) { continue; } 27 | 28 | // In the future, maybe we can support numeric characters in non-initial 29 | // positions. The tricky part is that the process of converting non-allowed 30 | // characters into allowed characters will differ based on whether numbers 31 | // are allowed in a given position. 32 | 33 | // Otherwise, bring the byte into the correct range. To do this, start by 34 | // sliding the byte value into a continuous range, meaning offset larger 35 | // values assuming the alphabetical range doesn't exist. 36 | if (b > 122) { b -= 52; } // Account for both cases 37 | else if (b > 90) { b -= 26; } // Account for only uppercase 38 | 39 | // With the byte in the range [0, 204), bring it into the [0, 52) range. 40 | // Note that this transformation is not uniform, so certain final values 41 | // are less likely than others. 42 | b = b % 52; 43 | 44 | if (b <= 25) { buf[i] = b + 65; } // uppercase 45 | else { buf[i] = b - 26 + 97; } // lowercase 46 | } 47 | 48 | buf[RAND_BUFFER_LENGTH] = 0; 49 | return garlic_intern_atom(buf); 50 | } 51 | 52 | garlic_native_export_t rand_exports[] = { 53 | {"rand-atom", rand_atom, 0}, 54 | 0 55 | }; 56 | -------------------------------------------------------------------------------- /stdlib-includes/sdl2.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #ifdef __APPLE__ 5 | #include 6 | #else 7 | #include 8 | #endif 9 | 10 | // Support for SDL 2.0.0, which doesn't include this flag. If the flag is not 11 | // available, assume that high DPI support is also unavailable. 12 | #ifndef SDL_WINDOW_ALLOW_HIGHDPI 13 | #define SDL_WINDOW_ALLOW_HIGHDPI 0 14 | #endif 15 | 16 | struct context { 17 | SDL_Window *window; 18 | SDL_Renderer *renderer; 19 | SDL_Texture *texture; 20 | 21 | int w; 22 | int h; 23 | }; 24 | 25 | typedef struct context *context; 26 | 27 | garlic_value_t cleanup(garlic_value_t ctx); 28 | 29 | garlic_value_t init( 30 | garlic_value_t s_title, 31 | garlic_value_t s_w, 32 | garlic_value_t s_h) { 33 | context ctx = (context) malloc(sizeof(struct context)); 34 | 35 | if (ctx == NULL) { 36 | printf("Unable to allocate memory for sdl_context"); 37 | return NIL_VALUE; 38 | } 39 | 40 | if (SDL_Init(SDL_INIT_VIDEO) != 0) { 41 | printf("SDL_Init ERROR: %s\n", SDL_GetError()); 42 | cleanup(ctx); 43 | return NIL_VALUE; 44 | } 45 | 46 | const char *title = garlic_unwrap_string(s_title); 47 | int w = garlicval_to_int(s_w); 48 | int h = garlicval_to_int(s_h); 49 | 50 | ctx->window = SDL_CreateWindow( 51 | title, 52 | SDL_WINDOWPOS_UNDEFINED, 53 | SDL_WINDOWPOS_UNDEFINED, 54 | w, 55 | h, 56 | SDL_WINDOW_SHOWN | SDL_WINDOW_ALLOW_HIGHDPI 57 | ); 58 | 59 | if (ctx->window == NULL) { 60 | printf("SDL_CreateWindow ERROR: %s\n", SDL_GetError()); 61 | cleanup(ctx); 62 | return NIL_VALUE; 63 | } 64 | 65 | ctx->renderer = SDL_CreateRenderer( 66 | ctx->window, 67 | -1, 68 | SDL_RENDERER_ACCELERATED | SDL_RENDERER_PRESENTVSYNC 69 | ); 70 | 71 | if (ctx->renderer == NULL) { 72 | printf("SDL_CreateRenderer ERROR: %s\n", SDL_GetError()); 73 | cleanup(ctx); 74 | return NIL_VALUE; 75 | } 76 | 77 | return garlic_wrap_native(ctx); 78 | } 79 | 80 | garlic_value_t load_img(garlic_value_t s_ctx, garlic_value_t s_filename) { 81 | const char *filename = garlic_unwrap_string(s_filename); 82 | 83 | SDL_Surface *img = IMG_Load(filename); 84 | 85 | if (img == NULL) { 86 | printf("SDL_LoadIMG ERROR: %s\n", SDL_GetError()); 87 | return NIL_VALUE; 88 | } 89 | 90 | return garlic_wrap_native(img); 91 | } 92 | 93 | garlic_value_t show_img(garlic_value_t s_ctx, garlic_value_t s_img) { 94 | context ctx = (context) garlic_unwrap_native(s_ctx); 95 | SDL_Surface *img = (SDL_Surface *) garlic_unwrap_native(s_img); 96 | 97 | ctx->texture = SDL_CreateTextureFromSurface(ctx->renderer, img); 98 | 99 | if (ctx->texture == NULL) { 100 | printf("SDL_CreateTexture ERROR: %s\n", SDL_GetError()); 101 | cleanup(ctx); 102 | return NIL_VALUE; 103 | } 104 | 105 | SDL_RenderClear(ctx->renderer); 106 | SDL_RenderCopy(ctx->renderer, ctx->texture, NULL, NULL); 107 | SDL_RenderPresent(ctx->renderer); 108 | 109 | return NIL_VALUE; 110 | } 111 | 112 | garlic_value_t free_image(garlic_value_t s_img) { 113 | SDL_Surface *img = (SDL_Surface *) garlic_unwrap_native(s_img); 114 | 115 | if (img != NULL) SDL_FreeSurface(img); 116 | return NIL_VALUE; 117 | } 118 | 119 | garlic_value_t main_loop(garlic_value_t s_ctx) { 120 | context ctx = (context) garlic_unwrap_native(s_ctx); 121 | 122 | SDL_RenderClear(ctx->renderer); 123 | SDL_RenderCopy(ctx->renderer, ctx->texture, NULL, NULL); 124 | SDL_RenderPresent(ctx->renderer); 125 | 126 | int quit = 0; 127 | SDL_Event event; 128 | while (!quit) { 129 | SDL_WaitEvent(&event); 130 | 131 | switch (event.type) { 132 | case SDL_QUIT: 133 | quit = 1; 134 | break; 135 | } 136 | } 137 | 138 | cleanup(ctx); 139 | 140 | SDL_Quit(); 141 | return NIL_VALUE; 142 | } 143 | 144 | garlic_value_t cleanup(garlic_value_t s_ctx) { 145 | context ctx = (context) garlic_unwrap_native(s_ctx); 146 | 147 | if (ctx == NULL) return NIL_VALUE; 148 | 149 | if (ctx->window != NULL) SDL_DestroyWindow(ctx->window); 150 | if (ctx->renderer != NULL) SDL_DestroyRenderer(ctx->renderer); 151 | if (ctx->texture != NULL) SDL_DestroyTexture(ctx->texture); 152 | 153 | free(ctx); 154 | return NIL_VALUE; 155 | } 156 | 157 | garlic_native_export_t sdl2_exports[] = { 158 | {"init", init, 3}, 159 | {"load-img", load_img, 3}, 160 | {"show-img", show_img, 2}, 161 | {"free-img", free_image, 1}, 162 | {"main-loop", main_loop, 1}, 163 | {"cleanup", cleanup, 1}, 164 | 0 165 | }; 166 | -------------------------------------------------------------------------------- /stdlib-includes/set.scm: -------------------------------------------------------------------------------- 1 | ;; A "set" data structure where every element appears exactly once. The 2 | ;; equality of elements in the set are determined by a user-supplied equality 3 | ;; function, and convenience constructors are provided when the equality 4 | ;; function is simply "=". 5 | ;; 6 | ;; Note that, in order to achieve simplicity of implementation, this data 7 | ;; structure implements inefficient operations. For example, containment checks 8 | ;; are O(N), meaning the "add-all" operator is O(N*M). Do not depend on this 9 | ;; data structure for large data sets. 10 | 11 | ;; CONSTRUCTORS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | 13 | (define (new-with-equality fn= items) (cons fn= items)) 14 | (define (new items) (new-with-equality = items)) 15 | 16 | (define (empty-with-equality fn=) (new-with-equality fn= '())) 17 | (define empty (empty-with-equality =)) 18 | 19 | ;; GETTERS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 20 | 21 | (define get-fn= car) 22 | (define get-items cdr) 23 | 24 | ;; PREDICATES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 25 | 26 | (define (contains? set item) 27 | (let ((fn= (get-fn= set)) 28 | (items (get-items set))) 29 | (any? (lambda (x) (fn= x item)) items) )) 30 | 31 | ;; OPERATIONS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 32 | 33 | ; Internal - create a new set with all the same properties as the original set 34 | ; (namely the same equality function), but with the given items. 35 | (define (update-items set new-items) 36 | (new-with-equality 37 | (get-fn= set) 38 | new-items) ) 39 | 40 | (define (add-all set items-to-add) 41 | (let ((items-not-in-set (reject (lambda (x) (contains? set x)) items-to-add)) 42 | (set-items (get-items set))) 43 | (update-items set (append set-items items-not-in-set)) )) 44 | 45 | ;; EXPORTS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 46 | 47 | (module-export 48 | ; Constructors 49 | empty 50 | empty-with-equality 51 | new 52 | new-with-equality 53 | 54 | ; Predicates 55 | contains? 56 | 57 | ; Operations 58 | add-all) 59 | -------------------------------------------------------------------------------- /stdlib-includes/stdlib.scm: -------------------------------------------------------------------------------- 1 | (define (newline) 2 | (display "\n")) 3 | 4 | (define (not val) 5 | (if val #f #t)) 6 | 7 | (define (length ls) 8 | (if (null? ls) 9 | 0 10 | (+ 1 (length (cdr ls))) ) ) 11 | 12 | (define (append l1 l2 . others) 13 | ; 1. others is empty 14 | ; 2. others has one list 15 | ; 3. others has more than one list 16 | 17 | (define (append-one l1 l2) 18 | (if (null? l1) 19 | l2 20 | (cons (car l1) (append (cdr l1) l2)) ) ) 21 | 22 | (define (helper lists) 23 | (if (null? lists) 24 | '() 25 | (append-one (car lists) (helper (cdr lists))) ) ) 26 | 27 | (append-one l1 (append-one l2 (helper others))) ) 28 | 29 | 30 | (define (map f ls) 31 | (if (null? ls) 32 | '() 33 | (cons (f (car ls)) (map f (cdr ls))) ) ) 34 | 35 | (define (filter f ls) 36 | (if (null? ls) 37 | '() 38 | (if (f (car ls)) 39 | (cons (car ls) (filter f (cdr ls))) 40 | (filter f (cdr ls)) ) ) ) 41 | 42 | (define (reject f ls) 43 | (filter (lambda (x) (not (f x))) ls) ) 44 | 45 | (define (find predicate ls) 46 | (cond ((null? ls) #f) 47 | ((predicate (car ls)) (car ls)) 48 | (else (find predicate (cdr ls))) )) 49 | 50 | (define (reduce f zero ls) 51 | (if (null? ls) 52 | zero 53 | (reduce f (f zero (car ls)) (cdr ls)) ) ) 54 | 55 | (define (sum ls) 56 | (reduce + 0 ls)) 57 | 58 | (define (foreach f ls) 59 | (if (null? ls) 60 | '() 61 | ((lambda () 62 | (f (car ls)) 63 | (foreach f (cdr ls)) 64 | '()) )) ) ; return nil no matter what 65 | 66 | (define (any? pred ls) 67 | (cond ((null? ls) #f) 68 | ((pred (car ls)) #t) 69 | (else (any? pred (cdr ls))) )) 70 | 71 | (define (identity x) x) 72 | 73 | (define (compose . fs) 74 | (define (compose2 f g) 75 | (lambda (x) (f (g x))) ) 76 | 77 | (define (helper fs) 78 | (if (null? fs) 79 | identity 80 | (compose2 (car fs) (helper (cdr fs))) )) 81 | 82 | (helper fs) ) 83 | 84 | (define (list . x) x) 85 | 86 | (module-export 87 | newline 88 | not 89 | length 90 | append 91 | map 92 | filter 93 | reject 94 | find 95 | reduce 96 | sum 97 | foreach 98 | any? 99 | identity 100 | compose 101 | list) 102 | -------------------------------------------------------------------------------- /stdlib-includes/string.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "../garlic-internal.h" 3 | 4 | #include 5 | #include 6 | #include 7 | #include 8 | 9 | static garlic_value_t nullp(garlic_value_t str) { 10 | if (garlic_get_type(str) != GARLIC_TYPE_STRING) { 11 | error_and_exit("ERROR - string:nullp - value is not a string"); 12 | } 13 | 14 | return garlic_string_length(str) == 0 ? TRUE_VALUE : FALSE_VALUE; 15 | } 16 | 17 | static garlic_value_t length(garlic_value_t str) { 18 | if (garlic_get_type(str) != GARLIC_TYPE_STRING) { 19 | error_and_exit("ERROR - string:length - value is not a string"); 20 | } 21 | 22 | return int_to_garlicval(garlic_string_length(str)); 23 | } 24 | 25 | garlic_value_t concat_list(garlic_value_t list) { 26 | if (list != NIL_VALUE && 27 | garlic_get_type(list) != GARLIC_TYPE_CONS) { 28 | printf("non-list passed to concat-list\n"); 29 | return NIL_VALUE; 30 | } 31 | 32 | return garlic_internal_string_concat(list); 33 | } 34 | 35 | garlic_value_t string_tail(garlic_value_t str, garlic_value_t index) { 36 | if (garlic_get_type(str) != GARLIC_TYPE_STRING) { 37 | error_and_exit("ERROR - string:string-tail - value is not a string"); 38 | } 39 | 40 | if (garlic_get_type(index) != GARLIC_TYPE_FIXNUM) { 41 | error_and_exit("ERROR - string:string-tail - index is not an integer"); 42 | } 43 | 44 | int64_t i = garlicval_to_int(index); 45 | 46 | if (i == 0) { 47 | return str; 48 | } 49 | 50 | if (i >= garlic_string_length(str)) { 51 | return garlic_empty_string; 52 | } 53 | 54 | return garlic_wrap_string(garlic_unwrap_string(str) + i); 55 | } 56 | 57 | garlic_value_t symbol_to_str(garlic_value_t sym) { 58 | if (garlic_get_type(sym) != GARLIC_TYPE_ATOM) { 59 | printf("non-symbol passed to symbol->str\n"); 60 | return NIL_VALUE; 61 | } 62 | 63 | return garlic_wrap_string(garlic_atom_name(sym)); 64 | } 65 | 66 | garlic_value_t string_equalp(garlic_value_t str1, garlic_value_t str2) { 67 | if (garlic_get_type(str1) != GARLIC_TYPE_STRING || 68 | garlic_get_type(str2) != GARLIC_TYPE_STRING) { 69 | error_and_exit("ERROR - string=? can only compare strings"); 70 | } 71 | 72 | const char *cstr1 = garlic_unwrap_string(str1); 73 | const char *cstr2 = garlic_unwrap_string(str2); 74 | return strcmp(cstr1, cstr2) == 0 ? TRUE_VALUE : FALSE_VALUE; 75 | } 76 | 77 | garlic_value_t character_at(garlic_value_t str, garlic_value_t index) { 78 | if (garlic_get_type(str) != GARLIC_TYPE_STRING) { 79 | error_and_exit("ERROR - string:at - value is not a string"); 80 | } 81 | 82 | if (garlic_get_type(index) != GARLIC_TYPE_FIXNUM) { 83 | error_and_exit("ERROR - string:at - index is not an integer"); 84 | } 85 | 86 | int64_t i = garlicval_to_int(index); 87 | if (i >= garlic_string_length(str)) { 88 | return NIL_VALUE; 89 | } 90 | 91 | char *result = (char *) malloc(sizeof(char) * 2); 92 | result[0] = garlic_unwrap_string(str)[i]; 93 | result[1] = 0; 94 | return garlic_wrap_string(result); 95 | } 96 | 97 | garlic_value_t downcase(garlic_value_t str) { 98 | if (garlic_get_type(str) != GARLIC_TYPE_STRING) { 99 | error_and_exit("ERROR - string:downcase - value is not a string"); 100 | } 101 | 102 | const char *cstr = garlic_unwrap_string(str); 103 | size_t len = garlic_string_length(str); 104 | 105 | char *result = (char *) malloc(sizeof(char) * (len + 1)); 106 | 107 | for (int i = 0; i < len; i++) { 108 | result[i] = tolower(cstr[i]); 109 | } 110 | 111 | result[len] = 0; 112 | return garlic_wrap_string(result); 113 | } 114 | 115 | garlic_native_export_t string_exports[] = { 116 | {"null?", nullp, 1}, 117 | {"length", length, 1}, 118 | {"concat", garlic_internal_string_concat, 0, 1}, 119 | {"concat-list", concat_list, 1}, 120 | {"string-tail", string_tail, 2}, 121 | {"symbol->str", symbol_to_str, 1}, 122 | {"string=?", string_equalp, 2}, 123 | {"at", character_at, 2}, 124 | {"downcase", downcase, 1}, 125 | 0 126 | }; 127 | -------------------------------------------------------------------------------- /test/aux/auxillary-module.scm: -------------------------------------------------------------------------------- 1 | ;; An auxillary module used by the tests. This module is not meant to be tested 2 | ;; in isolation, but it is provided as something that can be required as 3 | ;; necessary by the tests. 4 | 5 | (display "loading auxillary-module...") 6 | (newline) 7 | (newline) 8 | 9 | (define (auxillary-function x) 10 | (display "auxillary-function: ") 11 | (display x) 12 | (newline)) 13 | 14 | ; By not exporting this method, it should not be callable from outside this 15 | ; module. 16 | (define (private-method) 17 | "this is a private method") 18 | 19 | (define auxillary-symbol 'auxillary-symbol) 20 | 21 | (module-export 22 | ; exports 23 | auxillary-function 24 | auxillary-symbol) 25 | -------------------------------------------------------------------------------- /test/aux/circ1.scm: -------------------------------------------------------------------------------- 1 | (require "auxillary-module") 2 | (require "circ2") 3 | 4 | (display "loading circ1...") (newline) 5 | 6 | (define (no-deps) 1) 7 | (define (depends-on-circ2) 8 | (+ 10 (circ2:no-deps))) 9 | 10 | (module-export 11 | no-deps 12 | depends-on-circ2) 13 | -------------------------------------------------------------------------------- /test/aux/circ2.scm: -------------------------------------------------------------------------------- 1 | (require "auxillary-module") 2 | (require "circ1") 3 | 4 | (display "loading circ2...") (newline) 5 | 6 | (define (no-deps) 2) 7 | (define (depends-on-circ1) 8 | (+ 10 (circ1:no-deps))) 9 | 10 | (module-export 11 | no-deps 12 | depends-on-circ1) 13 | -------------------------------------------------------------------------------- /test/aux/hexdump.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #include 4 | 5 | /** 6 | * Function that prints the given list of bytes to the standard output. Assumes 7 | * the bytes are provided in one shot, allowing this function to break up the 8 | * bytes into manageable chunks for pretty-printing. 9 | */ 10 | garlic_value_t print_bytes(garlic_value_t bytes) { 11 | int i = 0; 12 | while (bytes != NIL_VALUE) { 13 | int64_t byte = garlicval_to_int(garlic_car(bytes)); 14 | bytes = garlic_cdr(bytes); 15 | 16 | printf("%02x ", byte); 17 | 18 | if (i % 16 == 3 || i % 16 == 11) { printf(" "); } 19 | if (i % 16 == 7) { printf(" "); } 20 | if (i % 16 == 15) { printf("\n"); } 21 | 22 | i++; 23 | } 24 | 25 | printf("\n"); 26 | 27 | return NIL_VALUE; 28 | } 29 | 30 | garlic_native_export_t hexdump_exports[] = { 31 | {"print-bytes", print_bytes, 1}, 32 | 0 33 | }; 34 | -------------------------------------------------------------------------------- /test/aux/libc_module.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | // This function will not be included as part of the exports, so it will not be 5 | // accessible outside this module. 6 | garlic_value_t private_identity(garlic_value_t input) { 7 | return input; 8 | } 9 | 10 | garlic_value_t add(garlic_value_t a, garlic_value_t b) { 11 | printf("Adding %" PRId64 " and %" PRId64 " in C!\n", 12 | garlicval_to_int(a), garlicval_to_int(b)); 13 | 14 | return private_identity( 15 | int_to_garlicval(garlicval_to_int(a) + garlicval_to_int(b)) 16 | ); 17 | } 18 | 19 | garlic_value_t lastarg12( 20 | garlic_value_t a, 21 | garlic_value_t b, 22 | garlic_value_t c, 23 | garlic_value_t d, 24 | garlic_value_t e, 25 | garlic_value_t f, 26 | garlic_value_t g, 27 | garlic_value_t h, 28 | garlic_value_t i, 29 | garlic_value_t j, 30 | garlic_value_t k, 31 | garlic_value_t l 32 | ) { 33 | printf("Returning 12th argument from C!\n"); 34 | return l; 35 | } 36 | 37 | /* A series of functions with different arities, useful for testing various 38 | * scenarios regarding passing arguments via registers. */ 39 | 40 | garlic_value_t arg0() { 41 | return int_to_garlicval(0); 42 | } 43 | 44 | garlic_value_t arg1(garlic_value_t a) { 45 | int64_t ca = garlicval_to_int(a); 46 | printf("%" PRId64 " = ", ca); 47 | 48 | return a; 49 | } 50 | 51 | garlic_value_t arg2( 52 | garlic_value_t a, 53 | garlic_value_t b) { 54 | int64_t ca = garlicval_to_int(a); 55 | int64_t cb = garlicval_to_int(b); 56 | 57 | printf("%" PRId64 58 | " + %" PRId64 " = ", 59 | ca, cb); 60 | 61 | int64_t sum = ca + cb; 62 | return int_to_garlicval(sum); 63 | } 64 | 65 | garlic_value_t arg3( 66 | garlic_value_t a, 67 | garlic_value_t b, 68 | garlic_value_t c) { 69 | int64_t ca = garlicval_to_int(a); 70 | int64_t cb = garlicval_to_int(b); 71 | int64_t cc = garlicval_to_int(c); 72 | 73 | printf("%" PRId64 74 | " + %" PRId64 75 | " + %" PRId64 " = ", 76 | ca, cb, cc); 77 | 78 | int64_t sum = ca + cb + cc; 79 | return int_to_garlicval(sum); 80 | } 81 | 82 | garlic_value_t arg4( 83 | garlic_value_t a, 84 | garlic_value_t b, 85 | garlic_value_t c, 86 | garlic_value_t d) { 87 | int64_t ca = garlicval_to_int(a); 88 | int64_t cb = garlicval_to_int(b); 89 | int64_t cc = garlicval_to_int(c); 90 | int64_t cd = garlicval_to_int(d); 91 | 92 | printf("%" PRId64 93 | " + %" PRId64 94 | " + %" PRId64 95 | " + %" PRId64 " = ", 96 | ca, cb, cc, cd); 97 | 98 | int64_t sum = ca + cb + cc + cd; 99 | return int_to_garlicval(sum); 100 | } 101 | 102 | garlic_value_t arg5( 103 | garlic_value_t a, 104 | garlic_value_t b, 105 | garlic_value_t c, 106 | garlic_value_t d, 107 | garlic_value_t e) { 108 | int64_t ca = garlicval_to_int(a); 109 | int64_t cb = garlicval_to_int(b); 110 | int64_t cc = garlicval_to_int(c); 111 | int64_t cd = garlicval_to_int(d); 112 | int64_t ce = garlicval_to_int(e); 113 | 114 | printf("%" PRId64 115 | " + %" PRId64 116 | " + %" PRId64 117 | " + %" PRId64 118 | " + %" PRId64 " = ", 119 | ca, cb, cc, cd, ce); 120 | 121 | int64_t sum = ca + cb + cc + cd + ce; 122 | return int_to_garlicval(sum); 123 | } 124 | 125 | garlic_value_t arg6( 126 | garlic_value_t a, 127 | garlic_value_t b, 128 | garlic_value_t c, 129 | garlic_value_t d, 130 | garlic_value_t e, 131 | garlic_value_t f) { 132 | int64_t ca = garlicval_to_int(a); 133 | int64_t cb = garlicval_to_int(b); 134 | int64_t cc = garlicval_to_int(c); 135 | int64_t cd = garlicval_to_int(d); 136 | int64_t ce = garlicval_to_int(e); 137 | int64_t cf = garlicval_to_int(f); 138 | 139 | printf("%" PRId64 140 | " + %" PRId64 141 | " + %" PRId64 142 | " + %" PRId64 143 | " + %" PRId64 144 | " + %" PRId64 " = ", 145 | ca, cb, cc, cd, ce, cf); 146 | 147 | int64_t sum = ca + cb + cc + cd + ce + cf; 148 | return int_to_garlicval(sum); 149 | } 150 | 151 | // More than 6 parameters means spilling onto the stack. 152 | garlic_value_t arg8( 153 | garlic_value_t a, 154 | garlic_value_t b, 155 | garlic_value_t c, 156 | garlic_value_t d, 157 | garlic_value_t e, 158 | garlic_value_t f, 159 | garlic_value_t g, 160 | garlic_value_t h) { 161 | int64_t ca = garlicval_to_int(a); 162 | int64_t cb = garlicval_to_int(b); 163 | int64_t cc = garlicval_to_int(c); 164 | int64_t cd = garlicval_to_int(d); 165 | int64_t ce = garlicval_to_int(e); 166 | int64_t cf = garlicval_to_int(f); 167 | int64_t cg = garlicval_to_int(g); 168 | int64_t ch = garlicval_to_int(h); 169 | 170 | printf("%" PRId64 171 | " + %" PRId64 172 | " + %" PRId64 173 | " + %" PRId64 174 | " + %" PRId64 175 | " + %" PRId64 176 | " + %" PRId64 177 | " + %" PRId64 " = ", 178 | ca, cb, cc, cd, ce, cf, cg, ch); 179 | 180 | int64_t sum = ca + cb + cc + cd + ce + cf + cg + ch; 181 | return int_to_garlicval(sum); 182 | } 183 | 184 | garlic_value_t callme5(garlic_value_t fn) { 185 | garlic_value_t args[] = { 186 | int_to_garlicval(1), 187 | int_to_garlicval(2), 188 | int_to_garlicval(3), 189 | int_to_garlicval(4), 190 | int_to_garlicval(5) 191 | }; 192 | 193 | return garlic_call_function(fn, args, 5); 194 | } 195 | 196 | garlic_value_t callme6(garlic_value_t fn) { 197 | garlic_value_t args[] = { 198 | int_to_garlicval(1), 199 | int_to_garlicval(2), 200 | int_to_garlicval(3), 201 | int_to_garlicval(4), 202 | int_to_garlicval(5), 203 | int_to_garlicval(6) 204 | }; 205 | 206 | return garlic_call_function(fn, args, 6); 207 | } 208 | 209 | garlic_native_export_t libc_module_exports[] = { 210 | {"add", add, 2}, 211 | {"lastarg12", lastarg12, 12}, 212 | {"arg0", arg0, 0}, 213 | {"arg1", arg1, 1}, 214 | {"arg2", arg2, 2}, 215 | {"arg3", arg3, 3}, 216 | {"arg4", arg4, 4}, 217 | {"arg5", arg5, 5}, 218 | {"arg6", arg6, 6}, 219 | {"arg8", arg8, 8}, 220 | {"callme5", callme5, 1}, 221 | {"callme6", callme6, 1}, 222 | 0 223 | }; 224 | -------------------------------------------------------------------------------- /test/aux/libc_variadic_module.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | // This function will be exported twice under two different names, once where 5 | // the exports list specifies the is_vararg flag, and once where it doesn't. 6 | // This will test that the flag defaults to "false". 7 | garlic_value_t non_variadic_add(garlic_value_t a, garlic_value_t b) { 8 | return int_to_garlicval(garlicval_to_int(a) + garlicval_to_int(b)); 9 | } 10 | 11 | // This is a private function used to implement the rest of the functions. 12 | garlic_value_t add_all(garlic_value_t items) { 13 | int64_t sum = 0; 14 | 15 | while (items != NIL_VALUE) { 16 | garlic_value_t item = garlic_car(items); 17 | items = garlic_cdr(items); 18 | 19 | sum += garlicval_to_int(item); 20 | } 21 | 22 | return int_to_garlicval(sum); 23 | } 24 | 25 | garlic_value_t variadic0_add(garlic_value_t items) { 26 | return add_all(items); 27 | } 28 | 29 | garlic_value_t variadic1_add(garlic_value_t arg0, garlic_value_t items) { 30 | printf("Required args: %" PRId64 "\n", garlicval_to_int(arg0)); 31 | return add_all(items); 32 | } 33 | 34 | garlic_value_t variadic9_add( 35 | garlic_value_t arg0, 36 | garlic_value_t arg1, 37 | garlic_value_t arg2, 38 | garlic_value_t arg3, 39 | garlic_value_t arg4, 40 | garlic_value_t arg5, 41 | garlic_value_t arg6, 42 | garlic_value_t arg7, 43 | garlic_value_t arg8, 44 | garlic_value_t items) { 45 | printf("Required args: %" PRId64 "\n" 46 | " %" PRId64 "\n" 47 | " %" PRId64 "\n" 48 | " %" PRId64 "\n" 49 | " %" PRId64 "\n" 50 | " %" PRId64 "\n" 51 | " %" PRId64 "\n" 52 | " %" PRId64 "\n" 53 | " %" PRId64 "\n", 54 | garlicval_to_int(arg0), 55 | garlicval_to_int(arg1), 56 | garlicval_to_int(arg2), 57 | garlicval_to_int(arg3), 58 | garlicval_to_int(arg4), 59 | garlicval_to_int(arg5), 60 | garlicval_to_int(arg6), 61 | garlicval_to_int(arg7), 62 | garlicval_to_int(arg8)); 63 | return add_all(items); 64 | } 65 | 66 | garlic_native_export_t libc_variadic_module_exports[] = { 67 | {"non_variadic_add_no_flag", non_variadic_add, 2}, 68 | {"non_variadic_add_flag", non_variadic_add, 2, 0}, 69 | {"variadic0_add", variadic0_add, 0, 1}, 70 | {"variadic1_add", variadic1_add, 1, 1}, 71 | {"variadic9_add", variadic9_add, 9, 1}, 72 | 0 73 | }; 74 | -------------------------------------------------------------------------------- /test/aux/many-exports-1.scm: -------------------------------------------------------------------------------- 1 | (define (f0) "f0") 2 | (define (f1) "f1") 3 | (define (f2) "f2") 4 | 5 | (module-export 6 | f0 7 | f1 8 | f2) 9 | -------------------------------------------------------------------------------- /test/aux/many-exports-2.scm: -------------------------------------------------------------------------------- 1 | (define (g0) "g0") 2 | (define (g1) "g1") 3 | (define (g2) "g2") 4 | 5 | (module-export 6 | g0 7 | g1 8 | g2) 9 | -------------------------------------------------------------------------------- /test/failure-compile/begin-no-statements.scm: -------------------------------------------------------------------------------- 1 | (begin) 2 | -------------------------------------------------------------------------------- /test/failure-compile/empty-list-no-quoting.scm: -------------------------------------------------------------------------------- 1 | (display ()) (newline) 2 | -------------------------------------------------------------------------------- /test/failure-compile/let-depending-on-last.scm: -------------------------------------------------------------------------------- 1 | (let ((a 1) 2 | (b (+ 2 a))) 3 | b) 4 | -------------------------------------------------------------------------------- /test/failure-compile/let-depending-on-later.scm: -------------------------------------------------------------------------------- 1 | (let ((a (lambda (x) (+ x b))) 2 | (b 2)) 3 | (a 3)) 4 | -------------------------------------------------------------------------------- /test/failure-compile/let-list-matching-invalid-dotted-list.scm: -------------------------------------------------------------------------------- 1 | (let (((1 . 2) '(3 . 4))) 2 | (newline)) 3 | -------------------------------------------------------------------------------- /test/failure-compile/let-star-depending-on-later.scm: -------------------------------------------------------------------------------- 1 | (let* ((a (lambda (x) (+ x b))) 2 | (b 2)) 3 | (a 3)) 4 | -------------------------------------------------------------------------------- /test/failure-compile/multiple-require-star-conflict.scm: -------------------------------------------------------------------------------- 1 | (require "../aux/circ1" *) 2 | (require "../aux/circ2" *) 3 | -------------------------------------------------------------------------------- /test/failure-compile/nested-require.scm: -------------------------------------------------------------------------------- 1 | (define (f) 2 | (require stdlib)) 3 | -------------------------------------------------------------------------------- /test/failure-compile/non-existant-module-ref.scm: -------------------------------------------------------------------------------- 1 | (display-helpers:display-with-tag "INFO" "hello") 2 | -------------------------------------------------------------------------------- /test/failure-compile/private-c-module-method.scm: -------------------------------------------------------------------------------- 1 | (require "../aux/libc_module" => cm) 2 | (cm:private_identity 1) 3 | -------------------------------------------------------------------------------- /test/failure-compile/private-module-method.scm: -------------------------------------------------------------------------------- 1 | (require "../aux/auxillary-module" => am) 2 | 3 | (display (am:private-method)) 4 | -------------------------------------------------------------------------------- /test/failure-compile/renamed-require-using-original-name.scm: -------------------------------------------------------------------------------- 1 | (require "../aux/auxillary-module" => am) 2 | 3 | (auxillary-module:auxillary-function "hello") 4 | -------------------------------------------------------------------------------- /test/failure-compile/syntax-invalid-boolean-at-eof.scm: -------------------------------------------------------------------------------- 1 | (display 2 | #t 3 | ; Important: make sure the file does not end in a newline! 4 | # -------------------------------------------------------------------------------- /test/failure-compile/syntax-invalid-boolean.scm: -------------------------------------------------------------------------------- 1 | (display #not-a-boolean) 2 | -------------------------------------------------------------------------------- /test/failure-compile/syntax-invalid-integer.scm: -------------------------------------------------------------------------------- 1 | (display 123-456) 2 | -------------------------------------------------------------------------------- /test/failure-compile/syntax-too-many-closing-parens.scm: -------------------------------------------------------------------------------- 1 | (display "first list is okay") 2 | 3 | (display 4 | "second list is not okay" 5 | '(1 2 3) 6 | '(4 5 6))) ; <- extra closing paren for 'display' 7 | (newline) 8 | 9 | (display 10 | "third list is also not okay" 11 | '(7 8 9))))) ; <- extra closing parens for 'display' 12 | (newline) 13 | 14 | (display "fourth list is okay") 15 | -------------------------------------------------------------------------------- /test/failure-compile/syntax-unclosed-paren.scm: -------------------------------------------------------------------------------- 1 | (display "first list is okay") 2 | 3 | (display 4 | "second list is not okay" 5 | '(1 2 3) 6 | '(4 5 6) ; <- no closing paren for 'display' 7 | (newline) 8 | -------------------------------------------------------------------------------- /test/failure-compile/syntax-unclosed-string.scm: -------------------------------------------------------------------------------- 1 | (display 2 | '(1 2 3) 3 | "a string) ; <- no closing quote 4 | (newline) 5 | -------------------------------------------------------------------------------- /test/failure-compile/undefined-var.scm: -------------------------------------------------------------------------------- 1 | (+ 1 a) 2 | -------------------------------------------------------------------------------- /test/failure-runtime/let-list-matching-too-long.scm: -------------------------------------------------------------------------------- 1 | (let (((a b) '(1 2 3))) 2 | (+ a b)) 3 | -------------------------------------------------------------------------------- /test/failure-runtime/let-list-matching-too-short.scm: -------------------------------------------------------------------------------- 1 | (let (((a b) '(1))) 2 | (+ a b)) 3 | -------------------------------------------------------------------------------- /test/rb/c_parse_spec.rb: -------------------------------------------------------------------------------- 1 | require 'rspec' 2 | 3 | require_relative '../../c_parse' 4 | 5 | describe CParser do 6 | describe '#parse_c_exports_from_string' do 7 | it 'parses a basic exports structure' do 8 | input = <<-CODE 9 | garlic_native_export_t mod_exports[] = { 10 | {"init", init, 1}, 11 | {"cleanup", cleanup, 2}, 12 | 0 13 | }; 14 | CODE 15 | 16 | exports = [ 17 | CParser::CExport.new('init', 1, false), 18 | CParser::CExport.new('cleanup', 2, false) 19 | ] 20 | 21 | parsed = CParser.parse_c_exports_from_string('mod', input) 22 | expect(parsed).to eq(exports) 23 | end 24 | 25 | it 'optionally accepts a "variadic" flag' do 26 | input = <<-CODE 27 | garlic_native_export_t mod_exports[] = { 28 | {"non-variadic-0", non_variadic_0, 1}, 29 | {"non-variadic-1", non_variadic_1, 1, 0}, 30 | {"variadic-0" , variadic , 1, 1}, 31 | 0 32 | }; 33 | CODE 34 | 35 | exports = [ 36 | CParser::CExport.new('non-variadic-0', 1, false), 37 | CParser::CExport.new('non-variadic-1', 1, false), 38 | CParser::CExport.new('variadic-0' , 1, true) 39 | ] 40 | 41 | parsed = CParser.parse_c_exports_from_string('mod', input) 42 | expect(parsed).to eq(exports) 43 | end 44 | 45 | it 'allows for various amounts of space' do 46 | input = <<-CODE 47 | garlic_native_export_t mod_exports[] = { 48 | {"a", a, 0}, 49 | {"b",b,0}, 50 | { "c", c, 0 }, 51 | {"d",d,0},{"e",f,0}, 52 | 53 | { "f", f, 0 }, 54 | 0 55 | }; 56 | CODE 57 | 58 | exports = [ 59 | CParser::CExport.new('a', 0, false), 60 | CParser::CExport.new('b', 0, false), 61 | CParser::CExport.new('c', 0, false), 62 | CParser::CExport.new('d', 0, false), 63 | CParser::CExport.new('e', 0, false), 64 | CParser::CExport.new('f', 0, false) 65 | ] 66 | 67 | parsed = CParser.parse_c_exports_from_string('mod', input) 68 | expect(parsed).to eq(exports) 69 | end 70 | 71 | it 'allows for tight spacing' do 72 | input = <<-CODE 73 | garlic_native_export_t mod_exports[]={{"a",a,0},0}; 74 | CODE 75 | 76 | exports = [ 77 | CParser::CExport.new('a', 0, false) 78 | ] 79 | 80 | parsed = CParser.parse_c_exports_from_string('mod', input) 81 | expect(parsed).to eq(exports) 82 | end 83 | 84 | it 'ignores surrounding code' do 85 | input = <<-CODE 86 | #include 87 | #include 88 | 89 | garlic_value_t init(garlic_value_t a) { 90 | return NULL; 91 | } 92 | 93 | garlic_value_t cleanup() { 94 | return NULL; 95 | } 96 | 97 | garlic_native_export_t mod_exports[] = { 98 | {"init", init, 1}, 99 | {"cleanup", cleanup, 2}, 100 | 0 101 | }; 102 | 103 | void private_function() { 104 | // do something 105 | } 106 | CODE 107 | 108 | exports = [ 109 | CParser::CExport.new('init', 1, false), 110 | CParser::CExport.new('cleanup', 2, false) 111 | ] 112 | 113 | parsed = CParser.parse_c_exports_from_string('mod', input) 114 | expect(parsed).to eq(exports) 115 | end 116 | end 117 | end 118 | 119 | # vim: ts=2 sw=2 : 120 | -------------------------------------------------------------------------------- /test/success/append-in-place.scm: -------------------------------------------------------------------------------- 1 | (define l1 '(1 2 3)) 2 | (define l2 '(4 5 6)) 3 | (define l3 '(7 8 9)) 4 | (define l4 '(a b c)) 5 | (define l5 '(d e f)) 6 | 7 | (display l1) (newline) 8 | (display l2) (newline) 9 | (display l3) (newline) 10 | (display l4) (newline) 11 | (display l5) (newline) 12 | 13 | (newline) 14 | 15 | (append-in-place l1 l2 l3 l4 l5) 16 | 17 | (display l1) (newline) 18 | (display l2) (newline) 19 | (display l3) (newline) 20 | (display l4) (newline) 21 | (display l5) (newline) 22 | 23 | (newline) 24 | 25 | (display (append-in-place '(1 2 3) '() '(4 5 6))) (newline) 26 | (display (append-in-place '() '() '(1 2 3))) (newline) 27 | (display (append-in-place '() '() '())) (newline) 28 | -------------------------------------------------------------------------------- /test/success/append-in-place.scm.result: -------------------------------------------------------------------------------- 1 | (1 2 3) 2 | (4 5 6) 3 | (7 8 9) 4 | (a b c) 5 | (d e f) 6 | 7 | (1 2 3 4 5 6 7 8 9 a b c d e f) 8 | (4 5 6 7 8 9 a b c d e f) 9 | (7 8 9 a b c d e f) 10 | (a b c d e f) 11 | (d e f) 12 | 13 | (1 2 3 4 5 6) 14 | (1 2 3) 15 | () 16 | -------------------------------------------------------------------------------- /test/success/apply.scm: -------------------------------------------------------------------------------- 1 | (display (apply + '(1 2 3))) (apply newline '()) 2 | (apply display '(1 " " 2 " " 3)) (apply newline '()) 3 | -------------------------------------------------------------------------------- /test/success/apply.scm.result: -------------------------------------------------------------------------------- 1 | 6 2 | 1 2 3 3 | -------------------------------------------------------------------------------- /test/success/argv.scm: -------------------------------------------------------------------------------- 1 | ; While it would be possible to create a system where test programs are called 2 | ; with certain command line arguments, that's a lot of complexity for little 3 | ; benefit. Instead, just check that the `*argv*` variable exists. 4 | ; 5 | ; The name of the executable is constant, so we can rely on that. 6 | 7 | (define (shadow-args) 8 | (let ((*argv* 'argv)) 9 | (display *argv*) (newline) )) 10 | 11 | (display *argv*) (newline) 12 | (shadow-args) 13 | (display *argv*) (newline) 14 | -------------------------------------------------------------------------------- /test/success/argv.scm.result: -------------------------------------------------------------------------------- 1 | (./main) 2 | argv 3 | (./main) 4 | -------------------------------------------------------------------------------- /test/success/arithmetic.scm: -------------------------------------------------------------------------------- 1 | (display (+)) (newline) 2 | (display (+ 1)) (newline) 3 | (display (+ 1 2)) (newline) 4 | (display (+ 1 2 3)) (newline) 5 | (display (+ 1 2 3 4)) (newline) 6 | (display (+ 1 2 3 4 5)) (newline) 7 | 8 | (newline) 9 | 10 | (display (- 1)) (newline) 11 | (display (- 2 1)) (newline) 12 | (display (- 3 2 1)) (newline) 13 | (display (- 4 3 2 1)) (newline) 14 | (display (- 5 4 3 2 1)) (newline) 15 | 16 | (newline) 17 | 18 | (display (*)) (newline) 19 | (display (* 1)) (newline) 20 | (display (* 1 -2)) (newline) 21 | (display (* 1 -2 3)) (newline) 22 | (display (* 1 -2 3 -4)) (newline) 23 | (display (* 1 -2 3 -4 5)) (newline) 24 | 25 | (newline) 26 | 27 | (display (> 1 2)) (newline) 28 | (display (> 1 -2)) (newline) 29 | (display (> -1 2)) (newline) 30 | (display (> -1 -2)) (newline) 31 | (display (< 1 2)) (newline) 32 | (display (< 1 -2)) (newline) 33 | (display (< -1 2)) (newline) 34 | (display (< -1 -2)) (newline) 35 | 36 | ;; BITWISE ARITHMETIC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | 38 | (display (bitwise-and 0x12345678 0xff )) (newline) 39 | (display (bitwise-and 0x12345678 0xff00 )) (newline) 40 | (display (bitwise-and 0x12345678 0xff0000 )) (newline) 41 | (display (bitwise-and 0x12345678 0xff000000)) (newline) 42 | 43 | ; 1111 1110 1100 1000 0000 => fec80 44 | ; 1001 1001 1001 1001 1001 => 99999 45 | ; ------------------------ 46 | ; 1111 1111 1101 1001 1001 => ffd99 47 | (display (bitwise-ior 0xfec80 0x99999)) (newline) 48 | 49 | ; NOTE: 0b1001 == 9 50 | (display (arithmetic-shift 9 2)) (newline) 51 | (display (arithmetic-shift 9 1)) (newline) 52 | (display (arithmetic-shift 9 0)) (newline) 53 | (display (arithmetic-shift 9 -1)) (newline) 54 | (display (arithmetic-shift 9 -2)) (newline) 55 | (display (arithmetic-shift 9 -3)) (newline) 56 | (display (arithmetic-shift 9 -4)) (newline) 57 | (display (arithmetic-shift 9 -5)) (newline) 58 | -------------------------------------------------------------------------------- /test/success/arithmetic.scm.result: -------------------------------------------------------------------------------- 1 | 0 2 | 1 3 | 3 4 | 6 5 | 10 6 | 15 7 | 8 | -1 9 | 1 10 | 0 11 | -2 12 | -5 13 | 14 | 1 15 | 1 16 | -2 17 | -6 18 | 24 19 | 120 20 | 21 | #f 22 | #t 23 | #f 24 | #t 25 | #t 26 | #f 27 | #t 28 | #f 29 | 120 30 | 22016 31 | 3407872 32 | 301989888 33 | 1047961 34 | 36 35 | 18 36 | 9 37 | 4 38 | 2 39 | 1 40 | 0 41 | 0 42 | -------------------------------------------------------------------------------- /test/success/assoc.scm: -------------------------------------------------------------------------------- 1 | (require assoc) 2 | 3 | (define base-alist 4 | (let* ((al0 (assoc:empty)) 5 | (al1 (assoc:add al0 'a 100)) 6 | (al2 (assoc:add al1 'b 200)) 7 | (al3 (assoc:add al2 'a 101)) ; shadows original entry 8 | (al4 (assoc:add al3 'c 300))) 9 | al4)) 10 | 11 | (display (assoc:get base-alist 'a)) (newline) 12 | (display (assoc:get base-alist 'b)) (newline) 13 | (display (assoc:get base-alist 'c)) (newline) 14 | (display (assoc:get base-alist 'd)) (newline) 15 | (display (assoc:get (assoc:add base-alist 'd 400) 'd)) (newline) 16 | (display (assoc:get (assoc:add base-alist 'b 201) 'd)) (newline) 17 | (display (assoc:get (assoc:add base-alist 'b 201) 'b)) (newline) 18 | (display (assoc:pairs base-alist)) (newline) 19 | 20 | (newline) 21 | 22 | (display (assoc:has-key? base-alist 'a)) (newline) 23 | (display (assoc:has-key? base-alist 'b)) (newline) 24 | (display (assoc:has-key? base-alist 'c)) (newline) 25 | (display (assoc:has-key? base-alist 'd)) (newline) 26 | (display (assoc:has-key? (assoc:add base-alist 'd 400) 'd)) (newline) 27 | (display (assoc:has-key? (assoc:add base-alist 'b 201) 'd)) (newline) 28 | (display (assoc:has-key? (assoc:add base-alist 'b 201) 'b)) (newline) 29 | 30 | 31 | (newline) 32 | 33 | (display (assoc:get (assoc:singleton 'a 100) 'a)) (newline) 34 | (display (assoc:get (assoc:singleton 'a 100) 'b)) (newline) 35 | (display (assoc:pairs (assoc:singleton 'a 100))) (newline) 36 | 37 | (newline) 38 | 39 | (define merged-alist 40 | (let* ((al0 (assoc:empty)) 41 | (al1 (assoc:add al0 'aa 1000)) 42 | (al2 (assoc:add al1 'bb 2000)) 43 | (al3 (assoc:add al2 'c 3000)) ; will overwrite key in first assoc 44 | (ml (assoc:merge base-alist al3))) 45 | ml)) 46 | 47 | (display (assoc:get merged-alist 'a )) (newline) 48 | (display (assoc:get merged-alist 'b )) (newline) 49 | (display (assoc:get merged-alist 'c )) (newline) 50 | (display (assoc:get merged-alist 'aa)) (newline) 51 | (display (assoc:get merged-alist 'bb)) (newline) 52 | (display (assoc:get merged-alist 'd )) (newline) 53 | (display (assoc:pairs merged-alist)) (newline) 54 | -------------------------------------------------------------------------------- /test/success/assoc.scm.result: -------------------------------------------------------------------------------- 1 | 101 2 | 200 3 | 300 4 | #f 5 | 400 6 | #f 7 | 201 8 | ((b . 200) (a . 101) (c . 300)) 9 | 10 | #t 11 | #t 12 | #t 13 | #f 14 | #t 15 | #f 16 | #t 17 | 18 | 100 19 | #f 20 | ((a . 100)) 21 | 22 | 101 23 | 200 24 | 3000 25 | 1000 26 | 2000 27 | #f 28 | ((b . 200) (a . 101) (aa . 1000) (bb . 2000) (c . 3000)) 29 | -------------------------------------------------------------------------------- /test/success/begin.scm: -------------------------------------------------------------------------------- 1 | (begin 2 | (display "beginning new block:") (newline) 3 | (display 1) (newline) 4 | (display 2) (newline)) 5 | 6 | (newline) 7 | 8 | (display (+ 1 9 | (begin (display "beginning new block:") (newline) 10 | (display 1) (newline) 11 | 2))) (newline) 12 | 13 | (newline) 14 | 15 | (display 16 | (if #t 17 | (begin 18 | (display "true") (newline) 19 | 1) 20 | (begin 21 | (display "false") (newline) 22 | 2))) (newline) 23 | -------------------------------------------------------------------------------- /test/success/begin.scm.result: -------------------------------------------------------------------------------- 1 | beginning new block: 2 | 1 3 | 2 4 | 5 | beginning new block: 6 | 1 7 | 3 8 | 9 | true 10 | 1 11 | -------------------------------------------------------------------------------- /test/success/boolean-operator.scm: -------------------------------------------------------------------------------- 1 | (define (print-and-true) 2 | (display "returning true... ") 3 | #t) 4 | 5 | (define (print-and-false) 6 | (display "returning false... ") 7 | #f) 8 | 9 | ;; AND ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | 11 | ; booleans 12 | (display (and #t)) (newline) 13 | (display (and #t #t)) (newline) 14 | (display (and #t #f)) (newline) 15 | (display (and #t #t #t)) (newline) 16 | (display (and #t #f #t)) (newline) 17 | 18 | (newline) 19 | 20 | ; truthy vs. falsey values 21 | (display (and '() #t)) (newline) 22 | (display (and #f #t)) (newline) 23 | (display (and '(1) #t)) (newline) 24 | (display (and 1 #t)) (newline) 25 | 26 | (newline) 27 | 28 | ; short circuiting 29 | (display (and (print-and-true) (print-and-false))) (newline) 30 | (display (and (print-and-false) (print-and-true))) (newline) 31 | 32 | (newline) 33 | (newline) 34 | 35 | ;; AND ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 36 | 37 | ; booleans 38 | (display (or #t)) (newline) 39 | (display (or #t #t)) (newline) 40 | (display (or #t #f)) (newline) 41 | (display (or #f #f)) (newline) 42 | (display (or #t #t #t)) (newline) 43 | (display (or #f #f #f)) (newline) 44 | 45 | (newline) 46 | 47 | ; truthy vs. falsey values 48 | (display (or '() #f)) (newline) 49 | (display (or #f #f)) (newline) 50 | (display (or '(1) #f)) (newline) 51 | (display (or 1 #f)) (newline) 52 | 53 | (newline) 54 | 55 | ; short circuiting 56 | (display (or (print-and-true) (print-and-false))) (newline) 57 | (display (or (print-and-false) (print-and-true))) (newline) 58 | -------------------------------------------------------------------------------- /test/success/boolean-operator.scm.result: -------------------------------------------------------------------------------- 1 | #t 2 | #t 3 | #f 4 | #t 5 | #f 6 | 7 | #f 8 | #f 9 | #t 10 | #t 11 | 12 | returning true... returning false... #f 13 | returning false... #f 14 | 15 | 16 | #t 17 | #t 18 | #t 19 | #f 20 | #t 21 | #f 22 | 23 | #f 24 | #f 25 | #t 26 | #t 27 | 28 | returning true... #t 29 | returning false... returning true... #t 30 | -------------------------------------------------------------------------------- /test/success/c-module-variadic.scm: -------------------------------------------------------------------------------- 1 | (require "../aux/libc_variadic_module" => v) 2 | 3 | ; Non-variadic functions work whether or not they were exported with the 4 | ; "is_vararg" set. 5 | (display (v:non_variadic_add_no_flag 1 2)) (newline) 6 | (display (v:non_variadic_add_flag 3 4)) (newline) 7 | 8 | (newline) 9 | 10 | ; Variadic functions work when there are extra arguments passed to them. 11 | (display (v:variadic0_add 1 2 3 4)) (newline) 12 | (display (v:variadic1_add 1 2 3 4)) (newline) 13 | (display (v:variadic9_add 1 2 3 4 5 6 7 8 9 10 11)) (newline) 14 | 15 | (newline) 16 | 17 | ; Variadic functions work when there are no extra arguments passed to them. 18 | (display (v:variadic0_add)) (newline) 19 | (display (v:variadic1_add 1)) (newline) 20 | (display (v:variadic9_add 1 2 3 4 5 6 7 8 9)) (newline) 21 | -------------------------------------------------------------------------------- /test/success/c-module-variadic.scm.result: -------------------------------------------------------------------------------- 1 | 3 2 | 7 3 | 4 | 10 5 | Required args: 1 6 | 9 7 | Required args: 1 8 | 2 9 | 3 10 | 4 11 | 5 12 | 6 13 | 7 14 | 8 15 | 9 16 | 21 17 | 18 | 0 19 | Required args: 1 20 | 0 21 | Required args: 1 22 | 2 23 | 3 24 | 4 25 | 5 26 | 6 27 | 7 28 | 8 29 | 9 30 | 0 31 | -------------------------------------------------------------------------------- /test/success/c-module.scm: -------------------------------------------------------------------------------- 1 | ; libctest is a C module, not a Garlic one. 2 | (require "../aux/libc_module") 3 | 4 | ; We can call arbitrary methods inside the C module, passing it parameters and 5 | ; getting back values that can be composed with other, Garlic functions. 6 | (display (libc_module:add 1 2)) (newline) 7 | (display (+ (libc_module:add 3 4) 5)) (newline) 8 | 9 | ; This tests that parameters that spill out of the registers are passed 10 | ; properly on the stack. 11 | (display (libc_module:lastarg12 1 2 3 4 5 6 7 8 9 10 11 12)) (newline) 12 | 13 | ; The arguments can be arbitrary expressions. 14 | (display (libc_module:add 15 | ((lambda (x) (+ x 1)) 2) 16 | (libc_module:lastarg12 1 2 3 4 5 6 7 8 9 10 11 24)) ) 17 | (newline) 18 | 19 | ; All the extra arguments are ignored. 20 | (display (libc_module:add 1 2 3 4 5 6 7 8 9 10 11 12)) (newline) 21 | 22 | (newline) 23 | 24 | ; Comprehensive tests based on number of arguments (from none to 6, the max 25 | ; number of arguments passed in registers, as well as more than 6, which causes 26 | ; spilling onto the stack). 27 | (display (libc_module:arg0)) (newline) 28 | (display (libc_module:arg1 1)) (newline) 29 | (display (libc_module:arg2 1 2)) (newline) 30 | (display (libc_module:arg3 1 2 3)) (newline) 31 | (display (libc_module:arg4 1 2 3 4)) (newline) 32 | (display (libc_module:arg5 1 2 3 4 5)) (newline) 33 | (display (libc_module:arg6 1 2 3 4 5 6)) (newline) 34 | (display (libc_module:arg8 1 2 3 4 5 6 7 8)) (newline) 35 | -------------------------------------------------------------------------------- /test/success/c-module.scm.result: -------------------------------------------------------------------------------- 1 | Adding 1 and 2 in C! 2 | 3 3 | Adding 3 and 4 in C! 4 | 12 5 | Returning 12th argument from C! 6 | 12 7 | Returning 12th argument from C! 8 | Adding 3 and 24 in C! 9 | 27 10 | Adding 1 and 2 in C! 11 | 3 12 | 13 | 0 14 | 1 = 1 15 | 1 + 2 = 3 16 | 1 + 2 + 3 = 6 17 | 1 + 2 + 3 + 4 = 10 18 | 1 + 2 + 3 + 4 + 5 = 15 19 | 1 + 2 + 3 + 4 + 5 + 6 = 21 20 | 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 = 36 21 | -------------------------------------------------------------------------------- /test/success/callback.scm: -------------------------------------------------------------------------------- 1 | (require "../aux/libc_module" => c) 2 | 3 | (define (print-args x y . rest) 4 | (display x " " y " " rest) 5 | (newline) 6 | 7 | (length rest)) 8 | 9 | (display (c:callme5 print-args)) (newline) 10 | (display (c:callme6 print-args)) (newline) 11 | -------------------------------------------------------------------------------- /test/success/callback.scm.result: -------------------------------------------------------------------------------- 1 | 1 2 (3 4 5) 2 | 3 3 | 1 2 (3 4 5 6) 4 | 4 5 | -------------------------------------------------------------------------------- /test/success/circular-deps.scm: -------------------------------------------------------------------------------- 1 | (require "../aux/circ1") 2 | (require "../aux/circ2") 3 | 4 | (newline) 5 | 6 | (display (circ1:no-deps)) (newline) 7 | (display (circ2:no-deps)) (newline) 8 | 9 | (display (circ1:depends-on-circ2)) (newline) 10 | (display (circ2:depends-on-circ1)) (newline) 11 | -------------------------------------------------------------------------------- /test/success/circular-deps.scm.result: -------------------------------------------------------------------------------- 1 | loading auxillary-module... 2 | 3 | loading circ2... 4 | loading circ1... 5 | 6 | 1 7 | 2 8 | 12 9 | 11 10 | -------------------------------------------------------------------------------- /test/success/comments.scm: -------------------------------------------------------------------------------- 1 | ; Allow top-level comments 2 | ;; Starting with two semicolons 3 | ; Starting after a space 4 | ; Starting after many spaces 5 | ; With lots of spaces 6 | 7 | (display "line comment") ; Allow inline commentS 8 | (newline) ; At end of line 9 | ; Followed by top-level comment 10 | 11 | ( ; Allow comment inside function call 12 | ; On its own line 13 | display ; After the function 14 | ; On its own line again 15 | "comment inside function call" ; After an argument 16 | ; Breaking up the end parentheses 17 | ) (newline) 18 | 19 | (let ; Comment 20 | ( ; Lots 21 | ( ; of 22 | a ; comments 23 | 1 ; all 24 | ) ; over 25 | ) ; the 26 | ; place 27 | (display a) ; all 28 | (newline) ; ignored 29 | ; properly 30 | ) 31 | 32 | ; Repeat for let* and letrec 33 | 34 | (let* ; Comment 35 | ( ; Lots 36 | ( ; of 37 | a ; comments 38 | 2 ; all 39 | ) ; over 40 | ) ; the 41 | ; place 42 | (display a) ; all 43 | (newline) ; ignored 44 | ; properly 45 | ) 46 | 47 | (letrec ; Comment 48 | ( ; Lots 49 | ( ; of 50 | a ; comments 51 | 3 ; all 52 | ) ; over 53 | ) ; the 54 | ; place 55 | (display a) ; all 56 | (newline) ; ignored 57 | ; properly 58 | ) 59 | 60 | ( ; At the beginning 61 | if ; and 62 | #t ; all 63 | (display 11) ; over 64 | (display 12) ; the 65 | ; place 66 | ) 67 | (newline) 68 | 69 | (display 70 | ( ; Inside a cond 71 | ; Lots 72 | cond ; and 73 | ; lots 74 | ( ; and 75 | ; lots 76 | ( ; and 77 | ; lots 78 | = ; and 79 | ; lots 80 | 1 ; and 81 | ; lots 82 | 2 ; and 83 | ; lots 84 | ) ; and 85 | ; lots 86 | 13 ; and 87 | ; lots 88 | ) ; and 89 | ; lots 90 | ( ; and 91 | ; lots 92 | ( ; and 93 | ; lots 94 | = ; and 95 | ; lots 96 | 1 ; and 97 | ; lots 98 | 1 ; and 99 | ; lots 100 | ) ; and 101 | ; lots 102 | 14 ; and 103 | ; lots 104 | ) ; and 105 | ; lots 106 | ( ; and 107 | ; lots 108 | else ; and 109 | ; lots 110 | 15 ; and 111 | ; lots 112 | ) ; and 113 | ; of 114 | ) ; comments! 115 | ) 116 | (newline) 117 | 118 | (;Comment 119 | ; TODO: comments are not currently allowed without a leading space inside of 120 | ; lists :( 121 | display 122 | "allow comments without space separator" 123 | );Comment 124 | (newline) 125 | 126 | (display 127 | '(;Comment 128 | 21 ; Comment 129 | ;Comment 130 | . 131 | 22 132 | ) 133 | );Comment 134 | (newline) 135 | -------------------------------------------------------------------------------- /test/success/comments.scm.result: -------------------------------------------------------------------------------- 1 | line comment 2 | comment inside function call 3 | 1 4 | 2 5 | 3 6 | 11 7 | 14 8 | allow comments without space separator 9 | (21 . 22) 10 | -------------------------------------------------------------------------------- /test/success/cond-no-else.scm: -------------------------------------------------------------------------------- 1 | (define (to-word n) 2 | (cond ((= n 0) 'one) 3 | ((= n 1) 'two))) 4 | 5 | (display (to-word 0)) (newline) 6 | (display (to-word 1)) (newline) 7 | (display (to-word 2)) (newline) 8 | -------------------------------------------------------------------------------- /test/success/cond-no-else.scm.result: -------------------------------------------------------------------------------- 1 | one 2 | two 3 | () 4 | -------------------------------------------------------------------------------- /test/success/cond-only-else.scm: -------------------------------------------------------------------------------- 1 | (display (cond (else 'default))) (newline) 2 | -------------------------------------------------------------------------------- /test/success/cond-only-else.scm.result: -------------------------------------------------------------------------------- 1 | default 2 | -------------------------------------------------------------------------------- /test/success/cond.scm: -------------------------------------------------------------------------------- 1 | (define (fib n) 2 | (cond ((= n 0) 1) 3 | ((= n 1) 1) 4 | (else (+ (fib (- n 1)) (fib (- n 2)) )) )) 5 | 6 | (display (fib 0)) (newline) 7 | (display (fib 1)) (newline) 8 | (display (fib 2)) (newline) 9 | (display (fib 3)) (newline) 10 | (display (fib 4)) (newline) 11 | (display (fib 5)) (newline) 12 | (display (fib 6)) (newline) 13 | (display (fib 7)) (newline) 14 | (display (fib 8)) (newline) 15 | (display (fib 9)) (newline) 16 | (display (fib 10)) (newline) 17 | -------------------------------------------------------------------------------- /test/success/cond.scm.result: -------------------------------------------------------------------------------- 1 | 1 2 | 1 3 | 2 4 | 3 5 | 5 6 | 8 7 | 13 8 | 21 9 | 34 10 | 55 11 | 89 12 | -------------------------------------------------------------------------------- /test/success/core-namespace.scm: -------------------------------------------------------------------------------- 1 | ; "core" is imported implicitly. It is imported with the "import alL" syntax, 2 | ; so it's not necessary to prefix functions exported by "core" (such as 3 | ; "display" or "core") with the module name 4 | (display (+ 1 2)) (newline) 5 | 6 | ; But, it's legal to do so. 7 | (core:display (core:+ 1 2)) (newline) 8 | -------------------------------------------------------------------------------- /test/success/core-namespace.scm.result: -------------------------------------------------------------------------------- 1 | 3 2 | 3 3 | -------------------------------------------------------------------------------- /test/success/create-elf-file.scm: -------------------------------------------------------------------------------- 1 | (require assoc) 2 | 3 | (require "../../recursive/elf-x86-64-linux-gnu" => elf) 4 | (require "../aux/hexdump") 5 | 6 | (define test-code-base 7 | '(0x48 0xc7 0xc0 0x3c 0x00 0x00 0x00 ; mov $60, %rax 8 | 0xbf 0x2a 0x00 0x00 0x00 ; mov $42, %edi 9 | 0x0f 0x05)) ; syscall 10 | 11 | ((compose 12 | (lambda (b) (hexdump:print-bytes b)) 13 | (lambda (e) (elf:emit-as-bytes e)) 14 | (lambda (e) (elf:add-executable-code e 'main test-code-base))) 15 | (elf:empty-static-executable)) 16 | 17 | (newline) 18 | 19 | (define test-code-referencing-data 20 | (list 21 | 0xb8 0x01 0x00 0x00 0x00 ; mov $1, %eax 22 | 0xbf 0x01 0x00 0x00 0x00 ; mov $1, %edi 23 | 0xbe (elf:data-ref 'msg 4) ; mov $msg, %esi -- will be resolved to address 24 | 0xba 0x0e 0x00 0x00 0x00 ; mov $14, %edx 25 | 0x0f 0x05 ; syscall 26 | 27 | 0xb8 0x3c 0x00 0x00 0x00 ; mov $60, %eax 28 | 0xbf 0x2a 0x00 0x00 0x00 ; mov $42, %edi 29 | 0x0f 0x05)) ; syscall 30 | 31 | (define test-data 32 | (assoc:singleton 33 | 'msg 34 | '(0x48 0x65 0x6c 0x6c 0x6f 0x2c 0x20 ; "Hello, " 35 | 0x77 0x6f 0x72 0x6c 0x64 0x21 0x0a))) ; "world!\n" 36 | 37 | ((compose 38 | (lambda (b) (hexdump:print-bytes b)) 39 | (lambda (e) (elf:emit-as-bytes e)) 40 | (lambda (e) (elf:add-data e test-data)) 41 | (lambda (e) (elf:add-executable-code e 'main test-code-referencing-data))) 42 | (elf:empty-static-executable)) 43 | -------------------------------------------------------------------------------- /test/success/create-elf-file.scm.result: -------------------------------------------------------------------------------- 1 | 7f 45 4c 46 02 01 01 00 00 00 00 00 00 00 00 00 2 | 02 00 3e 00 01 00 00 00 38 01 40 00 00 00 00 00 3 | 00 01 00 00 00 00 00 00 40 00 00 00 00 00 00 00 4 | 00 00 00 00 40 00 38 00 01 00 40 00 03 00 02 00 5 | 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 6 | 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 7 | 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 8 | 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 9 | 01 00 00 00 01 00 00 00 06 00 00 00 00 00 00 00 10 | 38 01 40 00 00 00 00 00 38 01 00 00 00 00 00 00 11 | 0e 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 12 | 00 10 00 00 00 00 00 00 00 00 00 00 00 00 00 00 13 | 07 00 00 00 03 00 00 00 00 00 00 00 00 00 00 00 14 | 00 00 00 00 00 00 00 00 46 01 00 00 00 00 00 00 15 | 11 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 16 | 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 17 | 01 00 00 00 05 00 00 00 38 01 00 00 00 00 00 00 18 | 38 01 40 00 00 00 00 00 38 01 40 00 00 00 00 00 19 | 0e 00 00 00 00 00 00 00 0e 00 00 00 00 00 00 00 20 | 00 10 00 00 00 00 00 00 48 c7 c0 3c 00 00 00 bf 21 | 2a 00 00 00 0f 05 00 2e 74 65 78 74 00 2e 73 68 22 | 73 74 72 74 61 62 00 23 | 24 | 7f 45 4c 46 02 01 01 00 00 00 00 00 00 00 00 00 25 | 02 00 3e 00 01 00 00 00 b0 01 40 00 00 00 00 00 26 | 40 01 00 00 00 00 00 00 40 00 00 00 00 00 00 00 27 | 00 00 00 00 40 00 38 00 02 00 40 00 04 00 03 00 28 | 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 29 | 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 30 | 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 31 | 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 32 | 01 00 00 00 01 00 00 00 06 00 00 00 00 00 00 00 33 | b0 01 40 00 00 00 00 00 b0 01 00 00 00 00 00 00 34 | 22 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 35 | 00 10 00 00 00 00 00 00 00 00 00 00 00 00 00 00 36 | 07 00 00 00 01 00 00 00 03 00 00 00 00 00 00 00 37 | d2 01 80 00 00 00 00 00 d2 01 00 00 00 00 00 00 38 | 0e 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 39 | 00 10 00 00 00 00 00 00 00 00 00 00 00 00 00 00 40 | 0d 00 00 00 03 00 00 00 00 00 00 00 00 00 00 00 41 | 00 00 00 00 00 00 00 00 e0 01 00 00 00 00 00 00 42 | 17 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 43 | 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 44 | 01 00 00 00 05 00 00 00 b0 01 00 00 00 00 00 00 45 | b0 01 40 00 00 00 00 00 b0 01 40 00 00 00 00 00 46 | 22 00 00 00 00 00 00 00 22 00 00 00 00 00 00 00 47 | 00 10 00 00 00 00 00 00 01 00 00 00 06 00 00 00 48 | d2 01 00 00 00 00 00 00 d2 01 80 00 00 00 00 00 49 | d2 01 80 00 00 00 00 00 0e 00 00 00 00 00 00 00 50 | 0e 00 00 00 00 00 00 00 00 10 00 00 00 00 00 00 51 | b8 01 00 00 00 bf 01 00 00 00 be d2 01 80 00 ba 52 | 0e 00 00 00 0f 05 b8 3c 00 00 00 bf 2a 00 00 00 53 | 0f 05 48 65 6c 6c 6f 2c 20 77 6f 72 6c 64 21 0a 54 | 00 2e 74 65 78 74 00 2e 64 61 74 61 00 2e 73 68 55 | 73 74 72 74 61 62 00 56 | -------------------------------------------------------------------------------- /test/success/equal_sign.scm: -------------------------------------------------------------------------------- 1 | (require "../aux/auxillary-module" => am) 2 | 3 | ;; Numbers 4 | (display (= 1 1)) (newline) 5 | (display (= 1 1 1 1)) (newline) 6 | (display (= 1 1 2 1)) (newline) 7 | 8 | (newline) 9 | 10 | ;; Symbols 11 | (display (= 'a 'a)) (newline) 12 | (display (= 'a 'a 'a 'a)) (newline) 13 | (display (= 'a 'a 'b 'a)) (newline) 14 | 15 | ; symbols should be unique across modules 16 | (display (= 'auxillary-symbol am:auxillary-symbol)) (newline) 17 | -------------------------------------------------------------------------------- /test/success/equal_sign.scm.result: -------------------------------------------------------------------------------- 1 | loading auxillary-module... 2 | 3 | #t 4 | #t 5 | #f 6 | 7 | #t 8 | #t 9 | #f 10 | #t 11 | -------------------------------------------------------------------------------- /test/success/file-lib.scm: -------------------------------------------------------------------------------- 1 | (require file) 2 | 3 | ; This test is run from the root of the garlic repository, so all file paths 4 | ; are relative to that directory. 5 | (display (file:read-text "test/success/file-lib.scm")) 6 | -------------------------------------------------------------------------------- /test/success/file-lib.scm.result: -------------------------------------------------------------------------------- 1 | file-lib.scm -------------------------------------------------------------------------------- /test/success/float.scm: -------------------------------------------------------------------------------- 1 | ; Basic float literals 2 | (display 1.234) (newline) 3 | (display 1.0) (newline) 4 | (display -0.0123) (newline) ; negative 5 | (display -3.1415e6) (newline) ; scientific notation 6 | (display 0.1e-5) (newline) ; scientific notation with negative exponent 7 | (display 2.1E2) (newline) ; scientific notation with capital "E" 8 | -------------------------------------------------------------------------------- /test/success/float.scm.result: -------------------------------------------------------------------------------- 1 | 1.234000 2 | 1.000000 3 | -0.012300 4 | -3141500.000000 5 | 0.000001 6 | 210.000000 7 | -------------------------------------------------------------------------------- /test/success/full.scm.result: -------------------------------------------------------------------------------- 1 | loading display-helpers... 2 | 3 | 6 4 | 12 5 | 10 6 | 3 7 | 8 | 3 9 | (this is a list) 10 | (this is a list) 11 | 12 | 2 13 | 2 14 | -2 15 | -1 16 | 0 17 | 6 18 | -6 19 | -3 20 | 2 21 | -1 22 | -3 23 | -6 24 | -24 25 | 120 26 | -15 27 | 28 | a 29 | 123 30 | #t 31 | #f 32 | (1 2 3) 33 | (1 (2 3) 4) 34 | 35 | () 36 | a() 37 | 38 | (1 2 . 3) 39 | 1 40 | (2 . 3) 41 | (a b c) 42 | (a b c) 43 | #f 44 | #t 45 | #f 46 | 47 | #t 48 | #f 49 | correct 50 | correct 51 | correct 52 | correct 53 | correct 54 | correct 55 | correct 56 | correct 57 | correct 58 | #t 59 | #t 60 | #t 61 | #t 62 | 63 | 1 64 | 1 65 | 2 66 | 3 67 | 5 68 | 8 69 | 13 70 | 21 71 | 34 72 | 55 73 | 89 74 | 75 | one 76 | two 77 | three 78 | 79 | 4 80 | (2 3 4 5) 81 | 82 | 4 83 | (2 3 4 5) 84 | (1 2 3 4) 85 | (1 2 3 4 5) 86 | (1 2 3 4 5 6) 87 | (1 2 3 4 5 6) 88 | 89 | (1 . 2) 90 | (1 2 . 3) 91 | (2 . 3) 92 | 3 93 | 94 | a string 95 | some numbers and symbols: 1 2 3 # @ <- cool! 96 | a string with a newline afterwards 97 | a string with 98 | a newline in the middle 99 | another string with 100 | a newline in the middle 101 | a string with an embedded tab 102 | a string with "escaped" quotes 103 | no need to 'escape' single quotes 104 | 105 | ^ empty string above 106 | 107 | PRINT-WITH-NEWLINE: hello 108 | LAMBDA-VERSION: hello again 109 | 110 | inner 111 | outer 112 | 113 | 4 114 | (2 3 4 5) 115 | (1 3) 116 | 117 | [INFO] this is calling a function in display-helpers 118 | [DEBUG] debugging output... 119 | 120 | one 121 | two 122 | three 123 | 124 | 0 125 | 1 126 | 3 127 | 6 128 | 10 129 | 15 130 | 1 131 | 2 132 | 6 133 | 24 134 | 120 135 | 136 | (3 3 4 5) 137 | 138 | (a b c d) 139 | [INFO] 1st message 140 | [INFO] 2nd message 141 | [INFO] 3rd message 142 | 143 | 21 144 | 6 145 | 146 | 3 147 | 4 148 | hello world 149 | 150 | 3 151 | 4 152 | 5 153 | hello world 154 | -------------------------------------------------------------------------------- /test/success/function-def.scm: -------------------------------------------------------------------------------- 1 | (define (f x) 2 | (+ 1 x)) 3 | 4 | (define (g a b c d) 5 | (cons a (cons b (cons c (cons d '())))) ) 6 | 7 | (display (f 2)) (newline) 8 | (display (g 1 2 3 4)) (newline) 9 | -------------------------------------------------------------------------------- /test/success/function-def.scm.result: -------------------------------------------------------------------------------- 1 | 3 2 | (1 2 3 4) 3 | -------------------------------------------------------------------------------- /test/success/hex.scm: -------------------------------------------------------------------------------- 1 | (display 0x1) (newline) 2 | (display 0x01) (newline) 3 | (display 0xff) (newline) 4 | (display 0x100) (newline) 5 | 6 | (newline) 7 | 8 | ; upper case 9 | (display 0xF) (newline) 10 | (display 0x1A) (newline) 11 | (display 0xDEADBEEF) (newline) 12 | 13 | (newline) 14 | 15 | (display (+ 0xff 1)) (newline) 16 | (display (- 0xff 0xf)) (newline) 17 | -------------------------------------------------------------------------------- /test/success/hex.scm.result: -------------------------------------------------------------------------------- 1 | 1 2 | 1 3 | 255 4 | 256 5 | 6 | 15 7 | 26 8 | 3735928559 9 | 10 | 256 11 | 240 12 | -------------------------------------------------------------------------------- /test/success/if-else.scm: -------------------------------------------------------------------------------- 1 | (define my-not 2 | (lambda (val) (if val #f #t))) 3 | 4 | (display (if #t 'correct 'wrong)) (newline) 5 | (display (if #f 'wrong 'correct)) (newline) 6 | (display (if '() 'correct 'wrong)) (newline) 7 | (display (if 0 'correct 'wrong)) (newline) 8 | (display (if 1 'correct 'wrong)) (newline) 9 | (display (if (my-not #f) 'correct 'wrong)) (newline) 10 | (display (if (my-not #t) 'wrong 'correct)) (newline) 11 | (display (if (my-not 0) 'wrong 'correct)) (newline) 12 | (display (if (my-not 1) 'wrong 'correct)) (newline) 13 | -------------------------------------------------------------------------------- /test/success/if-else.scm.result: -------------------------------------------------------------------------------- 1 | correct 2 | correct 3 | correct 4 | correct 5 | correct 6 | correct 7 | correct 8 | correct 9 | correct 10 | -------------------------------------------------------------------------------- /test/success/label-resolution.scm: -------------------------------------------------------------------------------- 1 | (require "../../recursive/byte-utils") 2 | (require "../../recursive/label-resolution") 3 | 4 | ;; UTILITIES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 5 | 6 | (define (resolve-and-print insts) 7 | (display (label-resolution:resolve-local-labels insts)) (newline)) 8 | 9 | ;; This function is defined in label-resolution.scm, but it's not exported. In 10 | ;; the future, maybe the function can be moved out to a common location? Until 11 | ;; then, just copy the implementation here. 12 | (define (repeat-value val times) 13 | (define (helper so-far times-left) 14 | (if (= times-left 0) 15 | so-far 16 | (helper (cons val so-far) (- times-left 1)) )) 17 | 18 | (helper '() times)) 19 | 20 | (define NOP (label-resolution:bytes '(0x90))) 21 | (define (jmp delta) 22 | (if (and (> delta -129) 23 | (< delta 128)) 24 | (cons 0xeb (byte-utils:int->little-endian delta 1)) 25 | (cons 0xe9 (byte-utils:int->little-endian delta 4)) )) 26 | 27 | ;; MAIN TEST ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | 29 | (display " 30 | label1: 31 | nop 32 | jmp label2 33 | nop 34 | jmp label1 35 | nop 36 | label2: 37 | \n") 38 | 39 | (resolve-and-print 40 | (list 41 | (label-resolution:label-def 'label1) 42 | NOP 43 | (label-resolution:label-ref jmp '(label2)) 44 | NOP 45 | (label-resolution:label-ref jmp '(label1)) 46 | NOP 47 | (label-resolution:label-def 'label2)) ) 48 | 49 | (display " 50 | 51 | --------------------------------------------------------------------------------\n 52 | 53 | label1: 54 | nop 55 | jmp label2 56 | nop (× 123) 57 | jmp label1 58 | nop 59 | label2: 60 | \n") 61 | 62 | (resolve-and-print 63 | (append 64 | (list (label-resolution:label-def 'label1)) 65 | (list NOP) 66 | (list (label-resolution:label-ref jmp '(label2))) 67 | (repeat-value NOP 123) 68 | (list (label-resolution:label-ref jmp '(label1))) 69 | (list NOP) 70 | (list (label-resolution:label-def 'label2))) ) 71 | 72 | (display " 73 | 74 | --------------------------------------------------------------------------------\n 75 | 76 | label1: 77 | nop 78 | jmp label2 79 | nop (× 124) 80 | jmp label1 81 | nop 82 | label2: 83 | \n") 84 | 85 | (resolve-and-print 86 | (append 87 | (list (label-resolution:label-def 'label1)) 88 | (list NOP) 89 | (list (label-resolution:label-ref jmp '(label2))) 90 | (repeat-value NOP 124) 91 | (list (label-resolution:label-ref jmp '(label1))) 92 | (list NOP) 93 | (list (label-resolution:label-def 'label2))) ) 94 | -------------------------------------------------------------------------------- /test/success/label-resolution.scm.result: -------------------------------------------------------------------------------- 1 | 2 | label1: 3 | nop 4 | jmp label2 5 | nop 6 | jmp label1 7 | nop 8 | label2: 9 | 10 | (144 235 4 144 235 250 144) 11 | 12 | -------------------------------------------------------------------------------- 13 | 14 | label1: 15 | nop 16 | jmp label2 17 | nop (× 123) 18 | jmp label1 19 | nop 20 | label2: 21 | 22 | (144 235 126 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 235 128 144) 23 | 24 | -------------------------------------------------------------------------------- 25 | 26 | label1: 27 | nop 28 | jmp label2 29 | nop (× 124) 30 | jmp label1 31 | nop 32 | label2: 33 | 34 | (144 233 130 0 0 0 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 144 233 121 255 255 255 144) 35 | -------------------------------------------------------------------------------- /test/success/let-list-matching.scm: -------------------------------------------------------------------------------- 1 | ; A non-destructuring let binding. Nothing special about this one. 2 | (let ((ls '(1 2 3))) 3 | (display ls) (newline)) 4 | (newline) 5 | 6 | ; A series of singly-nested destructuring let bindings. 7 | 8 | (let (((first) '(1))) 9 | (display first) (newline)) 10 | (newline) 11 | 12 | (let (((first . rest) '(1 2 3))) 13 | (display first) (newline) 14 | (display rest) (newline)) 15 | (newline) 16 | 17 | (let (((first second . rest) '(1 2 3))) 18 | (display first) (newline) 19 | (display second) (newline) 20 | (display rest) (newline)) 21 | (newline) 22 | 23 | (let (((first second third . rest) '(1 2 3))) 24 | (display first) (newline) 25 | (display second) (newline) 26 | (display third) (newline) 27 | (display rest) (newline)) 28 | (newline) 29 | 30 | ; Nested destructuring, both at the second and third level 31 | (let (((a (b c . d) (e (f)) g) '(1 (2 3 . 4) (5 (6)) (7 . 8)))) 32 | (display a) (newline) 33 | (display b) (newline) 34 | (display c) (newline) 35 | (display d) (newline) 36 | (display e) (newline) 37 | (display f) (newline) 38 | (display g) (newline)) 39 | (newline) 40 | 41 | ; The l-value here could be expressed as simply as (a b c), but the form used 42 | ; here exercises l-values expressed with dotted lists 43 | (let (((a . (b . c)) '(1 2 . 3))) 44 | (display a) (newline) 45 | (display b) (newline) 46 | (display c) (newline)) 47 | (newline) 48 | 49 | (let ((pair '(1 . 2))) 50 | (display pair) (newline)) 51 | (newline) 52 | 53 | (let (((first . second) '(1 . 2))) 54 | (display first) (newline) 55 | (display second) (newline)) 56 | -------------------------------------------------------------------------------- /test/success/let-list-matching.scm.result: -------------------------------------------------------------------------------- 1 | (1 2 3) 2 | 3 | 1 4 | 5 | 1 6 | (2 3) 7 | 8 | 1 9 | 2 10 | (3) 11 | 12 | 1 13 | 2 14 | 3 15 | () 16 | 17 | 1 18 | 2 19 | 3 20 | 4 21 | 5 22 | 6 23 | (7 . 8) 24 | 25 | 1 26 | 2 27 | 3 28 | 29 | (1 . 2) 30 | 31 | 1 32 | 2 33 | -------------------------------------------------------------------------------- /test/success/let-star.scm: -------------------------------------------------------------------------------- 1 | (define a 4) 2 | (define c 5) 3 | 4 | (display 5 | (let* ((a 1) 6 | (b 2) 7 | (c (+ a b))) 8 | c)) (newline) 9 | 10 | (display a) (newline) 11 | (display c) (newline) 12 | 13 | ; The current binding should be available in its own definition in order to 14 | ; allow for recursion. 15 | (display 16 | (let* ((fac (lambda (n) (if (= n 0) 1 (* n (fac (- n 1))) )) )) 17 | (fac 5)) ) (newline) 18 | 19 | ; Again, we hoist definitions inside the let* body, as well as multiple 20 | ; statements. 21 | 22 | (let* ((hello "hello")) 23 | (display hello) 24 | (display " ") 25 | (display world) 26 | (newline) 27 | 28 | (define world "world")) 29 | -------------------------------------------------------------------------------- /test/success/let-star.scm.result: -------------------------------------------------------------------------------- 1 | 3 2 | 4 3 | 5 4 | 120 5 | hello world 6 | -------------------------------------------------------------------------------- /test/success/let.scm: -------------------------------------------------------------------------------- 1 | (define a 4) 2 | 3 | (display 4 | (let ((a 1) 5 | (b 2)) 6 | (+ a b))) (newline) 7 | 8 | (display a) (newline) 9 | 10 | ; The current binding should be available in its own definition in order to 11 | ; allow for recursion. 12 | (display 13 | (let ((fac (lambda (n) (if (= n 0) 1 (* n (fac (- n 1))) )) )) 14 | (fac 5)) ) (newline) 15 | 16 | ; Again, we hoist definitions inside the let body, as well as multiple 17 | ; statements. 18 | 19 | (let ((hello "hello")) 20 | (display hello) 21 | (display " ") 22 | (display world) 23 | (newline) 24 | 25 | (define world "world")) 26 | -------------------------------------------------------------------------------- /test/success/let.scm.result: -------------------------------------------------------------------------------- 1 | 3 2 | 4 3 | 120 4 | hello world 5 | -------------------------------------------------------------------------------- /test/success/letrec.scm: -------------------------------------------------------------------------------- 1 | (define a 3) 2 | (define b 4) 3 | 4 | (display 5 | (letrec ((a (lambda (x) (+ x b))) 6 | (b 2)) 7 | (a 3))) (newline) 8 | 9 | (display a) (newline) 10 | (display b) (newline) 11 | 12 | ; The current binding should be available in its own definition in order to 13 | ; allow for recursion. 14 | (display 15 | (letrec ((fac (lambda (n) (if (= n 0) 1 (* n (fac (- n 1))) )) )) 16 | (fac 5)) ) (newline) 17 | 18 | ; letrec allows for mutual recursion. This example is adapted from the Racket 19 | ; language documentation. 20 | (letrec ((is-even? (lambda (x) 21 | (if (= x 0) 22 | #t 23 | (is-odd? (- x 1))) )) 24 | (is-odd? (lambda (x) 25 | (if (= x 0) 26 | #f 27 | (is-even? (- x 1))) ))) 28 | (display (is-odd? 11)) (newline) 29 | (display (is-odd? 12)) (newline)) 30 | 31 | ; Again, we hoist definitions inside the let* body, as well as multiple 32 | ; statements. 33 | 34 | (letrec ((hello "hello")) 35 | (display hello) 36 | (display " ") 37 | (display world) 38 | (newline) 39 | 40 | (define world "world")) 41 | -------------------------------------------------------------------------------- /test/success/letrec.scm.result: -------------------------------------------------------------------------------- 1 | 5 2 | 3 3 | 4 4 | 120 5 | #t 6 | #f 7 | hello world 8 | -------------------------------------------------------------------------------- /test/success/list.scm: -------------------------------------------------------------------------------- 1 | (display '()) (newline) 2 | (display '(a)) (newline) 3 | (display '(a b)) (newline) 4 | (display '(a b c)) (newline) 5 | (display '(a b c d)) (newline) 6 | 7 | (newline) 8 | 9 | (display (list)) (newline) 10 | (display (list 'a)) (newline) 11 | (display (list 'a 'b)) (newline) 12 | (display (list 'a 'b 'c)) (newline) 13 | (display (list 'a 'b 'c 'd)) (newline) 14 | 15 | (newline) 16 | 17 | (display '(())) (newline) 18 | (display '(a ())) (newline) 19 | (display '(a () b)) (newline) 20 | (display '(a (b) c)) (newline) 21 | (display '(a (b c) ((d)))) (newline) 22 | (display '((a b) (c d) (e))) (newline) 23 | 24 | (newline) 25 | 26 | (display (list (list))) (newline) 27 | (display (list 'a (list))) (newline) 28 | (display (list 'a (list) 'b)) (newline) 29 | (display (list 'a (list 'b) 'c)) (newline) 30 | (display (list 'a (list 'b 'c) (list (list 'd)))) (newline) 31 | (display (list (list 'a 'b) (list 'c 'd) (list 'e))) (newline) 32 | 33 | (newline) 34 | 35 | (display (list '(1 2 3) '(a b c))) (newline) 36 | -------------------------------------------------------------------------------- /test/success/list.scm.result: -------------------------------------------------------------------------------- 1 | () 2 | (a) 3 | (a b) 4 | (a b c) 5 | (a b c d) 6 | 7 | () 8 | (a) 9 | (a b) 10 | (a b c) 11 | (a b c d) 12 | 13 | (()) 14 | (a ()) 15 | (a () b) 16 | (a (b) c) 17 | (a (b c) ((d))) 18 | ((a b) (c d) (e)) 19 | 20 | (()) 21 | (a ()) 22 | (a () b) 23 | (a (b) c) 24 | (a (b c) ((d))) 25 | ((a b) (c d) (e)) 26 | 27 | ((1 2 3) (a b c)) 28 | -------------------------------------------------------------------------------- /test/success/numerical-tower.scm: -------------------------------------------------------------------------------- 1 | ;; + 2 | (display (+)) (newline) ; returns a fixnum by default 3 | (display (+ 1)) (newline) ; no conversion 4 | (display (+ 1.0)) (newline) ; no conversion 5 | (display (+ 1 2)) (newline) ; no conversion 6 | (display (+ 1.0 2)) (newline) ; convert to float 7 | (display (+ 1 2.0)) (newline) ; convert to float 8 | (display (+ 1.0 2 3.0 4 5.0)) (newline) ; convert to float 9 | 10 | (newline) 11 | 12 | ;; * 13 | (display (*)) (newline) ; returns a fixnum by default 14 | (display (* 1)) (newline) ; no conversion 15 | (display (* 1.0)) (newline) ; no conversion 16 | (display (* 1 2)) (newline) ; no conversion 17 | (display (* 1.0 2)) (newline) ; convert to float 18 | (display (* 1 2.0)) (newline) ; convert to float 19 | (display (* 1.0 2 3.0 4 5.0)) (newline) ; convert to float 20 | 21 | (newline) 22 | 23 | ;; - 24 | (display (- 1)) (newline) ; no conversion 25 | (display (- 1.0)) (newline) ; no conversion 26 | (display (- 1 2)) (newline) ; no conversion 27 | (display (- 1.0 2)) (newline) ; convert to float 28 | (display (- 1 2.0)) (newline) ; convert to float 29 | (display (- 1.0 2 3.0 4 5.0)) (newline) ; convert to float 30 | 31 | (newline) 32 | 33 | ;; < and > 34 | 35 | (display (> 1.0 2)) (newline) 36 | (display (< 1 2.0)) (newline) 37 | 38 | (newline) 39 | 40 | ;; nested and combinations 41 | (display (+ (* 1 2) 3)) (newline) ; no conversion 42 | (display (+ (* 1.0 2) 3)) (newline) ; convert to float 43 | (display (+ (* 1 2) 3.0)) (newline) ; convert to float 44 | -------------------------------------------------------------------------------- /test/success/numerical-tower.scm.result: -------------------------------------------------------------------------------- 1 | 0 2 | 1 3 | 1.000000 4 | 3 5 | 3.000000 6 | 3.000000 7 | 15.000000 8 | 9 | 1 10 | 1 11 | 1.000000 12 | 2 13 | 2.000000 14 | 2.000000 15 | 120.000000 16 | 17 | -1 18 | -1.000000 19 | -1 20 | -1.000000 21 | -1.000000 22 | -13.000000 23 | 24 | #f 25 | #t 26 | 27 | 5 28 | 5.000000 29 | 5.000000 30 | -------------------------------------------------------------------------------- /test/success/recursive-byte-utils.scm: -------------------------------------------------------------------------------- 1 | (require "../../recursive/byte-utils" => bu) 2 | 3 | (define (test-int->little-endian num-bytes ints) 4 | (display "num-bytes: " num-bytes) (newline) 5 | (display "------------") (newline) 6 | 7 | (foreach 8 | (lambda (int) 9 | (display " " int " -> " (bu:int->little-endian int num-bytes)) 10 | (newline)) 11 | ints)) 12 | 13 | ;; 1 byte 14 | (test-int->little-endian 15 | 1 16 | '( 0 17 | 1 18 | 2 19 | 4 20 | 8 21 | 16 22 | 32 23 | 64 24 | 127 25 | -1 26 | -2 27 | -4 28 | -8 29 | -16 30 | -32 31 | -64 32 | -127 33 | -128)) 34 | (newline) 35 | 36 | ;; 2 bytes 37 | (test-int->little-endian 38 | 2 39 | '( 0 40 | 1 41 | 2 42 | 4 43 | 8 44 | 16 45 | 32 46 | 64 47 | 128 48 | 256 49 | 512 50 | 1024 51 | 32767 52 | -1 53 | -2 54 | -4 55 | -8 56 | -16 57 | -32 58 | -64 59 | -128 60 | -256 61 | -512 62 | -1024 63 | -32767 64 | -32768)) 65 | (newline) 66 | 67 | ;; 4 bytes 68 | (test-int->little-endian 69 | 4 70 | '( 71 | 0 72 | 1 73 | 2 74 | 4 75 | 8 76 | 16 77 | 32 78 | 64 79 | 128 80 | 256 81 | 512 82 | 1024 83 | 32767 84 | 2147483647 85 | -1 86 | -2 87 | -4 88 | -8 89 | -16 90 | -32 91 | -64 92 | -128 93 | -256 94 | -512 95 | -1024 96 | -32767 97 | -32768 98 | -2147483647 99 | -2147483648)) 100 | (newline) 101 | -------------------------------------------------------------------------------- /test/success/recursive-byte-utils.scm.result: -------------------------------------------------------------------------------- 1 | num-bytes: 1 2 | ------------ 3 | 0 -> (0) 4 | 1 -> (1) 5 | 2 -> (2) 6 | 4 -> (4) 7 | 8 -> (8) 8 | 16 -> (16) 9 | 32 -> (32) 10 | 64 -> (64) 11 | 127 -> (127) 12 | -1 -> (255) 13 | -2 -> (254) 14 | -4 -> (252) 15 | -8 -> (248) 16 | -16 -> (240) 17 | -32 -> (224) 18 | -64 -> (192) 19 | -127 -> (129) 20 | -128 -> (128) 21 | 22 | num-bytes: 2 23 | ------------ 24 | 0 -> (0 0) 25 | 1 -> (1 0) 26 | 2 -> (2 0) 27 | 4 -> (4 0) 28 | 8 -> (8 0) 29 | 16 -> (16 0) 30 | 32 -> (32 0) 31 | 64 -> (64 0) 32 | 128 -> (128 0) 33 | 256 -> (0 1) 34 | 512 -> (0 2) 35 | 1024 -> (0 4) 36 | 32767 -> (255 127) 37 | -1 -> (255 255) 38 | -2 -> (254 255) 39 | -4 -> (252 255) 40 | -8 -> (248 255) 41 | -16 -> (240 255) 42 | -32 -> (224 255) 43 | -64 -> (192 255) 44 | -128 -> (128 255) 45 | -256 -> (0 255) 46 | -512 -> (0 254) 47 | -1024 -> (0 252) 48 | -32767 -> (1 128) 49 | -32768 -> (0 128) 50 | 51 | num-bytes: 4 52 | ------------ 53 | 0 -> (0 0 0 0) 54 | 1 -> (1 0 0 0) 55 | 2 -> (2 0 0 0) 56 | 4 -> (4 0 0 0) 57 | 8 -> (8 0 0 0) 58 | 16 -> (16 0 0 0) 59 | 32 -> (32 0 0 0) 60 | 64 -> (64 0 0 0) 61 | 128 -> (128 0 0 0) 62 | 256 -> (0 1 0 0) 63 | 512 -> (0 2 0 0) 64 | 1024 -> (0 4 0 0) 65 | 32767 -> (255 127 0 0) 66 | 2147483647 -> (255 255 255 127) 67 | -1 -> (255 255 255 255) 68 | -2 -> (254 255 255 255) 69 | -4 -> (252 255 255 255) 70 | -8 -> (248 255 255 255) 71 | -16 -> (240 255 255 255) 72 | -32 -> (224 255 255 255) 73 | -64 -> (192 255 255 255) 74 | -128 -> (128 255 255 255) 75 | -256 -> (0 255 255 255) 76 | -512 -> (0 254 255 255) 77 | -1024 -> (0 252 255 255) 78 | -32767 -> (1 128 255 255) 79 | -32768 -> (0 128 255 255) 80 | -2147483647 -> (1 0 0 128) 81 | -2147483648 -> (0 0 0 128) 82 | 83 | -------------------------------------------------------------------------------- /test/success/recursive-string-utils.scm: -------------------------------------------------------------------------------- 1 | (require "../../recursive/string-utils" => su) 2 | 3 | (display (su:ascii-string-to-bytes "abcd")) (newline) 4 | (display (su:ascii-string-to-bytes "1234\t\nabcd\\\"")) (newline) 5 | -------------------------------------------------------------------------------- /test/success/recursive-string-utils.scm.result: -------------------------------------------------------------------------------- 1 | (97 98 99 100 0) 2 | (49 50 51 52 9 10 97 98 99 100 92 34 0) 3 | -------------------------------------------------------------------------------- /test/success/renamed-require-c.scm: -------------------------------------------------------------------------------- 1 | ; libctest is a C module, not a Garlic one. 2 | (require "../aux/libc_module" => cm) 3 | 4 | (display (cm:add 1 2)) (newline) 5 | -------------------------------------------------------------------------------- /test/success/renamed-require-c.scm.result: -------------------------------------------------------------------------------- 1 | Adding 1 and 2 in C! 2 | 3 3 | -------------------------------------------------------------------------------- /test/success/renamed-require.scm: -------------------------------------------------------------------------------- 1 | (require "../aux/auxillary-module" => am) 2 | 3 | (am:auxillary-function "hello") 4 | -------------------------------------------------------------------------------- /test/success/renamed-require.scm.result: -------------------------------------------------------------------------------- 1 | loading auxillary-module... 2 | 3 | auxillary-function: hello 4 | -------------------------------------------------------------------------------- /test/success/require-relative.scm: -------------------------------------------------------------------------------- 1 | (require "../aux/auxillary-module") 2 | 3 | (auxillary-module:auxillary-function "hello") 4 | -------------------------------------------------------------------------------- /test/success/require-relative.scm.result: -------------------------------------------------------------------------------- 1 | loading auxillary-module... 2 | 3 | auxillary-function: hello 4 | -------------------------------------------------------------------------------- /test/success/require-star-c.scm: -------------------------------------------------------------------------------- 1 | ; libctest is a C module, not a Garlic one. 2 | (require "../aux/libc_module" *) 3 | 4 | (display (add 1 2)) (newline) 5 | -------------------------------------------------------------------------------- /test/success/require-star-c.scm.result: -------------------------------------------------------------------------------- 1 | Adding 1 and 2 in C! 2 | 3 3 | -------------------------------------------------------------------------------- /test/success/require-star-using-original-name.scm: -------------------------------------------------------------------------------- 1 | (require "../aux/auxillary-module" *) 2 | 3 | (define (auxillary-function x) 4 | (display "local auxillary-function: ") 5 | (display x) 6 | (newline)) 7 | 8 | (auxillary-function "hello") 9 | (auxillary-module:auxillary-function "hello") 10 | -------------------------------------------------------------------------------- /test/success/require-star-using-original-name.scm.result: -------------------------------------------------------------------------------- 1 | loading auxillary-module... 2 | 3 | local auxillary-function: hello 4 | auxillary-function: hello 5 | -------------------------------------------------------------------------------- /test/success/require-star.scm: -------------------------------------------------------------------------------- 1 | (require "../aux/many-exports-1" *) 2 | (require "../aux/many-exports-2" *) 3 | (require display-helpers => dh) 4 | 5 | (define (f2) "local-f2") 6 | (define (f3) "local-f3") 7 | 8 | (newline) 9 | 10 | (display (f0)) (newline) 11 | (display (f1)) (newline) 12 | (display (f2)) (newline) 13 | (display (f3)) (newline) 14 | 15 | (newline) 16 | 17 | (display (g0)) (newline) 18 | (display (g1)) (newline) 19 | (display (g2)) (newline) 20 | 21 | (newline) 22 | 23 | (dh:display-with-tag "INFO" "hello") 24 | -------------------------------------------------------------------------------- /test/success/require-star.scm.result: -------------------------------------------------------------------------------- 1 | loading display-helpers... 2 | 3 | f0 4 | f1 5 | local-f2 6 | local-f3 7 | 8 | g0 9 | g1 10 | g2 11 | 12 | [INFO] hello 13 | -------------------------------------------------------------------------------- /test/success/require-std.scm: -------------------------------------------------------------------------------- 1 | ; TODO 2 | (require display-helpers) 3 | 4 | (display-helpers:display-with-tag "INFO" "hello") 5 | -------------------------------------------------------------------------------- /test/success/require-std.scm.result: -------------------------------------------------------------------------------- 1 | loading display-helpers... 2 | [INFO] hello 3 | -------------------------------------------------------------------------------- /test/success/stdlib-overwrite.scm: -------------------------------------------------------------------------------- 1 | ; "filter" is provided by stdlib, and therefore it's imported into the current 2 | ; scope automatically. However, we can overwrite it if desired. 3 | (define (filter f ls) 4 | '()) 5 | 6 | (define not-null? (compose not null?)) 7 | (display (filter not-null? '(1 () 2 () 3))) (newline) 8 | 9 | ; However, the original stdlib function is still available using an explicit 10 | ; name space. 11 | (display (stdlib:filter not-null? '(1 () 2 () 3))) (newline) 12 | 13 | ; Furthermore, inside of stdlib, "filter" continues to refer to the original 14 | ; stdlib function. For example, "reject" is provided by stdlib and it depends 15 | ; on "filter". Despite not using an explitic namespace, stdlib will continue to 16 | ; use the original function. 17 | (display (reject null? '(1 () 2 () 3))) (newline) 18 | -------------------------------------------------------------------------------- /test/success/stdlib-overwrite.scm.result: -------------------------------------------------------------------------------- 1 | () 2 | (1 2 3) 3 | (1 2 3) 4 | -------------------------------------------------------------------------------- /test/success/string-lib.scm: -------------------------------------------------------------------------------- 1 | (require string => str) 2 | 3 | (display (str:concat)) (newline) 4 | (display (str:concat "a")) (newline) 5 | (display (str:concat "a" "bc")) (newline) 6 | (display (str:concat "a" "bc" "def")) (newline) 7 | (display (str:concat "a" "" "bc" "" "def")) (newline) 8 | 9 | (newline) 10 | 11 | (display (str:concat-list '())) (newline) 12 | (display (str:concat-list (list "a"))) (newline) 13 | (display (str:concat-list (list "a" "bc"))) (newline) 14 | (display (str:concat-list (list "a" "bc" "def"))) (newline) 15 | (display (str:concat-list (list "a" "" "bc" "" "def"))) (newline) 16 | 17 | (newline) 18 | 19 | (display (str:symbol->str 'this-was-a-symbol)) (newline) 20 | 21 | (newline) 22 | 23 | (display (str:string=? "abc" "abc")) (newline) 24 | (display (str:string=? "ABC" "abc")) (newline) 25 | 26 | (newline) 27 | 28 | (display (str:at "abcd" 0)) (newline) 29 | (display (str:at "abcd" 1)) (newline) 30 | (display (str:at "abcd" 2)) (newline) 31 | (display (str:at "abcd" 3)) (newline) 32 | (display (str:at "abcd" 4)) (newline) 33 | 34 | (newline) 35 | 36 | (display (str:string-tail "abcd" 0)) (newline) 37 | (display (str:string-tail "abcd" 1)) (newline) 38 | (display (str:string-tail "abcd" 2)) (newline) 39 | (display (str:string-tail "abcd" 3)) (newline) 40 | (display (str:string-tail "abcd" 4)) (newline) 41 | 42 | (newline) 43 | 44 | (display (str:null? "not-empty")) (newline) 45 | (display (str:null? "")) (newline) 46 | 47 | (newline) 48 | 49 | (display (str:length "")) (newline) 50 | (display (str:length "a")) (newline) 51 | (display (str:length "ab")) (newline) 52 | (display (str:length "abc")) (newline) 53 | (display (str:length "abcd")) (newline) 54 | -------------------------------------------------------------------------------- /test/success/string-lib.scm.result: -------------------------------------------------------------------------------- 1 | 2 | a 3 | abc 4 | abcdef 5 | abcdef 6 | 7 | 8 | a 9 | abc 10 | abcdef 11 | abcdef 12 | 13 | this-was-a-symbol 14 | 15 | #t 16 | #f 17 | 18 | a 19 | b 20 | c 21 | d 22 | () 23 | 24 | abcd 25 | bcd 26 | cd 27 | d 28 | 29 | 30 | #f 31 | #t 32 | 33 | 0 34 | 1 35 | 2 36 | 3 37 | 4 38 | -------------------------------------------------------------------------------- /test/success/sub.scm: -------------------------------------------------------------------------------- 1 | ;; Like add.scm, this tests variadic functions. However, in this test, the 2 | ;; order of the parameters matters, and so, accidentally pulling out the 3 | ;; parameters in reverse order will not be acceptable. 4 | 5 | (display (- 1)) (newline) 6 | (display (- 1 2)) (newline) 7 | (display (- 1 2 3)) (newline) 8 | (display (- 1 2 3 4)) (newline) 9 | (display (- 1 2 3 4 5)) (newline) 10 | -------------------------------------------------------------------------------- /test/success/sub.scm.result: -------------------------------------------------------------------------------- 1 | -1 2 | -1 3 | -4 4 | -8 5 | -13 6 | -------------------------------------------------------------------------------- /test/success/type-checks.scm: -------------------------------------------------------------------------------- 1 | (display (null? '())) (newline) 2 | (display (null? (list))) (newline) 3 | (display (null? '(1))) (newline) 4 | (display (null? '(1 2))) (newline) 5 | (display (null? 'symbol)) (newline) 6 | (display (null? 1)) (newline) 7 | 8 | (newline) 9 | 10 | (display (symbol? 'symbol)) (newline) 11 | (display (symbol? '())) (newline) 12 | (display (symbol? 1)) (newline) 13 | 14 | (newline) 15 | 16 | (display (list? '(1))) (newline) 17 | (display (list? '(1 2))) (newline) 18 | (display (list? (list 1 2))) (newline) 19 | (display (list? '())) (newline) 20 | (display (list? 'symbol)) (newline) 21 | (display (list? 1)) (newline) 22 | 23 | (newline) 24 | 25 | (display (number? 1)) (newline) 26 | (display (number? -100)) (newline) 27 | (display (number? 0xFF)) (newline) 28 | (display (number? 1.2)) (newline) 29 | (display (number? 'symbol)) (newline) 30 | (display (number? '())) (newline) 31 | (display (number? '(1 2))) (newline) 32 | -------------------------------------------------------------------------------- /test/success/type-checks.scm.result: -------------------------------------------------------------------------------- 1 | #t 2 | #t 3 | #f 4 | #f 5 | #f 6 | #f 7 | 8 | #t 9 | #f 10 | #f 11 | 12 | #t 13 | #t 14 | #t 15 | #f 16 | #f 17 | #f 18 | 19 | #t 20 | #t 21 | #t 22 | #t 23 | #f 24 | #f 25 | #f 26 | -------------------------------------------------------------------------------- /test/success/variadic.scm: -------------------------------------------------------------------------------- 1 | (require display-helpers) 2 | 3 | (newline) 4 | 5 | (define (varargs x y . z) (cons (+ x y) z)) 6 | (display (varargs 1 2 3 4 5)) (newline) 7 | 8 | (newline) 9 | 10 | (display (list 'a 'b 'c 'd)) (newline) 11 | (display-helpers:display-all-with-tag "INFO" 12 | "1st message" 13 | "2nd message" 14 | "3rd message") 15 | 16 | (newline) 17 | 18 | ; varargs work for lambdas too 19 | (display 20 | ((lambda (x y . z) 21 | (+ (* x y) 22 | (sum z)) ) 2 3 4 5 6) ) (newline) 23 | 24 | ; Note that because lambdas have no names, the syntax to specify no positional 25 | ; arguments is a little different: you have to specify the entire argument list 26 | ; as a single variable, not a list. 27 | (display ((lambda ls (sum ls)) 1 2 3)) (newline) 28 | 29 | (newline) 30 | 31 | ; `compose` is an example of a variadic function 32 | (display ((compose 33 | (lambda (x) (* x 2)) 34 | (lambda (x) (- x 3)) 35 | (lambda (x) (+ x 4)) 36 | (lambda (x) (* x 5))) 1)) (newline) 37 | -------------------------------------------------------------------------------- /test/success/variadic.scm.result: -------------------------------------------------------------------------------- 1 | loading display-helpers... 2 | 3 | (3 3 4 5) 4 | 5 | (a b c d) 6 | [INFO] 1st message 7 | [INFO] 2nd message 8 | [INFO] 3rd message 9 | 10 | 21 11 | 6 12 | 13 | 12 14 | --------------------------------------------------------------------------------