├── .clang-format ├── .gitattributes ├── .gitignore ├── .travis.yml ├── CONTRIBUTING.md ├── CONTRIBUTORS.md ├── LICENSE ├── README.md ├── lispfmt.py ├── scheme-gc ├── .gitignore ├── configure ├── docs │ └── microlisp.1 └── src │ ├── fib.scm │ ├── lib.scm │ └── scheme.c └── scheme ├── .gitignore ├── configure ├── docs └── microlisp.1 └── src ├── fib.scm ├── lib.scm └── scheme.c /.clang-format: -------------------------------------------------------------------------------- 1 | --- 2 | Language: Cpp 3 | # BasedOnStyle: LLVM 4 | AccessModifierOffset: -2 5 | ConstructorInitializerIndentWidth: 4 6 | AlignEscapedNewlinesLeft: false 7 | AlignTrailingComments: true 8 | AllowAllParametersOfDeclarationOnNextLine: true 9 | AllowShortBlocksOnASingleLine: false 10 | AllowShortIfStatementsOnASingleLine: false 11 | AllowShortLoopsOnASingleLine: false 12 | AllowShortFunctionsOnASingleLine: All 13 | AlwaysBreakTemplateDeclarations: false 14 | AlwaysBreakBeforeMultilineStrings: false 15 | BreakBeforeBinaryOperators: false 16 | BreakBeforeTernaryOperators: true 17 | BreakConstructorInitializersBeforeComma: false 18 | BinPackParameters: true 19 | ColumnLimit: 80 20 | ConstructorInitializerAllOnOneLineOrOnePerLine: false 21 | DerivePointerAlignment: false 22 | ExperimentalAutoDetectBinPacking: false 23 | IndentCaseLabels: false 24 | IndentWrappedFunctionNames: false 25 | IndentFunctionDeclarationAfterType: false 26 | MaxEmptyLinesToKeep: 1 27 | KeepEmptyLinesAtTheStartOfBlocks: true 28 | NamespaceIndentation: None 29 | ObjCSpaceAfterProperty: false 30 | ObjCSpaceBeforeProtocolList: true 31 | PenaltyBreakBeforeFirstCallParameter: 19 32 | PenaltyBreakComment: 300 33 | PenaltyBreakString: 1000 34 | PenaltyBreakFirstLessLess: 120 35 | PenaltyExcessCharacter: 1000000 36 | PenaltyReturnTypeOnItsOwnLine: 60 37 | PointerAlignment: Right 38 | SpacesBeforeTrailingComments: 1 39 | Cpp11BracedListStyle: true 40 | Standard: Cpp11 41 | IndentWidth: 4 42 | TabWidth: 4 43 | UseTab: Never 44 | BreakBeforeBraces: Attach 45 | SpacesInParentheses: false 46 | SpacesInAngles: false 47 | SpaceInEmptyParentheses: false 48 | SpacesInCStyleCastParentheses: false 49 | SpacesInContainerLiterals: true 50 | SpaceBeforeAssignmentOperators: true 51 | ContinuationIndentWidth: 4 52 | CommentPragmas: '^ IWYU pragma:' 53 | ForEachMacros: [ foreach, Q_FOREACH, BOOST_FOREACH ] 54 | SpaceBeforeParens: ControlStatements 55 | DisableFormat: false 56 | ... 57 | 58 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | * text=auto -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.out 3 | lisp 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | script: cd scheme && ./configure && make && build/microlisp src/fib.scm 4 | 5 | notifications: 6 | email: false 7 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contribution Guide 2 | 3 | ### For All Projects 4 | 5 | * By contributing, you agree to release your contributions under the MIT License (default), or whatever the LICENSE file being used is. 6 | * Please do not include any external libraries that are not already used by the project. Adding in new source files is OK, but in general, I don't like using external libraries for my projects. 7 | * Before submitting a PR, make sure that the code compiles. 8 | * Try to maintain format/style 9 | 10 | ### For C Projects 11 | 12 | * Compilation: Typically, try to compile using the provided Makefile settings/CFLAGS. The goal is to compile most projects with `-Wall -Wextra -Werror`, although exceptions are allowed. 13 | * Formatting: 4 spaces to a tab. If a .clang-format file is provided, please format code using clang-format before submitting a PR 14 | 15 | ### For Rust Projects 16 | 17 | * Compilation: Code should compile without warnings or errors. 18 | * Testing: Code should have tests, where applicable 19 | * Formatting: Use `rustfmt` -------------------------------------------------------------------------------- /CONTRIBUTORS.md: -------------------------------------------------------------------------------- 1 | Ben Simms @nitros12 https://github.com/nitros12 -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2016 - 2019 Michael Lazear 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # microlisp 2 | [![Build Status](https://travis-ci.org/lazear/microlisp.svg?branch=master)](https://travis-ci.org/lazear/microlisp) 3 | 4 | A set of minimal LISP[1] implementations. 5 | 6 | !["I've just received word that the Emperor has dissolved the MIT computer science program permanently."](https://imgs.xkcd.com/comics/lisp_cycles.png) 7 | 8 | 1. The `scheme` folder contains a minimal implementation of scheme that supports the most important primitives. Currently only supports integer type for numbers. This implementation takes the homoiconic approach outlined in SICP's metacircular evaluator, in which procedures are represented as lists tagged with 'procedure. This allows some interesting differences over other C implementations where procedures are stored as C-style data structures. Due to lack of a garbage collector, it's relatively quick but can be a major memory hog (e.g. when calculating the 30th fibonacci number using recursion) 9 | 10 | 2. The `scheme-gc` folder contains a version of the `scheme` interpreter with a garbage collector 11 | 12 | To build and run either of the projects, `cd` into the folder and run `./configure && make && ./build/microlisp` 13 | 14 | [1]: http://www-formal.stanford.edu/jmc/recursive.pdf 15 | -------------------------------------------------------------------------------- /lispfmt.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/python 2 | # formatting for lisp code 3 | # 2 spaces per paren depth per line 4 | import sys 5 | 6 | def reformat(s): 7 | depth = 0 8 | 9 | # formatted string 10 | fmt = "" 11 | 12 | # remove leading whitespaces 13 | unfmt = "" 14 | for c in s: 15 | if c == '\t' or c == ' ' and hit == False: 16 | continue 17 | else: 18 | unfmt += c 19 | if c == '\n': 20 | hit = False 21 | else: 22 | hit = True 23 | 24 | # add in proper indentation 25 | for c in unfmt: 26 | fmt += c 27 | if c == '(': 28 | depth += 1 29 | elif c == ')': 30 | depth -= 1 31 | elif c == '\n': 32 | for x in range(0, depth): 33 | fmt += " " 34 | 35 | return fmt 36 | 37 | def format_file(filename): 38 | with open(filename) as f: 39 | return reformat(f.read()) 40 | 41 | 42 | if __name__ == "__main__": 43 | if len(sys.argv) > 1: 44 | for f in sys.argv[1:]: 45 | print(format_file(f)) 46 | else: 47 | s = "" 48 | for line in sys.stdin: 49 | s += line 50 | print(reformat(s)) -------------------------------------------------------------------------------- /scheme-gc/.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.a 3 | *.tar.gz 4 | .config 5 | build/ -------------------------------------------------------------------------------- /scheme-gc/configure: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Automatic configuration script 3 | # Released under the MIT License 4 | # Copyright (c) 2017 Michael Lazear 5 | 6 | # Project information 7 | SOURCE_DIR=src 8 | INCLUDE_DIR=include 9 | BUILD_DIR=build 10 | DOCUMENTATION=docs 11 | OUTPUT=Makefile 12 | MANPATH="" 13 | PROJECT="microlisp" 14 | PROJECT_VER="" 15 | PREFIX=/usr/local/bin 16 | 17 | # Build machine and compiler information 18 | CC=$(which cc) 19 | CMACHINE=$(cc -dumpmachine) 20 | CVERSION=$(cc -dumpversion) 21 | CFLAGS="" 22 | ARCH=$(uname -m) 23 | OS=$(uname -s) 24 | STDC_VERSION="" 25 | 26 | # Configuration information 27 | CONFIG_DIR=.config 28 | CONFIG_HEADER=$INCLUDE_DIR/configure.h 29 | 30 | check_header() { 31 | printf "Checking for $1... " 32 | cat << ENDHEADER > $CONFIG_DIR/header.c 33 | #include "$1" 34 | int main(void) { 35 | return 0; 36 | } 37 | ENDHEADER 38 | $CC -Wall -Wextra -Werror $CONFIG_DIR/header.c 2> /dev/null 39 | if [ $? -eq 0 ]; then 40 | echo "success" 41 | name=$(echo $1 | sed 's/\.h//g') 42 | echo "#define CONFIGURE_${name^^}" 1 >> $CONFIG_HEADER 43 | rm ./a.out 44 | else 45 | echo "fail" 46 | echo "#define CONFIGURE_${name^^}" 0 >> $CONFIG_HEADER 47 | fi 48 | 49 | } 50 | 51 | check_function() { 52 | printf "Checking for function $2 in $1... " 53 | cat << ENDHEADER > $CONFIG_DIR/function.c 54 | #include "$1" 55 | int main(void) { 56 | $2(${@:3}); 57 | return 0; 58 | } 59 | ENDHEADER 60 | $CC -Wall -Wextra -Werror $CONFIG_DIR/function.c 2> /dev/null 61 | 62 | if [ $? -eq 0 ]; then 63 | echo "success" 64 | echo "#define CONFIGURE_${2^^} 1" >> $CONFIG_HEADER 65 | rm ./a.out 66 | else 67 | echo "fail" 68 | echo "#define CONFIGURE_${2^^} 0" >> $CONFIG_HEADER 69 | fi 70 | 71 | } 72 | 73 | # Determine what version of standard C library we support 74 | check_stdc() { 75 | printf "Checking which version of the C standard compiler supports... " 76 | cat << END_STDC > $CONFIG_DIR/version.c 77 | #include "stdio.h" 78 | int main(int argc, char** argv) { 79 | printf("%ld", __STDC_VERSION__); 80 | return 0; 81 | } 82 | END_STDC 83 | $CC $CONFIG_DIR/version.c 2> /dev/null 84 | if [ $? -eq 0 ]; then 85 | STDC_VERSION=$(./a.out) 86 | echo $STDC_VERSION 87 | rm ./a.out 88 | else 89 | echo "__STDC_VERSION__ not defined" 90 | fi 91 | } 92 | 93 | # Create a makefile 94 | create_makefile() { 95 | cat << EOF > $OUTPUT 96 | #!/usr/bin/make 97 | # Makefile automatically generated using $0 $@ 98 | # $(date +"%F") 99 | 100 | # Build machine specs 101 | export MACHINE = $CMACHINE 102 | export ARCH = $ARCH 103 | 104 | # C compiler information 105 | export CC = $CC 106 | export CCVER = $CVERSION 107 | export STDC_VER = $STDC_VERSION 108 | export CFLAGS = $CFLAGS 109 | 110 | # Project information 111 | export PREFIX = $PREFIX 112 | export PROJECT = $PROJECT 113 | export VERSION = $PROJECT_VER 114 | 115 | export DOCS = $DOCUMENTATION 116 | export MANPATH = $MANPATH 117 | EOF 118 | cat << 'EOF' >> $OUTPUT 119 | # Build information 120 | export SRC_DIR = src 121 | export INC_DIR = include 122 | export BUILD = build 123 | export HEADERS = $(wildcard $(INC_DIR)/*.h) 124 | export SOURCE = $(wildcard $(SRC_DIR)/*.c) 125 | export OBJECTS = $(SOURCE:.c=.o) 126 | export TARGET = $(BUILD)/$(PROJECT) 127 | 128 | .PHONY: all clean dist install uninstall upgrade 129 | 130 | all: $(TARGET) 131 | 132 | clean: 133 | @rm -rf $(OBJECTS) 134 | 135 | dist: $(TARGET) clean 136 | @echo "creating distribution archive $(PROJECT)-$(VERSION).tar.gz" 137 | if [ -d $(DOCS) ]; then \ 138 | tar -czvf $(PROJECT)-$(VERSION).tar.gz configure Makefile $(DOCS) $(TARGET) $(SRC_DIR) $(IN_DIR); \ 139 | else \ 140 | tar -czvf $(PROJECT)-$(VERSION).tar.gz configure Makefile $(TARGET) $(SRC_DIR) $(INC_DIR); \ 141 | fi 142 | install: $(TARGET) 143 | @echo "installing $(PROJECT) in $(PREFIX)" 144 | @cp -uv $(TARGET) $(PREFIX)/$(PROJECT)-$(VERSION) 145 | @chmod 0755 $(PREFIX)/$(PROJECT)-$(VERSION) 146 | @ln -sf $(PREFIX)/$(PROJECT)-$(VERSION) $(PREFIX)/$(PROJECT) 147 | if [ -f $(DOCS)/$(PROJECT).1 ]; then \ 148 | cp $(DOCS)/$(PROJECT).1 $(MANPATH); \ 149 | fi; 150 | 151 | uninstall: 152 | @echo "uninstalling $(PROJECT) in $(PREFIX)" 153 | if [ -f $(PREFIX)/$(PROJECT) ]; then \ 154 | rm -rf $(PREFIX)/$(PROJECT); \ 155 | rm -rf $(PREFIX)/$(PROJECT)-$(VERSION); \ 156 | fi 157 | if [ -f $(MANPATH)/$(PROJECT).1 ]; then \ 158 | rm -rf $(MANPATH)/$(PROJECT).1; \ 159 | fi 160 | 161 | upgrade: 162 | @cp -uv $(TARGET) $(PREFIX)/$(PROJECT)-$(VERSION) 163 | @cp -uv $(DOCS)/$(PROJECT).1 $(MANPATH)/$(PROJECT).1 164 | @ln -sf $(PREFIX)/$(PROJECT)-$(VERSION) $(PREFIX)/$(PROJECT) 165 | 166 | %.o: %.c 167 | @echo "cc $<" 168 | @$(CC) $(CFLAGS) -c $< -o $@ 169 | 170 | $(TARGET): $(OBJECTS) $(HEADERS) 171 | @echo "building $(PROJECT)" 172 | @$(CC) $(CFLAGS) $(OBJECTS) -o $(TARGET) 173 | EOF 174 | } 175 | 176 | create_accessories() { 177 | 178 | if [ ! -f README.md ]; then 179 | cat << ENDREADME > README.md 180 | # $PROJECT-$PROJECT_VER 181 | 182 | ### Building 183 | \`\`\` 184 | ./configure 185 | make 186 | make install 187 | \`\`\` 188 | 189 | ### Documentation 190 | See $PROJECT(1) 191 | 192 | ### License 193 | See LICENSE file 194 | ENDREADME 195 | fi 196 | if [ ! -f LICENSE ]; then 197 | cat << ENDLICENSE > LICENSE 198 | MIT License 199 | 200 | Copyright (c) $(date +"%Y") $(whoami) 201 | 202 | Permission is hereby granted, free of charge, to any person obtaining a copy 203 | of this software and associated documentation files (the "Software"), to deal 204 | in the Software without restriction, including without limitation the rights 205 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 206 | copies of the Software, and to permit persons to whom the Software is 207 | furnished to do so, subject to the following conditions: 208 | 209 | The above copyright notice and this permission notice shall be included in all 210 | copies or substantial portions of the Software. 211 | 212 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 213 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 214 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 215 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 216 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 217 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 218 | SOFTWARE. 219 | ENDLICENSE 220 | fi 221 | if [ ! -f .gitignore ]; then 222 | cat << ENDIGNORE > .gitignore 223 | *.o 224 | *.a 225 | .config 226 | ENDIGNORE 227 | fi 228 | } 229 | 230 | manpage() { 231 | # don't overwrite existing man pages 232 | if [ -f $DOCUMENTATION/$PROJECT.1 ]; then 233 | return 234 | fi 235 | cat << ENDMAN1 > $DOCUMENTATION/$PROJECT.1 236 | .TH ${PROJECT^^} 1 237 | .SH NAME 238 | $PROJECT \- project description 239 | .SH SYNOPSIS 240 | .B $PROJECT 241 | [\fB\-\-option1\fR] 242 | [\fB\-\-option2\fR] 243 | [\fB\-\-option3\fR \fIfile\fR] 244 | .SH DESCRIPTION 245 | Longform project description 246 | .SH OPTIONS 247 | .TP 248 | \fB\-short\fR, \fB\-\-option1\fR 249 | option1 command 250 | .TP 251 | \fB\-\-option2\fR 252 | option2 command 253 | .TP 254 | \fB\-\-option2\fR \fIfile\fR 255 | .I file 256 | does what 257 | .SH FILES 258 | .I ~/.$PROJECT.conf 259 | .RS 260 | User configuration file. See 261 | .BR $PROJECT(5) 262 | for further details 263 | 264 | .SH AUTHOR 265 | $(whoami) 266 | .SH "SEE ALSO" 267 | .BR $PROJECT(5) 268 | ENDMAN1 269 | } 270 | 271 | # Clean configuration and build directories 272 | clean() { 273 | rm -rf $CONFIG_DIR 274 | rm -rf $BUILD_DIR 275 | } 276 | 277 | 278 | ### Script begins here ### 279 | 280 | # If Makefile exists, grab the existing PROJECT_VER and CFLAGS variables and use them 281 | if [ -f $OUTPUT ]; then 282 | PROJECT_VER=$(cat $OUTPUT | grep "export VERSION" | sed -e 's/^.*=[ ]*//g') 283 | CFLAGS=$(cat $OUTPUT | grep "export CFLAGS" | sed -e 's/^export CFLAGS\s*=\s*//') 284 | MANPATH=$(cat $OUTPUT | grep "export MANPATH" | sed -e 's/^.*[ ]*//g') 285 | else 286 | PROJECT_VER="0.1.0" 287 | fi 288 | 289 | TEMP=`getopt -o hp --long help,clean,prefix:,cc:,cflags: -n 'configure' -- "$@"` 290 | 291 | # Note the quotes around `$TEMP': they are essential! 292 | eval set -- "$TEMP" 293 | 294 | while true ; do 295 | case "$1" in 296 | -h|--help) 297 | echo "$0" 298 | echo "--help: display help menu 299 | --prefix=/path/to/dir set the installation directory default /usr/local/bin 300 | --cc=/path/to/compiler set the C compiler default /usr/bin/cc 301 | --cflags=\"-Wall -O3\" set the C compiler flags default -O2 -Wall -Wextra -Werror -I $INCLUDE_DIR 302 | --clean clean up the config and build directories, regenerate Makefile" 303 | exit 0;; 304 | --clean) 305 | clean 306 | exit 0;; 307 | -p|--prefix) 308 | PREFIX="$2"; 309 | shift 2 ;; 310 | --cc) 311 | CC="$2"; 312 | shift 2;; 313 | --cflags) 314 | CFLAGS="$2"; 315 | shift 2;; 316 | --) 317 | shift; 318 | break ;; 319 | *) 320 | echo "$0 error: unknown argument!" ; 321 | exit 1 ;; 322 | esac 323 | done 324 | 325 | # Make sure we've been passed a valid executable file 326 | if [ ! $(which $CC) ]; then 327 | echo "$0 error: C compiler not found" 328 | exit 1; 329 | fi 330 | 331 | echo "Configuring for $PROJECT-$PROJECT_VER" 332 | 333 | # If no source directory found, go ahead and create one - with a helloworld.c 334 | if [ ! -d $SOURCE_DIR ]; then 335 | mkdir -p $SOURCE_DIR 336 | cat << HELLOWORLD > $SOURCE_DIR/$PROJECT.c 337 | #include 338 | #include 339 | #include "configure.h" 340 | 341 | int main(void) { 342 | printf("Hello world brought to you by %s\n", CONFIGURE_NAME); 343 | return EXIT_SUCCESS; 344 | } 345 | HELLOWORLD 346 | fi 347 | 348 | # Make any directories we don't have yet 349 | mkdir -p $DOCUMENTATION 350 | mkdir -p $CONFIG_DIR 351 | mkdir -p $INCLUDE_DIR 352 | mkdir -p $BUILD_DIR 353 | 354 | # No CFLAGS parsed from the Makefile, fallback to the default 355 | if [[ $CFLAGS == "" ]]; then 356 | CFLAGS="-O2 -Wall -Wextra -Werror -I$INCLUDE_DIR" 357 | fi 358 | 359 | # No project version parsed from the Makefile, fallback to default 360 | if [[ $PROJECT_VER == "" ]]; then 361 | PROJECT_VER="0.1.0" 362 | fi 363 | 364 | # If we haven't parsed a manpath from the Makefile, figure out what it should be 365 | if [[ $MANPATH == "" ]]; then 366 | for path in $(manpath | tr ":" "\n"); do 367 | if [ -d $path/man1 ]; then 368 | MANPATH="$path/man1" 369 | echo "Setting man page path to $MANPATH" 370 | break; 371 | fi 372 | done 373 | fi 374 | 375 | # Does a file in the install directory already exist? 376 | if [ -f $PREFIX/$PROJECT ]; then 377 | echo "Warning: $PREFIX/$PROJECT already exists - suggest changing project name before install" 378 | fi 379 | 380 | # If we haven't made a local copy of the configure script, do so now 381 | if [ ! -f configure ]; then 382 | echo "Copying configure script to $(pwd)" 383 | cp $0 configure 384 | fi 385 | 386 | # Begin dependency/header check 387 | cat << ECONFIG > $CONFIG_HEADER 388 | /* This file was automatically generated by $0 */ 389 | #ifndef _CONFIGURE_H_ 390 | #define _CONFIGURE_H_ 391 | 392 | #define CONFIGURE_NAME "$PROJECT" 393 | #define CONFIGURE_VERSION "$PROJECT_VER" 394 | #define CONFIGURE_ARCH "$ARCH" 395 | ECONFIG 396 | 397 | check_stdc 398 | create_makefile 399 | create_accessories 400 | manpage 401 | 402 | check_header "stdio.h" 403 | check_header "stddef.h" 404 | check_header "stdint.h" 405 | check_header "stdlib.h" 406 | 407 | printf "\n#endif" >> $CONFIG_HEADER 408 | -------------------------------------------------------------------------------- /scheme-gc/docs/microlisp.1: -------------------------------------------------------------------------------- 1 | .TH MICROLISP 1 2 | .SH NAME 3 | microlisp \- microlisp interpreter 4 | .SH SYNOPSIS 5 | .B microlisp 6 | [\fIfile\fR] ... 7 | .SH DESCRIPTION 8 | Lightweight LISP interpreter that follows a minimal Scheme-like dialect. 9 | .SH OPTIONS 10 | .TP 11 | \fIfile\fR 12 | Load and silently evaluate the source file 13 | 14 | .SH AUTHOR 15 | Michael Lazear 16 | .I 17 | @lazear 18 | -------------------------------------------------------------------------------- /scheme-gc/src/fib.scm: -------------------------------------------------------------------------------- 1 | (define (fib n) 2 | (if (= n 2) 3 | 1 4 | (if (= n 1) 5 | 1 6 | (+ 7 | (fib (- n 1)) 8 | (fib (- n 2)))))) 9 | (print (fib 35)) 10 | (exit) 11 | -------------------------------------------------------------------------------- /scheme-gc/src/lib.scm: -------------------------------------------------------------------------------- 1 | ;;; Michael Lazear, (C) 2016 - MIT License 2 | ;;; Standard Library functions 3 | 4 | (define caar (lambda(a) (car (car a)))) 5 | (define cadr (lambda(a) (car (cdr a)))) 6 | (define cdar (lambda(a) (cdr (car a)))) 7 | (define cddr (lambda(a) (cdr (cdr a)))) 8 | (define cadar (lambda(a) (car (cdr (car a))))) 9 | (define caddr (lambda(a) (car (cdr (cdr a))))) 10 | (define cdddr (lambda(a) (cdr (cdr (cdr a))))) 11 | (define cadddr (lambda(a) (car (cdr (cdr (cdr a)))))) 12 | 13 | (define != (lambda (a b) (if (= a b) #f #t))) 14 | (define >= (lambda (a b) (if (< a b) #f #t))) 15 | (define <= (lambda (a b) (if (> a b) #f #t))) 16 | 17 | ;;; Return the maximum value from a list of integers 18 | (define (max list-of-numbers) 19 | (define (max-iter best remaining) 20 | (cond ((null? remaining) best) 21 | ((> (car remaining) best) (max-iter (car remaining) (cdr remaining))) 22 | (else (max-iter best (cdr remaining))))) 23 | (max-iter (car list-of-numbers) (cdr list-of-numbers))) 24 | 25 | ;;; Return the minimum value from a list of integers 26 | (define (min list-of-numbers) 27 | (define (min-iter best remaining) 28 | (cond ((null? remaining) best) 29 | ((< (car remaining) best) (min-iter (car remaining) (cdr remaining))) 30 | (else (min-iter best (cdr remaining))))) 31 | (min-iter (car list-of-numbers) (cdr list-of-numbers))) 32 | 33 | ;;; Map a function 'f' onto list 'a' 34 | (define map (lambda (f a) 35 | (if (null? a) 36 | '() 37 | (cons (f (car a)) (map f (cdr a)))))) 38 | 39 | 40 | ;;; Provide the association pair of key from list 41 | (define (assoc key list) 42 | (if (null? list) 43 | '() 44 | (if (eq? key (car (car list))) 45 | (car list) 46 | (assoc key (cdr list))))) 47 | 48 | ;;; Lambda key-list with dispatch 49 | (define (make-key-list) 50 | (let ((list '())) 51 | (define get-val (lambda (var) 52 | (assoc var list))) 53 | (define add-key (lambda (var val) 54 | (set! list (cons (cons var val) list)))) 55 | (define (dispatch m) 56 | (if (eq? m 'add) add-key 57 | (if (eq? m 'get) get-val 58 | list))) 59 | dispatch)) 60 | 61 | ;;; Lambda stack with dispatch 62 | (define (make-stack) 63 | (let ((stack '())) 64 | (define push (lambda (x) 65 | (set! stack (cons x stack)) 66 | stack)) 67 | (define pop (lambda (x) 68 | (define q (car stack)) 69 | (set! stack (cdr stack)) 70 | q)) 71 | (define (dispatch m) 72 | (if (eq? m 'push) push 73 | (if (eq? m 'pop) pop 74 | stack))) 75 | dispatch)) 76 | ;;; Returns the last item in a list or pair. 77 | ;;; Pointer to cdr if list, Pointer to object if pair 78 | (define last-item-in-list (lambda (list) 79 | (define (helper remaining) 80 | (if (null? (cdr remaining)) 81 | remaining 82 | (helper (cdr remaining)))) 83 | (helper list))) 84 | 85 | ;;; Returns a list from (0-number) 86 | (define (range number) 87 | (define (range-helper start max) 88 | (if (= start max) 89 | (cons max '()) 90 | (cons start (range-helper (+ 1 start) max)))) 91 | (range-helper 0 number)) 92 | 93 | ;;; Returns a list from (0-number) 94 | (define (range-from start finish) 95 | (if (= start finish) 96 | finish 97 | (cons start (range-from (+ 1 start) finish)))) 98 | 99 | ;;; Tail recursive length 100 | (define (length list) 101 | (define (length-helper accum remaining) 102 | (if (null? remaining) 103 | accum 104 | (length-helper (+ 1 accum) (cdr remaining)))) 105 | (length-helper 1 (cdr list))) 106 | 107 | ;;; Append list2 to list1 108 | (define append (lambda (list1 list2) 109 | (define (append-helper l1 l2) 110 | (if (null? l1) 111 | l2 112 | (cons (car l1) (append-helper (cdr l1) l2)))) 113 | (append-helper list1 list2))) 114 | 115 | ;;; Reverse list 116 | (define (reverse list) 117 | (define (reverse-iter remaining first) 118 | (if (null? remaining) 119 | first 120 | (reverse-iter (cdr remaining) (cons (car remaining) first)))) 121 | (reverse-iter list '())) 122 | 123 | (define (pow num exp) 124 | (define (iter a b) 125 | (if (eq? b 1) 126 | a 127 | (iter (* a num) (- b 1)))) 128 | (if (eq? exp 0) 129 | 1 130 | (iter num exp))) 131 | 132 | (define (>= a b) 133 | (if (< a b) #f #t)) 134 | 135 | (define (<= a b) 136 | (if (> a b) #f #t)) 137 | 138 | (define ge <=) 139 | (define le >=) 140 | 141 | (define (mod a b) 142 | (define (iter rem div) 143 | (if (< rem div) 144 | rem 145 | (iter (- rem div) div))) 146 | (iter a b)) 147 | 148 | ;;; A couple macros 149 | ;;; Because this is LISP and we can... 150 | (define procedure-body (lambda (proc) (caddr proc))) 151 | (define procedure-args (lambda (proc) (cadr proc))) 152 | (define (mutate-procedure-env name new-env) (set-car! (cdddr name) new-env)) 153 | (define (mutate-procedure-body name new-body) (set-car! (cddr name) (list new-body))) 154 | (define (mutate-procedure-args name new-args) (set-car! (cdr name) new-args)) 155 | 156 | (define (construct-procedure args body env) 157 | (let ((new-proc (cons 'procedure (cons '() (cons '() (cons '())))))) 158 | (mutate-procedure-args new-proc args) 159 | (mutate-procedure-body new-proc body) 160 | (mutate-procedure-env new-proc env) 161 | new-proc)) 162 | 163 | (define (if-zero x then) (list 'if (list '= x 0) then)) 164 | 165 | (define (gen-accum number) 166 | (lambda (amount) 167 | (set! number (+ number amount)) 168 | number)) 169 | 170 | ;;; Everytime (new-accum) is called, it's accumulator should be increased by one 171 | (define new-accum (gen-accum 0)) 172 | 173 | ;; Simple for loop 174 | (define for (lambda (start end do) 175 | (define (for-loop a z) 176 | (if (= a z) 177 | 'Done;; Last iteration 178 | (begin 179 | (do) 180 | (for-loop (+ 1 a) z)))) 181 | (for-loop start end do))) 182 | 183 | (define (make-withdraw balance) 184 | (lambda (amount) 185 | (if (> balance amount) 186 | (begin (set! balance (- balance amount)) 187 | balance) 188 | "Insufficient funds"))) 189 | 190 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 191 | ;;; Various tests 192 | (define x '(1 2 3)) 193 | (define factorial (lambda(n) (if (= n 0) 1 (* n (factorial (- n 1)))))) 194 | (define add1 (lambda(n) (+ 1 n))) 195 | (define (sum-of-squares num-list) 196 | (define sos-helper (lambda (remaining sum-so-far) 197 | (if (null? remaining) 198 | sum-so-far 199 | (sos-helper (cdr remaining) (+ sum-so-far (* (car remaining) (car remaining))))))) 200 | (sos-helper num-list 0)) 201 | 202 | ;;; Procedure with no args 203 | (define (new-env) (cons (cons '() '()) '())) 204 | ;;; Construct a procedure with macro 205 | (define new-func (construct-procedure '(a) '(cons a 10) (get-global-environment))) 206 | (define with-macros (construct-procedure '(x) (if-zero 'x 'ZERO) (get-global-environment))) -------------------------------------------------------------------------------- /scheme-gc/src/scheme.c: -------------------------------------------------------------------------------- 1 | /* 2 | Single file scheme interpreter 3 | 4 | MIT License 5 | 6 | Copyright (c) Michael Lazear (@lazear) 2016-2017 7 | Copyright (c) Ben Simms (@nitros12) 2017 8 | 9 | Permission is hereby granted, free of charge, to any person obtaining a copy 10 | of this software and associated documentation files (the "Software"), to deal 11 | in the Software without restriction, including without limitation the rights 12 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 13 | copies of the Software, and to permit persons to whom the Software is 14 | furnished to do so, subject to the following conditions: 15 | 16 | The above copyright notice and this permission notice shall be included in all 17 | copies or substantial portions of the Software. 18 | 19 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 25 | SOFTWARE. 26 | */ 27 | 28 | #include 29 | #include 30 | #include 31 | #include 32 | #include 33 | #include 34 | #include 35 | #include 36 | #include 37 | 38 | #define null(x) ((x) == NULL || (x) == NIL) 39 | #define EOL(x) (null((x)) || (x) == EMPTY_LIST) 40 | #define error(x) \ 41 | do { \ 42 | fprintf(stderr, "%s\n", x); \ 43 | exit(1); \ 44 | } while (0) 45 | #define caar(x) (car(car((x)))) 46 | #define cdar(x) (cdr(car((x)))) 47 | #define cadr(x) (car(cdr((x)))) 48 | #define caddr(x) (car(cdr(cdr((x))))) 49 | #define cadddr(x) (car(cdr(cdr(cdr((x)))))) 50 | #define cadar(x) (car(cdr(car((x))))) 51 | #define cddr(x) (cdr(cdr((x)))) 52 | #define cdadr(x) (cdr(car(cdr((x))))) 53 | #define atom(x) (!null(x) && (x)->type != LIST) 54 | #define ASSERT_TYPE(x, t) (__type_check(__func__, x, t)) 55 | 56 | typedef enum { INTEGER, SYMBOL, STRING, LIST, PRIMITIVE, VECTOR } type_t; 57 | typedef struct object *(*primitive_t)(void *, struct object *); 58 | 59 | /* Lisp object. We want to mimic the homoiconicity of LISP, so we will not be 60 | providing separate "types" for procedures, etc. Everything is represented as 61 | atoms (integers, strings, booleans) or a list of atoms, except for the 62 | primitive functions */ 63 | 64 | struct object { 65 | char gc; 66 | type_t type; 67 | bool mark; 68 | struct object *gc_next; 69 | union { 70 | int64_t integer; 71 | char *string; 72 | struct { 73 | struct object **vector; 74 | int vsize; 75 | }; 76 | struct { 77 | struct object *car; 78 | struct object *cdr; 79 | }; 80 | primitive_t primitive; 81 | }; 82 | } __attribute__((packed)); 83 | 84 | /* We declare a couple of global variables for keywords */ 85 | static struct object *ENV = NULL; 86 | static struct object *NIL = NULL; 87 | static struct object *EMPTY_LIST = NULL; 88 | static struct object *TRUE = NULL; 89 | static struct object *FALSE = NULL; 90 | static struct object *QUOTE = NULL; 91 | static struct object *DEFINE = NULL; 92 | static struct object *SET = NULL; 93 | static struct object *LET = NULL; 94 | static struct object *IF = NULL; 95 | static struct object *LAMBDA = NULL; 96 | static struct object *BEGIN = NULL; 97 | static struct object *PROCEDURE = NULL; 98 | 99 | void print_exp(char *, struct object *); 100 | bool is_tagged(struct object *cell, struct object *tag); 101 | struct object *read_exp(void *, FILE *in); 102 | struct object *eval(void *, struct object *exp, struct object *env); 103 | struct object *cons(void *, struct object *x, struct object *y); 104 | struct object *load_file(void *, struct object *args); 105 | struct object *cdr(struct object *); 106 | struct object *car(struct object *); 107 | struct object *lookup_variable(struct object *var, struct object *env); 108 | struct object *make_symbol(void *, char *); 109 | 110 | /*============================================================================== 111 | Hash table for saving Lisp symbol objects. Conserves memory and faster 112 | compares 113 | ==============================================================================*/ 114 | struct htable { 115 | struct object *key; 116 | }; 117 | /* One dimensional hash table */ 118 | static struct htable *HTABLE = NULL; 119 | static int HTABLE_SIZE; 120 | 121 | static uint64_t hash(const char *s) { 122 | uint64_t h = 0; 123 | uint8_t *u = (uint8_t *)s; 124 | while (*u) { 125 | h = (h * 256 + *u) % HTABLE_SIZE; 126 | u++; 127 | } 128 | return h; 129 | } 130 | 131 | int ht_init(int size) { 132 | if (HTABLE || !(size % 2)) 133 | error("Hash table already initialized or even # of entries"); 134 | HTABLE = malloc(sizeof(struct htable) * size); 135 | memset(HTABLE, 0, sizeof(struct htable) * size); 136 | HTABLE_SIZE = size; 137 | return size; 138 | } 139 | 140 | void ht_insert(struct object *key) { 141 | uint64_t h = hash(key->string); 142 | HTABLE[h].key = key; 143 | } 144 | 145 | void ht_delete(struct object *key) { 146 | uint64_t h = hash(key->string); 147 | HTABLE[h].key = 0; 148 | } 149 | 150 | struct object *ht_lookup(char *s) { 151 | uint64_t h = hash(s); 152 | return HTABLE[h].key; 153 | } 154 | 155 | /*============================================================================== 156 | Memory management 157 | Garbage collection implemented by @nitros12 https://github.com/nitros12 158 | ==============================================================================*/ 159 | 160 | /* Store working object pointers in the stack. 161 | * each stack will hold reference to parent workspaces, up to this root on here 162 | * workspace will always end with a 1 pointer followed by the start address of 163 | * the next workspace. 164 | */ 165 | void *workspace_base[2] = {(void *)1, NULL}; 166 | 167 | /* create a workspace, set 1 pointer and set up workspace_root*/ 168 | #define create_workspace(size) \ 169 | void *workspace_ARRAY[size + 2] = {0}; \ 170 | workspace_ARRAY[size] = (void *)1; \ 171 | workspace_ARRAY[size + 1] = workspace; \ 172 | workspace = workspace_ARRAY; 173 | 174 | #define set_local(pos, var) (((struct object ***)workspace)[pos] = &var) 175 | 176 | size_t gc_total_alloc = 0; // total objects allocated over the runtime of the interpreter 177 | size_t gc_objects_used = 0; // total objects currently in use 178 | size_t gc_pool_size = 0; // total objects in pool 179 | // current objects currently allocated = gc_pool_size + gc_objects_used 180 | 181 | static struct object *GC_HEAD = NULL; 182 | static struct object *GC_POOL_HEAD = NULL; 183 | 184 | int gc_pass(void *); 185 | void mark_object(struct object *); 186 | void grow_pool(size_t); 187 | void shrink_pool(size_t); 188 | 189 | void push_object(struct object **head, struct object *obj) { 190 | obj->gc_next = *head; 191 | *head = obj; 192 | } 193 | 194 | struct object *pop_object(struct object **head) { 195 | if (*head == NULL) 196 | return NULL; 197 | struct object *ret = *head; 198 | *head = (*head)->gc_next; 199 | return ret; 200 | } 201 | 202 | void gc_pool_maintain(void *workspace) { 203 | #ifdef FORCE_GC 204 | gc_pass(workspace); 205 | #else 206 | if (gc_pool_size == gc_objects_used) 207 | gc_pass(workspace); 208 | #endif 209 | if (gc_pool_size == gc_objects_used) 210 | grow_pool((gc_pool_size >> 1) + 1); // grow to 150% 211 | else if (gc_objects_used < gc_pool_size >> 1) // shrink when we have more than 50% unused 212 | shrink_pool(gc_pool_size >> 2); // trim off 25% 213 | } 214 | 215 | void grow_pool(size_t n) { 216 | #ifdef DEBUG_POOL 217 | printf("growing pool by %ld\n", n); 218 | #endif 219 | gc_pool_size += n; 220 | gc_total_alloc += n; 221 | struct object *obj; 222 | while (n--) { 223 | obj = malloc(sizeof(struct object)); 224 | push_object(&GC_POOL_HEAD, obj); 225 | } 226 | } 227 | 228 | void shrink_pool(size_t n) { 229 | #ifdef DEBUG_POOL 230 | printf("shrinking pool by %ld\n", n); 231 | #endif 232 | gc_pool_size -= n; 233 | while (n--) { 234 | free(pop_object(&GC_POOL_HEAD)); 235 | } 236 | } 237 | 238 | struct object *alloc(void *workspace) { 239 | gc_pool_maintain(workspace); 240 | struct object *ret = pop_object(&GC_POOL_HEAD); 241 | push_object(&GC_HEAD, ret); 242 | ret->mark = false; 243 | gc_objects_used++; 244 | return ret; 245 | } 246 | 247 | void mark_object(struct object *obj) { 248 | if (obj == NULL || obj->mark) 249 | return; 250 | #ifdef DEBUG_GC 251 | print_exp("marking: ", obj); 252 | putchar('\n'); 253 | #endif 254 | obj->mark = true; 255 | switch (obj->type) { 256 | case LIST: 257 | mark_object(obj->car); 258 | mark_object(obj->cdr); 259 | break; 260 | case VECTOR: { 261 | int i; 262 | for (i = 0; i < obj->vsize; i++) { 263 | if (obj->vector[i] != NULL) 264 | mark_object(obj->vector[i]); 265 | } 266 | break; 267 | } 268 | default: 269 | break; 270 | } 271 | } 272 | 273 | void collect_hashed(struct object *obj) { 274 | ht_delete(obj); 275 | free(obj->string); 276 | } 277 | 278 | void debug_gc(struct object *obj) { 279 | char *types[6] = {"INTEGER", "SYMBOL", "STRING", 280 | "LIST", "PRIMITIVE", "VECTOR"}; 281 | printf("\nCollecting object at %p, of type %s, value: ", (void *)obj, 282 | types[obj->type]); 283 | print_exp(NULL, obj); 284 | putchar('\n'); 285 | } 286 | 287 | int gc_sweep() { 288 | struct object *obj = GC_HEAD; 289 | struct object *tmp, *prev = NULL; 290 | int freed = 0; 291 | while (obj != NULL) { 292 | if (obj->mark) { 293 | obj->mark = false; 294 | prev = obj; 295 | obj = obj->gc_next; 296 | } else { 297 | if (prev != NULL) 298 | prev->gc_next = obj->gc_next; 299 | // object was the gc head, so move everything down one 300 | if (obj == GC_HEAD) 301 | GC_HEAD = obj->gc_next; 302 | 303 | tmp = obj; 304 | obj = obj->gc_next; 305 | #ifdef DEBUG_GC 306 | debug_gc(tmp); 307 | #endif 308 | if (tmp->type == STRING || tmp->type == SYMBOL) 309 | collect_hashed(tmp); 310 | push_object(&GC_POOL_HEAD, tmp); 311 | freed++; 312 | gc_objects_used--; 313 | } 314 | } 315 | return freed; 316 | } 317 | 318 | void gc_mark(void *workspace_root) { 319 | mark_object(ENV); // mark global environment 320 | void **workspace = workspace_root; 321 | /* pretty ugly this is 322 | * iterate over workspace until we find the (void *)1 value 323 | * marking off each object as we go. 324 | * when we find the (void *)1 value, test if the last element is null 325 | * if it is, we're at the end of the workspace chain. 326 | */ 327 | for (;;) { 328 | int i; 329 | for (i = 0; workspace[i] != (void *)1; i++) { 330 | if (workspace[i] != NULL) 331 | mark_object(*(struct object **)workspace[i]); 332 | } 333 | if ((workspace = (void *)workspace[i + 1]) == NULL) 334 | break; 335 | } 336 | } 337 | 338 | /* invoke the garbage collector */ 339 | int gc_pass(void *workspace) { 340 | gc_mark(workspace); 341 | return gc_sweep(); 342 | } 343 | 344 | /*============================================================================ 345 | Constructors and etc 346 | ==============================================================================*/ 347 | int __type_check(const char *func, struct object *obj, type_t type) { 348 | if (null(obj)) { 349 | fprintf(stderr, "Invalid argument to function %s: NIL\n", func); 350 | exit(1); 351 | } else if (obj->type != type) { 352 | char *types[6] = {"INTEGER", "SYMBOL", "STRING", 353 | "LIST", "PRIMITIVE", "VECTOR"}; 354 | fprintf(stderr, "Invalid argument to function %s. Expected %s got %s\n", 355 | func, types[type], types[obj->type]); 356 | exit(1); 357 | } 358 | return 1; 359 | } 360 | 361 | struct object *make_vector(void *workspace, int size) { 362 | struct object *ret = alloc(workspace); 363 | ret->type = VECTOR; 364 | ret->vector = malloc(sizeof(struct object *) * size); 365 | ret->vsize = size; 366 | 367 | memset(ret->vector, 0, size); 368 | 369 | return ret; 370 | } 371 | 372 | struct object *make_symbol(void *workspace, char *s) { 373 | struct object *ret = ht_lookup(s); 374 | if (null(ret)) { 375 | ret = alloc(workspace); 376 | ret->type = SYMBOL; 377 | ret->string = strdup(s); 378 | ht_insert(ret); 379 | } 380 | return ret; 381 | } 382 | 383 | struct object *make_integer(void *workspace, int x) { 384 | struct object *ret = alloc(workspace); 385 | ret->type = INTEGER; 386 | ret->integer = x; 387 | return ret; 388 | } 389 | 390 | struct object *make_primitive(void *workspace, primitive_t x) { 391 | struct object *ret = alloc(workspace); 392 | ret->type = PRIMITIVE; 393 | ret->primitive = x; 394 | return ret; 395 | } 396 | 397 | struct object *make_lambda(void *workspace, struct object *params, 398 | struct object *body) { 399 | // Shouldn't need to localise here since `cons` makes sure they're 400 | // preserved. 401 | return cons(workspace, LAMBDA, cons(workspace, params, body)); 402 | } 403 | 404 | struct object *make_procedure(void *workspace, struct object *params, 405 | struct object *body, struct object *env) { 406 | create_workspace(3); 407 | set_local(0, body); 408 | set_local(1, params); 409 | set_local(2, env); 410 | return cons(workspace, PROCEDURE, 411 | cons(workspace, params, 412 | cons(workspace, body, cons(workspace, env, EMPTY_LIST)))); 413 | } 414 | 415 | struct object *cons(void *workspace, struct object *x, struct object *y) { 416 | create_workspace(2); 417 | set_local(0, x); 418 | set_local(1, y); 419 | struct object *ret = alloc(workspace); 420 | ret->type = LIST; 421 | ret->car = x; 422 | ret->cdr = y; 423 | return ret; 424 | } 425 | 426 | struct object *car(struct object *cell) { 427 | if (null(cell) || cell->type != LIST) 428 | return NIL; 429 | return cell->car; 430 | } 431 | 432 | struct object *cdr(struct object *cell) { 433 | if (null(cell) || cell->type != LIST) 434 | return NIL; 435 | return cell->cdr; 436 | } 437 | 438 | struct object *append(void *workspace, struct object *l1, struct object *l2) { 439 | if (null(l1)) 440 | return l2; 441 | create_workspace(2); 442 | set_local(0, l1); 443 | set_local(1, l2); 444 | return cons(workspace, car(l1), append(workspace, cdr(l1), l2)); 445 | } 446 | 447 | struct object *reverse(void *workspace, struct object *list, 448 | struct object *first) { 449 | if (null(list)) 450 | return first; 451 | create_workspace(2); 452 | set_local(0, list); 453 | set_local(1, first); 454 | return reverse(workspace, cdr(list), cons(workspace, car(list), first)); 455 | } 456 | 457 | bool is_equal(struct object *x, struct object *y) { 458 | 459 | if (x == y) 460 | return true; 461 | if (null(x) || null(y)) 462 | return false; 463 | if (x->type != y->type) 464 | return false; 465 | switch (x->type) { 466 | case LIST: 467 | return false; 468 | case INTEGER: 469 | return x->integer == y->integer; 470 | case SYMBOL: 471 | case STRING: 472 | return !strcmp(x->string, y->string); 473 | } 474 | return false; 475 | } 476 | 477 | bool not_false(struct object *x) { 478 | if (null(x) || is_equal(x, FALSE)) 479 | return false; 480 | if (x->type == INTEGER && x->integer == 0) 481 | return false; 482 | return true; 483 | } 484 | 485 | bool is_tagged(struct object *cell, struct object *tag) { 486 | if (null(cell) || cell->type != LIST) 487 | return false; 488 | return is_equal(car(cell), tag); 489 | } 490 | 491 | int length(struct object *exp) { 492 | if (null(exp)) 493 | return 0; 494 | return 1 + length(cdr(exp)); 495 | } 496 | /*============================================================================== 497 | Primitive operations 498 | ==============================================================================*/ 499 | 500 | struct object *prim_type(void *workspace, struct object *args) { 501 | char *types[6] = {"integer", "symbol", "string", 502 | "list", "primitive", "vector"}; 503 | create_workspace(1); 504 | set_local(0, args); 505 | return make_symbol(workspace, types[car(args)->type]); 506 | } 507 | 508 | struct object *prim_get_env(void *workspace, struct object *args) { 509 | return ENV; 510 | } 511 | struct object *prim_set_env(void *workspace, struct object *args) { 512 | ENV = car(args); 513 | return NIL; 514 | } 515 | 516 | struct object *prim_list(void *workspace, struct object *args) { 517 | return (args); 518 | } 519 | struct object *prim_cons(void *workspace, struct object *args) { 520 | return cons(workspace, car(args), cadr(args)); 521 | } 522 | 523 | struct object *prim_car(void *workspace, struct object *args) { 524 | #ifdef STRICT 525 | ASSERT_TYPE(car(args), LIST); 526 | #endif 527 | return caar(args); 528 | } 529 | 530 | struct object *prim_cdr(void *workspace, struct object *args) { 531 | #ifdef STRICT 532 | ASSERT_TYPE(car(args), LIST); 533 | #endif 534 | return cdar(args); 535 | } 536 | 537 | struct object *prim_setcar(void *workspace, struct object *args) { 538 | ASSERT_TYPE(car(args), LIST); 539 | (args->car->car = (cadr(args))); 540 | return NIL; 541 | } 542 | struct object *prim_setcdr(void *workspace, struct object *args) { 543 | ASSERT_TYPE(car(args), LIST); 544 | (args->car->cdr = (cadr(args))); 545 | return NIL; 546 | } 547 | 548 | struct object *prim_nullq(void *workspace, struct object *args) { 549 | return EOL(car(args)) ? TRUE : FALSE; 550 | } 551 | 552 | struct object *prim_pairq(void *workspace, struct object *args) { 553 | if (car(args)->type != LIST) 554 | return FALSE; 555 | return (atom(caar(args)) && atom(cdar(args))) ? TRUE : FALSE; 556 | } 557 | 558 | struct object *prim_listq(void *workspace, struct object *args) { 559 | struct object *list = NULL; 560 | if (car(args)->type != LIST) 561 | return FALSE; 562 | for (list = car(args); !null(list); list = list->cdr) 563 | if (!null(list->cdr) && (list->cdr->type != LIST)) 564 | return FALSE; 565 | return (car(args)->type == LIST && prim_pairq(NULL, args) != TRUE) ? TRUE 566 | : FALSE; 567 | } 568 | 569 | struct object *prim_atomq(void *workspace, struct object *sexp) { 570 | return atom(car(sexp)) ? TRUE : FALSE; 571 | } 572 | 573 | /* = primitive, only valid for numbers */ 574 | struct object *prim_neq(void *workspace, struct object *args) { 575 | if ((car(args)->type != INTEGER) || (cadr(args)->type != INTEGER)) 576 | return FALSE; 577 | return (car(args)->integer == cadr(args)->integer) ? TRUE : FALSE; 578 | } 579 | 580 | /* eq? primitive, checks memory location, or if equal values for primitives */ 581 | struct object *prim_eq(void *workspace, struct object *args) { 582 | return is_equal(car(args), cadr(args)) ? TRUE : FALSE; 583 | } 584 | 585 | struct object *prim_equal(void *workspace, struct object *args) { 586 | if (is_equal(car(args), cadr(args))) 587 | return TRUE; 588 | if ((car(args)->type == LIST) && (cadr(args)->type == LIST)) { 589 | struct object *a, *b; 590 | a = car(args); 591 | b = cadr(args); 592 | while (!null(a) && !null(b)) { 593 | if (!is_equal(car(a), car(b))) 594 | return FALSE; 595 | a = cdr(a); 596 | b = cdr(b); 597 | } 598 | return TRUE; 599 | } 600 | return FALSE; 601 | } 602 | 603 | struct object *prim_add(void *workspace, struct object *list) { 604 | ASSERT_TYPE(car(list), INTEGER); 605 | int64_t total = car(list)->integer; 606 | list = cdr(list); 607 | while (!EOL(car(list))) { 608 | ASSERT_TYPE(car(list), INTEGER); 609 | total += car(list)->integer; 610 | list = cdr(list); 611 | } 612 | return make_integer(workspace, total); 613 | } 614 | 615 | struct object *prim_sub(void *workspace, struct object *list) { 616 | ASSERT_TYPE(car(list), INTEGER); 617 | int64_t total = car(list)->integer; 618 | list = cdr(list); 619 | while (!null(list)) { 620 | ASSERT_TYPE(car(list), INTEGER); 621 | total -= car(list)->integer; 622 | list = cdr(list); 623 | } 624 | return make_integer(workspace, total); 625 | } 626 | 627 | struct object *prim_div(void *workspace, struct object *list) { 628 | ASSERT_TYPE(car(list), INTEGER); 629 | int64_t total = car(list)->integer; 630 | list = cdr(list); 631 | while (!null(list)) { 632 | ASSERT_TYPE(car(list), INTEGER); 633 | total /= car(list)->integer; 634 | list = cdr(list); 635 | } 636 | return make_integer(workspace, total); 637 | } 638 | 639 | struct object *prim_mul(void *workspace, struct object *list) { 640 | ASSERT_TYPE(car(list), INTEGER); 641 | int64_t total = car(list)->integer; 642 | list = cdr(list); 643 | while (!null(list)) { 644 | ASSERT_TYPE(car(list), INTEGER); 645 | total *= car(list)->integer; 646 | list = cdr(list); 647 | } 648 | return make_integer(workspace, total); 649 | } 650 | struct object *prim_gt(void *workspace, struct object *sexp) { 651 | ASSERT_TYPE(car(sexp), INTEGER); 652 | ASSERT_TYPE(cadr(sexp), INTEGER); 653 | return (car(sexp)->integer > cadr(sexp)->integer) ? TRUE : NIL; 654 | } 655 | 656 | struct object *prim_lt(void *workspace, struct object *sexp) { 657 | ASSERT_TYPE(car(sexp), INTEGER); 658 | ASSERT_TYPE(cadr(sexp), INTEGER); 659 | return (car(sexp)->integer < cadr(sexp)->integer) ? TRUE : NIL; 660 | } 661 | 662 | struct object *prim_print(void *workspace, struct object *args) { 663 | print_exp(NULL, car(args)); 664 | printf("\n"); 665 | return NIL; 666 | } 667 | 668 | struct object *prim_exit(void *workspace, struct object *args) { 669 | exit(0); 670 | } 671 | 672 | struct object *prim_read(void *workspace, struct object *args) { 673 | return read_exp(workspace, stdin); 674 | } 675 | 676 | struct object *prim_vget(void *workspace, struct object *args) { 677 | ASSERT_TYPE(car(args), VECTOR); 678 | ASSERT_TYPE(cadr(args), INTEGER); 679 | if (cadr(args)->integer >= car(args)->vsize) 680 | return NIL; 681 | return car(args)->vector[cadr(args)->integer]; 682 | } 683 | 684 | struct object *prim_vset(void *workspace, struct object *args) { 685 | ASSERT_TYPE(car(args), VECTOR); 686 | ASSERT_TYPE(cadr(args), INTEGER); 687 | if (null(caddr(args))) 688 | return NIL; 689 | if (cadr(args)->integer >= car(args)->vsize) 690 | return NIL; 691 | car(args)->vector[cadr(args)->integer] = caddr(args); 692 | return make_symbol(workspace, "ok"); 693 | } 694 | 695 | struct object *prim_vec(void *workspace, struct object *args) { 696 | ASSERT_TYPE(car(args), INTEGER); 697 | return make_vector(workspace, car(args)->integer); 698 | } 699 | 700 | struct object *prim_gc_objects_used(void *workspace, struct object *args) { 701 | return make_integer(workspace, gc_objects_used); 702 | } 703 | 704 | struct object *prim_gc_pool_size(void *workspace, struct object *args) { 705 | return make_integer(workspace, gc_pool_size); 706 | } 707 | 708 | struct object *prim_gc_total_alloc(void *workspace, struct object *args) { 709 | return make_integer(workspace, gc_total_alloc); 710 | } 711 | 712 | struct object *prim_gc_pass(void *workspace, struct object *args) { 713 | return make_integer(workspace, gc_pass(workspace)); 714 | } 715 | 716 | /*============================================================================== 717 | Environment handling 718 | ==============================================================================*/ 719 | 720 | struct object *extend_env(void *workspace, struct object *var, 721 | struct object *val, struct object *env) { 722 | create_workspace(3); 723 | set_local(0, var); 724 | set_local(1, val); 725 | set_local(2, env); 726 | return cons(workspace, cons(workspace, var, val), env); 727 | } 728 | 729 | struct object *lookup_variable(struct object *var, struct object *env) { 730 | while (!null(env)) { 731 | struct object *frame = car(env); 732 | struct object *vars = car(frame); 733 | struct object *vals = cdr(frame); 734 | while (!null(vars)) { 735 | if (is_equal(car(vars), var)) 736 | return car(vals); 737 | vars = cdr(vars); 738 | vals = cdr(vals); 739 | } 740 | env = cdr(env); 741 | } 742 | return NIL; 743 | } 744 | 745 | /* set_variable binds var to val in the first frame in which var occurs */ 746 | void set_variable(struct object *var, struct object *val, struct object *env) { 747 | while (!null(env)) { 748 | struct object *frame = car(env); 749 | struct object *vars = car(frame); 750 | struct object *vals = cdr(frame); 751 | while (!null(vars)) { 752 | if (is_equal(car(vars), var)) { 753 | vals->car = val; 754 | return; 755 | } 756 | vars = cdr(vars); 757 | vals = cdr(vals); 758 | } 759 | env = cdr(env); 760 | } 761 | } 762 | 763 | /* define_variable binds var to val in the *current* frame */ 764 | struct object *define_variable(void *workspace, struct object *var, 765 | struct object *val, struct object *env) { 766 | struct object *frame = car(env); 767 | struct object *vars = car(frame); 768 | struct object *vals = cdr(frame); 769 | while (!null(vars)) { 770 | if (is_equal(var, car(vars))) { 771 | vals->car = val; 772 | return val; 773 | } 774 | vars = cdr(vars); 775 | vals = cdr(vals); 776 | } 777 | create_workspace(3); 778 | set_local(0, var); 779 | set_local(1, val); 780 | set_local(2, env); 781 | frame->car = cons(workspace, var, car(frame)); 782 | frame->cdr = cons(workspace, val, cdr(frame)); 783 | return val; 784 | } 785 | 786 | /*============================================================================== 787 | Recursive descent parser 788 | ==============================================================================*/ 789 | 790 | char SYMBOLS[] = "~!@#$%^&*_-+\\:,.<>|{}[]?=/"; 791 | 792 | int peek(FILE *in) { 793 | int c = getc(in); 794 | ungetc(c, in); 795 | return c; 796 | } 797 | 798 | /* skip characters until end of line */ 799 | void skip(FILE *in) { 800 | int c; 801 | for (;;) { 802 | c = getc(in); 803 | if (c == '\n' || c == EOF) 804 | return; 805 | } 806 | } 807 | 808 | struct object *read_string(void *workspace, FILE *in) { 809 | char buf[256]; 810 | int i = 0; 811 | int c; 812 | while ((c = getc(in)) != '\"') { 813 | if (c == EOF) 814 | return NIL; 815 | if (i >= 256) 816 | error("String too long - maximum length 256 characters"); 817 | buf[i++] = (char)c; 818 | } 819 | buf[i] = '\0'; 820 | struct object *s = make_symbol(workspace, buf); 821 | s->type = STRING; 822 | return s; 823 | } 824 | 825 | struct object *read_symbol(void *workspace, FILE *in, char start) { 826 | char buf[128]; 827 | buf[0] = start; 828 | int i = 1; 829 | while (isalnum(peek(in)) || strchr(SYMBOLS, peek(in))) { 830 | if (i >= 128) 831 | error("Symbol name too long - maximum length 128 characters"); 832 | buf[i++] = getc(in); 833 | } 834 | buf[i] = '\0'; 835 | return make_symbol(workspace, buf); 836 | } 837 | 838 | int read_int(FILE *in, int start) { 839 | while (isdigit(peek(in))) 840 | start = start * 10 + (getc(in) - '0'); 841 | return start; 842 | } 843 | 844 | struct object *read_list(void *workspace, FILE *in) { 845 | struct object *obj = NULL; 846 | struct object *cell = EMPTY_LIST; 847 | create_workspace(2); 848 | set_local(0, obj); 849 | set_local(1, cell); 850 | for (;;) { 851 | obj = read_exp(workspace, in); 852 | if (obj == EMPTY_LIST) 853 | return reverse(workspace, cell, EMPTY_LIST); 854 | cell = cons(workspace, obj, cell); 855 | } 856 | return EMPTY_LIST; 857 | } 858 | 859 | struct object *read_quote(void *workspace, FILE *in) { 860 | return cons(workspace, QUOTE, 861 | cons(workspace, read_exp(workspace, in), NIL)); 862 | } 863 | 864 | int depth = 0; 865 | 866 | struct object *read_exp(void *workspace, FILE *in) { 867 | int c; 868 | 869 | for (;;) { 870 | c = getc(in); 871 | if (c == '\n' || c == '\r' || c == ' ' || c == '\t') { 872 | if ((c == '\n' || c == '\r') && in == stdin) { 873 | int i; 874 | for (i = 0; i < depth; i++) 875 | printf(".."); 876 | } 877 | continue; 878 | } 879 | if (c == ';') { 880 | skip(in); 881 | continue; 882 | } 883 | if (c == EOF) 884 | return NULL; 885 | if (c == '\"') 886 | return read_string(workspace, in); 887 | if (c == '\'') 888 | return read_quote(workspace, in); 889 | if (c == '(') { 890 | depth++; 891 | return read_list(workspace, in); 892 | } 893 | if (c == ')') { 894 | depth--; 895 | return EMPTY_LIST; 896 | } 897 | if (isdigit(c)) 898 | return make_integer(workspace, read_int(in, c - '0')); 899 | if (c == '-' && isdigit(peek(in))) 900 | return make_integer(workspace, -1 * read_int(in, getc(in) - '0')); 901 | if (isalpha(c) || strchr(SYMBOLS, c)) 902 | return read_symbol(workspace, in, c); 903 | } 904 | return NIL; 905 | } 906 | 907 | void print_exp(char *str, struct object *e) { 908 | if (str) 909 | printf("%s ", str); 910 | if (null(e)) { 911 | printf("'()"); 912 | return; 913 | } 914 | switch (e->type) { 915 | case STRING: 916 | printf("\"%s\"", e->string); 917 | break; 918 | case SYMBOL: 919 | printf("%s", e->string); 920 | break; 921 | case INTEGER: 922 | printf("%ld", e->integer); 923 | break; 924 | case PRIMITIVE: 925 | printf(""); 926 | break; 927 | case VECTOR: 928 | printf("", e->vsize); 929 | break; 930 | case LIST: 931 | if (is_tagged(e, PROCEDURE)) { 932 | printf(""); 933 | return; 934 | } 935 | printf("("); 936 | struct object **t = &e; 937 | while (!null(*t)) { 938 | print_exp(NULL, (*t)->car); 939 | if (!null((*t)->cdr)) { 940 | printf(" "); 941 | if ((*t)->cdr->type == LIST) { 942 | t = &(*t)->cdr; 943 | } else { 944 | print_exp(".", (*t)->cdr); 945 | break; 946 | } 947 | } else 948 | break; 949 | } 950 | printf(")"); 951 | } 952 | } 953 | 954 | /*============================================================================== 955 | LISP evaluator 956 | ==============================================================================*/ 957 | 958 | struct object *evlis(void *workspace, struct object *exp, struct object *env) { 959 | if (null(exp)) 960 | return NIL; 961 | create_workspace(3); 962 | set_local(0, exp); 963 | set_local(1, env); 964 | struct object *tmp = eval(workspace, car(exp), env); 965 | set_local(2, tmp); 966 | return cons(workspace, tmp, evlis(workspace, cdr(exp), env)); 967 | } 968 | 969 | struct object *eval_sequence(void *workspace, struct object *exps, 970 | struct object *env) { 971 | if (null(cdr(exps))) 972 | return eval(workspace, car(exps), env); 973 | create_workspace(2); 974 | set_local(0, exps); 975 | set_local(1, env); 976 | eval(workspace, car(exps), env); 977 | return eval_sequence(workspace, cdr(exps), env); 978 | } 979 | 980 | struct object *eval(void *workspace, struct object *exp, struct object *env) { 981 | create_workspace(6); 982 | set_local(0, exp); 983 | set_local(1, env); 984 | tail: 985 | if (null(exp) || exp == EMPTY_LIST) { 986 | return NIL; 987 | } else if (exp->type == INTEGER || exp->type == STRING) { 988 | return exp; 989 | } else if (exp->type == SYMBOL) { 990 | struct object *s = lookup_variable(exp, env); 991 | #ifdef STRICT 992 | if (null(s)) { 993 | print_exp("Unbound symbol:", exp); 994 | printf("\n"); 995 | } 996 | #endif 997 | return s; 998 | } else if (is_tagged(exp, QUOTE)) { 999 | return cadr(exp); 1000 | } else if (is_tagged(exp, LAMBDA)) { 1001 | return make_procedure(workspace, cadr(exp), cddr(exp), env); 1002 | } else if (is_tagged(exp, DEFINE)) { 1003 | if (atom(cadr(exp))) { 1004 | define_variable(workspace, cadr(exp), 1005 | eval(workspace, caddr(exp), env), env); 1006 | } else { 1007 | struct object *closure = 1008 | eval(workspace, 1009 | make_lambda(workspace, cdr(cadr(exp)), cddr(exp)), env); 1010 | define_variable(workspace, car(cadr(exp)), closure, env); 1011 | } 1012 | return make_symbol(workspace, "ok"); 1013 | } else if (is_tagged(exp, BEGIN)) { 1014 | struct object *args = cdr(exp); 1015 | set_local(2, args); 1016 | for (; !null(cdr(args)); args = cdr(args)) 1017 | eval(workspace, car(args), env); 1018 | exp = car(args); 1019 | goto tail; 1020 | } else if (is_tagged(exp, IF)) { 1021 | struct object *predicate = eval(workspace, cadr(exp), env); 1022 | exp = (not_false(predicate)) ? caddr(exp) : cadddr(exp); 1023 | goto tail; 1024 | } else if (is_tagged(exp, make_symbol(workspace, "or"))) { 1025 | struct object *predicate = eval(workspace, cadr(exp), env); 1026 | exp = (not_false(predicate)) ? caddr(exp) : cadddr(exp); 1027 | goto tail; 1028 | } else if (is_tagged(exp, make_symbol(workspace, "cond"))) { 1029 | struct object *branch = cdr(exp); 1030 | set_local(2, branch); 1031 | for (; !null(branch); branch = cdr(branch)) { 1032 | if (is_tagged(car(branch), make_symbol(workspace, "else")) || 1033 | not_false(eval(workspace, caar(branch), env))) { 1034 | exp = cons(workspace, BEGIN, cdar(branch)); 1035 | goto tail; 1036 | } 1037 | } 1038 | return NIL; 1039 | } else if (is_tagged(exp, SET)) { 1040 | if (atom(cadr(exp))) 1041 | set_variable(cadr(exp), eval(workspace, caddr(exp), env), env); 1042 | else { 1043 | struct object *closure = 1044 | eval(workspace, 1045 | make_lambda(workspace, cdr(cadr(exp)), cddr(exp)), env); 1046 | set_variable(car(cadr(exp)), closure, env); 1047 | } 1048 | return make_symbol(workspace, "ok"); 1049 | } else if (is_tagged(exp, LET)) { 1050 | /* We go with the strategy of transforming let into a lambda function*/ 1051 | struct object **tmp; 1052 | struct object *vars = NIL; 1053 | struct object *vals = NIL; 1054 | set_local(2, vars); 1055 | set_local(3, vals); 1056 | if (null(cadr(exp))) 1057 | return NIL; 1058 | /* NAMED LET */ 1059 | if (atom(cadr(exp))) { 1060 | for (tmp = &exp->cdr->cdr->car; !null(*tmp); tmp = &(*tmp)->cdr) { 1061 | set_local(4, *tmp); 1062 | vars = cons(workspace, caar(*tmp), vars); 1063 | vals = cons(workspace, cadar(*tmp), vals); 1064 | } 1065 | /* Define the named let as a lambda function */ 1066 | struct object *lambda = 1067 | make_lambda(workspace, vars, cdr(cddr(exp))); 1068 | set_local(4, lambda); 1069 | struct object *new_env = extend_env(workspace, vars, vals, env); 1070 | set_local(5, new_env); 1071 | define_variable(workspace, cadr(exp), 1072 | eval(workspace, lambda, new_env), env); 1073 | /* Then evaluate the lambda function with the starting values */ 1074 | exp = cons(workspace, cadr(exp), vals); 1075 | goto tail; 1076 | } 1077 | for (tmp = &exp->cdr->car; !null(*tmp); tmp = &(*tmp)->cdr) { 1078 | vars = cons(workspace, caar(*tmp), vars); 1079 | vals = cons(workspace, cadar(*tmp), vals); 1080 | } 1081 | exp = cons(workspace, make_lambda(workspace, vars, cddr(exp)), vals); 1082 | goto tail; 1083 | } else { 1084 | /* procedure structure is as follows: 1085 | ('procedure, (parameters), (body), (env)) */ 1086 | struct object *proc = eval(workspace, car(exp), env); 1087 | set_local(2, proc); 1088 | struct object *args = evlis(workspace, cdr(exp), env); 1089 | set_local(3, args); 1090 | if (null(proc)) { 1091 | #ifdef STRICT 1092 | print_exp("Invalid arguments to eval:", exp); 1093 | printf("\n"); 1094 | #endif 1095 | 1096 | return NIL; 1097 | } 1098 | if (proc->type == PRIMITIVE) 1099 | return proc->primitive(workspace, args); 1100 | if (is_tagged(proc, PROCEDURE)) { 1101 | env = extend_env(workspace, cadr(proc), args, cadddr(proc)); 1102 | exp = cons(workspace, BEGIN, caddr(proc)); /* procedure body */ 1103 | goto tail; 1104 | } 1105 | } 1106 | print_exp("Invalid arguments to eval:", exp); 1107 | printf("\n"); 1108 | return NIL; 1109 | } 1110 | 1111 | extern char **environ; 1112 | struct object *prim_exec(void *workspace, struct object *args) { 1113 | ASSERT_TYPE(car(args), STRING); 1114 | int l = length(args); 1115 | struct object *tmp = args; 1116 | create_workspace(2); 1117 | set_local(0, tmp); 1118 | set_local(1, args); 1119 | 1120 | char **newarg = malloc(sizeof(char *) * (l + 1)); 1121 | char **n = newarg; 1122 | for (; l; l--) { 1123 | ASSERT_TYPE(car(tmp), STRING); 1124 | *n++ = car(tmp)->string; 1125 | tmp = cdr(tmp); 1126 | } 1127 | *n = NULL; 1128 | int pid = fork(); 1129 | if (pid == 0) { 1130 | /* if execve returns -1, there was an errorm so we need to kill*/ 1131 | if (execve(car(args)->string, newarg, environ)) { 1132 | perror(car(args)->string); 1133 | kill(getpid(), SIGTERM); 1134 | } 1135 | } 1136 | wait(&pid); 1137 | return NIL; 1138 | } 1139 | 1140 | /* Initialize the global environment, add primitive functions and symbols */ 1141 | void init_env(void *workspace) { 1142 | #define add_prim(s, c) \ 1143 | tmp_sym = make_symbol(workspace, s); \ 1144 | define_variable(workspace, tmp_sym, make_primitive(workspace, c), ENV) 1145 | #define add_sym(s, c) \ 1146 | do { \ 1147 | c = make_symbol(workspace, s); \ 1148 | set_local(1, c); \ 1149 | define_variable(workspace, c, c, ENV); \ 1150 | } while (0); 1151 | struct object *tmp_sym = NULL; 1152 | create_workspace(2); 1153 | set_local(0, tmp_sym); 1154 | ENV = extend_env(workspace, NIL, NIL, NIL); 1155 | add_sym("#t", TRUE); 1156 | add_sym("#f", FALSE); 1157 | add_sym("quote", QUOTE); 1158 | add_sym("lambda", LAMBDA); 1159 | add_sym("procedure", PROCEDURE); 1160 | add_sym("define", DEFINE); 1161 | add_sym("let", LET); 1162 | add_sym("set!", SET); 1163 | add_sym("begin", BEGIN); 1164 | add_sym("if", IF); 1165 | define_variable(workspace, make_symbol(workspace, "true"), TRUE, ENV); 1166 | define_variable(workspace, make_symbol(workspace, "false"), FALSE, ENV); 1167 | 1168 | add_prim("cons", prim_cons); 1169 | add_prim("car", prim_car); 1170 | add_prim("cdr", prim_cdr); 1171 | add_prim("set-car!", prim_setcar); 1172 | add_prim("set-cdr!", prim_setcdr); 1173 | add_prim("list", prim_list); 1174 | add_prim("list?", prim_listq); 1175 | add_prim("null?", prim_nullq); 1176 | add_prim("pair?", prim_pairq); 1177 | add_prim("atom?", prim_atomq); 1178 | add_prim("eq?", prim_eq); 1179 | add_prim("equal?", prim_equal); 1180 | 1181 | add_prim("+", prim_add); 1182 | add_prim("-", prim_sub); 1183 | add_prim("*", prim_mul); 1184 | add_prim("/", prim_div); 1185 | add_prim("=", prim_neq); 1186 | add_prim("<", prim_lt); 1187 | add_prim(">", prim_gt); 1188 | 1189 | add_prim("type", prim_type); 1190 | add_prim("load", load_file); 1191 | add_prim("print", prim_print); 1192 | add_prim("get-global-environment", prim_get_env); 1193 | add_prim("set-global-environment", prim_set_env); 1194 | add_prim("exit", prim_exit); 1195 | add_prim("exec", prim_exec); 1196 | add_prim("read", prim_read); 1197 | add_prim("vector", prim_vec); 1198 | add_prim("vector-get", prim_vget); 1199 | add_prim("vector-set", prim_vset); 1200 | add_prim("gc-objects-used", prim_gc_objects_used); 1201 | add_prim("gc-pool-size", prim_gc_pool_size); 1202 | add_prim("gc-total-allocated", prim_gc_total_alloc); 1203 | add_prim("gc-pass", prim_gc_pass); 1204 | } 1205 | 1206 | /* Loads and evaluates a file containing lisp s-expressions */ 1207 | struct object *load_file(void *workspace, struct object *args) { 1208 | struct object *exp = NULL; 1209 | struct object *ret = NULL; 1210 | create_workspace(1); 1211 | set_local(0, exp); 1212 | char *filename = car(args)->string; 1213 | printf("Evaluating file %s\n", filename); 1214 | FILE *fp = fopen(filename, "r"); 1215 | if (fp == NULL) { 1216 | printf("Error opening file %s\n", filename); 1217 | return fp; 1218 | } 1219 | 1220 | for (;;) { 1221 | exp = read_exp(workspace, fp); 1222 | if (null(exp)) 1223 | break; 1224 | ret = eval(workspace, exp, ENV); 1225 | } 1226 | fclose(fp); 1227 | return ret; 1228 | } 1229 | 1230 | int main(int argc, char **argv) { 1231 | GC_HEAD = NULL; 1232 | void *workspace = workspace_base; 1233 | int NELEM = 8191; 1234 | ht_init(NELEM); 1235 | init_env(workspace); 1236 | struct object *exp = NULL; 1237 | int i; 1238 | 1239 | printf("uscheme intrepreter - michael lazear (c) 2016-2017\n"); 1240 | for (i = 1; i < argc; i++) 1241 | load_file(workspace, 1242 | cons(workspace, make_symbol(workspace, argv[i]), NIL)); 1243 | 1244 | for (;;) { 1245 | printf("user> "); 1246 | exp = eval(workspace, read_exp(workspace, stdin), ENV); 1247 | if (!null(exp)) { 1248 | print_exp("====>", exp); 1249 | printf("\n"); 1250 | } 1251 | } 1252 | } 1253 | -------------------------------------------------------------------------------- /scheme/.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.a 3 | *.tar.gz 4 | .config 5 | build/ -------------------------------------------------------------------------------- /scheme/configure: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Automatic configuration script 3 | # Released under the MIT License 4 | # Copyright (c) 2017 Michael Lazear 5 | 6 | # Project information 7 | SOURCE_DIR=src 8 | INCLUDE_DIR=include 9 | BUILD_DIR=build 10 | DOCUMENTATION=docs 11 | OUTPUT=Makefile 12 | MANPATH="" 13 | PROJECT="microlisp" 14 | PROJECT_VER="" 15 | PREFIX=/usr/local/bin 16 | 17 | # Build machine and compiler information 18 | CC=$(which cc) 19 | CMACHINE=$(cc -dumpmachine) 20 | CVERSION=$(cc -dumpversion) 21 | CFLAGS="" 22 | ARCH=$(uname -m) 23 | OS=$(uname -s) 24 | STDC_VERSION="" 25 | 26 | # Configuration information 27 | CONFIG_DIR=.config 28 | CONFIG_HEADER=$INCLUDE_DIR/configure.h 29 | 30 | check_header() { 31 | printf "Checking for $1... " 32 | cat << ENDHEADER > $CONFIG_DIR/header.c 33 | #include "$1" 34 | int main(void) { 35 | return 0; 36 | } 37 | ENDHEADER 38 | $CC -Wall -Wextra -Werror $CONFIG_DIR/header.c 2> /dev/null 39 | if [ $? -eq 0 ]; then 40 | echo "success" 41 | name=$(echo $1 | sed 's/\.h//g') 42 | echo "#define CONFIGURE_${name^^}" 1 >> $CONFIG_HEADER 43 | rm ./a.out 44 | else 45 | echo "fail" 46 | echo "#define CONFIGURE_${name^^}" 0 >> $CONFIG_HEADER 47 | fi 48 | 49 | } 50 | 51 | check_function() { 52 | printf "Checking for function $2 in $1... " 53 | cat << ENDHEADER > $CONFIG_DIR/function.c 54 | #include "$1" 55 | int main(void) { 56 | $2(${@:3}); 57 | return 0; 58 | } 59 | ENDHEADER 60 | $CC -Wall -Wextra -Werror $CONFIG_DIR/function.c 2> /dev/null 61 | 62 | if [ $? -eq 0 ]; then 63 | echo "success" 64 | echo "#define CONFIGURE_${2^^} 1" >> $CONFIG_HEADER 65 | rm ./a.out 66 | else 67 | echo "fail" 68 | echo "#define CONFIGURE_${2^^} 0" >> $CONFIG_HEADER 69 | fi 70 | 71 | } 72 | 73 | # Determine what version of standard C library we support 74 | check_stdc() { 75 | printf "Checking which version of the C standard compiler supports... " 76 | cat << END_STDC > $CONFIG_DIR/version.c 77 | #include "stdio.h" 78 | int main(int argc, char** argv) { 79 | printf("%ld", __STDC_VERSION__); 80 | return 0; 81 | } 82 | END_STDC 83 | $CC $CONFIG_DIR/version.c 2> /dev/null 84 | if [ $? -eq 0 ]; then 85 | STDC_VERSION=$(./a.out) 86 | echo $STDC_VERSION 87 | rm ./a.out 88 | else 89 | echo "__STDC_VERSION__ not defined" 90 | fi 91 | } 92 | 93 | # Create a makefile 94 | create_makefile() { 95 | cat << EOF > $OUTPUT 96 | #!/usr/bin/make 97 | # Makefile automatically generated using $0 $@ 98 | # $(date +"%F") 99 | 100 | # Build machine specs 101 | export MACHINE = $CMACHINE 102 | export ARCH = $ARCH 103 | 104 | # C compiler information 105 | export CC = $CC 106 | export CCVER = $CVERSION 107 | export STDC_VER = $STDC_VERSION 108 | export CFLAGS = $CFLAGS 109 | 110 | # Project information 111 | export PREFIX = $PREFIX 112 | export PROJECT = $PROJECT 113 | export VERSION = $PROJECT_VER 114 | 115 | export DOCS = $DOCUMENTATION 116 | export MANPATH = $MANPATH 117 | EOF 118 | cat << 'EOF' >> $OUTPUT 119 | # Build information 120 | export SRC_DIR = src 121 | export INC_DIR = include 122 | export BUILD = build 123 | export HEADERS = $(wildcard $(INC_DIR)/*.h) 124 | export SOURCE = $(wildcard $(SRC_DIR)/*.c) 125 | export OBJECTS = $(SOURCE:.c=.o) 126 | export TARGET = $(BUILD)/$(PROJECT) 127 | 128 | .PHONY: all clean dist install uninstall upgrade 129 | 130 | all: $(TARGET) 131 | 132 | clean: 133 | @rm -rf $(OBJECTS) 134 | 135 | dist: $(TARGET) clean 136 | @echo "creating distribution archive $(PROJECT)-$(VERSION).tar.gz" 137 | if [ -d $(DOCS) ]; then \ 138 | tar -czvf $(PROJECT)-$(VERSION).tar.gz configure Makefile $(DOCS) $(TARGET) $(SRC_DIR) $(IN_DIR); \ 139 | else \ 140 | tar -czvf $(PROJECT)-$(VERSION).tar.gz configure Makefile $(TARGET) $(SRC_DIR) $(INC_DIR); \ 141 | fi 142 | install: $(TARGET) 143 | @echo "installing $(PROJECT) in $(PREFIX)" 144 | @cp -uv $(TARGET) $(PREFIX)/$(PROJECT)-$(VERSION) 145 | @chmod 0755 $(PREFIX)/$(PROJECT)-$(VERSION) 146 | @ln -sf $(PREFIX)/$(PROJECT)-$(VERSION) $(PREFIX)/$(PROJECT) 147 | if [ -f $(DOCS)/$(PROJECT).1 ]; then \ 148 | cp $(DOCS)/$(PROJECT).1 $(MANPATH); \ 149 | fi; 150 | 151 | uninstall: 152 | @echo "uninstalling $(PROJECT) in $(PREFIX)" 153 | if [ -f $(PREFIX)/$(PROJECT) ]; then \ 154 | rm -rf $(PREFIX)/$(PROJECT); \ 155 | rm -rf $(PREFIX)/$(PROJECT)-$(VERSION); \ 156 | fi 157 | if [ -f $(MANPATH)/$(PROJECT).1 ]; then \ 158 | rm -rf $(MANPATH)/$(PROJECT).1; \ 159 | fi 160 | 161 | upgrade: 162 | @cp -uv $(TARGET) $(PREFIX)/$(PROJECT)-$(VERSION) 163 | @cp -uv $(DOCS)/$(PROJECT).1 $(MANPATH)/$(PROJECT).1 164 | @ln -sf $(PREFIX)/$(PROJECT)-$(VERSION) $(PREFIX)/$(PROJECT) 165 | 166 | %.o: %.c 167 | @echo "cc $<" 168 | @$(CC) $(CFLAGS) -c $< -o $@ 169 | 170 | $(TARGET): $(OBJECTS) $(HEADERS) 171 | @echo "building $(PROJECT)" 172 | @$(CC) $(CFLAGS) $(OBJECTS) -o $(TARGET) 173 | EOF 174 | } 175 | 176 | create_accessories() { 177 | 178 | if [ ! -f README.md ]; then 179 | cat << ENDREADME > README.md 180 | # $PROJECT-$PROJECT_VER 181 | 182 | ### Building 183 | \`\`\` 184 | ./configure 185 | make 186 | make install 187 | \`\`\` 188 | 189 | ### Documentation 190 | See $PROJECT(1) 191 | 192 | ### License 193 | See LICENSE file 194 | ENDREADME 195 | fi 196 | if [ ! -f LICENSE ]; then 197 | cat << ENDLICENSE > LICENSE 198 | MIT License 199 | 200 | Copyright (c) $(date +"%Y") $(whoami) 201 | 202 | Permission is hereby granted, free of charge, to any person obtaining a copy 203 | of this software and associated documentation files (the "Software"), to deal 204 | in the Software without restriction, including without limitation the rights 205 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 206 | copies of the Software, and to permit persons to whom the Software is 207 | furnished to do so, subject to the following conditions: 208 | 209 | The above copyright notice and this permission notice shall be included in all 210 | copies or substantial portions of the Software. 211 | 212 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 213 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 214 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 215 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 216 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 217 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 218 | SOFTWARE. 219 | ENDLICENSE 220 | fi 221 | if [ ! -f .gitignore ]; then 222 | cat << ENDIGNORE > .gitignore 223 | *.o 224 | *.a 225 | .config 226 | ENDIGNORE 227 | fi 228 | } 229 | 230 | manpage() { 231 | # don't overwrite existing man pages 232 | if [ -f $DOCUMENTATION/$PROJECT.1 ]; then 233 | return 234 | fi 235 | cat << ENDMAN1 > $DOCUMENTATION/$PROJECT.1 236 | .TH ${PROJECT^^} 1 237 | .SH NAME 238 | $PROJECT \- project description 239 | .SH SYNOPSIS 240 | .B $PROJECT 241 | [\fB\-\-option1\fR] 242 | [\fB\-\-option2\fR] 243 | [\fB\-\-option3\fR \fIfile\fR] 244 | .SH DESCRIPTION 245 | Longform project description 246 | .SH OPTIONS 247 | .TP 248 | \fB\-short\fR, \fB\-\-option1\fR 249 | option1 command 250 | .TP 251 | \fB\-\-option2\fR 252 | option2 command 253 | .TP 254 | \fB\-\-option2\fR \fIfile\fR 255 | .I file 256 | does what 257 | .SH FILES 258 | .I ~/.$PROJECT.conf 259 | .RS 260 | User configuration file. See 261 | .BR $PROJECT(5) 262 | for further details 263 | 264 | .SH AUTHOR 265 | $(whoami) 266 | .SH "SEE ALSO" 267 | .BR $PROJECT(5) 268 | ENDMAN1 269 | } 270 | 271 | # Clean configuration and build directories 272 | clean() { 273 | rm -rf $CONFIG_DIR 274 | rm -rf $BUILD_DIR 275 | } 276 | 277 | 278 | ### Script begins here ### 279 | 280 | # If Makefile exists, grab the existing PROJECT_VER and CFLAGS variables and use them 281 | if [ -f $OUTPUT ]; then 282 | PROJECT_VER=$(cat $OUTPUT | grep "export VERSION" | sed -e 's/^.*=[ ]*//g') 283 | CFLAGS=$(cat $OUTPUT | grep "export CFLAGS" | sed -e 's/^export CFLAGS\s*=\s*//') 284 | MANPATH=$(cat $OUTPUT | grep "export MANPATH" | sed -e 's/^.*[ ]*//g') 285 | else 286 | PROJECT_VER="0.1.0" 287 | fi 288 | 289 | TEMP=`getopt -o hp --long help,clean,prefix:,cc:,cflags: -n 'configure' -- "$@"` 290 | 291 | # Note the quotes around `$TEMP': they are essential! 292 | eval set -- "$TEMP" 293 | 294 | while true ; do 295 | case "$1" in 296 | -h|--help) 297 | echo "$0" 298 | echo "--help: display help menu 299 | --prefix=/path/to/dir set the installation directory default /usr/local/bin 300 | --cc=/path/to/compiler set the C compiler default /usr/bin/cc 301 | --cflags=\"-Wall -O3\" set the C compiler flags default -O2 -Wall -Wextra -Werror -I $INCLUDE_DIR 302 | --clean clean up the config and build directories, regenerate Makefile" 303 | exit 0;; 304 | --clean) 305 | clean 306 | exit 0;; 307 | -p|--prefix) 308 | PREFIX="$2"; 309 | shift 2 ;; 310 | --cc) 311 | CC="$2"; 312 | shift 2;; 313 | --cflags) 314 | CFLAGS="$2"; 315 | shift 2;; 316 | --) 317 | shift; 318 | break ;; 319 | *) 320 | echo "$0 error: unknown argument!" ; 321 | exit 1 ;; 322 | esac 323 | done 324 | 325 | # Make sure we've been passed a valid executable file 326 | if [ ! $(which $CC) ]; then 327 | echo "$0 error: C compiler not found" 328 | exit 1; 329 | fi 330 | 331 | echo "Configuring for $PROJECT-$PROJECT_VER" 332 | 333 | # If no source directory found, go ahead and create one - with a helloworld.c 334 | if [ ! -d $SOURCE_DIR ]; then 335 | mkdir -p $SOURCE_DIR 336 | cat << HELLOWORLD > $SOURCE_DIR/$PROJECT.c 337 | #include 338 | #include 339 | #include "configure.h" 340 | 341 | int main(void) { 342 | printf("Hello world brought to you by %s\n", CONFIGURE_NAME); 343 | return EXIT_SUCCESS; 344 | } 345 | HELLOWORLD 346 | fi 347 | 348 | # Make any directories we don't have yet 349 | mkdir -p $DOCUMENTATION 350 | mkdir -p $CONFIG_DIR 351 | mkdir -p $INCLUDE_DIR 352 | mkdir -p $BUILD_DIR 353 | 354 | # No CFLAGS parsed from the Makefile, fallback to the default 355 | if [[ $CFLAGS == "" ]]; then 356 | CFLAGS="-O2 -Wall -Wextra -Werror -I$INCLUDE_DIR" 357 | fi 358 | 359 | # No project version parsed from the Makefile, fallback to default 360 | if [[ $PROJECT_VER == "" ]]; then 361 | PROJECT_VER="0.1.0" 362 | fi 363 | 364 | # If we haven't parsed a manpath from the Makefile, figure out what it should be 365 | if [[ $MANPATH == "" ]]; then 366 | for path in $(manpath | tr ":" "\n"); do 367 | if [ -d $path/man1 ]; then 368 | MANPATH="$path/man1" 369 | echo "Setting man page path to $MANPATH" 370 | break; 371 | fi 372 | done 373 | fi 374 | 375 | # Does a file in the install directory already exist? 376 | if [ -f $PREFIX/$PROJECT ]; then 377 | echo "Warning: $PREFIX/$PROJECT already exists - suggest changing project name before install" 378 | fi 379 | 380 | # If we haven't made a local copy of the configure script, do so now 381 | if [ ! -f configure ]; then 382 | echo "Copying configure script to $(pwd)" 383 | cp $0 configure 384 | fi 385 | 386 | # Begin dependency/header check 387 | cat << ECONFIG > $CONFIG_HEADER 388 | /* This file was automatically generated by $0 */ 389 | #ifndef _CONFIGURE_H_ 390 | #define _CONFIGURE_H_ 391 | 392 | #define CONFIGURE_NAME "$PROJECT" 393 | #define CONFIGURE_VERSION "$PROJECT_VER" 394 | #define CONFIGURE_ARCH "$ARCH" 395 | ECONFIG 396 | 397 | check_stdc 398 | create_makefile 399 | create_accessories 400 | manpage 401 | 402 | check_header "stdio.h" 403 | check_header "stddef.h" 404 | check_header "stdint.h" 405 | check_header "stdlib.h" 406 | 407 | printf "\n#endif" >> $CONFIG_HEADER 408 | -------------------------------------------------------------------------------- /scheme/docs/microlisp.1: -------------------------------------------------------------------------------- 1 | .TH MICROLISP 1 2 | .SH NAME 3 | microlisp \- microlisp interpreter 4 | .SH SYNOPSIS 5 | .B microlisp 6 | [\fIfile\fR] ... 7 | .SH DESCRIPTION 8 | Lightweight LISP interpreter that follows a minimal Scheme-like dialect. 9 | .SH OPTIONS 10 | .TP 11 | \fIfile\fR 12 | Load and silently evaluate the source file 13 | 14 | .SH AUTHOR 15 | Michael Lazear 16 | .I 17 | @lazear 18 | -------------------------------------------------------------------------------- /scheme/src/fib.scm: -------------------------------------------------------------------------------- 1 | (define (fib n) 2 | (if (= n 2) 3 | 1 4 | (if (= n 1) 5 | 1 6 | (+ 7 | (fib (- n 1)) 8 | (fib (- n 2)))))) 9 | (print (fib 30)) 10 | (exit) -------------------------------------------------------------------------------- /scheme/src/lib.scm: -------------------------------------------------------------------------------- 1 | ;;; Michael Lazear, (C) 2016 - MIT License 2 | ;;; Standard Library functions 3 | 4 | (define caar (lambda(a) (car (car a)))) 5 | (define cadr (lambda(a) (car (cdr a)))) 6 | (define cdar (lambda(a) (cdr (car a)))) 7 | (define cddr (lambda(a) (cdr (cdr a)))) 8 | (define cadar (lambda(a) (car (cdr (car a))))) 9 | (define caddr (lambda(a) (car (cdr (cdr a))))) 10 | (define cdddr (lambda(a) (cdr (cdr (cdr a))))) 11 | (define cadddr (lambda(a) (car (cdr (cdr (cdr a)))))) 12 | 13 | (define != (lambda (a b) (if (= a b) #f #t))) 14 | (define >= (lambda (a b) (if (< a b) #f #t))) 15 | (define <= (lambda (a b) (if (> a b) #f #t))) 16 | 17 | ;;; Return the maximum value from a list of integers 18 | (define (max list-of-numbers) 19 | (define (max-iter best remaining) 20 | (cond ((null? remaining) best) 21 | ((> (car remaining) best) (max-iter (car remaining) (cdr remaining))) 22 | (else (max-iter best (cdr remaining))))) 23 | (max-iter (car list-of-numbers) (cdr list-of-numbers))) 24 | 25 | ;;; Return the minimum value from a list of integers 26 | (define (min list-of-numbers) 27 | (define (min-iter best remaining) 28 | (cond ((null? remaining) best) 29 | ((< (car remaining) best) (min-iter (car remaining) (cdr remaining))) 30 | (else (min-iter best (cdr remaining))))) 31 | (min-iter (car list-of-numbers) (cdr list-of-numbers))) 32 | 33 | ;;; Map a function 'f' onto list 'a' 34 | (define map (lambda (f a) 35 | (if (null? a) 36 | '() 37 | (cons (f (car a)) (map f (cdr a)))))) 38 | 39 | 40 | ;;; Provide the association pair of key from list 41 | (define (assoc key list) 42 | (if (null? list) 43 | '() 44 | (if (eq? key (car (car list))) 45 | (car list) 46 | (assoc key (cdr list))))) 47 | 48 | ;;; Lambda key-list with dispatch 49 | (define (make-key-list) 50 | (let ((list '())) 51 | (define get-val (lambda (var) 52 | (assoc var list))) 53 | (define add-key (lambda (var val) 54 | (set! list (cons (cons var val) list)))) 55 | (define (dispatch m) 56 | (if (eq? m 'add) add-key 57 | (if (eq? m 'get) get-val 58 | list))) 59 | dispatch)) 60 | 61 | ;;; Lambda stack with dispatch 62 | (define (make-stack) 63 | (let ((stack '())) 64 | (define push (lambda (x) 65 | (set! stack (cons x stack)) 66 | stack)) 67 | (define pop (lambda (x) 68 | (define q (car stack)) 69 | (set! stack (cdr stack)) 70 | q)) 71 | (define (dispatch m) 72 | (if (eq? m 'push) push 73 | (if (eq? m 'pop) pop 74 | stack))) 75 | dispatch)) 76 | ;;; Returns the last item in a list or pair. 77 | ;;; Pointer to cdr if list, Pointer to object if pair 78 | (define last-item-in-list (lambda (list) 79 | (define (helper remaining) 80 | (if (null? (cdr remaining)) 81 | remaining 82 | (helper (cdr remaining)))) 83 | (helper list))) 84 | 85 | ;;; Returns a list from (0-number) 86 | (define (range number) 87 | (define (range-helper start max) 88 | (if (= start max) 89 | (cons max '()) 90 | (cons start (range-helper (+ 1 start) max)))) 91 | (range-helper 0 number)) 92 | 93 | ;;; Returns a list from (0-number) 94 | (define (range-from start finish) 95 | (if (= start finish) 96 | finish 97 | (cons start (range-from (+ 1 start) finish)))) 98 | 99 | ;;; Tail recursive length 100 | (define (length list) 101 | (define (length-helper accum remaining) 102 | (if (null? remaining) 103 | accum 104 | (length-helper (+ 1 accum) (cdr remaining)))) 105 | (length-helper 1 (cdr list))) 106 | 107 | ;;; Append list2 to list1 108 | (define append (lambda (list1 list2) 109 | (define (append-helper l1 l2) 110 | (if (null? l1) 111 | l2 112 | (cons (car l1) (append-helper (cdr l1) l2)))) 113 | (append-helper list1 list2))) 114 | 115 | ;;; Reverse list 116 | (define (reverse list) 117 | (define (reverse-iter remaining first) 118 | (if (null? remaining) 119 | first 120 | (reverse-iter (cdr remaining) (cons (car remaining) first)))) 121 | (reverse-iter list '())) 122 | 123 | (define (pow num exp) 124 | (define (iter a b) 125 | (if (eq? b 1) 126 | a 127 | (iter (* a num) (- b 1)))) 128 | (if (eq? exp 0) 129 | 1 130 | (iter num exp))) 131 | 132 | (define (>= a b) 133 | (if (< a b) #f #t)) 134 | 135 | (define (<= a b) 136 | (if (> a b) #f #t)) 137 | 138 | (define ge <=) 139 | (define le >=) 140 | 141 | (define (mod a b) 142 | (define (iter rem div) 143 | (if (< rem div) 144 | rem 145 | (iter (- rem div) div))) 146 | (iter a b)) 147 | 148 | ;;; A couple macros 149 | ;;; Because this is LISP and we can... 150 | (define procedure-body (lambda (proc) (caddr proc))) 151 | (define procedure-args (lambda (proc) (cadr proc))) 152 | (define (mutate-procedure-env name new-env) (set-car! (cdddr name) new-env)) 153 | (define (mutate-procedure-body name new-body) (set-car! (cddr name) (list new-body))) 154 | (define (mutate-procedure-args name new-args) (set-car! (cdr name) new-args)) 155 | 156 | (define (construct-procedure args body env) 157 | (let ((new-proc (cons 'procedure (cons '() (cons '() (cons '())))))) 158 | (mutate-procedure-args new-proc args) 159 | (mutate-procedure-body new-proc body) 160 | (mutate-procedure-env new-proc env) 161 | new-proc)) 162 | 163 | (define (if-zero x then) (list 'if (list '= x 0) then)) 164 | 165 | (define (gen-accum number) 166 | (lambda (amount) 167 | (set! number (+ number amount)) 168 | number)) 169 | 170 | ;;; Everytime (new-accum) is called, it's accumulator should be increased by one 171 | (define new-accum (gen-accum 0)) 172 | 173 | ;; Simple for loop 174 | (define for (lambda (start end do) 175 | (define (for-loop a z) 176 | (if (= a z) 177 | 'Done;; Last iteration 178 | (begin 179 | (do) 180 | (for-loop (+ 1 a) z)))) 181 | (for-loop start end do))) 182 | 183 | (define (make-withdraw balance) 184 | (lambda (amount) 185 | (if (> balance amount) 186 | (begin (set! balance (- balance amount)) 187 | balance) 188 | "Insufficient funds"))) 189 | 190 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 191 | ;;; Various tests 192 | (define x '(1 2 3)) 193 | (define factorial (lambda(n) (if (= n 0) 1 (* n (factorial (- n 1)))))) 194 | (define add1 (lambda(n) (+ 1 n))) 195 | (define (sum-of-squares num-list) 196 | (define sos-helper (lambda (remaining sum-so-far) 197 | (if (null? remaining) 198 | sum-so-far 199 | (sos-helper (cdr remaining) (+ sum-so-far (* (car remaining) (car remaining))))))) 200 | (sos-helper num-list 0)) 201 | 202 | ;;; Procedure with no args 203 | (define (new-env) (cons (cons '() '()) '())) 204 | ;;; Construct a procedure with macro 205 | (define new-func (construct-procedure '(a) '(cons a 10) (get-global-environment))) 206 | (define with-macros (construct-procedure '(x) (if-zero 'x 'ZERO) (get-global-environment))) -------------------------------------------------------------------------------- /scheme/src/scheme.c: -------------------------------------------------------------------------------- 1 | /* Single file scheme interpreter 2 | MIT License 3 | Copyright Michael Lazear (c) 2016 */ 4 | 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | 16 | #define null(x) ((x) == NULL || (x) == NIL) 17 | #define EOL(x) (null((x)) || (x) == EMPTY_LIST) 18 | #define error(x) \ 19 | do { \ 20 | fprintf(stderr, "%s\n", x); \ 21 | exit(1); \ 22 | } while (0) 23 | #define caar(x) (car(car((x)))) 24 | #define cdar(x) (cdr(car((x)))) 25 | #define cadr(x) (car(cdr((x)))) 26 | #define caddr(x) (car(cdr(cdr((x))))) 27 | #define cadddr(x) (car(cdr(cdr(cdr((x)))))) 28 | #define cadar(x) (car(cdr(car((x))))) 29 | #define cddr(x) (cdr(cdr((x)))) 30 | #define cdadr(x) (cdr(car(cdr((x))))) 31 | #define atom(x) (!null(x) && (x)->type != LIST) 32 | #define ASSERT_TYPE(x, t) (__type_check(__func__, x, t)) 33 | 34 | typedef enum { INTEGER, SYMBOL, STRING, LIST, PRIMITIVE, VECTOR } type_t; 35 | typedef struct object *(*primitive_t)(struct object *); 36 | 37 | /* Lisp object. We want to mimic the homoiconicity of LISP, so we will not be 38 | providing separate "types" for procedures, etc. Everything is represented as 39 | atoms (integers, strings, booleans) or a list of atoms, except for the 40 | primitive functions */ 41 | 42 | struct object { 43 | char gc; 44 | type_t type; 45 | union { 46 | int64_t integer; 47 | char *string; 48 | struct { 49 | struct object **vector; 50 | int vsize; 51 | }; 52 | struct { 53 | struct object *car; 54 | struct object *cdr; 55 | }; 56 | primitive_t primitive; 57 | }; 58 | } __attribute__((packed)); 59 | 60 | /* We declare a couple of global variables for keywords */ 61 | static struct object *ENV; 62 | static struct object *NIL; 63 | static struct object *EMPTY_LIST; 64 | static struct object *TRUE; 65 | static struct object *FALSE; 66 | static struct object *QUOTE; 67 | static struct object *DEFINE; 68 | static struct object *SET; 69 | static struct object *LET; 70 | static struct object *IF; 71 | static struct object *LAMBDA; 72 | static struct object *BEGIN; 73 | static struct object *PROCEDURE; 74 | 75 | void print_exp(char *, struct object *); 76 | bool is_tagged(struct object *cell, struct object *tag); 77 | struct object *read_exp(FILE *in); 78 | struct object *eval(struct object *exp, struct object *env); 79 | struct object *cons(struct object *x, struct object *y); 80 | struct object *load_file(struct object *args); 81 | struct object *cdr(struct object *); 82 | struct object *car(struct object *); 83 | struct object *lookup_variable(struct object *var, struct object *env); 84 | 85 | /*============================================================================== 86 | Hash table for saving Lisp symbol objects. Conserves memory and faster compares 87 | ==============================================================================*/ 88 | struct htable { 89 | struct object *key; 90 | }; 91 | /* One dimensional hash table */ 92 | static struct htable *HTABLE = NULL; 93 | static int HTABLE_SIZE; 94 | 95 | static uint64_t hash(const char *s) { 96 | uint64_t h = 0; 97 | uint8_t *u = (uint8_t *)s; 98 | while (*u) { 99 | h = (h * 256 + *u) % HTABLE_SIZE; 100 | u++; 101 | } 102 | return h; 103 | } 104 | 105 | int ht_init(int size) { 106 | if (HTABLE || !(size % 2)) 107 | error("Hash table already initialized or even # of entries"); 108 | HTABLE = malloc(sizeof(struct htable) * size); 109 | memset(HTABLE, 0, sizeof(struct htable) * size); 110 | HTABLE_SIZE = size; 111 | return size; 112 | } 113 | 114 | void ht_insert(struct object *key) { 115 | uint64_t h = hash(key->string); 116 | HTABLE[h].key = key; 117 | } 118 | 119 | struct object *ht_lookup(char *s) { 120 | uint64_t h = hash(s); 121 | return HTABLE[h].key; 122 | } 123 | 124 | /*============================================================================== 125 | Memory management - Currently no GC 126 | ==============================================================================*/ 127 | int alloc_count = 0; 128 | 129 | struct object *alloc() { 130 | struct object *ret = malloc(sizeof(struct object)); 131 | alloc_count++; 132 | return ret; 133 | } 134 | 135 | /*============================================================================ 136 | Constructors and etc 137 | ==============================================================================*/ 138 | int __type_check(const char *func, struct object *obj, type_t type) { 139 | if (null(obj)) { 140 | fprintf(stderr, "Invalid argument to function %s: NIL\n", func); 141 | exit(1); 142 | } else if (obj->type != type) { 143 | char *types[6] = {"INTEGER", "SYMBOL", "STRING", 144 | "LIST", "PRIMITIVE", "VECTOR"}; 145 | fprintf(stderr, "Invalid argument to function %s. Expected %s got %s\n", 146 | func, types[type], types[obj->type]); 147 | exit(1); 148 | } 149 | return 1; 150 | } 151 | 152 | struct object *make_vector(int size) { 153 | struct object *ret = alloc(); 154 | ret->type = VECTOR; 155 | ret->vector = malloc(sizeof(struct object *) * size); 156 | ret->vsize = size; 157 | 158 | memset(ret->vector, 0, size); 159 | 160 | return ret; 161 | } 162 | 163 | struct object *make_symbol(char *s) { 164 | struct object *ret = ht_lookup(s); 165 | if (null(ret)) { 166 | ret = alloc(); 167 | ret->type = SYMBOL; 168 | ret->string = strdup(s); 169 | ht_insert(ret); 170 | } 171 | return ret; 172 | } 173 | 174 | struct object *make_integer(int x) { 175 | struct object *ret = alloc(); 176 | ret->type = INTEGER; 177 | ret->integer = x; 178 | return ret; 179 | } 180 | 181 | struct object *make_primitive(primitive_t x) { 182 | struct object *ret = alloc(); 183 | ret->type = PRIMITIVE; 184 | ret->primitive = x; 185 | return ret; 186 | } 187 | 188 | struct object *make_lambda(struct object *params, struct object *body) { 189 | return cons(LAMBDA, cons(params, body)); 190 | } 191 | 192 | struct object *make_procedure(struct object *params, struct object *body, 193 | struct object *env) { 194 | return cons(PROCEDURE, cons(params, cons(body, cons(env, EMPTY_LIST)))); 195 | } 196 | 197 | struct object *cons(struct object *x, struct object *y) { 198 | struct object *ret = alloc(); 199 | ret->type = LIST; 200 | ret->car = x; 201 | ret->cdr = y; 202 | return ret; 203 | } 204 | 205 | struct object *car(struct object *cell) { 206 | if (null(cell) || cell->type != LIST) 207 | return NIL; 208 | return cell->car; 209 | } 210 | 211 | struct object *cdr(struct object *cell) { 212 | if (null(cell) || cell->type != LIST) 213 | return NIL; 214 | return cell->cdr; 215 | } 216 | 217 | struct object *append(struct object *l1, struct object *l2) { 218 | if (null(l1)) 219 | return l2; 220 | return cons(car(l1), append(cdr(l1), l2)); 221 | } 222 | 223 | struct object *reverse(struct object *list, struct object *first) { 224 | if (null(list)) 225 | return first; 226 | return reverse(cdr(list), cons(car(list), first)); 227 | } 228 | 229 | // Pointer equality 230 | bool is_equal(struct object *x, struct object *y) { 231 | 232 | if (x == y) 233 | return true; 234 | if (null(x) || null(y)) 235 | return false; 236 | if (x->type != y->type) 237 | return false; 238 | switch (x->type) { 239 | case LIST: 240 | return false; 241 | case INTEGER: 242 | return x->integer == y->integer; 243 | case SYMBOL: 244 | case STRING: 245 | return !strcmp(x->string, y->string); 246 | case PRIMITIVE: 247 | return false; 248 | case VECTOR: 249 | return false; 250 | } 251 | return false; 252 | } 253 | 254 | bool not_false(struct object *x) { 255 | if (null(x) || is_equal(x, FALSE)) 256 | return false; 257 | if (x->type == INTEGER && x->integer == 0) 258 | return false; 259 | return true; 260 | } 261 | 262 | bool is_tagged(struct object *cell, struct object *tag) { 263 | if (null(cell) || cell->type != LIST) 264 | return false; 265 | return is_equal(car(cell), tag); 266 | } 267 | 268 | int length(struct object *exp) { 269 | if (null(exp)) 270 | return 0; 271 | return 1 + length(cdr(exp)); 272 | } 273 | /*============================================================================== 274 | Primitive operations 275 | ==============================================================================*/ 276 | 277 | struct object *prim_type(struct object *args) { 278 | char *types[6] = {"integer", "symbol", "string", 279 | "list", "primitive", "vector"}; 280 | return make_symbol(types[car(args)->type]); 281 | } 282 | 283 | struct object *prim_get_env(struct object *args) { 284 | assert(null(args)); 285 | return ENV; 286 | } 287 | struct object *prim_set_env(struct object *args) { 288 | ENV = car(args); 289 | return NIL; 290 | } 291 | 292 | struct object *prim_list(struct object *args) { 293 | return (args); 294 | } 295 | struct object *prim_cons(struct object *args) { 296 | return cons(car(args), cadr(args)); 297 | } 298 | 299 | struct object *prim_car(struct object *args) { 300 | #ifdef STRICT 301 | ASSERT_TYPE(car(args), LIST); 302 | #endif 303 | return caar(args); 304 | } 305 | 306 | struct object *prim_cdr(struct object *args) { 307 | #ifdef STRICT 308 | ASSERT_TYPE(car(args), LIST); 309 | #endif 310 | return cdar(args); 311 | } 312 | 313 | struct object *prim_setcar(struct object *args) { 314 | ASSERT_TYPE(car(args), LIST); 315 | (args->car->car = (cadr(args))); 316 | return NIL; 317 | } 318 | struct object *prim_setcdr(struct object *args) { 319 | ASSERT_TYPE(car(args), LIST); 320 | (args->car->cdr = (cadr(args))); 321 | return NIL; 322 | } 323 | 324 | struct object *prim_nullq(struct object *args) { 325 | return EOL(car(args)) ? TRUE : FALSE; 326 | } 327 | 328 | struct object *prim_pairq(struct object *args) { 329 | if (car(args)->type != LIST) 330 | return FALSE; 331 | return (atom(caar(args)) && atom(cdar(args))) ? TRUE : FALSE; 332 | } 333 | 334 | struct object *prim_listq(struct object *args) { 335 | struct object *list; 336 | if (car(args)->type != LIST) 337 | return FALSE; 338 | for (list = car(args); !null(list); list = list->cdr) 339 | if (!null(list->cdr) && (list->cdr->type != LIST)) 340 | return FALSE; 341 | return (car(args)->type == LIST && prim_pairq(args) != TRUE) ? TRUE : FALSE; 342 | } 343 | 344 | struct object *prim_atomq(struct object *sexp) { 345 | return atom(car(sexp)) ? TRUE : FALSE; 346 | } 347 | 348 | /* = primitive, only valid for numbers */ 349 | struct object *prim_neq(struct object *args) { 350 | if ((car(args)->type != INTEGER) || (cadr(args)->type != INTEGER)) 351 | return FALSE; 352 | return (car(args)->integer == cadr(args)->integer) ? TRUE : FALSE; 353 | } 354 | 355 | /* eq? primitive, checks memory location, or if equal values for primitives */ 356 | struct object *prim_eq(struct object *args) { 357 | return is_equal(car(args), cadr(args)) ? TRUE : FALSE; 358 | } 359 | 360 | struct object *prim_equal(struct object *args) { 361 | if (is_equal(car(args), cadr(args))) 362 | return TRUE; 363 | if ((car(args)->type == LIST) && (cadr(args)->type == LIST)) { 364 | struct object *a, *b; 365 | a = car(args); 366 | b = cadr(args); 367 | while (!null(a) && !null(b)) { 368 | if (!is_equal(car(a), car(b))) 369 | return FALSE; 370 | a = cdr(a); 371 | b = cdr(b); 372 | } 373 | return TRUE; 374 | } 375 | if ((car(args)->type == VECTOR) && (cadr(args)->type == VECTOR)) { 376 | if (car(args)->vsize != cadr(args)->vsize) { 377 | return FALSE; 378 | } 379 | struct object **va = car(args)->vector; 380 | struct object **vb = cadr(args)->vector; 381 | int i = 0; 382 | for (i = 0; i < car(args)->vsize; i++) { 383 | if (!is_equal(*(va + i), *(vb + i))) { 384 | return FALSE; 385 | } 386 | } 387 | return TRUE; 388 | } 389 | return FALSE; 390 | } 391 | 392 | struct object *prim_add(struct object *list) { 393 | ASSERT_TYPE(car(list), INTEGER); 394 | int64_t total = car(list)->integer; 395 | list = cdr(list); 396 | while (!EOL(car(list))) { 397 | ASSERT_TYPE(car(list), INTEGER); 398 | total += car(list)->integer; 399 | list = cdr(list); 400 | } 401 | return make_integer(total); 402 | } 403 | 404 | struct object *prim_sub(struct object *list) { 405 | ASSERT_TYPE(car(list), INTEGER); 406 | int64_t total = car(list)->integer; 407 | list = cdr(list); 408 | while (!null(list)) { 409 | ASSERT_TYPE(car(list), INTEGER); 410 | total -= car(list)->integer; 411 | list = cdr(list); 412 | } 413 | return make_integer(total); 414 | } 415 | 416 | struct object *prim_div(struct object *list) { 417 | ASSERT_TYPE(car(list), INTEGER); 418 | int64_t total = car(list)->integer; 419 | list = cdr(list); 420 | while (!null(list)) { 421 | ASSERT_TYPE(car(list), INTEGER); 422 | total /= car(list)->integer; 423 | list = cdr(list); 424 | } 425 | return make_integer(total); 426 | } 427 | 428 | struct object *prim_mul(struct object *list) { 429 | ASSERT_TYPE(car(list), INTEGER); 430 | int64_t total = car(list)->integer; 431 | list = cdr(list); 432 | while (!null(list)) { 433 | ASSERT_TYPE(car(list), INTEGER); 434 | total *= car(list)->integer; 435 | list = cdr(list); 436 | } 437 | return make_integer(total); 438 | } 439 | struct object *prim_gt(struct object *sexp) { 440 | ASSERT_TYPE(car(sexp), INTEGER); 441 | ASSERT_TYPE(cadr(sexp), INTEGER); 442 | return (car(sexp)->integer > cadr(sexp)->integer) ? TRUE : NIL; 443 | } 444 | 445 | struct object *prim_lt(struct object *sexp) { 446 | ASSERT_TYPE(car(sexp), INTEGER); 447 | ASSERT_TYPE(cadr(sexp), INTEGER); 448 | return (car(sexp)->integer < cadr(sexp)->integer) ? TRUE : NIL; 449 | } 450 | 451 | struct object *prim_print(struct object *args) { 452 | print_exp(NULL, car(args)); 453 | printf("\n"); 454 | return NIL; 455 | } 456 | 457 | struct object *prim_exit(struct object *args) { 458 | assert(null(args)); 459 | exit(0); 460 | } 461 | 462 | struct object *prim_read(struct object *args) { 463 | assert(null(args)); 464 | return read_exp(stdin); 465 | } 466 | 467 | struct object *prim_vget(struct object *args) { 468 | ASSERT_TYPE(car(args), VECTOR); 469 | ASSERT_TYPE(cadr(args), INTEGER); 470 | if (cadr(args)->integer >= car(args)->vsize) 471 | return NIL; 472 | return car(args)->vector[cadr(args)->integer]; 473 | } 474 | 475 | struct object *prim_vset(struct object *args) { 476 | ASSERT_TYPE(car(args), VECTOR); 477 | ASSERT_TYPE(cadr(args), INTEGER); 478 | if (null(caddr(args))) 479 | return NIL; 480 | if (cadr(args)->integer >= car(args)->vsize) 481 | return NIL; 482 | car(args)->vector[cadr(args)->integer] = caddr(args); 483 | return make_symbol("ok"); 484 | } 485 | 486 | struct object *prim_vec(struct object *args) { 487 | ASSERT_TYPE(car(args), INTEGER); 488 | return make_vector(car(args)->integer); 489 | } 490 | 491 | /*============================================================================== 492 | Environment handling 493 | ==============================================================================*/ 494 | 495 | struct object *extend_env(struct object *var, struct object *val, 496 | struct object *env) { 497 | return cons(cons(var, val), env); 498 | } 499 | 500 | struct object *lookup_variable(struct object *var, struct object *env) { 501 | while (!null(env)) { 502 | struct object *frame = car(env); 503 | struct object *vars = car(frame); 504 | struct object *vals = cdr(frame); 505 | while (!null(vars)) { 506 | if (is_equal(car(vars), var)) 507 | return car(vals); 508 | vars = cdr(vars); 509 | vals = cdr(vals); 510 | } 511 | env = cdr(env); 512 | } 513 | return NIL; 514 | } 515 | 516 | /* set_variable binds var to val in the first frame in which var occurs */ 517 | void set_variable(struct object *var, struct object *val, struct object *env) { 518 | while (!null(env)) { 519 | struct object *frame = car(env); 520 | struct object *vars = car(frame); 521 | struct object *vals = cdr(frame); 522 | while (!null(vars)) { 523 | if (is_equal(car(vars), var)) { 524 | vals->car = val; 525 | return; 526 | } 527 | vars = cdr(vars); 528 | vals = cdr(vals); 529 | } 530 | env = cdr(env); 531 | } 532 | } 533 | 534 | /* define_variable binds var to val in the *current* frame */ 535 | struct object *define_variable(struct object *var, struct object *val, 536 | struct object *env) { 537 | struct object *frame = car(env); 538 | struct object *vars = car(frame); 539 | struct object *vals = cdr(frame); 540 | 541 | while (!null(vars)) { 542 | if (is_equal(var, car(vars))) { 543 | vals->car = val; 544 | return val; 545 | } 546 | vars = cdr(vars); 547 | vals = cdr(vals); 548 | } 549 | frame->car = cons(var, car(frame)); 550 | frame->cdr = cons(val, cdr(frame)); 551 | return val; 552 | } 553 | 554 | /*============================================================================== 555 | Recursive descent parser 556 | ==============================================================================*/ 557 | 558 | char SYMBOLS[] = "~!@#$%^&*_-+\\:,.<>|{}[]?=/"; 559 | 560 | int peek(FILE *in) { 561 | int c = getc(in); 562 | ungetc(c, in); 563 | return c; 564 | } 565 | 566 | /* skip characters until end of line */ 567 | void skip(FILE *in) { 568 | int c; 569 | for (;;) { 570 | c = getc(in); 571 | if (c == '\n' || c == EOF) 572 | return; 573 | } 574 | } 575 | 576 | struct object *read_string(FILE *in) { 577 | char buf[256]; 578 | int i = 0; 579 | int c; 580 | while ((c = getc(in)) != '\"') { 581 | if (c == EOF) 582 | return NIL; 583 | if (i >= 256) 584 | error("String too long - maximum length 256 characters"); 585 | buf[i++] = (char)c; 586 | } 587 | buf[i] = '\0'; 588 | struct object *s = make_symbol(buf); 589 | s->type = STRING; 590 | return s; 591 | } 592 | 593 | struct object *read_symbol(FILE *in, char start) { 594 | char buf[128]; 595 | buf[0] = start; 596 | int i = 1; 597 | while (isalnum(peek(in)) || strchr(SYMBOLS, peek(in))) { 598 | if (i >= 128) 599 | error("Symbol name too long - maximum length 128 characters"); 600 | buf[i++] = getc(in); 601 | } 602 | buf[i] = '\0'; 603 | return make_symbol(buf); 604 | } 605 | 606 | int read_int(FILE *in, int start) { 607 | while (isdigit(peek(in))) 608 | start = start * 10 + (getc(in) - '0'); 609 | return start; 610 | } 611 | 612 | struct object *read_list(FILE *in) { 613 | struct object *obj; 614 | struct object *cell = EMPTY_LIST; 615 | for (;;) { 616 | obj = read_exp(in); 617 | 618 | if (obj == EMPTY_LIST) 619 | return reverse(cell, EMPTY_LIST); 620 | cell = cons(obj, cell); 621 | } 622 | return EMPTY_LIST; 623 | } 624 | 625 | struct object *read_quote(FILE *in) { 626 | return cons(QUOTE, cons(read_exp(in), NIL)); 627 | } 628 | 629 | int depth = 0; 630 | 631 | struct object *read_exp(FILE *in) { 632 | int c; 633 | 634 | for (;;) { 635 | c = getc(in); 636 | if (c == '\n' || c == '\r' || c == ' ' || c == '\t') { 637 | if ((c == '\n' || c == '\r') && in == stdin) { 638 | int i; 639 | for (i = 0; i < depth; i++) 640 | printf(".."); 641 | } 642 | continue; 643 | } 644 | if (c == ';') { 645 | skip(in); 646 | continue; 647 | } 648 | if (c == EOF) 649 | return NULL; 650 | if (c == '\"') 651 | return read_string(in); 652 | if (c == '\'') 653 | return read_quote(in); 654 | if (c == '(') { 655 | depth++; 656 | return read_list(in); 657 | } 658 | if (c == ')') { 659 | depth--; 660 | return EMPTY_LIST; 661 | } 662 | if (isdigit(c)) 663 | return make_integer(read_int(in, c - '0')); 664 | if (c == '-' && isdigit(peek(in))) 665 | return make_integer(-1 * read_int(in, getc(in) - '0')); 666 | if (isalpha(c) || strchr(SYMBOLS, c)) 667 | return read_symbol(in, c); 668 | } 669 | return NIL; 670 | } 671 | 672 | void print_exp(char *str, struct object *e) { 673 | if (str) 674 | printf("%s ", str); 675 | if (null(e)) { 676 | printf("'()"); 677 | return; 678 | } 679 | switch (e->type) { 680 | case STRING: 681 | printf("\"%s\"", e->string); 682 | break; 683 | case SYMBOL: 684 | printf("%s", e->string); 685 | break; 686 | case INTEGER: 687 | printf("%ld", e->integer); 688 | break; 689 | case PRIMITIVE: 690 | printf(""); 691 | break; 692 | case VECTOR: 693 | printf("", e->vsize); 694 | break; 695 | case LIST: 696 | if (is_tagged(e, PROCEDURE)) { 697 | printf(""); 698 | return; 699 | } 700 | printf("("); 701 | struct object **t = &e; 702 | while (!null(*t)) { 703 | print_exp(NULL, (*t)->car); 704 | if (!null((*t)->cdr)) { 705 | printf(" "); 706 | if ((*t)->cdr->type == LIST) { 707 | t = &(*t)->cdr; 708 | } else { 709 | print_exp(".", (*t)->cdr); 710 | break; 711 | } 712 | } else 713 | break; 714 | } 715 | printf(")"); 716 | } 717 | } 718 | 719 | /*============================================================================== 720 | LISP evaluator 721 | ==============================================================================*/ 722 | 723 | struct object *evlis(struct object *exp, struct object *env) { 724 | if (null(exp)) 725 | return NIL; 726 | return cons(eval(car(exp), env), evlis(cdr(exp), env)); 727 | } 728 | 729 | struct object *eval_sequence(struct object *exps, struct object *env) { 730 | if (null(cdr(exps))) 731 | return eval(car(exps), env); 732 | eval(car(exps), env); 733 | return eval_sequence(cdr(exps), env); 734 | } 735 | 736 | struct object *eval(struct object *exp, struct object *env) { 737 | 738 | tail: 739 | if (null(exp) || exp == EMPTY_LIST) { 740 | return NIL; 741 | } else if (exp->type == INTEGER || exp->type == STRING) { 742 | return exp; 743 | } else if (exp->type == SYMBOL) { 744 | struct object *s = lookup_variable(exp, env); 745 | #ifdef STRICT 746 | if (null(s)) { 747 | print_exp("Unbound symbol:", exp); 748 | printf("\n"); 749 | } 750 | #endif 751 | return s; 752 | } else if (is_tagged(exp, QUOTE)) { 753 | return cadr(exp); 754 | } else if (is_tagged(exp, LAMBDA)) { 755 | return make_procedure(cadr(exp), cddr(exp), env); 756 | } else if (is_tagged(exp, DEFINE)) { 757 | if (atom(cadr(exp))) 758 | define_variable(cadr(exp), eval(caddr(exp), env), env); 759 | else { 760 | struct object *closure = 761 | eval(make_lambda(cdr(cadr(exp)), cddr(exp)), env); 762 | define_variable(car(cadr(exp)), closure, env); 763 | } 764 | return make_symbol("ok"); 765 | } else if (is_tagged(exp, BEGIN)) { 766 | struct object *args = cdr(exp); 767 | for (; !null(cdr(args)); args = cdr(args)) 768 | eval(car(args), env); 769 | exp = car(args); 770 | goto tail; 771 | } else if (is_tagged(exp, IF)) { 772 | struct object *predicate = eval(cadr(exp), env); 773 | exp = (not_false(predicate)) ? caddr(exp) : cadddr(exp); 774 | goto tail; 775 | } else if (is_tagged(exp, make_symbol("or"))) { 776 | struct object *predicate = eval(cadr(exp), env); 777 | exp = (not_false(predicate)) ? caddr(exp) : cadddr(exp); 778 | goto tail; 779 | } else if (is_tagged(exp, make_symbol("cond"))) { 780 | struct object *branch = cdr(exp); 781 | for (; !null(branch); branch = cdr(branch)) { 782 | if (is_tagged(car(branch), make_symbol("else")) || 783 | not_false(eval(caar(branch), env))) { 784 | exp = cons(BEGIN, cdar(branch)); 785 | goto tail; 786 | } 787 | } 788 | return NIL; 789 | } else if (is_tagged(exp, SET)) { 790 | if (atom(cadr(exp))) 791 | set_variable(cadr(exp), eval(caddr(exp), env), env); 792 | else { 793 | struct object *closure = 794 | eval(make_lambda(cdr(cadr(exp)), cddr(exp)), env); 795 | set_variable(car(cadr(exp)), closure, env); 796 | } 797 | return make_symbol("ok"); 798 | } else if (is_tagged(exp, LET)) { 799 | /* We go with the strategy of transforming let into a lambda function*/ 800 | struct object **tmp; 801 | struct object *vars = NIL; 802 | struct object *vals = NIL; 803 | if (null(cadr(exp))) 804 | return NIL; 805 | /* NAMED LET */ 806 | if (atom(cadr(exp))) { 807 | for (tmp = &exp->cdr->cdr->car; !null(*tmp); tmp = &(*tmp)->cdr) { 808 | vars = cons(caar(*tmp), vars); 809 | vals = cons(cadar(*tmp), vals); 810 | } 811 | /* Define the named let as a lambda function */ 812 | define_variable(cadr(exp), 813 | eval(make_lambda(vars, cdr(cddr(exp))), 814 | extend_env(vars, vals, env)), 815 | env); 816 | /* Then evaluate the lambda function with the starting values */ 817 | exp = cons(cadr(exp), vals); 818 | goto tail; 819 | } 820 | for (tmp = &exp->cdr->car; !null(*tmp); tmp = &(*tmp)->cdr) { 821 | vars = cons(caar(*tmp), vars); 822 | vals = cons(cadar(*tmp), vals); 823 | } 824 | exp = cons(make_lambda(vars, cddr(exp)), vals); 825 | goto tail; 826 | } else { 827 | /* procedure structure is as follows: 828 | ('procedure, (parameters), (body), (env)) */ 829 | struct object *proc = eval(car(exp), env); 830 | struct object *args = evlis(cdr(exp), env); 831 | if (null(proc)) { 832 | #ifdef STRICT 833 | print_exp("Invalid arguments to eval:", exp); 834 | printf("\n"); 835 | #endif 836 | 837 | return NIL; 838 | } 839 | if (proc->type == PRIMITIVE) 840 | return proc->primitive(args); 841 | if (is_tagged(proc, PROCEDURE)) { 842 | env = extend_env(cadr(proc), args, cadddr(proc)); 843 | exp = cons(BEGIN, caddr(proc)); /* procedure body */ 844 | goto tail; 845 | } 846 | } 847 | print_exp("Invalid arguments to eval:", exp); 848 | printf("\n"); 849 | return NIL; 850 | } 851 | 852 | extern char **environ; 853 | struct object *prim_exec(struct object *args) { 854 | ASSERT_TYPE(car(args), STRING); 855 | int l = length(args); 856 | struct object *tmp = args; 857 | 858 | char **newarg = malloc(sizeof(char *) * (l + 1)); 859 | char **n = newarg; 860 | for (; l; l--) { 861 | ASSERT_TYPE(car(tmp), STRING); 862 | *n++ = car(tmp)->string; 863 | tmp = cdr(tmp); 864 | } 865 | *n = NULL; 866 | int pid = fork(); 867 | if (pid == 0) { 868 | /* if execve returns -1, there was an errorm so we need to kill*/ 869 | if (execve(car(args)->string, newarg, environ)) { 870 | perror(car(args)->string); 871 | kill(getpid(), SIGTERM); 872 | } 873 | } 874 | wait(&pid); 875 | return NIL; 876 | } 877 | 878 | /* Initialize the global environment, add primitive functions and symbols */ 879 | void init_env() { 880 | #define add_prim(s, c) define_variable(make_symbol(s), make_primitive(c), ENV) 881 | #define add_sym(s, c) \ 882 | do { \ 883 | c = make_symbol(s); \ 884 | define_variable(c, c, ENV); \ 885 | } while (0); 886 | ENV = extend_env(NIL, NIL, NIL); 887 | add_sym("#t", TRUE); 888 | add_sym("#f", FALSE); 889 | add_sym("quote", QUOTE); 890 | add_sym("lambda", LAMBDA); 891 | add_sym("procedure", PROCEDURE); 892 | add_sym("define", DEFINE); 893 | add_sym("let", LET); 894 | add_sym("set!", SET); 895 | add_sym("begin", BEGIN); 896 | add_sym("if", IF); 897 | define_variable(make_symbol("true"), TRUE, ENV); 898 | define_variable(make_symbol("false"), FALSE, ENV); 899 | 900 | add_prim("cons", prim_cons); 901 | add_prim("car", prim_car); 902 | add_prim("cdr", prim_cdr); 903 | add_prim("set-car!", prim_setcar); 904 | add_prim("set-cdr!", prim_setcdr); 905 | add_prim("list", prim_list); 906 | add_prim("list?", prim_listq); 907 | add_prim("null?", prim_nullq); 908 | add_prim("pair?", prim_pairq); 909 | add_prim("atom?", prim_atomq); 910 | add_prim("eq?", prim_eq); 911 | add_prim("equal?", prim_equal); 912 | 913 | add_prim("+", prim_add); 914 | add_prim("-", prim_sub); 915 | add_prim("*", prim_mul); 916 | add_prim("/", prim_div); 917 | add_prim("=", prim_neq); 918 | add_prim("<", prim_lt); 919 | add_prim(">", prim_gt); 920 | 921 | add_prim("type", prim_type); 922 | add_prim("load", load_file); 923 | add_prim("print", prim_print); 924 | add_prim("get-global-environment", prim_get_env); 925 | add_prim("set-global-environment", prim_set_env); 926 | add_prim("exit", prim_exit); 927 | add_prim("exec", prim_exec); 928 | add_prim("read", prim_read); 929 | add_prim("vector", prim_vec); 930 | add_prim("vector-get", prim_vget); 931 | add_prim("vector-set", prim_vset); 932 | } 933 | 934 | /* Loads and evaluates a file containing lisp s-expressions */ 935 | struct object *load_file(struct object *args) { 936 | struct object *exp; 937 | struct object *ret = NULL; 938 | char *filename = car(args)->string; 939 | printf("Evaluating file %s\n", filename); 940 | FILE *fp = fopen(filename, "r"); 941 | if (fp == NULL) { 942 | printf("Error opening file %s\n", filename); 943 | return NIL; 944 | } 945 | 946 | for (;;) { 947 | exp = read_exp(fp); 948 | if (null(exp)) 949 | break; 950 | ret = eval(exp, ENV); 951 | } 952 | fclose(fp); 953 | return ret; 954 | } 955 | 956 | int main(int argc, char **argv) { 957 | int NELEM = 8191; 958 | ht_init(NELEM); 959 | init_env(); 960 | struct object *exp; 961 | int i; 962 | 963 | printf( 964 | "Microlisp intrepreter - (c) Michael Lazear 2016-2019, MIT License\n"); 965 | for (i = 1; i < argc; i++) 966 | load_file(cons(make_symbol(argv[i]), NIL)); 967 | 968 | for (;;) { 969 | printf("user> "); 970 | exp = eval(read_exp(stdin), ENV); 971 | if (!null(exp)) { 972 | print_exp("====>", exp); 973 | printf("\n"); 974 | } 975 | } 976 | } 977 | --------------------------------------------------------------------------------