├── .gitignore ├── .travis.yml ├── .vscode ├── c_cpp_properties.json ├── launch.json ├── settings.json └── tasks.json ├── Doxyfile ├── README.md ├── compiler └── compiler.lisp ├── docs ├── doxystyle │ ├── customdoxygen.css │ ├── doxy-boot.js │ ├── doxygen-layout.xml │ ├── footer.html │ └── header.html └── html │ └── logo.png ├── examples ├── a.lisp ├── basic.lisp ├── bench.lisp ├── compilable_maze.lisp ├── diff_benchmark.lisp ├── functions.lisp └── init.lisp ├── img ├── ftv2doc.png ├── ftv2folderclosed.png ├── ftv2folderopen.png ├── logo.png └── performances.png ├── include ├── meson.build ├── pibuiltin.h ├── picell.h ├── pichecks.h ├── picore.h ├── pierror.h ├── pifile.h ├── piinit.h ├── pilisp.h ├── piparser.h ├── piprint.h ├── piremove.h ├── pisettings.h ├── pistack.h ├── pitestutils.h └── piutils.h ├── meson.build ├── src ├── main.c ├── meson.build ├── pibuiltin.c ├── picell.c ├── pichecks.c ├── picore.c ├── pierror.c ├── pifile.c ├── piinit.c ├── pilisp.c ├── piparser.c ├── piprint.c ├── piremove.c ├── pistack.c ├── pitestutils.c └── piutils.c └── test ├── bad_prints_test.c ├── expressions ├── atom.lisp ├── atoms.lisp ├── badexpressions │ ├── closedpar.lisp │ ├── complicate.lisp │ └── unfinished.lisp ├── dotexpressions.lisp ├── listnotation1.lisp ├── listnotation2.lisp ├── tokens.lisp └── void.lisp ├── lisp_program_load_test.c ├── lisp_program_test.c ├── lisp_programs ├── compilable_diff.lisp ├── diff.lisp ├── factorial.lisp ├── ibeforee.lisp ├── list_operations.lisp ├── loadtest.lisp ├── maps.lisp ├── max.lisp ├── maze.lisp ├── maze_let.lisp └── maze_old.lisp ├── meson.build ├── parser_accepted_strings_test.c ├── parser_rejected_strings_test.c ├── print_lexer_test.c ├── print_test.c ├── recursive_structure_print_test.c └── sexpr_copy_test.c /.gitignore: -------------------------------------------------------------------------------- 1 | # Pilisp files 2 | .piinit 3 | .picompile* 4 | .picompiler* 5 | 6 | # CLion 7 | .idea/ 8 | 9 | # Build dir 10 | build/ 11 | 12 | # npm 13 | node_modules/ 14 | 15 | # Coverage files 16 | *.gcov 17 | 18 | # Doxygen documentation 19 | # docs/html/ 20 | docs/latex/ 21 | docs/xml/ 22 | 23 | # IDE 24 | # .vscode/ 25 | 26 | # Prerequisites 27 | *.d 28 | 29 | # Object files 30 | *.o 31 | *.ko 32 | *.obj 33 | *.elf 34 | 35 | # Linker output 36 | *.ilk 37 | *.map 38 | *.exp 39 | 40 | # Precompiled Headers 41 | *.gch 42 | *.pch 43 | 44 | # Libraries 45 | *.lib 46 | *.a 47 | *.la 48 | *.lo 49 | 50 | # Shared objects (inc. Windows DLLs) 51 | *.dll 52 | *.so 53 | *.so.* 54 | *.dylib 55 | 56 | # Executables 57 | *.exe 58 | *.out 59 | *.app 60 | *.i*86 61 | *.x86_64 62 | *.hex 63 | 64 | # Debug files 65 | *.dSYM/ 66 | *.su 67 | *.idb 68 | *.pdb 69 | 70 | # Kernel Module Compile Results 71 | *.mod* 72 | *.cmd 73 | .tmp_versions/ 74 | modules.order 75 | Module.symvers 76 | Mkfile.old 77 | dkms.conf 78 | 79 | 80 | # User-specific stuff 81 | .idea/**/workspace.xml 82 | .idea/**/tasks.xml 83 | .idea/**/usage.statistics.xml 84 | .idea/**/dictionaries 85 | .idea/**/shelf 86 | 87 | # Sensitive or high-churn files 88 | .idea/**/dataSources/ 89 | .idea/**/dataSources.ids 90 | .idea/**/dataSources.local.xml 91 | .idea/**/sqlDataSources.xml 92 | .idea/**/dynamic.xml 93 | .idea/**/uiDesigner.xml 94 | .idea/**/dbnavigator.xml 95 | 96 | # Gradle 97 | .idea/**/gradle.xml 98 | .idea/**/libraries 99 | 100 | # Gradle and Maven with auto-import 101 | # When using Gradle or Maven with auto-import, you should exclude module files, 102 | # since they will be recreated, and may cause churn. Uncomment if using 103 | # auto-import. 104 | # .idea/modules.xml 105 | # .idea/*.iml 106 | # .idea/modules 107 | 108 | # CMake 109 | cmake-build-*/ 110 | 111 | # Mongo Explorer plugin 112 | .idea/**/mongoSettings.xml 113 | 114 | # File-based project format 115 | *.iws 116 | 117 | # IntelliJ 118 | out/ 119 | 120 | # mpeltonen/sbt-idea plugin 121 | .idea_modules/ 122 | 123 | # JIRA plugin 124 | atlassian-ide-plugin.xml 125 | 126 | # Cursive Clojure plugin 127 | .idea/replstate.xml 128 | 129 | # Crashlytics plugin (for Android Studio and IntelliJ) 130 | com_crashlytics_export_strings.xml 131 | crashlytics.properties 132 | crashlytics-build.properties 133 | fabric.properties 134 | 135 | # Editor-based Rest Client 136 | .idea/httpRequests 137 | .idea/pilisp.iml 138 | .idea/misc.xml 139 | .idea/modules.xml 140 | .idea/vcs.xml 141 | .idea/codeStyles/Project.xml 142 | .idea/vcs.xml 143 | .idea/misc.xml 144 | .idea/modules.xml 145 | .idea/pilisp.iml 146 | .idea/codeStyles/Project.xml 147 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: required 2 | language: c 3 | notifications: 4 | email: false 5 | before_install: 6 | - sudo apt-get update -qq 7 | - sudo apt-get install gcc 8 | - sudo apt-get install gcovr 9 | - sudo apt-get install python3 10 | - sudo apt-get install python3-pip 11 | - wget https://github.com/ninja-build/ninja/releases/download/v1.8.2/ninja-linux.zip 12 | - sudo unzip ninja-linux.zip -d /usr/local/bin/ 13 | - sudo update-alternatives --install /usr/bin/ninja ninja /usr/local/bin/ninja 1 --force 14 | - sudo pip3 install meson==0.44.0 15 | - sudo pip install codecov 16 | - sudo apt-get install doxygen 17 | - "sudo apt-get install graphviz" # required for drawing dependecy graphs 18 | - "sudo pip install --upgrade pip" # last version 19 | - "sudo pip install pydot-ng pyparsing" # required for drawing dependecy graphs 20 | after_success: 21 | - bash <(curl -s https://codecov.io/bash) -g '*test*' -g '*main*' -g '*piprint*' -g '*pichecks*' -g '*pierror*' -g '*pilisp*' 22 | script: 23 | - curl --data-binary @codecov.yml https://codecov.io/validate 24 | - meson build -Dc_args=-Og -Db_coverage=true # enable coverage 25 | - ninja -C build # build project 26 | - MESON_TESTTHREADS=1 ninja test -C build # run tests 27 | - gcovr -r . -e '.*/test/.*' -e '.*pitestutils*' -e '.*main*' -e '.*pilisp*' -e '.*pichecks*' -e '.*pierror*' 28 | - doxygen # auto generate documentation 29 | - mv img/ftv2doc.png docs/html/ 30 | - mv img/ftv2folderclosed.png docs/html/ 31 | - mv img/ftv2folderopen.png docs/html/ 32 | deploy: 33 | provider: pages 34 | local-dir: docs/html 35 | skip-cleanup: true 36 | file_glob: true 37 | file: docs/* 38 | overwrite: true 39 | github-token: $GITHUB_TOKEN 40 | on: 41 | branch: master 42 | -------------------------------------------------------------------------------- /.vscode/c_cpp_properties.json: -------------------------------------------------------------------------------- 1 | { 2 | "configurations": [ 3 | { 4 | "name": "Mac", 5 | "includePath": [ 6 | "/usr/include", 7 | "/usr/local/include", 8 | "${workspaceRoot}", 9 | "${workspaceFolder}/include" 10 | ], 11 | "defines": [], 12 | "intelliSenseMode": "clang-x64", 13 | "browse": { 14 | "path": [ 15 | "/usr/include", 16 | "/usr/local/include", 17 | "${workspaceRoot}" 18 | ], 19 | "limitSymbolsToIncludedHeaders": true, 20 | "databaseFilename": "" 21 | }, 22 | "macFrameworkPath": [ 23 | "/System/Library/Frameworks", 24 | "/Library/Frameworks" 25 | ], 26 | "compilerPath": "/usr/bin/clang", 27 | "cStandard": "c11", 28 | "cppStandard": "c++17" 29 | }, 30 | { 31 | "name": "Linux", 32 | "includePath": [ 33 | "/usr/include", 34 | "/usr/local/include", 35 | "${workspaceRoot}", 36 | "${workspaceRoot}/include" 37 | ], 38 | "defines": [], 39 | "intelliSenseMode": "clang-x64", 40 | "browse": { 41 | "path": [ 42 | "/usr/include", 43 | "/usr/local/include", 44 | "${workspaceRoot}", 45 | "${workspaceRoot}/include", 46 | "${workspaceRoot}/src", 47 | "${workspaceRoot}/test" 48 | ], 49 | "limitSymbolsToIncludedHeaders": true, 50 | "databaseFilename": "" 51 | }, 52 | "compilerPath": "/usr/bin/clang", 53 | "cStandard": "c11", 54 | "cppStandard": "c++17", 55 | "compileCommands": "${workspaceFolder}/build/compile_commands.json" 56 | }, 57 | { 58 | "name": "Win32", 59 | "includePath": [ 60 | "C:/Program Files (x86)/Microsoft Visual Studio 14.0/VC/include/*", 61 | "C:/Program Files (x86)/Windows Kits/10/Include/10.0.14393.0/um", 62 | "C:/Program Files (x86)/Windows Kits/10/Include/10.0.14393.0/ucrt", 63 | "C:/Program Files (x86)/Windows Kits/10/Include/10.0.14393.0/shared", 64 | "C:/Program Files (x86)/Windows Kits/10/Include/10.0.14393.0/winrt", 65 | "C:/MinGW/include", 66 | "C:/MinGW/mingw32/include", 67 | "C:/MinGW/msys/1.0/include", 68 | "C:/MinGW/lib/gcc/mingw32/5.3.0/include", 69 | "C:/MinGW/lib/gcc/mingw32/5.3.0/include-fixed", 70 | "C:/MinGW/lib/gcc/mingw32/5.3.0/include/c++", 71 | "C:/MinGW/lib/gcc/mingw32/5.3.0/include/c++/mingw32", 72 | "${workspaceRoot}" 73 | ], 74 | "defines": [ 75 | "_DEBUG", 76 | "UNICODE" 77 | ], 78 | "intelliSenseMode": "msvc-x64", 79 | "browse": { 80 | "path": [ 81 | "C:/Program Files (x86)/Microsoft Visual Studio 14.0/VC/include/*", 82 | "C:/Program Files (x86)/Windows Kits/10/Include/10.0.14393.0/um", 83 | "C:/Program Files (x86)/Windows Kits/10/Include/10.0.14393.0/ucrt", 84 | "C:/Program Files (x86)/Windows Kits/10/Include/10.0.14393.0/shared", 85 | "C:/Program Files (x86)/Windows Kits/10/Include/10.0.14393.0/winrt", 86 | "C:/MinGW/include", 87 | "C:/MinGW/mingw32/include", 88 | "C:/MinGW/msys/1.0/include", 89 | "C:/MinGW/lib/gcc/mingw32/5.3.0/include", 90 | "C:/MinGW/lib/gcc/mingw32/5.3.0/include-fixed", 91 | "C:/MinGW/lib/gcc/mingw32/5.3.0/include/c++", 92 | "C:/MinGW/lib/gcc/mingw32/5.3.0/include/c++/mingw32", 93 | "${workspaceRoot}" 94 | ], 95 | "limitSymbolsToIncludedHeaders": true, 96 | "databaseFilename": "" 97 | }, 98 | "compilerPath": "/usr/bin/clang", 99 | "cStandard": "c11", 100 | "cppStandard": "c++17" 101 | } 102 | ], 103 | "version": 4 104 | } -------------------------------------------------------------------------------- /.vscode/launch.json: -------------------------------------------------------------------------------- 1 | { 2 | // Use IntelliSense to learn about possible attributes. 3 | // Hover to view descriptions of existing attributes. 4 | // For more information, visit: https://go.microsoft.com/fwlink/?linkid=830387 5 | "version": "0.2.0", 6 | "configurations": [ 7 | { 8 | "name": "(gdb) Test", 9 | "type": "cppdbg", 10 | "request": "launch", 11 | "program": "${workspaceFolder}/build/test/lisp_program_test", 12 | "args": [], 13 | "stopAtEntry": false, 14 | "cwd": "${workspaceFolder}", 15 | "environment": [], 16 | "externalConsole": true, 17 | "MIMode": "gdb", 18 | "setupCommands": [ 19 | { 20 | "description": "Enable pretty-printing for gdb", 21 | "text": "-enable-pretty-printing", 22 | "ignoreFailures": true 23 | } 24 | ] 25 | }, 26 | { 27 | "name": "(gdb) Launch", 28 | "type": "cppdbg", 29 | "request": "launch", 30 | "program": "${workspaceFolder}/build/pilisp", 31 | "args": [], 32 | "stopAtEntry": false, 33 | "cwd": "${workspaceFolder}", 34 | "environment": [], 35 | "externalConsole": true, 36 | "MIMode": "gdb", 37 | "setupCommands": [ 38 | { 39 | "description": "Enable pretty-printing for gdb", 40 | "text": "-enable-pretty-printing", 41 | "ignoreFailures": true 42 | } 43 | ] 44 | } 45 | ] 46 | } -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "cSpell.enabled": true, 3 | "files.associations": { 4 | "exception": "c", 5 | "type_traits": "c", 6 | "pitestutils.h": "c", 7 | "pilisp.h": "c", 8 | "typeinfo": "c", 9 | "pierror.h": "c", 10 | "picell.h": "c", 11 | "string.h": "c", 12 | "error.h": "c", 13 | "stdbool.h": "c", 14 | "setjmp.h": "c", 15 | "piparser.h": "c", 16 | "pibuiltin.h": "c", 17 | "piinit.h": "c", 18 | "array": "c", 19 | "initializer_list": "c", 20 | "utility": "c", 21 | "*.tcc": "c", 22 | "chrono": "c", 23 | "functional": "c", 24 | "ratio": "c", 25 | "tuple": "c", 26 | "pifile.h": "c", 27 | "pistack.h": "c" 28 | }, 29 | "cSpell.enabledLanguageIds": [ 30 | "asciidoc", 31 | "c", 32 | "cpp", 33 | "csharp", 34 | "css", 35 | "go", 36 | "handlebars", 37 | "html", 38 | "jade", 39 | "javascript", 40 | "javascriptreact", 41 | "json", 42 | "latex", 43 | "less", 44 | "markdown", 45 | "php", 46 | "plaintext", 47 | "pub", 48 | "python", 49 | "restructuredtext", 50 | "rust", 51 | "scss", 52 | "text", 53 | "typescript", 54 | "typescriptreact", 55 | "yml" 56 | ] 57 | } -------------------------------------------------------------------------------- /.vscode/tasks.json: -------------------------------------------------------------------------------- 1 | { 2 | // See https://go.microsoft.com/fwlink/?LinkId=733558 3 | // for the documentation about the tasks.json format 4 | "version": "2.0.0", 5 | "tasks": [ 6 | { 7 | "label": "Build", 8 | "type": "shell", 9 | "command": "ninja", 10 | "group": { 11 | "kind": "build", 12 | "isDefault": true 13 | }, 14 | "options": { 15 | "cwd": "${workspaceRoot}/build" 16 | }, 17 | "presentation": { 18 | "echo": true, 19 | "reveal": "always", 20 | "focus": true, 21 | "panel": "shared" 22 | }, 23 | "problemMatcher": { 24 | "base":"$gcc", 25 | "fileLocation" : ["relative", "${workspaceRoot}/build"] 26 | } 27 | }, 28 | { 29 | "label": "Scan", 30 | "type": "shell", 31 | "command": "ninja -C build && ninja scan-build -C build", 32 | "presentation": { 33 | "echo": true, 34 | "reveal": "always", 35 | "focus": true, 36 | "panel": "dedicated" 37 | }, 38 | "problemMatcher": { 39 | "base":"$gcc", 40 | "fileLocation" : ["relative", "${workspaceRoot}/build/meson-private/tmpsm350_09"] 41 | } 42 | }, 43 | { 44 | "label": "Run", 45 | "type": "shell", 46 | "presentation": { 47 | "echo": true, 48 | "reveal": "always", 49 | "focus": true, 50 | "panel": "new" 51 | }, 52 | "command": "ninja -C build && ./build/pilisp", 53 | "problemMatcher": [ 54 | "$gcc" 55 | ] 56 | }, 57 | { 58 | "label": "Test", 59 | "type": "shell", 60 | "group": { 61 | "kind": "test", 62 | "isDefault": true 63 | }, 64 | "presentation": { 65 | "echo": true, 66 | "reveal": "always", 67 | "focus": true, 68 | "panel": "shared" 69 | }, 70 | "options": { 71 | "cwd": "${workspaceRoot}/build" 72 | }, 73 | "command": "ninja && MESON_TESTTHREADS=1 ninja test", 74 | "problemMatcher":{ 75 | "base":"$gcc", 76 | "fileLocation" : ["relative", "${workspaceRoot}/build"] 77 | } 78 | } 79 | ] 80 | } -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # pilisp # 2 | 3 | [![Build Status](https://travis-ci.com/parof/pilisp.svg?token=tdfVkJVdJvEzUpskJRQE&branch=master)](https://travis-ci.com/parof/pilisp) [![codecov](https://codecov.io/gh/parof/pilisp/branch/master/graph/badge.svg)](https://codecov.io/gh/parof/pilisp) [![Github Pages docs](https://img.shields.io/badge/docs-ghpages-blue.svg)](https://parof.github.io/pilisp/) 4 | 5 | * [Introduction](#introduction) 6 | * [Language](#language) 7 | * [Documentation](#documentation) 8 | * [Installation](#installation) 9 | 10 | ## Introduction ## 11 | 12 | Pilisp aims to be a small LISP interpreter for the 1.5 version of the language described [here](http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf). 13 | 14 | ### Features ### 15 | 16 | * **Lambdas**: (lambda ({args}) {body}) syntax allowed 17 | * **Garbage Collector**: mark and sweep garbage collector 18 | * **Bytecode virtual machine interpreter**: some simple lambdas can be compiled to a bytecode faster version 19 | * **Memory dump builtin**: (md) prints the structure of the allocated memory 20 | 21 | ### Performance ### 22 | 23 | These are the performances compared to other Lisp interpreters: [CLisp](https://clisp.sourceforge.io/), Yoctolisp (similar performances to [Femtolisp](https://github.com/JeffBezanson/femtolisp)) and [SBCL](http://www.sbcl.org/). 24 | 25 | 26 | ![alt text](img/performances.png "Logo Title Text 1") 27 | 28 | 29 | ## Language ## 30 | 31 | The language accepted by the interpreter is inspired to the [Common Lisp](https://en.wikipedia.org/wiki/Common_Lisp), but keeps the _homoiconicity_ feature of the original definition of the LISP 1.5: data and instructions are kept together in the same data structure, the _cons cell_. 32 | 33 | ### Builtin functions ### 34 | 35 | * Lisp basic functions 36 | * car 37 | * cdr 38 | * cons 39 | * atom 40 | * eq 41 | * quote 42 | * cond 43 | * Arithmetic 44 | * \+ 45 | * \- 46 | * \* 47 | * \/ 48 | * Logic 49 | * or 50 | * and 51 | * not 52 | * Comparison 53 | * \> 54 | * \>= 55 | * \< 56 | * \<= 57 | * integerp 58 | * symbolp 59 | * Lists operations 60 | * list 61 | * reverse 62 | * member 63 | * nth 64 | * concatenate 65 | * append 66 | * length 67 | * subseq 68 | * Common Lisp inherited functions 69 | * set 70 | * write 71 | * load 72 | * bye 73 | * Macros 74 | * setq 75 | * defun 76 | * let 77 | * dotimes 78 | * map 79 | * time 80 | * defmacro 81 | * Pilisp special functions 82 | * md: prints the memory 83 | * env: prints the global env 84 | * cg: calls the garbage collector 85 | 86 | ### Bytecode instruction set ### 87 | 88 | You can optionally produce one mid-representation for some expression. The bytecode will run faster than normal LISP code. 89 | To achieve this goal Pilisp interpreter adds these instructions to the language: 90 | 91 | * **plc**: PiLisp Compiler. Called on one sexpression tries to produce the corresponding bytecode of one quoted expression. 92 | 93 | ``` 94 | (plc '(car '(a))) => (ASM "!$B" (A) CAR) 95 | ``` 96 | 97 | * **asm**: c-like notation for assembly. This instruction can be interpreted. The first arg is the machine code. Refer [here](#instructionset) for the list of codes. The other arguments are the parameters. 98 | 99 | ``` 100 | (ASM "!$B" (A) CAR) 101 | ``` 102 | has to be read as: `load a const -> that const is (A) -> apply a builtin function -> That function is car -> That function has 1 parameter -> Put the result on the top of the stack` . The result of a computation is always the top of the stack. 103 | 104 | * **lasm**: lambda-asm. Represents a asm computation that accepts input parameters: it is a compiled lambda. The first parameter represents the number of parameters. The rest of the parameters are the same as asm. 105 | 106 | ``` 107 | ((LASM 1 "@A!$C" 1 +) 2) 108 | ``` 109 | The last is an example of the 1+ function compiled and applied to the number 2 110 | 111 | * **compile**: tries to compile one function. If this is possible the new definition will be substituted to the old one. 112 | 113 | ``` 114 | (defun id (x) x) 115 | (compile id) 116 | ``` 117 | will produce a new and faster identity function. 118 | 119 | 120 | #### Instruction set #### 121 | | Code | Meaning | 122 | | :---: | :---: | 123 | | ! | load constant | 124 | | ? | load symbol | 125 | | @ | load name from stack | 126 | | $ | apply builtin lambda | 127 | | \[A-Z\] | numbers from 0 to 25 | 128 | 129 | 130 | ## Documentation ## 131 | 132 | Full code documentation can be found on [github pages](https://parof.github.io/pilisp/). It is automatically generated using [Doxygen](http://www.stack.nl/~dimitri/doxygen/), with [Bootstrap](https://getbootstrap.com/) CSS (using [this](https://github.com/Velron/doxygen-bootstrapped) guide). The code documentation is generated every push with [Travis CI](https://travis-ci.org/), so it should be always up to date. 133 | 134 | ## Installation ## 135 | 136 | ### Prerequisites ### 137 | 138 | * [Meson](http://mesonbuild.com/) (version 0.44 or newer) 139 | * [Python](https://www.python.org/) (version 3.5 or newer) 140 | * [Ninja](https://ninja-build.org/) (version 1.5 or newer) 141 | 142 | ### Installing with Meson ### 143 | 144 | These commands should run on any OS. To build the `ninja.build` file run. The `-Dc_args` will add optimizations. 145 | 146 | ``` 147 | meson build -Dc_args=-Og 148 | ``` 149 | 150 | To build the executable in the `build` directory run 151 | 152 | ``` 153 | ninja -C build 154 | ``` 155 | 156 | To install `pilisp` run with root permissions 157 | 158 | ``` 159 | ninja install -C build 160 | ``` 161 | 162 | To run tests use 163 | 164 | ``` 165 | ninja test -C build 166 | ``` 167 | 168 | By default Meson won't allow debugging: if you want to run a debbuger you have to write: 169 | ``` 170 | meson build -Db_coverage=true 171 | ``` 172 | 173 | Run with Valngrid: 174 | ``` 175 | meson test --wrap=valgrind 'testname' 176 | ``` 177 | -------------------------------------------------------------------------------- /compiler/compiler.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; ;; 3 | ;; 88""Yb 88 88 88 .dP"Y8 88""Yb dP""b8 dP"Yb 8b d8 88""Yb 88 88 888888 88""Yb ;; 4 | ;; 88__dP 88 88 88 `Ybo." 88__dP dP `" dP Yb 88b d88 88__dP 88 88 88__ 88__dP ;; 5 | ;; 88""" 88 88 .o 88 o.`Y8b 88""" Yb Yb dP 88YbdP88 88""" 88 88 .o 88"" 88"Yb ;; 6 | ;; 88 88 88ood8 88 8bodP' 88 YboodP YbodP 88 YY 88 88 88 88ood8 888888 88 Yb ;; 7 | ;; ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | 11 | ; (plc '[EXPRESSION]) -> (asm [ASM_STRING] {ARGS_LIST}) 12 | (defun plc (not_evaluated_expression) 13 | ( get_interpretable_code 14 | ( _compile not_evaluated_expression nil) 15 | not_evaluated_expression)) 16 | 17 | ;; **************************************************************** 18 | ;; *=================== Instructions Generator ===================* 19 | ;; **************************************************************** 20 | 21 | 22 | ; Instructions: 23 | ; :loadconst -> load one const followed by the const 24 | ; :loadstack -> load one stack parameter followed by the position 25 | ; :loadsymbol -> load one symbol followed by the symbol 26 | ; :argsnum -> start of a lambda with n parameters 27 | ; :cbs -> call builtin stack function 28 | ; 29 | ; If the expression is not compilable the result will be: 30 | ; :notcompilable 31 | ; 32 | 33 | (setq builtin_stack_lambdas 34 | '( car cdr cons atom eq list +)) 35 | 36 | (defun _compile (expr symbol_table) 37 | (cond 38 | ((atom expr) 39 | (list ( compile_atom expr symbol_table))) 40 | 41 | (( is_quoted_expression expr) 42 | (list ( compile_quote expr))) 43 | 44 | ((atom (car expr)) 45 | ( compile_atom_function expr symbol_table)) 46 | 47 | (( else) 48 | :notcompilable ))) 49 | 50 | ;; ==================== Atom or Quote Compiling ==================== 51 | 52 | (defun compile_atom (ato symbol_table) 53 | (cond 54 | (( null ato) 55 | (cons :loadconst ato)) 56 | ((eq ato t) 57 | (cons :loadconst ato)) 58 | (( has_value_in_stack ato symbol_table) 59 | (cons :loadstack ( get_stack_index ato symbol_table))) 60 | ((symbolp ato) 61 | ;; here search in the symbol table 62 | (cons :loadsymbol ato)) 63 | (( else) 64 | (cons :loadconst ato)))) 65 | 66 | (defun has_value_in_stack (name symbol_table) 67 | (cond 68 | ((null symbol_table) nil) 69 | ((eq name ( extract_first_symbol symbol_table)) t) 70 | (( else) ( has_value_in_stack name ( next symbol_table))))) 71 | 72 | (defun get_stack_index (name symbol_table) 73 | (cond 74 | ((null symbol_table) nil) ; unreachable 75 | ((eq name ( extract_first_symbol symbol_table)) 76 | ( extract_first_index symbol_table)) 77 | (( else) 78 | ( get_stack_index name ( next symbol_table))))) 79 | 80 | (defun extract_first_symbol (symbol_table) 81 | (car (car symbol_table))) 82 | 83 | (defun extract_first_index (symbol_table) 84 | (cdr (car symbol_table))) 85 | 86 | (defun compile_quote (quote_expression) 87 | (cons :loadconst ( extract_cons_cell quote_expression))) 88 | 89 | (defun extract_cons_cell (quote_expression) 90 | (car (cdr quote_expression))) 91 | 92 | ;; ==================== Atom function Compiling ==================== 93 | 94 | (defun compile_atom_function (expr symbol_table) 95 | ( compile_atom_function_name_args (car expr) (cdr expr) symbol_table)) 96 | 97 | (defun compile_atom_function_name_args (fun args symbol_table) 98 | (cond 99 | (( is_builtin_stack fun) 100 | ( compile_builtin_stack fun args symbol_table)) 101 | (( is_lambda fun) 102 | ( compile_lambda fun args symbol_table)) 103 | ;; (( is_cond fun) 104 | ;; ( compile_cond fun args symbol_table)) 105 | (( else) 106 | :notcompilable ))) 107 | 108 | (defun is_builtin_stack (fun) 109 | (member fun builtin_stack_lambdas)) 110 | 111 | (defun is_lambda (fun) 112 | (eq fun 'lambda)) 113 | 114 | ;; (defun is_cond (fun) 115 | ;; (eq fun 'cond)) 116 | 117 | ;; ==================== Builtin stack compiling ==================== 118 | 119 | (defun compile_builtin_stack (fun args_list symbol_table) 120 | ( compile_args_and_append_builtin_stack fun args_list ( count_args args_list) symbol_table)) 121 | 122 | ; why keep passing fun? -> no list surgery, but when found the botton 123 | ; naturally append the function apply 124 | (defun compile_args_and_append_builtin_stack (fun args_list initial_args_number symbol_table) 125 | (cond 126 | ((null args_list) 127 | ( create_builtin_stack_trailer fun initial_args_number)) 128 | (( else) 129 | ( let 130 | ((first_arg_compiled 131 | ( compile_first_arg args_list symbol_table)) 132 | (rest_of_the_args_compiled 133 | ( compile_remaining_list_and_append_builtin_stack fun args_list initial_args_number symbol_table))) 134 | ( compile_only_if_everything_is_compilable first_arg_compiled rest_of_the_args_compiled))))) 135 | 136 | (defun compile_only_if_everything_is_compilable (first_arg_compiled rest_of_the_args_compiled) 137 | (cond 138 | (( both_compilables first_arg_compiled rest_of_the_args_compiled) 139 | (append first_arg_compiled rest_of_the_args_compiled)) 140 | (( else) 141 | :notcompilable))) 142 | 143 | (defun compile_first_arg (args_list symbol_table) 144 | ( _compile (car args_list) symbol_table)) 145 | 146 | (defun compile_remaining_list_and_append_builtin_stack (fun args_list initial_args_number symbol_table) 147 | ( compile_args_and_append_builtin_stack fun ( next args_list) initial_args_number symbol_table)) 148 | 149 | (defun create_builtin_stack_trailer (fun initial_args_number) 150 | (list 151 | (cons :cbs fun) 152 | ( get_params_trailer initial_args_number))) 153 | 154 | (defun get_params_trailer (args_number) 155 | (cons :argsnum args_number)) 156 | 157 | ;; ==================== Lambda Compiling ==================== 158 | 159 | (defun compile_lambda (fun args symbol_table) 160 | (let ( 161 | (lambda_args ( extract_lambda_args args)) 162 | (lambda_body ( extract_lambda_body args)) 163 | (new_symbol_table ( build_symbol_table ( extract_lambda_args args) symbol_table))) 164 | (let ( 165 | (lambda_args_number_instruction ( build_lambda_args_number_instruction lambda_args)) 166 | (lambda_body_instruction_list ( build_lambda_body_instruction_list lambda_body new_symbol_table))) 167 | ( compile_lambda_only_if_compilable lambda_args_number_instruction lambda_body_instruction_list)))) 168 | 169 | (defun compile_lambda_only_if_compilable (lambda_args_number_instruction lambda_body_instructions_list) 170 | (cond 171 | (( is_compilable lambda_body_instructions_list) 172 | (cons 173 | lambda_args_number_instruction 174 | lambda_body_instructions_list)) 175 | (( else) 176 | :notcompilable))) 177 | 178 | ;; @ BUILD LAMBDA BODY 179 | (defun build_lambda_body_instruction_list (lambda_body symbol_table) 180 | ( _compile lambda_body symbol_table)) 181 | 182 | ;; @ SYMBOL TABLE 183 | ;; pushes on the top of the old symbol table the new symbols 184 | (defun build_symbol_table (lambda_args old_symbol_table) 185 | (let 186 | ((new_symbol_table_head 187 | (reverse ( build_symbol_table_with_position lambda_args 0)))) 188 | (append 189 | new_symbol_table_head 190 | old_symbol_table))) 191 | 192 | ; we need the position to set that number in the pair (x . 0) 193 | (defun build_symbol_table_with_position (lambda_args actual_position) 194 | (cond 195 | ((null lambda_args) nil) 196 | (( else) ( build_one_symbol_and_the_rest_of_the_list lambda_args actual_position)))) 197 | 198 | (defun build_one_symbol_and_the_rest_of_the_list (lambda_args actual_position) 199 | (cons 200 | ( build_one_symbol lambda_args actual_position) 201 | ( build_symbol_table_with_position ( next lambda_args) (1+ actual_position)))) 202 | 203 | (defun build_one_symbol (lambda_args actual_position) 204 | (cons (car lambda_args) actual_position)) 205 | 206 | (defun build_lambda_args_number_instruction (lambda_args) 207 | (cons :lambdanargs ( count_args lambda_args))) 208 | 209 | ; @param lambda cons -> ((x y z) (+ x y z)) 210 | (defun extract_lambda_args (lambda_cons) 211 | (car lambda_cons)) 212 | 213 | (defun extract_lambda_body (lambda_cons) 214 | (car (cdr lambda_cons))) 215 | 216 | ;; ***************************************************************** 217 | ;; *=================== Machine Code Generation ===================* 218 | ;; ***************************************************************** 219 | 220 | ; ((:[INSTRUCTION] . [PARAM]) {(:[INSTRUCTION] . [PARAM])} ) 221 | ; -> (ASM "{MACHINE_CODE_OPERATIONS}" {PARAMETERS}) 222 | (defun get_interpretable_code (compiled_expression original_expression) 223 | (cond 224 | ((eq compiled_expression :notcompilable) 225 | original_expression ) 226 | ((not ( is_lasm compiled_expression)) 227 | ; asm 228 | (cons 'asm 229 | ( build_interpretable_string_and_args compiled_expression))) 230 | (( else) 231 | ; lambda asm 232 | (cons 'lasm 233 | (cons 234 | (cdr (car compiled_expression)) 235 | ( build_interpretable_string_and_args ( next compiled_expression))))))) 236 | 237 | (defun is_lasm (compiled_expression) 238 | (eq :lambdanargs (car (car compiled_expression)))) 239 | 240 | (defun build_interpretable_string_and_args (compiled_expression) 241 | (cons 242 | ( extract_machine_code_string compiled_expression ) 243 | ( extract_args compiled_expression))) 244 | 245 | (defun extract_instruction_code (compiled_expression) 246 | (car (car compiled_expression))) 247 | 248 | (defun extract_arg (compiled_expression) 249 | (cdr (car compiled_expression))) 250 | 251 | ;; ==================== Args append ==================== 252 | 253 | (defun extract_args (compiled_expression) 254 | (cond 255 | ((null compiled_expression) nil) 256 | (( else) ( build_one_arg_and_extract_next compiled_expression)))) 257 | 258 | (defun build_one_arg_and_extract_next (compiled_expression) 259 | (cond 260 | (( must_ignore_arg compiled_expression) 261 | ( extract_args (cdr compiled_expression))) 262 | (( else) 263 | (cons 264 | ( extract_arg compiled_expression) 265 | ( extract_args (cdr compiled_expression)))))) 266 | 267 | ; case: (list 1 2 3 4) -> compilation -> 268 | ; ((:LOADCONST . 1) (:LOADCONST . 2) (:LOADCONST . 3) 269 | ; (:LOADCONST . 4) (:CBS0 . LIST) (:ARGSNUM . 4)) 270 | ; -> must not append the last 4 to the list 271 | (defun must_ignore_arg (compiled_expression) 272 | (cond 273 | ((eq :argsnum ( extract_instruction_code compiled_expression)) t) 274 | ((eq :loadstack ( extract_instruction_code compiled_expression)) t) 275 | (( else) nil))) 276 | 277 | ;; ==================== Machine code string generation ==================== 278 | 279 | (defun extract_machine_code_string (compiled_expression) 280 | (cond 281 | ((null compiled_expression) "") 282 | (( else) ( build_remaining_machine_code_string_char compiled_expression)))) 283 | 284 | (defun build_remaining_machine_code_string_char (compiled_expression) 285 | (concatenate 'string 286 | ( get_instruction_code compiled_expression) 287 | ( extract_machine_code_string ( next compiled_expression)))) 288 | 289 | (defun get_instruction_code (compiled_expression) 290 | ( translate_instruction_code 291 | ( extract_instruction_code compiled_expression) 292 | ( extract_arg compiled_expression))) 293 | 294 | ; ( :[keyword] argument ) -> "[MACHINE_CODE]{OPTIONAL_NUM}" 295 | (defun translate_instruction_code (code arg) 296 | (cond 297 | ((eq code :loadconst) "!") 298 | ((eq code :loadsymbol) "?") 299 | ((eq code :cbs) "$") 300 | ((eq code :loadstack) ( get_instruction_code_for_stack_load arg)) ; arg will be the index in the stack 301 | ((eq code :argsnum) ( translate_num_to_digit arg)) 302 | (( else) "__ERROR:UNKNOWN_INSTRUCTION_CODE__"))) 303 | 304 | ; this will be a pair 305 | (defun get_instruction_code_for_stack_load (stack_index) 306 | (concatenate 'string "@" ( translate_num_to_digit stack_index))) 307 | 308 | (defun translate_num_to_digit (args_number) 309 | (cond 310 | ((eq args_number 0) "A") 311 | ((eq args_number 1) "B") 312 | ((eq args_number 2) "C") 313 | ((eq args_number 3) "D") 314 | ((eq args_number 4) "E") 315 | ((eq args_number 5) "F") 316 | ((eq args_number 6) "G") 317 | ((eq args_number 7) "H") 318 | ((eq args_number 8) "I") 319 | ((eq args_number 9) "J") 320 | ((eq args_number 10) "K") 321 | ((eq args_number 11) "L") 322 | ((eq args_number 12) "M") 323 | ((eq args_number 13) "n") 324 | ((eq args_number 14) "O") 325 | ((eq args_number 15) "P") 326 | ((eq args_number 16) "Q") 327 | ((eq args_number 17) "R") 328 | ((eq args_number 18) "S") 329 | ((eq args_number 19) "T") 330 | ((eq args_number 20) "U") 331 | ((eq args_number 21) "V") 332 | ((eq args_number 22) "W") 333 | ((eq args_number 23) "X") 334 | ((eq args_number 24) "Y") 335 | ((eq args_number 25) "Z") 336 | (( else) "__ERROR:TOO_MANY_ARGS__"))) 337 | 338 | 339 | 340 | ;; ************************************************* 341 | ;; *=================== Utility ===================* 342 | ;; ************************************************* 343 | 344 | 345 | (defun is_quoted_expression (expr) 346 | (and (atom (car expr)) (eq 'quote (car expr)))) 347 | 348 | (defun is_compilable (expression) 349 | (not (eq expression :notcompilable))) 350 | 351 | (defun count_args (args_list) 352 | (length args_list)) 353 | 354 | (defun else () t) 355 | 356 | (defun next (l) (cdr l)) 357 | 358 | (defun both_compilables (first_sequence second_sequence) 359 | (and ( is_compilable first_sequence) 360 | ( is_compilable second_sequence))) 361 | 362 | T -------------------------------------------------------------------------------- /docs/doxystyle/customdoxygen.css: -------------------------------------------------------------------------------- 1 | h1, .h1, h2, .h2, h3, .h3{ 2 | font-weight: 200 !important; 3 | } 4 | 5 | #navrow1, #navrow2, #navrow3, #navrow4, #navrow5{ 6 | border-bottom: 1px solid #EEEEEE; 7 | } 8 | 9 | .adjust-right { 10 | margin-left: 30px !important; 11 | font-size: 1.15em !important; 12 | } 13 | .navbar{ 14 | border: 0px solid #222 !important; 15 | } 16 | table{ 17 | white-space:pre-wrap !important; 18 | } 19 | /* 20 | =========================== 21 | */ 22 | 23 | 24 | /* Sticky footer styles 25 | -------------------------------------------------- */ 26 | html, 27 | body { 28 | height: 100%; 29 | /* The html and body elements cannot have any padding or margin. */ 30 | } 31 | 32 | /* Wrapper for page content to push down footer */ 33 | #wrap { 34 | min-height: 100%; 35 | height: auto; 36 | /* Negative indent footer by its height */ 37 | margin: 0 auto -60px; 38 | /* Pad bottom by footer height */ 39 | padding: 0 0 60px; 40 | } 41 | 42 | /* Set the fixed height of the footer here */ 43 | #footer { 44 | font-size: 0.9em; 45 | padding: 8px 0px; 46 | background-color: #f5f5f5; 47 | } 48 | 49 | .footer-row { 50 | line-height: 44px; 51 | } 52 | 53 | #footer > .container { 54 | padding-left: 15px; 55 | padding-right: 15px; 56 | } 57 | 58 | .footer-follow-icon { 59 | margin-left: 3px; 60 | text-decoration: none !important; 61 | } 62 | 63 | .footer-follow-icon img { 64 | width: 20px; 65 | } 66 | 67 | .footer-link { 68 | padding-top: 5px; 69 | display: inline-block; 70 | color: #999999; 71 | text-decoration: none; 72 | } 73 | 74 | .footer-copyright { 75 | text-align: center; 76 | } 77 | 78 | 79 | @media (min-width: 992px) { 80 | .footer-row { 81 | text-align: left; 82 | } 83 | 84 | .footer-icons { 85 | text-align: right; 86 | } 87 | } 88 | @media (max-width: 991px) { 89 | .footer-row { 90 | text-align: center; 91 | } 92 | 93 | .footer-icons { 94 | text-align: center; 95 | } 96 | } 97 | 98 | /* DOXYGEN Code Styles 99 | ----------------------------------- */ 100 | 101 | 102 | a.qindex { 103 | font-weight: bold; 104 | } 105 | 106 | a.qindexHL { 107 | font-weight: bold; 108 | background-color: #9CAFD4; 109 | color: #ffffff; 110 | border: 1px double #869DCA; 111 | } 112 | 113 | .contents a.qindexHL:visited { 114 | color: #ffffff; 115 | } 116 | 117 | a.code, a.code:visited, a.line, a.line:visited { 118 | color: #4665A2; 119 | } 120 | 121 | a.codeRef, a.codeRef:visited, a.lineRef, a.lineRef:visited { 122 | color: #4665A2; 123 | } 124 | 125 | /* @end */ 126 | 127 | dl.el { 128 | margin-left: -1cm; 129 | } 130 | 131 | pre.fragment { 132 | border: 1px solid #C4CFE5; 133 | background-color: #FBFCFD; 134 | padding: 4px 6px; 135 | margin: 4px 8px 4px 2px; 136 | overflow: auto; 137 | word-wrap: break-word; 138 | font-size: 9pt; 139 | line-height: 125%; 140 | font-family: monospace, fixed; 141 | font-size: 105%; 142 | } 143 | 144 | div.fragment { 145 | padding: 4px 6px; 146 | margin: 4px 8px 4px 2px; 147 | border: 1px solid #C4CFE5; 148 | } 149 | 150 | div.line { 151 | font-family: Consolas, "Liberation Mono", Menlo, Courier, monospace; 152 | font-size: 12px; 153 | min-height: 13px; 154 | line-height: 1.0; 155 | text-wrap: unrestricted; 156 | white-space: -moz-pre-wrap; /* Moz */ 157 | white-space: -pre-wrap; /* Opera 4-6 */ 158 | white-space: -o-pre-wrap; /* Opera 7 */ 159 | white-space: pre-wrap; /* CSS3 */ 160 | word-wrap: normal; /* IE 5.5+ */ 161 | text-indent: -53px; 162 | padding-left: 53px; 163 | padding-bottom: 0px; 164 | margin: 0px; 165 | -webkit-transition-property: background-color, box-shadow; 166 | -webkit-transition-duration: 0.5s; 167 | -moz-transition-property: background-color, box-shadow; 168 | -moz-transition-duration: 0.5s; 169 | -ms-transition-property: background-color, box-shadow; 170 | -ms-transition-duration: 0.5s; 171 | -o-transition-property: background-color, box-shadow; 172 | -o-transition-duration: 0.5s; 173 | transition-property: background-color, box-shadow; 174 | transition-duration: 0.5s; 175 | } 176 | div.line:hover{ 177 | background-color: #FBFF00; 178 | } 179 | 180 | div.line.glow { 181 | background-color: cyan; 182 | box-shadow: 0 0 10px cyan; 183 | } 184 | 185 | 186 | span.lineno { 187 | padding-right: 4px; 188 | text-align: right; 189 | color:rgba(0,0,0,0.3); 190 | border-right: 1px solid #EEE; 191 | border-left: 1px solid #EEE; 192 | background-color: #FFF; 193 | white-space: pre; 194 | font-family: Consolas, "Liberation Mono", Menlo, Courier, monospace ; 195 | } 196 | span.lineno a { 197 | background-color: #FAFAFA; 198 | cursor:pointer; 199 | } 200 | 201 | span.lineno a:hover { 202 | background-color: #EFE200; 203 | color: #1e1e1e; 204 | } 205 | 206 | div.groupHeader { 207 | margin-left: 16px; 208 | margin-top: 12px; 209 | font-weight: bold; 210 | } 211 | 212 | div.groupText { 213 | margin-left: 16px; 214 | font-style: italic; 215 | } 216 | 217 | /* @group Code Colorization */ 218 | 219 | span.keyword { 220 | color: #008000 221 | } 222 | 223 | span.keywordtype { 224 | color: #604020 225 | } 226 | 227 | span.keywordflow { 228 | color: #e08000 229 | } 230 | 231 | span.comment { 232 | color: #800000 233 | } 234 | 235 | span.preprocessor { 236 | color: #806020 237 | } 238 | 239 | span.stringliteral { 240 | color: #002080 241 | } 242 | 243 | span.charliteral { 244 | color: #008080 245 | } 246 | 247 | span.vhdldigit { 248 | color: #ff00ff 249 | } 250 | 251 | span.vhdlchar { 252 | color: #000000 253 | } 254 | 255 | span.vhdlkeyword { 256 | color: #700070 257 | } 258 | 259 | span.vhdllogic { 260 | color: #ff0000 261 | } 262 | 263 | blockquote { 264 | background-color: #F7F8FB; 265 | border-left: 2px solid #9CAFD4; 266 | margin: 0 24px 0 4px; 267 | padding: 0 12px 0 16px; 268 | } 269 | 270 | /*---------------- Search Box */ 271 | 272 | #search-box { 273 | margin: 10px 0px; 274 | } 275 | #search-box .close { 276 | display: none; 277 | position: absolute; 278 | right: 0px; 279 | padding: 6px 12px; 280 | z-index: 5; 281 | } 282 | 283 | /*---------------- Search results window */ 284 | 285 | #search-results-window { 286 | display: none; 287 | } 288 | 289 | iframe#MSearchResults { 290 | width: 100%; 291 | height: 15em; 292 | } 293 | 294 | .SRChildren { 295 | padding-left: 3ex; padding-bottom: .5em 296 | } 297 | .SRPage .SRChildren { 298 | display: none; 299 | } 300 | a.SRScope { 301 | display: block; 302 | } 303 | a.SRSymbol:focus, a.SRSymbol:active, 304 | a.SRScope:focus, a.SRScope:active { 305 | text-decoration: underline; 306 | } 307 | span.SRScope { 308 | padding-left: 4px; 309 | } 310 | .SRResult { 311 | display: none; 312 | } 313 | 314 | /* class and file list */ 315 | .directory .icona, 316 | .directory .arrow { 317 | height: auto; 318 | } 319 | .directory .icona .icon { 320 | height: 16px; 321 | } 322 | .directory .icondoc { 323 | background-position: 0px 0px; 324 | height: 20px; 325 | } 326 | .directory .iconfopen { 327 | background-position: 0px 0px; 328 | } 329 | .directory td.entry { 330 | padding: 7px 8px 6px 8px; 331 | } 332 | 333 | .table > tbody > tr > td.memSeparator { 334 | line-height: 0; 335 | .table-hover; 336 | 337 | } 338 | 339 | .memItemLeft, .memTemplItemLeft { 340 | white-space: normal; 341 | } 342 | 343 | /* enumerations */ 344 | .panel-body thead > tr { 345 | background-color: #e0e0e0; 346 | } 347 | 348 | /* todo lists */ 349 | .todoname, 350 | .todoname a { 351 | font-weight: bold; 352 | } 353 | 354 | /* Class title */ 355 | .summary { 356 | margin-top: 25px; 357 | } 358 | .page-header { 359 | margin: 20px 0px !important; 360 | } 361 | .page-header .title { 362 | display: inline-block; 363 | } 364 | .page-header .pull-right { 365 | margin-top: 0.3em; 366 | margin-left: 0.5em; 367 | } 368 | .page-header .label { 369 | font-size: 50%; 370 | } 371 | -------------------------------------------------------------------------------- /docs/doxystyle/doxy-boot.js: -------------------------------------------------------------------------------- 1 | $( document ).ready(function() { 2 | 3 | $("div.headertitle").addClass("page-header"); 4 | $("div.title").addClass("h1"); 5 | 6 | $('li > a[href="index.html"] > span').before(" "); 7 | $('li > a[href="modules.html"] > span').before(" "); 8 | $('li > a[href="namespaces.html"] > span').before(" "); 9 | $('li > a[href="annotated.html"] > span').before(" "); 10 | $('li > a[href="classes.html"] > span').before(" "); 11 | $('li > a[href="inherits.html"] > span').before(" "); 12 | $('li > a[href="functions.html"] > span').before(" "); 13 | $('li > a[href="functions_func.html"] > span').before(" "); 14 | $('li > a[href="functions_vars.html"] > span').before(" "); 15 | $('li > a[href="functions_enum.html"] > span').before(" "); 16 | $('li > a[href="functions_eval.html"] > span').before(" "); 17 | $('img[src="ftv2ns.png"]').replaceWith('N '); 18 | $('img[src="ftv2cl.png"]').replaceWith('C '); 19 | 20 | $("ul.tablist").addClass("nav nav-pills nav-justified"); 21 | $("ul.tablist").css("margin-top", "0.5em"); 22 | $("ul.tablist").css("margin-bottom", "0.5em"); 23 | $("li.current").addClass("active"); 24 | $("iframe").attr("scrolling", "yes"); 25 | 26 | $("#nav-path > ul").addClass("breadcrumb"); 27 | 28 | $("table.params").addClass("table"); 29 | $("div.ingroups").wrapInner(""); 30 | $("div.levels").css("margin", "0.5em"); 31 | $("div.levels > span").addClass("btn btn-default btn-xs"); 32 | $("div.levels > span").css("margin-right", "0.25em"); 33 | 34 | $("table.directory").addClass("table table-striped"); 35 | $("div.summary > a").addClass("btn btn-default btn-xs"); 36 | $("table.fieldtable").addClass("table"); 37 | $(".fragment").addClass("well"); 38 | $(".memitem").addClass("panel panel-default"); 39 | $(".memproto").addClass("panel-heading"); 40 | $(".memdoc").addClass("panel-body"); 41 | $("span.mlabel").addClass("label label-info"); 42 | 43 | $("table.memberdecls").addClass("table"); 44 | $("[class^=memitem]").addClass("active"); 45 | 46 | $("div.ah").addClass("btn btn-default"); 47 | $("span.mlabels").addClass("pull-right"); 48 | $("table.mlabels").css("width", "100%") 49 | $("td.mlabels-right").addClass("pull-right"); 50 | 51 | $("div.ttc").addClass("panel panel-primary"); 52 | $("div.ttname").addClass("panel-heading"); 53 | $("div.ttname a").css("color", 'white'); 54 | $("div.ttdef,div.ttdoc,div.ttdeci").addClass("panel-body"); 55 | 56 | $('div.fragment.well div.line:first').css('margin-top', '2px'); 57 | $('div.fragment.well div.line:last').css('margin-bottom', '2px'); 58 | 59 | $('table.doxtable').removeClass('doxtable').addClass('table table-striped table-bordered').each(function(){ 60 | $(this).prepend(''); 61 | $(this).find('tbody > tr:first').prependTo($(this).find('thead')); 62 | 63 | $(this).find('td > span.success').parent().addClass('success'); 64 | $(this).find('td > span.warning').parent().addClass('warning'); 65 | $(this).find('td > span.danger').parent().addClass('danger'); 66 | }); 67 | 68 | 69 | 70 | if($('div.fragment.well div.ttc').length > 0) 71 | { 72 | $('div.fragment.well div.line:first').parent().removeClass('fragment well'); 73 | } 74 | 75 | $('table.memberdecls').find('.memItemRight').each(function(){ 76 | $(this).contents().appendTo($(this).siblings('.memItemLeft')); 77 | $(this).siblings('.memItemLeft').attr('align', 'left'); 78 | }); 79 | 80 | $('table.memberdecls').find('.memTemplItemRight').each(function(){ 81 | $(this).contents().appendTo($(this).siblings('.memTemplItemLeft')); 82 | $(this).siblings('.memTemplItemLeft').attr('align', 'left'); 83 | }); 84 | 85 | function getOriginalWidthOfImg(img_element) { 86 | var t = new Image(); 87 | t.src = (img_element.getAttribute ? img_element.getAttribute("src") : false) || img_element.src; 88 | return t.width; 89 | } 90 | 91 | $('div.dyncontent').find('img').each(function(){ 92 | if(getOriginalWidthOfImg($(this)[0]) > $('#content>div.container').width()) 93 | $(this).css('width', '100%'); 94 | }); 95 | 96 | 97 | /* responsive search box */ 98 | $('#MSearchBox').parent().remove(); 99 | 100 | var nav_container = $('
'); 101 | $('#navrow1').parent().prepend(nav_container); 102 | 103 | var left_nav = $('
'); 104 | for (i = 0; i < 6; i++) { 105 | var navrow = $('#navrow' + i + ' > ul.tablist').detach(); 106 | left_nav.append(navrow); 107 | $('#navrow' + i).remove(); 108 | } 109 | var right_nav = $('
').append('\ 110 | '); 121 | $(nav_container).append(left_nav); 122 | $(nav_container).append(right_nav); 123 | 124 | $('#MSearchSelectWindow .SelectionMark').remove(); 125 | var search_selectors = $('#MSearchSelectWindow .SelectItem'); 126 | for (var i = 0; i < search_selectors.length; i += 1) { 127 | var element_a = $('').text($(search_selectors[i]).text()); 128 | 129 | element_a.click(function(){ 130 | $('#search-box .dropdown-menu li').removeClass('active'); 131 | $(this).parent().addClass('active'); 132 | searchBox.OnSelectItem($('#search-box li a').index(this)); 133 | searchBox.Search(); 134 | return false; 135 | }); 136 | 137 | var element = $('
  • ').append(element_a); 138 | $('#search-box .dropdown-menu').append(element); 139 | } 140 | $('#MSearchSelectWindow').remove(); 141 | 142 | $('#search-box .close').click(function (){ 143 | searchBox.CloseResultsWindow(); 144 | }); 145 | 146 | $('body').append('
    '); 147 | $('body').append('
    '); 148 | $('body').append('
    '); 149 | 150 | searchBox.searchLabel = ''; 151 | searchBox.DOMSearchField = function() { 152 | return document.getElementById("search-field"); 153 | } 154 | searchBox.DOMSearchClose = function(){ 155 | return document.getElementById("search-close"); 156 | } 157 | 158 | 159 | /* search results */ 160 | var results_iframe = $('#MSearchResults').detach(); 161 | $('#MSearchResultsWindow') 162 | .attr('id', 'search-results-window') 163 | .addClass('panel panel-default') 164 | .append( 165 | '
    \ 166 |

    Search Results

    \ 167 |
    \ 168 |
    ' 169 | ); 170 | $('#search-results-window .panel-body').append(results_iframe); 171 | 172 | searchBox.DOMPopupSearchResultsWindow = function() { 173 | return document.getElementById("search-results-window"); 174 | } 175 | 176 | function update_search_results_window() { 177 | $('#search-results-window').removeClass('panel-default panel-success panel-warning panel-danger') 178 | var status = $('#MSearchResults').contents().find('.SRStatus:visible'); 179 | if (status.length > 0) { 180 | switch(status.attr('id')) { 181 | case 'Loading': 182 | case 'Searching': 183 | $('#search-results-window').addClass('panel-warning'); 184 | break; 185 | case 'NoMatches': 186 | $('#search-results-window').addClass('panel-danger'); 187 | break; 188 | default: 189 | $('#search-results-window').addClass('panel-default'); 190 | } 191 | } else { 192 | $('#search-results-window').addClass('panel-success'); 193 | } 194 | } 195 | $('#MSearchResults').load(function() { 196 | $('#MSearchResults').contents().find('link[href="search.css"]').attr('href','../doxygen.css'); 197 | $('#MSearchResults').contents().find('head').append( 198 | ''); 199 | 200 | update_search_results_window(); 201 | 202 | // detect status changes (only for search with external search backend) 203 | var observer = new MutationObserver(function(mutations) { 204 | update_search_results_window(); 205 | }); 206 | var config = { attributes: true}; 207 | 208 | var targets = $('#MSearchResults').contents().find('.SRStatus'); 209 | for (i = 0; i < targets.length; i++) { 210 | observer.observe(targets[i], config); 211 | } 212 | }); 213 | 214 | 215 | /* enumerations */ 216 | $('table.fieldtable').removeClass('fieldtable').addClass('table table-striped table-bordered').each(function(){ 217 | $(this).prepend(''); 218 | $(this).find('tbody > tr:first').prependTo($(this).find('thead')); 219 | 220 | $(this).find('td > span.success').parent().addClass('success'); 221 | $(this).find('td > span.warning').parent().addClass('warning'); 222 | $(this).find('td > span.danger').parent().addClass('danger'); 223 | }); 224 | 225 | /* todo list */ 226 | var todoelements = $('.contents > .textblock > dl.reflist > dt, .contents > .textblock > dl.reflist > dd'); 227 | for (var i = 0; i < todoelements.length; i += 2) { 228 | $('.contents > .textblock').append( 229 | '
    ' 230 | + "
    " + $(todoelements[i]).html() + "
    " 231 | + "
    " + $(todoelements[i+1]).html() + "
    " 232 | + '
    '); 233 | } 234 | $('.contents > .textblock > dl').remove(); 235 | 236 | 237 | $(".memitem").removeClass('memitem'); 238 | $(".memproto").removeClass('memproto'); 239 | $(".memdoc").removeClass('memdoc'); 240 | $("span.mlabel").removeClass('mlabel'); 241 | $("table.memberdecls").removeClass('memberdecls'); 242 | $("[class^=memitem]").removeClass('memitem'); 243 | $("span.mlabels").removeClass('mlabels'); 244 | $("table.mlabels").removeClass('mlabels'); 245 | $("td.mlabels-right").removeClass('mlabels-right'); 246 | $(".navpath").removeClass('navpath'); 247 | $("li.navelem").removeClass('navelem'); 248 | $("a.el").removeClass('el'); 249 | $("div.ah").removeClass('ah'); 250 | $("div.header").removeClass("header"); 251 | 252 | $('.mdescLeft').each(function(){ 253 | if($(this).html()==" ") { 254 | $(this).siblings('.mdescRight').attr('colspan', 2); 255 | $(this).remove(); 256 | } 257 | }); 258 | $('td.memItemLeft').each(function(){ 259 | if($(this).siblings('.memItemRight').html()=="") { 260 | $(this).attr('colspan', 2); 261 | $(this).siblings('.memItemRight').remove(); 262 | } 263 | }); 264 | $('td.memTemplItemLeft').each(function(){ 265 | if($(this).siblings('.memTemplItemRight').html()=="") { 266 | $(this).attr('colspan', 2); 267 | $(this).siblings('.memTemplItemRight').remove(); 268 | } 269 | }); 270 | searchBox.CloseResultsWindow(); 271 | }); 272 | -------------------------------------------------------------------------------- /docs/doxystyle/doxygen-layout.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | 171 | 172 | 173 | 174 | 175 | 176 | 177 | 178 | 179 | 180 | 181 | 182 | 183 | 184 | 185 | 186 | 187 | 188 | 189 | 190 | 191 | 192 | 193 | 194 | 195 | 196 | 197 | 198 | 199 | 200 | 201 | 202 | 203 | 204 | 205 | 206 | 207 | 208 | 209 | 210 | 211 | 212 | 213 | 214 | 215 | 216 | 217 | 218 | 219 | -------------------------------------------------------------------------------- /docs/doxystyle/footer.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 25 | 26 | 27 | -------------------------------------------------------------------------------- /docs/doxystyle/header.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | $projectname: $title 15 | $title 16 | 17 | 18 | $treeview 19 | $search 20 | $mathjax 21 | 22 | $extrastylesheet 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 37 |
    38 |
    39 |
    40 |
    41 |
    42 |
    43 | 44 | -------------------------------------------------------------------------------- /docs/html/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/phreppo/pilisp/55d559126e04fd1148748085877ee43c674b26ba/docs/html/logo.png -------------------------------------------------------------------------------- /examples/a.lisp: -------------------------------------------------------------------------------- 1 | (load "./examples/functions.lisp") 2 | (load "./compiler/compiler.lisp") 3 | (set 'n 789) 4 | (set 'n2 2) 5 | NIL 6 | 44 7 | n2 8 | 44 9 | 2 10 | n 11 | 12 | (dotimes (n 5) (toz 5)) 13 | (ff '(a)) 14 | (ff '((((a) b ) c ) d)) 15 | (ff '((a) b )) 16 | ; ((label ff (lambda (x) (cond ((atom x) x ) (t (ff (car x)))))) '((a))) 17 | ; ((label ff (lambda (x) (cond ((atom x) x ) (t (ff (car x)))))) 'a) 18 | ; 19 | ((lambda (x) (cond ((eq x 1) 1 ) ((eq x 2) 2) (t 666))) '(1)) 20 | ((lambda (x) x) '(1)) 21 | 22 | 23 | ((lambda (x) (lambda (y) y)) 1 ) 24 | (((lambda (x) (lambda (y) 2)) ) ) 25 | (((lambda (x) (lambda (y) y)) 1 ) 2) 26 | (((lambda (x) (lambda (y) y)) 1 2 ) 3) 27 | ((((lambda (x) (lambda (y) (lambda (z) z))) 1 ) 2) 3) 28 | ( (lambda (x) (+ 1 x ) ) 1 ) 29 | (set 'ivar (lambda (x) (set 'var x))) 30 | (set 'l '(nil (1 2) ((1)(2)) nil "ciao")) 31 | (or nil nil nil '(1 2 3) 4) 32 | ; this leaks memory but not alone! 33 | ; (set 'toz (lambda (x) ( cond ( (eq x 0) 0 ) ( T (toz (- x 1)))))) 34 | (defun id (x) x) 35 | (let ((x 1)(y 2)) (+ x y)) 36 | ; 37 | (dotimes (n 1) (toz n)) 38 | (dotimes (n 2) (toz 3)) 39 | (dotimes (n 3) (toz 4)) 40 | (dotimes (n 3) (+ 2 2)) 41 | (dotimes (n 1) 666) 42 | (dotimes (n 2) 666) 43 | (dotimes (n 3) 666) 44 | ; 45 | (let ((l '(1 2 3))(num 0)) (nth num l)) 46 | ; 47 | (setq maze1 '( 48 | (1) 49 | (0 3) 50 | (3 -1) 51 | (1 2) 52 | )) 53 | 54 | (setq maze2 '( 55 | (3 1) ;0 56 | (0 2 4) ;1 57 | (1 5) ;2 58 | (0 4) ;3 59 | (1 3) ;4 60 | (2 8) ;5 61 | (-1 7) ;6 62 | (6 8) ;7 63 | (5 7) ;8 64 | )) 65 | 66 | (setq maze3 '( 67 | (4) ; 0 68 | (2) ; 1 69 | (1 3) ; 2 70 | (2 7) ; 3 71 | (8 5 0) ; 4 72 | (4 6) ; 5 73 | (5 7) ; 6 74 | (3 11 6) ; 7 75 | (4) ; 8 76 | (10 13) ; 9 77 | (9 14) ; 10 78 | (7 15) ; 11 79 | (13 -1) ; 12 80 | (9 12) ; 13 81 | (10 15) ; 14 82 | (11 14) ; 15 83 | )) 84 | 85 | (defun sm1 (maze actualCell exploredCells doors) 86 | (cond 87 | ( (not doors) 88 | nil ) 89 | ( t 90 | (cond 91 | ( (not (solveMazeRec maze (car doors) exploredCells)) 92 | (sm1 maze actualCell exploredCells (cdr doors)) ) 93 | ( t 94 | (solveMazeRec maze (car doors) exploredCells) 95 | ) ) ) ) ) 96 | 97 | (defun solveMazeRec 98 | (maze actualCell exploredCells) 99 | (cond 100 | ((= actualCell -1) 101 | exploredCells 102 | ) 103 | ((member actualCell exploredCells) 104 | nil) 105 | (t 106 | (sm1 maze actualCell (cons actualCell exploredCells) (nth actualCell maze)) 107 | ) ) ) 108 | 109 | 110 | (defun solveMaze 111 | (maze) 112 | (solveMazeRec maze 0 '()) ) 113 | 114 | 115 | (solveMaze maze1) 116 | 117 | (check "zombie") 118 | 119 | (LASM 3 "@A@B@C@C@B@A!!$I" 1 2 LIST) 120 | (defun mylist (x y z) (list z y x x y z 1 2)) 121 | 122 | (write "Invoking trough name") 123 | (time (dotimes ( n 10000000) (mylist 1 2 3))) 124 | 125 | (write "invoking through lambda") 126 | (time (dotimes (n 10000000) ( (lambda (x y z) (list z y x x x y z 1 2 )) 1 2 3 ))) 127 | 128 | (write "invoking through compiled code") 129 | (compile mylist) 130 | (time (dotimes ( n 10000000) (mylist 1 2 3))) 131 | 132 | (write "invoking direct compiled code") 133 | (time (dotimes (n 10000000) ( (LASM 3 "@A@B@C@C@B@A!!$I" 1 2 LIST) 1 2 3 ))) 134 | 135 | (load c) 136 | (md) 137 | (compile defmacro) 138 | (compile 1+) 139 | (compile id) 140 | (compile DEFMACRO) 141 | (compile D) 142 | (compile NULL) 143 | (compile p) 144 | (compile COMPILER) 145 | (compile B) 146 | (compile F) 147 | (compile C) 148 | 149 | (compile plc) 150 | (compile _compile) 151 | (compile compile_atom) 152 | (compile has_value_in_stack) 153 | (compile get_stack_index) 154 | (compile extract_first_symbol) 155 | (compile extract_first_index) 156 | (compile compile_quote) 157 | (compile extract_cons_cell) 158 | (compile compile_atom_function) 159 | (compile compile_atom_function_name_args) 160 | (compile is_builtin_stack) 161 | (compile is_lambda) 162 | (compile compile_builtin_stack) 163 | (compile compile_args_and_append_builtin_stack) 164 | (compile compile_only_if_everything_is_compilable) 165 | (compile compile_first_arg) 166 | (compile compile_remaining_list_and_append_builtin_stack) 167 | (compile create_builtin_stack_trailer) 168 | (compile get_params_trailer) 169 | (compile compile_lambda) 170 | (compile compile_lambda_only_if_compilable) 171 | (compile build_lambda_body_instruction_list) 172 | (compile build_symbol_table) 173 | (compile build_symbol_table_with_position) 174 | (compile build_one_symbol_and_the_rest_of_the_list) 175 | ; error to the next instruction 176 | (compile build_one_symbol) 177 | (compile build_lambda_args_number_instruction) 178 | (compile extract_lambda_args) 179 | (compile extract_lambda_body) 180 | (compile get_interpretable_code) 181 | (compile is_lasm) 182 | (compile build_interpretable_string_and_args) 183 | (compile extract_instruction_code) 184 | (compile extract_arg) 185 | (compile extract_args) 186 | (compile build_one_arg_and_extract_next) 187 | (compile must_ignore_arg) 188 | (compile extract_machine_code_string) 189 | (compile build_remaining_machine_code_string_char) 190 | (compile get_instruction_code) 191 | (compile translate_instruction_code) 192 | (compile get_instruction_code_for_stack_load) 193 | (compile translate_num_to_digit) 194 | (compile is_quoted_expression) 195 | (compile is_compilable) 196 | (compile count_args) 197 | (compile else) 198 | (compile next) -------------------------------------------------------------------------------- /examples/basic.lisp: -------------------------------------------------------------------------------- 1 | (set 'a "A") 2 | (set 'b 777) 3 | (set 'ff (lambda (x) 4 | (cond 5 | ((atom x) x ) 6 | (t (ff (car x)))) 7 | )) 8 | 9 | (set 'we 10 | (lambda () 11 | (cond 12 | (NIL NIL) 13 | ((atom a) 14 | (1) 15 | ) 16 | ) ) 17 | ) 18 | 19 | (set 'test1 (lambda (num) 20 | ( cond 21 | ( (eq num 0) 22 | T) 23 | ( T 24 | (test1 (- num 1)) ) 25 | ) ) 26 | ) -------------------------------------------------------------------------------- /examples/bench.lisp: -------------------------------------------------------------------------------- 1 | (setq maze '( (4) (2) (1 3) (2 7) (8 5 0) (4 6) (5 7) (3 11 6) (4) (10 13) (9 14) (7 15) (13 -1) (9 12) (10 15) (11 14) )) 2 | 3 | (defun sm1 (maze actualCell exploredCells doors) 4 | (cond 5 | ( (not doors) 6 | nil ) 7 | ( t 8 | (cond 9 | ( (not (solveMazeRec maze (car doors) exploredCells)) 10 | (sm1 maze actualCell exploredCells (cdr doors)) ) 11 | ( t 12 | (solveMazeRec maze (car doors) exploredCells) 13 | ) ) ) ) ) 14 | 15 | (defun solveMazeRec 16 | (maze actualCell exploredCells) 17 | (cond 18 | ((= actualCell -1) 19 | exploredCells 20 | ) 21 | ((member actualCell exploredCells) 22 | nil) 23 | (t 24 | (sm1 maze actualCell (cons actualCell exploredCells) (nth actualCell maze)) 25 | ) ) ) 26 | 27 | 28 | (defun solveMaze 29 | (maze) 30 | (solveMazeRec maze 0 '()) ) 31 | 32 | (defun first_arg (func) (car (cdr func)) ) 33 | (defun second_arg (func) (car (cdr (cdr func))) ) 34 | (defun fun_name (func) (car func) ) 35 | 36 | (defun mult (first second) (cons '* (cons first (cons second NIL))) ) 37 | (defun expo (first second) (cons 'expt (cons first (cons second NIL))) ) 38 | (defun sum (first second) (cons '+ (cons first (cons second NIL))) ) 39 | (defun diff (first second) (cons '- (cons first (cons second NIL))) ) 40 | (defun frac (first second) (cons '/ (cons first (cons second NIL))) ) 41 | 42 | (defun d (func) ( cond 43 | ((integerp func) 0) 44 | ((symbolp func) 1) 45 | ((eq (fun_name func) 'ln) 46 | (mult 47 | (frac 1 (first_arg func)) 48 | (d (first_arg func)))) 49 | ((eq (fun_name func) 'exp) 50 | (mult 51 | func 52 | (d (first_arg func)))) 53 | ((eq (car func) 'expt) 54 | (mult 55 | (cons 'expt (cons (first_arg func) (- (second_arg func ) 1) ) ) 56 | (second_arg func))) 57 | ((eq (fun_name func) 'sin) 58 | (mult 59 | (cons 'cos (cons (first_arg func) NIL)) 60 | (d (first_arg func)))) 61 | ((eq (fun_name func) 'cos) 62 | (mult 63 | (mult (cons 'sin (cons (first_arg func) NIL)) -1) 64 | (d (first_arg func)))) 65 | ((eq (fun_name func) 'tan) 66 | (mult 67 | (frac 68 | 1 69 | (expo (cons 'cos (cons (first_arg func) NIL)) 2) ) 70 | (d (first_arg func)))) 71 | ((eq (fun_name func) '+) 72 | (sum 73 | (d (first_arg func)) 74 | (d (second_arg func)))) 75 | ((eq (fun_name func) '*) 76 | (sum 77 | (mult (d (first_arg func)) (second_arg func)) 78 | (mult (first_arg func) (d (second_arg func))))) 79 | ((eq (fun_name func) '/) 80 | (frac 81 | (diff 82 | (mult (d (first_arg func)) (second_arg func)) 83 | (mult (first_arg func) (d (second_arg func)))) 84 | (expo (second_arg func) 2))) 85 | (t 86 | NIL))) 87 | 88 | (defun string-include (string1 string2) 89 | (cond 90 | ((eq (length string1) 0) nil) 91 | ((> (length string1) (length string2)) nil) 92 | ((eq string1 (subseq string2 0 (length string1))) string1) 93 | (t (string-include string1 (subseq string2 1))))) 94 | 95 | (defun check 96 | (word) 97 | (cond 98 | ((string-include "cie" word) NIL) 99 | ((and (string-include "ei" word) 100 | (not (string-include "cei" word))) NIL) 101 | (t t))) 102 | 103 | (defun ff (x) (cond ((atom x) x ) (t (ff (car x)))) ) 104 | 105 | (defun toz (n) (cond ((eq n 0) 0) (t (toz (- n 1))) ) ) 106 | 107 | (defun mymult (x y) (* x y)) 108 | 109 | (defun second (list) (car (cdr list))) 110 | 111 | (defun listoperations (l) (list (nth 0 l) 1 2 3 4 l)) 112 | 113 | (write "maze") 114 | (time (dotimes (n 5) (solvemaze maze))) 115 | 116 | (write "ff") 117 | (time (dotimes (n 50000) (ff '(((((((((((a)))))))))))) )) 118 | 119 | (write "list") 120 | (time (dotimes (n 1000000) (list 1 1 1 1 1))) 121 | 122 | (write "additions") 123 | (time (dotimes (n 1000000) (+ 1 1))) 124 | 125 | (write "to zero") 126 | (time (dotimes (n 1000) (toz 100))) 127 | 128 | (write "to integerp") 129 | (time (dotimes (n 1000000) (integerp 20))) 130 | 131 | (write "my mult") 132 | (time (dotimes (n 1000000) 133 | (let ((x 10)) 134 | (mymult x x)))) 135 | 136 | (write "mult builtin") 137 | (time (dotimes (n 1000000) 138 | (let ((x 10)) 139 | (* x x)))) 140 | 141 | (write "map") 142 | (time (dotimes (n 1000000) (map 1+ '(1 2 3 4 5)))) 143 | 144 | 145 | (write "diff") 146 | (time (dotimes (n 10000) 147 | (d '(/ (+ (expt x 2) 1) (cos x))))) 148 | 149 | (write "car and cdr") 150 | (time (dotimes (n 1000000) 151 | (car (cdr '(a b c d e f g h))))) 152 | 153 | (write "second") 154 | (time (dotimes (n 1000000) 155 | (second '(a b c d e f g h)))) 156 | 157 | (write "grammar game") 158 | (time (dotimes (n 10000) 159 | (map check '("a" "zombie" "transceiver" "veil" "icier")))) 160 | 161 | (write "logical operations") 162 | (time (dotimes (n 4000000) 163 | (or 1 2 3 (and 4 (not 5))))) 164 | 165 | (write "list operations") 166 | (time (dotimes (n 1000000) (listoperations '(1 2 3 4 "ciao")))) 167 | 168 | (write "setq") 169 | (time (dotimes (n 10000000) (setq var 30))) -------------------------------------------------------------------------------- /examples/compilable_maze.lisp: -------------------------------------------------------------------------------- 1 | (setq maze1 '( 2 | (4) ; 0 3 | (2) ; 1 4 | (1 3) ; 2 5 | (2 7) ; 3 6 | (8 5 0) ; 4 7 | (4 6) ; 5 8 | (5 7) ; 6 9 | (3 11 6) ; 7 10 | (4) ; 8 11 | (10 13) ; 9 12 | (9 14) ; 10 13 | (7 15) ; 11 14 | (13 -1) ; 12 15 | (9 12) ; 13 16 | (10 15) ; 14 17 | (11 14) ; 15 18 | )) 19 | 20 | (defun else () t) 21 | 22 | (defun sm1 (maze actualCell exploredCells doors) 23 | (cond 24 | ((not doors) 25 | nil ) 26 | (t 27 | (cond 28 | ((not (solveMazeRec maze (car doors) exploredCells)) 29 | (sm1 maze actualCell exploredCells (cdr doors))) 30 | (( else) 31 | (solveMazeRec maze (car doors) exploredCells)))))) 32 | 33 | (defun solveMazeRec (maze actualCell exploredCells) 34 | (cond 35 | ((eq actualCell -1) 36 | exploredCells) 37 | ((member actualCell exploredCells) 38 | nil) 39 | (( else) 40 | (sm1 maze actualCell (cons actualCell exploredCells) (nth actualCell maze))))) 41 | 42 | 43 | (defun solveMaze (maze) 44 | (solveMazeRec maze 0 '())) 45 | -------------------------------------------------------------------------------- /examples/diff_benchmark.lisp: -------------------------------------------------------------------------------- 1 | (defun first_arg (func) (car (cdr func)) ) 2 | (defun second_arg (func) (car (cdr (cdr func))) ) 3 | (defun fun_name (func) (car func) ) 4 | 5 | (defun mult (first second) (cons '* (cons first (cons second NIL))) ) 6 | (defun expo (first second) (cons 'expt (cons first (cons second NIL))) ) 7 | (defun sum (first second) (cons '+ (cons first (cons second NIL))) ) 8 | (defun diff (first second) (cons '- (cons first (cons second NIL))) ) 9 | (defun frac (first second) (cons '/ (cons first (cons second NIL))) ) 10 | 11 | (defun is_ln (func) (eq (car func) 'ln)) 12 | (defun is_exp (func) (eq (car func) 'exp)) 13 | (defun is_expt (func) (eq (car func) 'expt)) 14 | (defun is_sin (func) (eq (car func) 'sin)) 15 | (defun is_cos (func) (eq (car func) 'cos)) 16 | (defun is_tan (func) (eq (car func) 'tan)) 17 | (defun is_sum (func) (eq (car func) '+)) 18 | (defun is_mult (func) (eq (car func) '*)) 19 | (defun is_div (func) (eq (car func) '/)) 20 | 21 | (defun d (func) ( cond 22 | ((integerp func) 0) 23 | ((symbolp func) 1) 24 | (( is_ln func) 25 | ( mult 26 | ( frac 1 ( first_arg func)) 27 | ( d ( first_arg func)))) 28 | (( is_exp func) 29 | ( mult 30 | func 31 | ( d ( first_arg func)))) 32 | (( is_expt func) 33 | ( mult 34 | (cons 'expt (cons ( first_arg func) (- ( second_arg func ) 1))) 35 | ( second_arg func))) 36 | (( is_sin func) 37 | ( mult 38 | (cons 'cos (cons ( first_arg func) NIL)) 39 | ( d ( first_arg func)))) 40 | (( is_cos func) 41 | ( mult 42 | ( mult (cons 'sin (cons ( first_arg func) NIL)) -1) 43 | ( d ( first_arg func)))) 44 | (( is_tan func) 45 | ( mult 46 | ( frac 47 | 1 48 | ( expo (cons 'cos (cons ( first_arg func) NIL)) 2) ) 49 | ( d ( first_arg func)))) 50 | (( is_sum func) 51 | ( sum 52 | ( d ( first_arg func)) 53 | ( d ( second_arg func)))) 54 | (( is_mult func) 55 | ( sum 56 | ( mult ( d ( first_arg func)) ( second_arg func)) 57 | ( mult ( first_arg func) ( d ( second_arg func))))) 58 | (( is_div func) 59 | ( frac 60 | ( diff 61 | ( mult ( d ( first_arg func)) ( second_arg func)) 62 | ( mult ( first_arg func) ( d ( second_arg func)))) 63 | ( expo ( second_arg func) 2))) 64 | (t NIL))) 65 | 66 | (write "Executing not-compiled version") 67 | (time (dotimes (n 10000) (d '(/ (+ (expt x 2) 1) (cos x))))) 68 | 69 | (compile first_arg) 70 | (compile second_arg) 71 | (compile fun_name) 72 | (compile mult) 73 | (compile expo) 74 | (compile sum) 75 | (compile diff) 76 | (compile frac) 77 | (compile is_ln) 78 | (compile is_exp) 79 | (compile is_expt) 80 | (compile is_sin) 81 | (compile is_cos) 82 | (compile is_tan) 83 | (compile is_sum) 84 | (compile is_mult) 85 | (compile is_div) 86 | 87 | (write "Executing the compiled version") 88 | (time (dotimes (n 10000) (d '(/ (+ (expt x 2) 1) (cos x))))) 89 | 90 | ; (load "examples/diff_benchmark.lisp") 91 | (defun d (func) ( cond 92 | ((integerp func) 0) 93 | ((symbolp func) 1) 94 | (( ( LASM 1 "@A$B!$C" CAR LN EQ) func) 95 | ( ( LASM 2 "!@A@B!$C$C$C" * NIL CONS CONS CONS) 96 | ( ( LASM 2 "!@A@B!$C$C$C" / NIL CONS CONS CONS) 1 ( ( LASM 1 "@A$B$B" CDR CAR) func)) 97 | ( d ( ( LASM 1 "@A$B$B" CDR CAR) func)))) 98 | (( is_exp func) 99 | ( ( LASM 2 "!@A@B!$C$C$C" * NIL CONS CONS CONS) 100 | func 101 | ( d ( ( LASM 1 "@A$B$B" CDR CAR) func)))) 102 | (( is_expt func) 103 | ( ( LASM 2 "!@A@B!$C$C$C" * NIL CONS CONS CONS) 104 | (cons 'expt (cons ( ( LASM 1 "@A$B$B" CDR CAR) func) (- ( ( LASM 1 "@A$B$B$B" CDR CDR CAR) func ) 1))) 105 | ( ( LASM 1 "@A$B$B$B" CDR CDR CAR) func))) 106 | (( is_sin func) 107 | ( ( LASM 2 "!@A@B!$C$C$C" * NIL CONS CONS CONS) 108 | (cons 'cos (cons ( ( LASM 1 "@A$B$B" CDR CAR) func) NIL)) 109 | ( d ( ( LASM 1 "@A$B$B" CDR CAR) func)))) 110 | (( is_cos func) 111 | ( ( LASM 2 "!@A@B!$C$C$C" * NIL CONS CONS CONS) 112 | ( ( LASM 2 "!@A@B!$C$C$C" * NIL CONS CONS CONS) (cons 'sin (cons ( ( LASM 1 "@A$B$B" CDR CAR) func) NIL)) -1) 113 | ( d ( ( LASM 1 "@A$B$B" CDR CAR) func)))) 114 | (( is_tan func) 115 | ( ( LASM 2 "!@A@B!$C$C$C" * NIL CONS CONS CONS) 116 | ( ( LASM 2 "!@A@B!$C$C$C" / NIL CONS CONS CONS) 117 | 1 118 | ( expo (cons 'cos (cons ( ( LASM 1 "@A$B$B" CDR CAR) func) NIL)) 2) ) 119 | ( d ( ( LASM 1 "@A$B$B" CDR CAR) func)))) 120 | (( is_sum func) 121 | ( sum 122 | ( d ( ( LASM 1 "@A$B$B" CDR CAR) func)) 123 | ( d ( ( LASM 1 "@A$B$B$B" CDR CDR CAR) func)))) 124 | (( is_mult func) 125 | ( sum 126 | ( ( LASM 2 "!@A@B!$C$C$C" * NIL CONS CONS CONS) ( d ( ( LASM 1 "@A$B$B" CDR CAR) func)) ( ( LASM 1 "@A$B$B$B" CDR CDR CAR) func)) 127 | ( ( LASM 2 "!@A@B!$C$C$C" * NIL CONS CONS CONS) ( ( LASM 1 "@A$B$B" CDR CAR) func) ( d ( ( LASM 1 "@A$B$B$B" CDR CDR CAR) func))))) 128 | (( is_div func) 129 | ( ( LASM 2 "!@A@B!$C$C$C" / NIL CONS CONS CONS) 130 | ( diff 131 | ( ( LASM 2 "!@A@B!$C$C$C" * NIL CONS CONS CONS) ( d ( ( LASM 1 "@A$B$B" CDR CAR) func)) ( ( LASM 1 "@A$B$B$B" CDR CDR CAR) func)) 132 | ( ( LASM 2 "!@A@B!$C$C$C" * NIL CONS CONS CONS) ( ( LASM 1 "@A$B$B" CDR CAR) func) ( d ( ( LASM 1 "@A$B$B$B" CDR CDR CAR) func)))) 133 | ( expo ( ( LASM 1 "@A$B$B$B" CDR CDR CAR) func) 2))) 134 | (t NIL))) 135 | 136 | (write "Executing the asm version") 137 | (time (dotimes (n 10000) (d '(/ (+ (expt x 2) 1) (cos x))))) -------------------------------------------------------------------------------- /examples/functions.lisp: -------------------------------------------------------------------------------- 1 | ;(set 'mysetq (macro (name val) (set name val))) 2 | ;(set 'mydefun (macro (name param body) (list 'set (list 'quote name) (list 'lambda param body)))) 3 | ;(set 'defun (macro (name param body) (list 'set (list 'quote name) (list 'lambda param body)))) 4 | 5 | (set 'toz (lambda (x) ( cond ( (eq x 0) 0 ) ( T (toz (- x 1)))))) 6 | (defun toz (n) (cond ((eq n 0) 0) (t (toz (- n 1))) ) ) 7 | 8 | (set 'ff (lambda (x) (cond ((atom x) x ) (t (ff (car x)))))) 9 | (defun ff (x) (cond ((atom x) x ) (t (ff (car x))))) 10 | 11 | (set 'iso (lambda (x) (cond ((eq x 1) 1 ) ((eq x 2) 2) (t 666)))) 12 | (set 'plo (lambda (n) (+ 1 n))) 13 | 14 | (setq maze '( (4) (2) (1 3) (2 7) (8 5 0) (4 6) (5 7) (3 11 6) (4) (10 13) (9 14) (7 15) (13 -1) (9 12) (10 15) (11 14) )) 15 | 16 | (defun sm1 (maze actualCell exploredCells doors) 17 | (cond 18 | ( (not doors) 19 | nil ) 20 | ( t 21 | (cond 22 | ( (not (solveMazeRec maze (car doors) exploredCells)) 23 | (sm1 maze actualCell exploredCells (cdr doors)) ) 24 | ( t 25 | (solveMazeRec maze (car doors) exploredCells) 26 | ) ) ) ) ) 27 | 28 | (defun solveMazeRec 29 | (maze actualCell exploredCells) 30 | (cond 31 | ((= actualCell -1) 32 | exploredCells 33 | ) 34 | ((member actualCell exploredCells) 35 | nil) 36 | (t 37 | (sm1 maze actualCell (cons actualCell exploredCells) (nth actualCell maze)) 38 | ) ) ) 39 | 40 | 41 | (defun solveMaze 42 | (maze) 43 | (solveMazeRec maze 0 '()) ) 44 | 45 | (defun first_arg (func) (car (cdr func)) ) 46 | (defun second_arg (func) (car (cdr (cdr func))) ) 47 | (defun fun_name (func) (car func) ) 48 | 49 | (defun mult (first second) (cons '* (cons first (cons second NIL))) ) 50 | (defun expo (first second) (cons 'expt (cons first (cons second NIL))) ) 51 | (defun sum (first second) (cons '+ (cons first (cons second NIL))) ) 52 | (defun diff (first second) (cons '- (cons first (cons second NIL))) ) 53 | (defun frac (first second) (cons '/ (cons first (cons second NIL))) ) 54 | 55 | (defun d (func) ( cond 56 | ((integerp func) 0) 57 | ((symbolp func) 1) 58 | ((eq (fun_name func) 'ln) 59 | (mult 60 | (frac 1 (first_arg func)) 61 | (d (first_arg func)))) 62 | ((eq (fun_name func) 'exp) 63 | (mult 64 | func 65 | (d (first_arg func)))) 66 | ((eq (car func) 'expt) 67 | (mult 68 | (cons 'expt (cons (first_arg func) (- (second_arg func ) 1) ) ) 69 | (second_arg func))) 70 | ((eq (fun_name func) 'sin) 71 | (mult 72 | (cons 'cos (cons (first_arg func) NIL)) 73 | (d (first_arg func)))) 74 | ((eq (fun_name func) 'cos) 75 | (mult 76 | (mult (cons 'sin (cons (first_arg func) NIL)) -1) 77 | (d (first_arg func)))) 78 | ((eq (fun_name func) 'tan) 79 | (mult 80 | (frac 81 | 1 82 | (expo (cons 'cos (cons (first_arg func) NIL)) 2) ) 83 | (d (first_arg func)))) 84 | ((eq (fun_name func) '+) 85 | (sum 86 | (d (first_arg func)) 87 | (d (second_arg func)))) 88 | ((eq (fun_name func) '*) 89 | (sum 90 | (mult (d (first_arg func)) (second_arg func)) 91 | (mult (first_arg func) (d (second_arg func))))) 92 | ((eq (fun_name func) '/) 93 | (frac 94 | (diff 95 | (mult (d (first_arg func)) (second_arg func)) 96 | (mult (first_arg func) (d (second_arg func)))) 97 | (expo (second_arg func) 2))) 98 | (t 99 | NIL))) 100 | 101 | (defun string-include (string1 string2) 102 | (cond 103 | ((eq (length string1) 0) nil) 104 | ((> (length string1) (length string2)) nil) 105 | ((eq string1 (subseq string2 0 (length string1))) string1) 106 | (t (string-include string1 (subseq string2 1))))) 107 | 108 | (defun check 109 | (word) 110 | (cond 111 | ((string-include "cie" word) NIL) 112 | ((and (string-include "ei" word) 113 | (not (string-include "cei" word))) NIL) 114 | (t t))) 115 | 116 | (defun ff (x) (cond ((atom x) x ) (t (ff (car x)))) ) 117 | 118 | (defun toz (n) (cond ((eq n 0) 0) (t (toz (- n 1))) ) ) 119 | 120 | (defun mymult (x y) (* x y)) 121 | 122 | (defun second (list) (car (cdr list))) -------------------------------------------------------------------------------- /examples/init.lisp: -------------------------------------------------------------------------------- 1 | ( (p . "l/basic.lisp")(nullo . nil) (n1 . 1) (n2 . 2) (n3 . 3) (s1 . "hi") (s2 . "hello") (s3 . "hey") (id . (lambda (x) x)) (plusone . (lambda (x) (+ x 1))) ) 2 | ;(ff . (lambda (x) (cond ((atom x) x ) (t (ff (car x)))))) 3 | 4 | ;( (t . t) ) -------------------------------------------------------------------------------- /img/ftv2doc.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/phreppo/pilisp/55d559126e04fd1148748085877ee43c674b26ba/img/ftv2doc.png -------------------------------------------------------------------------------- /img/ftv2folderclosed.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/phreppo/pilisp/55d559126e04fd1148748085877ee43c674b26ba/img/ftv2folderclosed.png -------------------------------------------------------------------------------- /img/ftv2folderopen.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/phreppo/pilisp/55d559126e04fd1148748085877ee43c674b26ba/img/ftv2folderopen.png -------------------------------------------------------------------------------- /img/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/phreppo/pilisp/55d559126e04fd1148748085877ee43c674b26ba/img/logo.png -------------------------------------------------------------------------------- /img/performances.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/phreppo/pilisp/55d559126e04fd1148748085877ee43c674b26ba/img/performances.png -------------------------------------------------------------------------------- /include/meson.build: -------------------------------------------------------------------------------- 1 | ################################################################################ 2 | # HEADERS 3 | ################################################################################ 4 | 5 | headers = [ 6 | 'pibuiltin.h', 7 | 'picell.h', 8 | 'pichecks.h', 9 | 'picore.h', 10 | 'pierror.h', 11 | 'pifile.h', 12 | 'piinit.h', 13 | 'pilisp.h', 14 | 'piparser.h', 15 | 'piprint.h', 16 | 'piremove.h', 17 | 'pisettings.h', 18 | 'pistack.h', 19 | 'pitestutils.h', 20 | 'piutils.h', 21 | ] 22 | 23 | install_headers(headers) -------------------------------------------------------------------------------- /include/pibuiltin.h: -------------------------------------------------------------------------------- 1 | /** @defgroup pibuiltin 2 | * 3 | * @brief Provides builtin lambdas: for example car, cdr 4 | * 5 | */ 6 | /** @addtogroup pibuiltin */ 7 | /*@{*/ 8 | #ifndef PIBUILTIN_H 9 | #define PIBUILTIN_H 10 | #include "picell.h" 11 | #include "pichecks.h" 12 | #include "pilisp.h" 13 | #include "pistack.h" 14 | #include "piutils.h" 15 | #include 16 | #include 17 | #include 18 | #include 19 | 20 | // ==================== Basic inline apply ==================== 21 | // not usable in the interpreter: no checks! => use only in the eval 22 | #if INLINE_FUNCTIONS 23 | inline cell *caar(cell *c) { return c->car->car; } 24 | inline cell *cddr(cell *c) { return c->cdr->cdr; } 25 | inline cell *cadr(cell *c) { return c->cdr->car; } 26 | inline cell *cdar(cell *c) { return c->car->cdr; } 27 | inline cell *cadar(cell *c) { return c->car->cdr->car; } 28 | inline cell *caddr(cell *c) { return c->cdr->cdr->car; } 29 | #else 30 | cell *caar(cell *c); 31 | cell *cddr(cell *c); 32 | cell *cadr(cell *c); 33 | cell *cdar(cell *c); 34 | cell *cadar(cell *c); 35 | cell *caddr(cell *c); 36 | #endif 37 | 38 | // ==================== Basic apply ==================== 39 | // differences from the first basic block: these functions can be called from 40 | // the apply, because they do cell_remove and cell_push and check for args error 41 | cell *builtin_car(cell *args); 42 | cell *builtin_cdr(cell *args); 43 | cell *builtin_cons(cell *args); 44 | cell *builtin_atom(cell *args); 45 | cell *builtin_eq(cell *args); 46 | 47 | // ==================== Arithmetic ==================== 48 | cell *addition(cell *numbers); 49 | cell *subtraction(cell *numbers); 50 | cell *subtraction_invert_result(cell *numbers); 51 | cell *subtraction_two_or_more_numbers(cell *numbers); 52 | cell *multiplication(cell *numbers); 53 | cell *division(cell *numbers); 54 | 55 | // ==================== Logic ==================== 56 | cell * or (cell * operands); 57 | cell * and (cell * operands); 58 | cell * not(cell * operands); 59 | 60 | // ==================== Comparison ==================== 61 | cell *greater(cell *operands); 62 | cell *compare_greater_numbers(cell *first_num, cell *second_num); 63 | cell *compare_greater_strings(cell *first_str, cell *second_str); 64 | 65 | cell *greater_eq(cell *operands); 66 | cell *compare_greater_eq_numbers(cell *first_num, cell *second_num); 67 | cell *compare_greater_eq_strings(cell *first_str, cell *second_str); 68 | 69 | cell *less(cell *operands); 70 | cell *compare_less_numbers(cell *first_num, cell *second_num); 71 | cell *compare_less_strings(cell *first_str, cell *second_str); 72 | 73 | cell *less_eq(cell *operands); 74 | cell *compare_less_eq_numbers(cell *first_num, cell *second_num); 75 | cell *compare_less_eq_strings(cell *first_str, cell *second_str); 76 | 77 | cell *integerp(cell *arg); 78 | cell *symbolp(cell *arg); 79 | 80 | // ==================== Lists ==================== 81 | cell *list(cell *args); 82 | cell *reverse(cell *args); 83 | cell *member(cell *args); 84 | cell *nth(cell *args); 85 | cell *concatenate(cell *args); // ! works only with strings 86 | cell *append(cell *args); 87 | 88 | cell *length(cell *args); 89 | cell *length_string(cell *string); 90 | cell *length_cons(cell *list); 91 | 92 | cell *subseq(cell *args); // ! works only with strings 93 | cell *subseq_one_index(cell *args, int start_index); 94 | cell *subseq_two_indices(cell *args, int start_index); 95 | 96 | // ==================== Utility ==================== 97 | cell *set(cell *args); 98 | cell *set_change_existing_value(cell *args, cell *pair); 99 | cell *set_add_new_value(cell *args, cell *prec); 100 | 101 | cell *write(cell *arg); 102 | cell *load(cell *arg, cell *env); 103 | cell *bye(cell *arg); 104 | 105 | // ==================== Macros ==================== 106 | cell *quote(cell *args, cell *env); 107 | cell *cond(cell *arg, cell *env); 108 | cell *setq(cell *args, cell *env); 109 | cell *defun(cell *args, cell *env); 110 | cell *let(cell *args, cell *env); 111 | cell *dotimes(cell *arg, cell *env); 112 | cell *map(cell *args, cell *env); 113 | cell *timer(cell *arg, cell *env); 114 | 115 | // ==================== Pilisp special functions ==================== 116 | cell *compile(cell *c, cell *env); // ! the compiler needs to be loaded 117 | bool should_be_compiled(cell *to_compilate); 118 | cell *asm_call(cell *args, cell *env); 119 | cell *mem_dump(cell *arg); 120 | cell *env(cell *arg); 121 | cell *collect_garbage_call(cell *arg); 122 | 123 | // ==================== Basic Lisp functions ==================== 124 | // works also on lists: eq does not, but 'it's slower 125 | bool total_eq(cell *c1, cell *c2); 126 | 127 | #if !INLINE_FUNCTIONS 128 | 129 | cell *car(cell *c); 130 | cell *cdr(cell *c); 131 | cell *cons(cell *car, cell *cdr); 132 | int atom(cell *c); 133 | bool eq(cell *v1, cell *v2); 134 | 135 | #else 136 | 137 | inline cell *cons(cell *car, cell *cdr) { return mk_cons(car, cdr); } 138 | 139 | inline int atom(cell *c) { 140 | return (c == NULL) || 141 | (c->type == TYPE_SYM || c->type == TYPE_NUM || c->type == TYPE_STR || 142 | c->type == TYPE_BUILTINLAMBDA || c->type == TYPE_BUILTINMACRO || 143 | c->type == TYPE_KEYWORD); 144 | } 145 | 146 | inline bool eq(cell *v1, cell *v2) { 147 | if (!v1 || !v2) 148 | return (v1 == v2); 149 | if (is_num(v1) && is_num(v2)) 150 | return (v1->value == v2->value); 151 | if (is_str(v1) && is_str(v2)) 152 | return (strcmp(v1->str, v2->str) == 0); 153 | return (v1 == v2); 154 | } 155 | 156 | inline cell *car(cell *c) { 157 | if (c == NULL) 158 | return NULL; 159 | #if CHECKS 160 | if (atom(c)) 161 | pi_lisp_error("car applied to an atom"); 162 | #endif 163 | return c->car; 164 | } 165 | 166 | inline cell *cdr(cell *c) { 167 | if (c == NULL) 168 | return NULL; 169 | #if CHECKS 170 | if (atom(c)) 171 | pi_lisp_error("cdr applied to an atom"); 172 | #endif 173 | return c->cdr; 174 | } 175 | 176 | #endif 177 | 178 | #endif // !PIBUILTIN_H 179 | /*@}*/ -------------------------------------------------------------------------------- /include/picell.h: -------------------------------------------------------------------------------- 1 | /** @defgroup picell 2 | * 3 | * @brief Provides the data structures for LISP, like cells 4 | * 5 | */ 6 | 7 | /** @addtogroup picell */ 8 | /*@{*/ 9 | #ifndef PICELL_H 10 | #define PICELL_H 11 | #include "pisettings.h" 12 | #include 13 | #include 14 | #include 15 | 16 | /******************************************************************************** 17 | * CELL DEFINITION 18 | ********************************************************************************/ 19 | 20 | /** 21 | * @brief Identifies the type of a cell 22 | * 23 | */ 24 | enum { 25 | TYPE_CONS = 0, // is a cell with a car and a cdr 26 | TYPE_SYM, // symbol cell 27 | TYPE_NUM, // integer cell 28 | TYPE_STR, // string cell 29 | TYPE_FREE, // free cell: can be allocated from the memory manager to another 30 | // cell 31 | TYPE_BUILTINLAMBDA, /// represents a builtin lisp function (e.g. car, cdr...) 32 | TYPE_BUILTINMACRO, /// represents a builtin lisp macro (e.g. dotimes, 33 | /// defun...) 34 | TYPE_KEYWORD, /// keyword cell (e.g. :mykeyword...) 35 | }; 36 | 37 | /** 38 | * @brief Basic Lisp entity 39 | * 40 | * Every cell has a type identifier (referred to the type enum). It identifies 41 | * the type of the cell. `marked` and `marks` are fields used to collect garbage. 42 | * 43 | */ 44 | typedef struct cell { 45 | unsigned char type; /// type of the cell referred to the type enum 46 | unsigned char marked; /// 1 if marked in the "mark" phase of the gc 47 | unsigned long marks; /// number of cells that refer to this cell 48 | union { 49 | int value; /// value of the num cell 50 | char *str; /// string of the string cell 51 | struct cell * 52 | next_free_cell; /// pointer to the next free cell for cells of type free 53 | struct { 54 | struct cell *car; /// car of the cons cell 55 | struct cell *cdr; /// cdr of the cons cell 56 | }; 57 | struct { 58 | char *sym; // symbol for symbol cells 59 | union { 60 | struct { 61 | struct cell *(*bl)( 62 | struct cell *args); /// pointer to builtin lambda function for 63 | /// builtin lambdas 64 | void (*bs)( 65 | size_t stack_base, 66 | unsigned char 67 | nargs); /// pointer to builtin stack lambdas function for 68 | /// functions that have a stack implementation that 69 | /// can be interpreted by the virtual machine 70 | }; 71 | struct cell *(*bm)( 72 | struct cell *args, 73 | struct cell *env); /// pointer to builtin macro function 74 | }; 75 | }; 76 | }; 77 | } cell; 78 | 79 | // unsafe unmark: no checks if cell is empty or a builtin! use only if you are 80 | // sure that cell exists and is not a builtin symbol. it's faster 81 | #if INLINE_FUNCTIONS 82 | inline void unsafe_cell_remove(cell *c) { c->marks--; } 83 | #else 84 | void unsafe_cell_remove(cell *c); 85 | #endif 86 | 87 | /******************************************************************************** 88 | * STACK DEFINITION 89 | ********************************************************************************/ 90 | 91 | size_t stack_pointer; 92 | cell *stack[STACK_LIMIT]; 93 | 94 | /******************************************************************************** 95 | * GARBAGE COLLECTOR 96 | ********************************************************************************/ 97 | 98 | // cells array 99 | typedef struct { 100 | size_t block_size; 101 | cell *block; 102 | } cell_block; 103 | 104 | cell_block *cell_block_create(size_t s); 105 | void cell_block_free(cell_block *cb); 106 | 107 | // cells space: array of cell blocks. Just one of this will be instantiated: 108 | // the pointer "memory" that represents the allocated cells in the interpreter 109 | typedef struct { 110 | size_t cell_space_size; 111 | size_t cell_space_capacity; 112 | size_t n_cells; 113 | size_t n_free_cells; 114 | cell *first_free; 115 | cell *global_env; 116 | cell_block *blocks; 117 | } cell_space; 118 | 119 | cell_space *memory; 120 | void init_memory(); 121 | void free_memory(); 122 | 123 | cell_space *cell_space_create(); 124 | cell *cell_space_get_cell(cell_space *cs); 125 | cell *cell_space_is_symbol_allocated(cell_space *cs, char *symbol); 126 | void cell_space_init(cell_space *cs); 127 | void cell_space_grow(cell_space *cs); 128 | void cell_space_double_capacity_if_full(cell_space *cs); 129 | void cell_space_mark_cell_as_free(cell_space *cs, cell *c); 130 | void cell_space_free(cell_space *cs); 131 | bool cell_space_is_full(cell_space *cs); 132 | 133 | /******************************************************************************** 134 | * CELL BASIC OPERATIONS 135 | ********************************************************************************/ 136 | 137 | #if INLINE_FUNCTIONS 138 | inline cell *get_cell() { return cell_space_get_cell(memory); } 139 | 140 | inline cell *mk_num(int n) { 141 | cell *c = get_cell(); 142 | c->type = TYPE_NUM; 143 | c->value = n; 144 | return c; 145 | } 146 | 147 | inline cell *mk_str(char *s) { 148 | cell *c = get_cell(); 149 | c->type = TYPE_STR; 150 | c->str = malloc(strlen(s) + 1); 151 | strcpy(c->str, s); 152 | 153 | return c; 154 | } 155 | 156 | inline cell *mk_cons(cell *car, cell *cdr) { 157 | cell *c = get_cell(); 158 | c->type = TYPE_CONS; 159 | c->car = car; 160 | c->cdr = cdr; 161 | return c; 162 | } 163 | #else 164 | cell *get_cell(); 165 | cell *mk_num(int n); 166 | cell *mk_str(char *s); 167 | cell *mk_cons(cell *car, cell *cdr); 168 | #endif 169 | 170 | cell *mk_sym(char *symbol); 171 | cell *mk_builtin_lambda(char *symbol, cell *(*function)(cell *), 172 | void (*builtin_stack)(size_t, unsigned char)); 173 | cell *mk_builtin_macro(char *symbol, cell *(*function)(cell *, cell *)); 174 | 175 | cell *copy_cell(cell *c); 176 | void free_cell_pointed_memory(cell *c); 177 | 178 | /******************************************************************************** 179 | * CELL IDENTIFICATION 180 | ********************************************************************************/ 181 | #if INLINE_FUNCTIONS 182 | inline bool is_num(cell *c) { return c->type == TYPE_NUM; } 183 | inline bool is_str(cell *c) { return c->type == TYPE_STR; } 184 | inline bool is_cons(cell *c) { return c->type == TYPE_CONS; } 185 | inline bool is_keyword(cell *c) { return c->type == TYPE_KEYWORD; } 186 | inline bool is_sym(cell *c) { 187 | return c->type == TYPE_SYM || c->type == TYPE_BUILTINLAMBDA || 188 | c->type == TYPE_BUILTINMACRO || c->type == TYPE_KEYWORD; 189 | } 190 | inline bool is_builtin(cell *c) { 191 | return c->type == TYPE_BUILTINLAMBDA || c->type == TYPE_BUILTINMACRO; 192 | } 193 | inline bool is_builtin_lambda(cell *c) { return c->type == TYPE_BUILTINLAMBDA; } 194 | inline bool is_builtin_macro(cell *c) { return c->type == TYPE_BUILTINMACRO; } 195 | #else 196 | bool is_num(cell *c); 197 | bool is_str(cell *c); 198 | bool is_cons(cell *c); 199 | bool is_sym(cell *c); 200 | bool is_keyword(cell *c); 201 | bool is_builtin(cell *c); 202 | bool is_builtin_lambda(cell *c); 203 | bool is_builtin_macro(cell *c); 204 | #endif 205 | cell *is_symbol_builtin_lambda(char *symbol); 206 | cell *is_symbol_builtin_macro(char *symbol); 207 | bool cell_is_in_global_env(cell *global_env, cell *c); 208 | 209 | /******************************************************************************** 210 | * CELL PROTECTION 211 | ********************************************************************************/ 212 | 213 | #if INLINE_FUNCTIONS 214 | inline void cell_push(cell *val) { 215 | #if COLLECT_GARBAGE 216 | val->marks++; 217 | #endif 218 | } 219 | 220 | inline void cell_remove(cell *val) { 221 | #if COLLECT_GARBAGE 222 | if (!val || is_builtin(val)) 223 | return; 224 | if (val->marks > 0) 225 | val->marks--; 226 | #endif 227 | } 228 | #else 229 | void cell_push(cell *val); 230 | void cell_remove(cell *val); 231 | #endif 232 | void cell_push_recursive(cell *c); // mark as used 233 | void cell_remove_recursive(cell *c); 234 | void cell_remove_args(cell *args); 235 | void cell_remove_pairlis(cell *new_env, cell *old_env); 236 | void cell_remove_cars(cell *list); 237 | void cell_remove_pairlis_deep(cell *new_env, cell *old_env); 238 | 239 | /******************************************************************************** 240 | * CORE OF THE GC 241 | ********************************************************************************/ 242 | 243 | void collect_garbage(cell_space *cs); 244 | void deep_collect_garbage(cell_space *cs); 245 | void mark_memory(cell_space *cs); 246 | void mark(cell *root); 247 | void sweep(cell_space *cs); 248 | void deep_sweep(cell_space *cs); 249 | 250 | #endif // !PICELL_H 251 | /*@}*/ -------------------------------------------------------------------------------- /include/pichecks.h: -------------------------------------------------------------------------------- 1 | /** @defgroup pichecks 2 | * 3 | * @brief Provides checks shortcuts for builtin functions 4 | * 5 | */ 6 | /** @addtogroup pibuiltin */ 7 | /*@{*/ 8 | #ifndef PICHECKS_H 9 | #define PICHECKS_H 10 | #include "picell.h" 11 | #include "pierror.h" 12 | 13 | // ==================== Number of arguments checks ==================== 14 | void check_zero_arg(cell * args); 15 | void check_one_arg(cell *args); 16 | void check_two_args(cell *args); 17 | void check_three_args(cell *args); 18 | 19 | // ==================== Arithmetic ==================== 20 | void check_addition_atom(cell *arg); 21 | void check_subtraction(cell *args); 22 | void check_subtraction_atom(cell *arg); 23 | void check_multiplication_atom(cell *arg); 24 | void check_division(cell *args); 25 | void check_division_atom(cell *arg); 26 | 27 | // ==================== Comparison ==================== 28 | void check_comparables(cell *args); 29 | 30 | // ==================== Lists ==================== 31 | void check_length(cell *args); 32 | void check_member(cell *args); 33 | void check_nth(cell *args); 34 | void check_subseq(cell *args); 35 | void check_append(cell *args); 36 | void check_concatenate(cell *args); 37 | 38 | // ==================== Utility ==================== 39 | void check_set(cell *args); 40 | 41 | // ==================== Macros ==================== 42 | void check_setq(cell *args); 43 | 44 | // ==================== Pilisp special functions ==================== 45 | void check_compile(cell *args); 46 | 47 | // ==================== Basic Lisp functions ==================== 48 | void check_car(cell *args); 49 | void check_cdr(cell *args); 50 | 51 | #endif // !PICHECKS_H 52 | /*@}*/ -------------------------------------------------------------------------------- /include/picore.h: -------------------------------------------------------------------------------- 1 | /** @defgroup picore 2 | * 3 | * @brief Provides LISP core functions: eval and apply 4 | * 5 | */ 6 | 7 | /** @addtogroup picore */ 8 | /*@{*/ 9 | 10 | #ifndef PICORE_H 11 | #define PICORE_H 12 | #include "pilisp.h" 13 | 14 | // ==================== Core functions ==================== 15 | 16 | /** 17 | * @brief Evaluates one sexpression and returns the result 18 | * 19 | * @param expression the sexpression to be evaluated 20 | * @param env list of pairs symbol - value 21 | * @return cell* the expression evaluated in the environment 22 | */ 23 | cell *eval(cell *expression, cell *env); 24 | 25 | /** 26 | * @brief Applies the function to the args in the environment 27 | * 28 | * @param fn sexpression representing the function. Can be non-atomic 29 | * @param args list of arguments 30 | * @param env list of pairs symbol - value 31 | * @param eval_args true if the arguments should be evaluated. They should not 32 | * be evaluated only when apllying a macro 33 | * @return cell* the result of the function applied to the arguments 34 | */ 35 | cell *apply(cell *fn, cell *args, cell *env, bool eval_args); 36 | 37 | /** 38 | * @brief Creates a new list of pairs symbol-values starting from another. It's 39 | * used to extend one environment 40 | * 41 | * @param symbols_list list containing the symbols 42 | * @param values_list list containing the values. the order Matters: the first 43 | * will be matched with the first symbol the second with the second symbol and 44 | * so on 45 | * @param env the environment to be extended 46 | * @return cell* the new environment 47 | */ 48 | cell *pairlis(cell *symbols_list, cell *values_list, cell *env); 49 | 50 | /** 51 | * @brief Associates one symbol to one values in the environment 52 | * 53 | * @param symbol the symbol to be associated 54 | * @param env the environment where the value of the symbol is contained 55 | * @return cell* the value of the symbol in the environment 56 | */ 57 | cell *assoc(cell *symbol, cell *env); 58 | 59 | /** 60 | * @brief Evaluates the cars of the list in the environment. It's called when a 61 | * lambda is evaluated: first the list of the arguments of the lambda will be 62 | * evaluated with this function 63 | * 64 | * @param args the list of the arguments 65 | * @param env the environment 66 | * @return cell* the list containing the valued cars 67 | */ 68 | cell *evlis(cell *args, cell *env); 69 | 70 | /** 71 | * @brief Evaluates the cond-special form 72 | * 73 | * @param args the list of the arguments: if the caar valuates to non-nill value 74 | * the the value of the cond will be the evaluated cadar 75 | * 76 | * @param env list of pairs symbol - value 77 | * @return cell* result of the cond 78 | */ 79 | cell *evcon(cell *args, cell *env); 80 | 81 | // ==================== Support functions ==================== 82 | cell *eval_atom(cell *expression, cell *env); 83 | cell *eval_atom_function(cell *expression, cell *env); 84 | cell *eval_composed_function(cell *expression, cell *env); 85 | cell *eval_macro(cell *expression, cell *env); 86 | 87 | cell *apply_atom_function(cell *fn, cell *args, cell *env, bool eval_args); 88 | cell *apply_composed_function(cell *fn, cell *args, cell *env, bool eval_args); 89 | cell *apply_lambda(cell *fn, cell *args, cell *env, bool eval_args); 90 | cell *apply_lasm(cell *fn, cell *args, cell *env, bool eval_args); 91 | cell *apply_label(cell *fn, cell *args, cell *env, bool eval_args); 92 | cell *apply_macro(cell *fn, cell *args, cell *env, bool eval_args); 93 | cell *eval_lambda_and_apply(cell *fn, cell *args, cell *env, bool eval_args); 94 | 95 | #endif // !PICORE_H 96 | /*@}*/ -------------------------------------------------------------------------------- /include/pierror.h: -------------------------------------------------------------------------------- 1 | /** @defgroup pierror 2 | * 3 | * @brief Provides errors handling 4 | * 5 | */ 6 | 7 | /** @addtogroup pierror */ 8 | /*@{*/ 9 | #ifndef PERROR_H 10 | #define PERROR_H 11 | #include "pilisp.h" 12 | #include 13 | #include 14 | #include 15 | 16 | enum error_types { 17 | NO_ERROR = -1, ///< no error occurrred 18 | LISP_ERROR = 1, ///< LISP syntax error 19 | MEMORY_ERROR = 2, ///< memory error 20 | MODE_ERROR = 3 ///< error passing mode to some kind of functions 21 | }; 22 | 23 | // ==================== Errors Throwing ==================== 24 | void pi_error(int CODE, char *message); 25 | void pi_lisp_error(char *message); // throws LISP_ERROR 26 | void pi_error_few_args(); // throws "too few args" 27 | void pi_error_many_args(); // throws "too many args" 28 | void pi_error_stack(); 29 | void pi_error_stack_overflow(); 30 | void pi_error_stack_undeflow(); 31 | 32 | // ==================== Last error informations ==================== 33 | int get_last_error(); 34 | bool had_error(); 35 | void reset_error(); 36 | 37 | #endif // !PERROR_H 38 | /*@}*/ -------------------------------------------------------------------------------- /include/pifile.h: -------------------------------------------------------------------------------- 1 | /** @defgroup pifile 2 | * 3 | * @brief Provides file handling 4 | * 5 | */ 6 | 7 | /** @addtogroup pifile */ 8 | /*@{*/ 9 | #ifndef PIFILE_H 10 | #define PIFILE_H 11 | #include "pilisp.h" 12 | #include 13 | 14 | void write_compiler_expression_to_file(char * file_name, cell * to_compilate); 15 | void write_compiler_to_file(char * file_name); 16 | void write_program_to_file(char *file_name, char *program_text); 17 | cell *parse_file(char *file_path); 18 | 19 | #endif // !PI_FILE 20 | /*@}*/ -------------------------------------------------------------------------------- /include/piinit.h: -------------------------------------------------------------------------------- 1 | /** @defgroup piinit 2 | * 3 | * @brief Provides methods that have to be called before using pilisp 4 | * 5 | */ 6 | 7 | /** @addtogroup piinit */ 8 | /*@{*/ 9 | 10 | #ifndef PIINIT_H 11 | #define PIINIT_H 12 | #include "picell.h" 13 | #include "piparser.h" 14 | #include "pisettings.h" 15 | #include "pistack.h" 16 | #include 17 | 18 | // ==================== Builtin Lambdas Structure ==================== 19 | cell BUILTIN_LAMBDAS[N_BUILTIN_LAMBDA]; 20 | size_t builtin_lambdas_index; // first free cell 21 | 22 | // ==================== Builtin Macro Structure ==================== 23 | cell BUILTIN_MACROS[N_BUILTIN_MACRO]; 24 | size_t builtin_macros_index; // first free cell 25 | 26 | /******************************************************************************** 27 | * Init Functions 28 | ********************************************************************************/ 29 | 30 | /** 31 | * @brief Initializes the variables and the structures that pilisp needs in 32 | * order to properly work. Always call this function before using pilisp core 33 | * functions 34 | * 35 | */ 36 | void init_pi(); // always call this before using pilisp 37 | 38 | /** 39 | * @brief Initializes the array of builtin macros 40 | * 41 | */ 42 | void init_builtin_macros(); 43 | 44 | /** 45 | * @brief Initializes the array of builtin lambdas 46 | * 47 | */ 48 | void init_builtin_lambdas(); 49 | 50 | /** 51 | * @brief Initializes the variables to handle the stack 52 | * 53 | */ 54 | void init_stack(); 55 | 56 | 57 | /** 58 | * @brief Provides some non-builtin definitions, like 1+ 59 | * 60 | */ 61 | void init_env(); // inits the global env 62 | 63 | /** 64 | * @brief Get the compiler source hardcoded 65 | * 66 | * @return char* string representing the compiler source code 67 | */ 68 | char *get_compiler_source_hardcoded(); 69 | 70 | 71 | /******************************************************************************** 72 | * Free Functions 73 | ********************************************************************************/ 74 | 75 | void free_pi(); 76 | void free_builtin_symbols(); 77 | 78 | /******************************************************************************** 79 | * Builtin Symbols 80 | ********************************************************************************/ 81 | 82 | // ==================== Lambdas ==================== 83 | cell *symbol_car; 84 | cell *symbol_cdr; 85 | cell *symbol_cons; 86 | cell *symbol_atom; 87 | cell *symbol_eq; // eq 88 | cell *symbol_eq_math; // = 89 | cell *symbol_true; 90 | cell *symbol_set; 91 | cell *symbol_addition; 92 | cell *symbol_subtraction; 93 | cell *symbol_multiplication; 94 | cell *symbol_division; 95 | cell *symbol_lambda; 96 | cell *symbol_label; 97 | cell *symbol_load; 98 | cell *symbol_or; 99 | cell *symbol_and; 100 | cell *symbol_not; 101 | cell *symbol_greater; 102 | cell *symbol_greater_equal; 103 | cell *symbol_less; 104 | cell *symbol_less_equal; 105 | cell *symbol_length; 106 | cell *symbol_member; 107 | cell *symbol_nth; 108 | cell *symbol_file_ended; 109 | cell *symbol_env; 110 | cell *symbol_mem_dump; 111 | cell *symbol_collect_garbage; 112 | cell *symbol_dotimes; 113 | cell *symbol_list; 114 | cell *symbol_bye; 115 | cell *symbol_macro; 116 | cell *symbol_integerp; 117 | cell *symbol_symbolp; 118 | cell *symbol_write; 119 | cell *symbol_subseq; 120 | cell *symbol_reverse; 121 | cell *symbol_concatenate; 122 | cell *symbol_append; 123 | cell *symbol_lasm; 124 | 125 | // ==================== Keyword Symbols ==================== 126 | cell *symbol_string; 127 | 128 | // ==================== Macros ==================== 129 | cell *symbol_setq; 130 | cell *symbol_let; 131 | cell *symbol_timer; 132 | cell *symbol_defun; 133 | cell *symbol_map; 134 | cell *symbol_cond; 135 | cell *symbol_quote; 136 | cell *symbol_asm; 137 | cell *symbol_compile; 138 | cell *symbol_concatenate; 139 | 140 | #endif // !PIINIT_H 141 | /*@}*/ -------------------------------------------------------------------------------- /include/pilisp.h: -------------------------------------------------------------------------------- 1 | /** @defgroup pilisp 2 | * 3 | * @brief Links the other modules of Pilisp 4 | * 5 | */ 6 | 7 | /** @addtogroup pilisp */ 8 | /*@{*/ 9 | 10 | #ifndef PILISP_h 11 | #define PILISP_h 12 | #define PROMPT_STRING "pi>" 13 | #include "pibuiltin.h" 14 | #include "picell.h" 15 | #include "picore.h" 16 | #include "pierror.h" 17 | #include "pifile.h" 18 | #include "piinit.h" 19 | #include "piparser.h" 20 | #include "piprint.h" 21 | #include "pisettings.h" 22 | #include 23 | #include 24 | #include 25 | #include 26 | #include 27 | #include 28 | #include 29 | #include 30 | 31 | /******************************************************************************** 32 | * Variables for Handling Errors 33 | ********************************************************************************/ 34 | int jmp_destination; 35 | jmp_buf env_buf; 36 | 37 | /******************************************************************************** 38 | * Basic Interpreter Functions 39 | ********************************************************************************/ 40 | 41 | int pi_prompt(); 42 | int pi_parse_args_files(int argc, char **argv); 43 | 44 | #endif // !PILISP_h 45 | /*@}*/ -------------------------------------------------------------------------------- /include/piparser.h: -------------------------------------------------------------------------------- 1 | /** @defgroup piparser 2 | * 3 | * @brief Provides lexer and parser 4 | * 5 | */ 6 | 7 | /** @addtogroup piparser */ 8 | /*@{*/ 9 | #ifndef PIPARSER_H 10 | #define PIPARSER_H 11 | #include "pilisp.h" 12 | #include 13 | #include 14 | 15 | /******************************************************************************** 16 | * PARSER AND LEXER 17 | ********************************************************************************/ 18 | 19 | enum { 20 | TOK_NONE, ///< empty file token 21 | TOK_OPEN, ///< open par token 22 | TOK_CLOSE, ///< closed par token 23 | TOK_DOT, ///< dot token 24 | TOK_QUOTE, ///< quote token 25 | TOK_SYM, ///< symbol token 26 | TOK_NUM, ///< number token 27 | TOK_STR ///< string token 28 | }; 29 | 30 | cell *read_sexpr(FILE *f); 31 | cell *read_sexpr_tok(FILE *f, int tok); 32 | char *get_token_text(); 33 | int next_token(FILE *f); 34 | 35 | #endif // !PIPARSER_H 36 | /*@}*/ -------------------------------------------------------------------------------- /include/piprint.h: -------------------------------------------------------------------------------- 1 | /** @defgroup piprint 2 | * 3 | * @brief Handles printing messages and data structures 4 | * 5 | */ 6 | 7 | /** @addtogroup pilisp */ 8 | /*@{*/ 9 | #ifndef PIPRINT_H 10 | #define PIPRINT_H 11 | #include "pilisp.h" 12 | 13 | /******************************************************************************** 14 | * PRINT FUNCTIONS 15 | ********************************************************************************/ 16 | 17 | enum sexpr_print_mode { 18 | SEXPR_PRINT_DEFAULT, ///< default print mode 19 | SEXPR_PRINT_VERBOSE ///< verbose print mode: (a b c) is printed (a . (b . (c 20 | ///< .NIL))) 21 | }; 22 | 23 | void print_sexpr_mode(cell *c, unsigned char mode); 24 | void print_sexpr(cell *c); 25 | void print_sexpr_to_file(cell *c, FILE *f); 26 | void print_token(int tok); 27 | void print_cell_block(cell_block *block); 28 | void print_cell(cell *cell); 29 | void print_cell_space(cell_space *cs); 30 | void print_free_cells(cell_space *cs); 31 | void print_global_env(cell *env); 32 | void pi_message(char *); 33 | void print_stack(); 34 | 35 | #endif // !PIPRINT_H 36 | /*@}*/ -------------------------------------------------------------------------------- /include/piremove.h: -------------------------------------------------------------------------------- 1 | /** @defgroup piremove 2 | * 3 | * @brief Provides shortcuts to remove cells from used memory 4 | * 5 | */ 6 | /** @addtogroup piremove */ 7 | /*@{*/ 8 | #ifndef PIREMOVE_H 9 | #define PIREMOVE_H 10 | #include "picell.h" 11 | #include "picore.h" 12 | 13 | void cell_remove_lambda(cell * new_env, cell * old_env, cell * args, cell * fn); 14 | void cell_remove_label(cell * new_env, cell * fn); 15 | void cell_remove_eval_macro(cell *new_env, cell *old_env, cell *expression); 16 | void cell_remove_apply_macro(cell * env, cell *old_env, cell *args, cell * fn); 17 | void cell_remove_let_param(cell *params); 18 | 19 | #endif // !PIREMOVE_H 20 | /*@}*/ -------------------------------------------------------------------------------- /include/pisettings.h: -------------------------------------------------------------------------------- 1 | /** @defgroup pisettings 2 | * 3 | * @brief Provides definitions for pilisp settings 4 | * 5 | */ 6 | 7 | /** @addtogroup pisettings */ 8 | /*@{*/ 9 | 10 | #ifndef PISETTINGS_H 11 | #define PISETTINGS_H 12 | 13 | /******************************************************************************** 14 | * GENERAL SETTINGS 15 | ********************************************************************************/ 16 | 17 | /** 18 | * @brief 1 will imply better performances: about 4 times faster programs 19 | * execution, but you will lose checks (then segmentation fault will appear if 20 | * programs aren't correct) and the size of executable will grow because some 21 | * small functions will be inlined 22 | * 23 | */ 24 | #define PERFORMANCES 0 25 | 26 | #if PERFORMANCES 27 | 28 | /** 29 | * @brief Disables garbage collection. This will make programs run faster but 30 | * after some time a segmentation fault will occur due to memory leaks 31 | * 32 | */ 33 | #define EXTREME_PERF 0 34 | 35 | /** 36 | * @brief 37 | * many functions will be declared inline, however the code won't compile in 38 | * many compilers and the build directory generated with meson must be 39 | * generated with: meson build -Dc_args=-Og. The compiler flag -O3 should be set 40 | * to be correctly compiled. Use only for testing performances 41 | * 42 | */ 43 | #define INLINE_FUNCTIONS 1 44 | 45 | #endif 46 | 47 | /** 48 | * @brief 0 => the memory will be dirty => segfault 49 | * anyway a good amount of programs could run anyway 50 | * in the middle between gc and no gc. 1 suggested. 51 | * 52 | */ 53 | #define DEEP_REMOVE 1 54 | 55 | /******************************************************************************** 56 | * MEMORY SETTINGS 57 | ********************************************************************************/ 58 | 59 | #if PERFORMANCES 60 | #if EXTREME_PERF 61 | /** 62 | * @brief Size of the first created block in the memory 63 | * 64 | */ 65 | #define INITIAL_BLOCK_SIZE 134217728 66 | #else 67 | /** 68 | * @brief Size of the first created block in the memory 69 | * 70 | */ 71 | #define INITIAL_BLOCK_SIZE 65536 72 | #endif 73 | #else 74 | /** 75 | * @brief Size of the first created block in the memory 76 | * 77 | */ 78 | #define INITIAL_BLOCK_SIZE 8 79 | #endif 80 | 81 | /** 82 | * @brief Dimension of the array pointing to cell blocks 83 | * 84 | */ 85 | #define INITIAL_BLOCKS 10000 86 | 87 | /** 88 | * @brief (n_free_cells/n_tot_cells) <= NEW_BLOCK_THRESHOLD => allocate a new 89 | * block 90 | * 91 | */ 92 | #define NEW_BLOCK_THRESHOLD 0.8 93 | 94 | // WARNING: if 0 the memory will always be dirty 95 | #if PERFORMANCES 96 | #if EXTREME_PERF 97 | #define COLLECT_GARBAGE 0 98 | #else 99 | #define COLLECT_GARBAGE 1 100 | #endif 101 | #else 102 | #define COLLECT_GARBAGE 1 103 | #endif 104 | 105 | /** 106 | * @brief Max dimension of the stack 107 | * 108 | */ 109 | #define STACK_LIMIT 10000 110 | 111 | /******************************************************************************** 112 | * DEBUGGING 113 | ********************************************************************************/ 114 | 115 | /** 116 | * @brief Print free cells in the (md) function 117 | * 118 | */ 119 | #define PRINT_FREE_CELLS 1 120 | 121 | /** 122 | * @brief Prints only the dangling cells in the (md) command . Use for debug 123 | * purposes 124 | * 125 | */ 126 | #define PRINT_ONLY_DANGLING_CELLS 1 127 | 128 | /** 129 | * @brief If set to 1 will display debug informations while running the gc 130 | * 131 | */ 132 | #define DEBUG_GARBAGE_COLLECTOR_MODE 0 133 | 134 | /******************************************************************************** 135 | * INIT 136 | ********************************************************************************/ 137 | 138 | // 0 => no checks about types nor errors, just segfaults => use ONLY when 139 | // testing performances on correct programs 140 | #if PERFORMANCES 141 | /** 142 | * @brief If set to 0 will remove the checks about errors during the execution 143 | * of a program. This will make run faster correct programs. 144 | * 145 | */ 146 | #define CHECKS 0 147 | #else 148 | /** 149 | * @brief If set to 0 will remove the checks about errors during the execution 150 | * of a program. This will make run faster correct programs. 151 | * 152 | */ 153 | #define CHECKS 1 154 | #endif 155 | 156 | /******************************************************************************** 157 | * FILES SETTINGS 158 | ********************************************************************************/ 159 | 160 | /** 161 | * @brief Prefix of the temporary file used to compile one expression 162 | * 163 | */ 164 | #define PI_COMPILE_FILE_NAME_PREFIX ".picompile" 165 | 166 | /** 167 | * @brief Prefix of the temporary file used to load the Pilisp compiler 168 | * 169 | */ 170 | #define PI_COMPILER_FILE_NAME_PREFIX ".picompiler" 171 | 172 | /** 173 | * @brief If set to 1 will remove temporary files. 1 suggested. 174 | * 175 | */ 176 | #define REMOVE_TMP_FILES 1 177 | 178 | /******************************************************************************** 179 | * LIMITS 180 | ********************************************************************************/ 181 | 182 | /** 183 | * @brief Max length of a LISP token 184 | * 185 | */ 186 | #define MAX_TOK_LEN 512 187 | 188 | /** 189 | * @brief Max length of a error message 190 | * 191 | */ 192 | #define ERROR_MESSAGE_LEN 512 193 | 194 | /** 195 | * @brief Number of builtin lambdas. It's used to create the array to store 196 | * them. 197 | * 198 | */ 199 | #define N_BUILTIN_LAMBDA 50 200 | 201 | /** 202 | * @brief Number of builtin macros. It's used to create the array to store them. 203 | * 204 | */ 205 | #define N_BUILTIN_MACRO 50 206 | 207 | /******************************************************************************** 208 | * CONSOLE ANSI COLORS 209 | ********************************************************************************/ 210 | 211 | #define ANSI_COLOR_BLACK "\x1b[0;30m" 212 | #define ANSI_COLOR_BLUE "\x1b[0;34m" 213 | #define ANSI_COLOR_GREEN "\x1b[0;32m" 214 | #define ANSI_COLOR_CYAN "\x1b[0;36m" 215 | #define ANSI_COLOR_RED "\x1b[0;31m" 216 | #define ANSI_COLOR_PURPLE "\x1b[0;35m" 217 | #define ANSI_COLOR_BROWN "\x1b[0;33m" 218 | #define ANSI_COLOR_GRAY "\x1b[0;37m" 219 | #define ANSI_COLOR_DARK_GRAY "\x1b[1;30m" 220 | #define ANSI_COLOR_LIGHT_BLUE "\x1b[1;34m" 221 | #define ANSI_COLOR_LIGHT_GREEN "\x1b[1;32m" 222 | #define ANSI_COLOR_LIGHT_CYAN "\x1b[1;36m" 223 | #define ANSI_COLOR_LIGHT_RED "\x1b[1;31m" 224 | #define ANSI_COLOR_LIGHT_PURPLE "\x1b[1;35m" 225 | #define ANSI_COLOR_YELLOW "\x1b[1;33m" 226 | #define ANSI_COLOR_WHITE "\x1b[1;37m" 227 | #define ANSI_COLOR_RESET "\x1b[0m" 228 | #define COLOR1 ANSI_COLOR_LIGHT_BLUE 229 | #define COLOR2 ANSI_COLOR_YELLOW 230 | 231 | #endif // !PISETTINGS_H 232 | /*@}*/ 233 | -------------------------------------------------------------------------------- /include/pistack.h: -------------------------------------------------------------------------------- 1 | #ifndef PI_STACK 2 | #define PI_STACK 3 | #include "picell.h" 4 | 5 | void stack_push(cell *c); 6 | cell *stack_pop(); 7 | void empty_stack(); 8 | void stack_car(size_t stack_base, unsigned char nargs); 9 | void stack_cdr(size_t stack_base, unsigned char nargs); 10 | void stack_list(size_t stack_base, unsigned char nargs); 11 | void stack_cons(size_t stack_base, unsigned char nargs); 12 | void stack_atom(size_t stack_base, unsigned char nargs); 13 | void stack_eq(size_t stack_base, unsigned char nargs); 14 | void stack_addition(size_t stack_base, unsigned char nargs); 15 | 16 | cell *asm_call_with_stack_base(cell *args, cell *env, size_t stack_base); 17 | 18 | #endif -------------------------------------------------------------------------------- /include/pitestutils.h: -------------------------------------------------------------------------------- 1 | /** @defgroup pitestutils 2 | * 3 | * @brief Provides tools like prompts to test some functions of pilisp 4 | * 5 | */ 6 | 7 | /** @addtogroup pitestutils */ 8 | /*@{*/ 9 | 10 | #ifndef PTESTUTILS_H 11 | #define PTESTUTILS_H 12 | #include "pilisp.h" 13 | #include 14 | #include 15 | 16 | /******************************************************************************** 17 | * PROMPTS 18 | ********************************************************************************/ 19 | 20 | void lexer_prompt(); 21 | void parse_prompt(); 22 | int lexer_file(FILE *f); 23 | void pairlis_prompt(); 24 | void eval_prompt(); 25 | 26 | #endif // !PTESTUTILS_H 27 | /*}*/ -------------------------------------------------------------------------------- /include/piutils.h: -------------------------------------------------------------------------------- 1 | /** @defgroup piutils 2 | * 3 | * @brief Provides generic utility tools 4 | * 5 | */ 6 | 7 | /** @addtogroup piutils */ 8 | /*@{*/ 9 | 10 | #ifndef PIUTILS_H 11 | #define PIUTILS_H 12 | #include "pisettings.h" 13 | #include 14 | #include 15 | #include 16 | #include 17 | #include 18 | 19 | char *generate_pi_compile_tmp_file_name(); 20 | char *generate_pi_compiler_tmp_file_name(); 21 | 22 | #endif 23 | /*}*/ 24 | -------------------------------------------------------------------------------- /meson.build: -------------------------------------------------------------------------------- 1 | ################################################################################ 2 | # CONFIGURATION 3 | ################################################################################ 4 | 5 | # Project setup 6 | project( 7 | 'pilisp', 'c', 8 | version : '1.0.0', 9 | ) 10 | 11 | # Compiler 12 | cc = meson.get_compiler('c') 13 | # arguments for the coverage 14 | # coverage_arguments = ['-O3'] 15 | # add_global_arguments(coverage_arguments, language : 'c') 16 | 17 | # Dependencies 18 | thread_dep = dependency('threads') # pthreads 19 | mathlib = cc.find_library('m', required: false) # math.h 20 | dependencies =[ 21 | thread_dep, 22 | mathlib 23 | ] 24 | 25 | # Includes 26 | inc = include_directories('include') 27 | 28 | # Subdirs 29 | subdir('include') 30 | subdir('src') 31 | subdir('test') -------------------------------------------------------------------------------- /src/main.c: -------------------------------------------------------------------------------- 1 | #include "pilisp.h" 2 | #include 3 | #include 4 | 5 | bool need_for_help(int argc, char **argv) { 6 | return argc > 1 && 7 | (strcmp(argv[1], "-h") == 0 || strcmp(argv[1], "--help") == 0); 8 | } 9 | 10 | void print_help() { printf("\npilisp [ ... [ ]]\n"); } 11 | 12 | int main(int argc, char **argv) { 13 | 14 | if (need_for_help(argc, argv)) { 15 | print_help(); 16 | return 0; 17 | } 18 | 19 | init_pi(); 20 | if (argc > 1) { 21 | pi_parse_args_files(argc,argv); 22 | } else { 23 | pi_prompt(); 24 | } 25 | free_pi(); 26 | 27 | return 0; 28 | } -------------------------------------------------------------------------------- /src/meson.build: -------------------------------------------------------------------------------- 1 | ################################################################################ 2 | # SOURCES 3 | ################################################################################ 4 | 5 | # List of sources 6 | sources = [ 7 | 'main.c', 8 | 'pibuiltin.c', 9 | 'picell.c', 10 | 'pichecks.c', 11 | 'picore.c', 12 | 'pierror.c', 13 | 'pifile.c', 14 | 'piinit.c', 15 | 'pilisp.c', 16 | 'piparser.c', 17 | 'piprint.c', 18 | 'piremove.c', 19 | 'pistack.c', 20 | 'pitestutils.c', 21 | 'piutils.c', 22 | ] 23 | 24 | # Creation of static library for testing 25 | pilisplib = shared_library( 26 | 'pilisplib', 27 | sources, 28 | include_directories : inc, 29 | dependencies : dependencies, 30 | install : false 31 | ) 32 | 33 | # Main executable 34 | executable( 35 | '../pilisp', 36 | sources: sources, 37 | include_directories : inc, 38 | dependencies : dependencies, 39 | c_args: ['-O3','-finline-small-functions'], 40 | install: true 41 | ) -------------------------------------------------------------------------------- /src/pichecks.c: -------------------------------------------------------------------------------- 1 | #include "pichecks.h" 2 | 3 | // ==================== Number of arguments checks ==================== 4 | 5 | void check_zero_arg(cell * args){ 6 | if(args) 7 | pi_error_many_args(); 8 | } 9 | 10 | void check_one_arg(cell *args) { 11 | if (!args) 12 | pi_error_few_args(); 13 | if (cdr(args)) 14 | pi_error_many_args(); 15 | } 16 | 17 | void check_two_args(cell *args) { 18 | if (!args || !cdr(args)) 19 | pi_error_few_args(); 20 | if (cddr(args)) 21 | pi_error_many_args(); 22 | } 23 | 24 | void check_three_args(cell *args) { 25 | if (!args || !cdr(args) || !cdr(cdr(args))) 26 | pi_error_few_args(); 27 | if (cdr(cddr(args))) 28 | pi_error_many_args(); 29 | } 30 | 31 | // ============================== Arithmetic ============================== 32 | 33 | void check_addition_atom(cell *arg) { 34 | if (!is_cons(arg)) 35 | pi_lisp_error("impossible to perform addition"); 36 | if (!is_num(car(arg))) 37 | pi_lisp_error("added a non-number"); 38 | } 39 | 40 | void check_subtraction(cell *args) { 41 | if (!args) 42 | pi_error_few_args(); 43 | } 44 | 45 | void check_subtraction_atom(cell *arg) { 46 | if (!is_num(car(arg))) 47 | pi_lisp_error("subtracted a non-number"); 48 | } 49 | 50 | void check_multiplication_atom(cell *arg) { 51 | if (!is_cons(arg)) 52 | pi_lisp_error("impossible to perform multiplication"); 53 | if (!is_num(car(arg))) 54 | pi_lisp_error("multiplicated a non-number"); 55 | } 56 | 57 | void check_division(cell *args) { 58 | if (!args || !cdr(args)) 59 | pi_error_few_args(); 60 | if (!is_num(car(args)) || !is_num(car(cdr(args)))) 61 | pi_lisp_error("divided a non-number"); 62 | } 63 | 64 | void check_division_atom(cell *arg) { 65 | if (!is_num(car(arg))) 66 | pi_lisp_error("divided a non-number"); 67 | if (car(arg)->value == 0) 68 | pi_lisp_error("division by 0"); 69 | } 70 | 71 | // ============================== Comparison ============================== 72 | 73 | void check_comparables(cell *args) { 74 | check_two_args(args); 75 | if (!car(args) || !cadr(args)) { 76 | pi_lisp_error("NIL not allowed as arg"); 77 | } 78 | if ((car(args) && car(args)->type) != (cadr(args) && cadr(args)->type)) 79 | pi_lisp_error("incompatible types"); 80 | } 81 | 82 | // ============================== Lists ============================== 83 | 84 | void check_length(cell *args) { 85 | check_one_arg(args); 86 | if (car(args) && !is_cons(car(args)) && !is_str(car(args))) 87 | pi_lisp_error("arg is not a list or a string"); 88 | } 89 | 90 | void check_member(cell *args) { 91 | check_two_args(args); 92 | if (cadr(args) && !is_cons(cadr(args))) 93 | pi_lisp_error("second arg must be a list"); 94 | } 95 | 96 | void check_nth(cell *args) { 97 | check_two_args(args); 98 | if (!is_num(car(args))) 99 | pi_lisp_error("first arg must be a number"); 100 | if (cadr(args) && !is_cons(cadr(args))) 101 | pi_lisp_error("second arg must be a list"); 102 | } 103 | 104 | void check_subseq(cell *args) { 105 | if (!args || !cdr(args)) 106 | pi_error_few_args(); 107 | if (!is_str(car(args))) 108 | pi_lisp_error("first arg in subseq must be a string"); 109 | } 110 | 111 | void check_append(cell *args) { 112 | check_two_args(args); 113 | if (car(args) && !is_cons(car(args))) 114 | pi_lisp_error("first arg must be a list"); 115 | } 116 | 117 | void check_concatenate(cell *args) { 118 | check_three_args(args); 119 | if (!is_sym(car(args))) 120 | pi_lisp_error("first arg must be a symbol"); 121 | if (!is_str(cadr(args))) 122 | pi_lisp_error("second arg must be a string"); 123 | if (!is_str(caddr(args))) 124 | pi_lisp_error("third arg must be a string"); 125 | } 126 | 127 | // ============================== Utility ============================== 128 | 129 | void check_set(cell *args) { 130 | check_two_args(args); 131 | if (!is_sym(car(args))) 132 | pi_lisp_error("first arg must be a symbol"); 133 | } 134 | 135 | // ============================== Macros ============================== 136 | 137 | void check_setq(cell *args) { 138 | check_two_args(args); 139 | if (!is_sym(car(args))) 140 | pi_lisp_error("setq: first arg must be a symbol"); 141 | } 142 | 143 | // ============================== Pilisp special functions 144 | // ============================== 145 | 146 | void check_compile(cell *args) { 147 | check_one_arg(args); 148 | if (!is_sym(car(args))) 149 | pi_lisp_error("arg in compile must be a symbol"); 150 | } 151 | 152 | // ==================== Basic Lisp functions ==================== 153 | 154 | void check_car(cell *args) { 155 | if (atom(args)) 156 | pi_lisp_error("car applied to an atom"); 157 | } 158 | void check_cdr(cell *args) { 159 | if (atom(args)) 160 | pi_lisp_error("cdr applied to an atom"); 161 | } -------------------------------------------------------------------------------- /src/picore.c: -------------------------------------------------------------------------------- 1 | #include "picore.h" 2 | #include "piremove.h" 3 | 4 | cell *eval(cell *expression, cell *env) { 5 | 6 | if (atom(expression)) 7 | return eval_atom(expression, env); 8 | 9 | if (atom(car(expression))) 10 | return eval_atom_function(expression, env); 11 | 12 | return eval_composed_function(expression, env); 13 | } 14 | 15 | cell *eval_atom(cell *expression, cell *env) { 16 | if (!expression) 17 | return NULL; 18 | 19 | if (is_num(expression) || is_str(expression) || is_keyword(expression)) 20 | return expression; 21 | 22 | if (expression == symbol_true) 23 | return symbol_true; 24 | 25 | // it's a symbol: we have to search for that 26 | cell *pair = assoc(expression, env); 27 | cell *symbol_value = cdr(pair); 28 | #if CHECKS 29 | if (!pair) { 30 | // the symbol has no value in the env 31 | char *err = "unknown symbol "; 32 | char *sym_name = expression->sym; 33 | char result[ERROR_MESSAGE_LEN]; 34 | strcpy(result, err); 35 | strcat(result, sym_name); 36 | pi_error(LISP_ERROR, result); 37 | } 38 | #endif 39 | // the symbol has a value in the env 40 | return symbol_value; 41 | } 42 | 43 | cell *eval_atom_function(cell *expression, cell *env) { 44 | cell *evaluated = NULL; 45 | cell *function_symbol = car(expression); 46 | cell *args = cdr(expression); 47 | 48 | if (is_builtin_macro(function_symbol)) 49 | evaluated = function_symbol->bm(args, env); 50 | else { 51 | if (function_symbol == symbol_lambda || function_symbol == symbol_macro || 52 | function_symbol == symbol_lasm) 53 | // "autoquote" 54 | evaluated = expression; 55 | else { 56 | // apply atom function to evaluated list of parameters 57 | evaluated = apply(function_symbol, args, env, true); 58 | cell_remove_args(args); // remove list of args 59 | } 60 | } 61 | unsafe_cell_remove(expression); // cons of the expression 62 | return evaluated; 63 | } 64 | 65 | cell *eval_composed_function(cell *expression, cell *env) { 66 | cell *evaluated = NULL; 67 | 68 | if (caar(expression) == symbol_macro) 69 | evaluated = eval_macro(expression, env); 70 | else { 71 | evaluated = apply(car(expression), cdr(expression), env, true); 72 | cell_remove_args(cdr(expression)); 73 | unsafe_cell_remove(expression); // remove function 74 | } 75 | 76 | return evaluated; 77 | } 78 | 79 | cell *eval_macro(cell *expression, cell *env) { 80 | cell *evaluated = NULL; 81 | cell *old_env = env; 82 | cell *body = car(expression); 83 | cell *params = cdr(expression); 84 | cell *fn_body = caddr(body); 85 | 86 | env = pairlis(cadr(body), params, env); 87 | evaluated = eval(fn_body, env); 88 | cell_remove_eval_macro(env, old_env, expression); 89 | return evaluated; 90 | } 91 | 92 | cell *apply(cell *fn, cell *args, cell *env, bool eval_args) { 93 | if (atom(fn)) 94 | return apply_atom_function(fn, args, env, eval_args); 95 | else 96 | return apply_composed_function(fn, args, env, eval_args); 97 | } 98 | 99 | cell *evlis(cell *args, cell *env) { 100 | if (!args) 101 | return NULL; 102 | cell *valued_car = eval(car(args), env); 103 | cell *valued_cdr = evlis(cdr(args), env); 104 | return mk_cons(valued_car, valued_cdr); 105 | } 106 | 107 | cell *evcon(cell *args, cell *env) { 108 | cell *res = eval(caar(args), env); 109 | cell *ret; 110 | 111 | if (res != NULL) { 112 | ret = eval(cadar(args), env); 113 | cell_remove_recursive(cdr(args)); // cut off the rest of the sexpressions 114 | } else { 115 | ret = evcon(cdr(args), env); 116 | cell_remove_recursive(cadar(args)); // remove the unevaluated body 117 | } 118 | 119 | cell_remove_recursive(res); // result of the cond 120 | unsafe_cell_remove(cdar(args)); // cons of the body 121 | unsafe_cell_remove(car(args)); // cons of the pair (cond [body]) 122 | unsafe_cell_remove(args); // head of the list 123 | 124 | return ret; 125 | } 126 | 127 | cell *pairlis(cell *symbols_list, cell *values_list, cell *a) { 128 | cell *result = a; 129 | cell *symbol; 130 | cell *value; 131 | cell *new_pair; 132 | 133 | while (symbols_list) { 134 | symbol = car(symbols_list); 135 | value = car(values_list); 136 | new_pair = mk_cons(symbol, value); 137 | result = mk_cons(new_pair, result); 138 | 139 | symbols_list = cdr(symbols_list); 140 | values_list = cdr(values_list); 141 | } 142 | return result; 143 | } 144 | 145 | cell *assoc(cell *symbol, cell *env) { 146 | cell *actual_symbol; 147 | cell *result = NULL; 148 | 149 | while (env && !result) { 150 | actual_symbol = caar(env); 151 | if (eq(symbol, actual_symbol)) { 152 | cell_push_recursive(cdar(env)); // protect the value of the symbol 153 | unsafe_cell_remove(symbol); // symbol was used 154 | result = env->car; 155 | } 156 | env = env->cdr; 157 | } 158 | 159 | return result; 160 | } 161 | 162 | cell *apply_atom_function(cell *fn, cell *args, cell *env, bool eval_args) { 163 | if (is_builtin_lambda(fn)) { 164 | // BASIC OPERATIONS 165 | if (eval_args) 166 | args = evlis(args, env); 167 | if (fn) 168 | return fn->bl(args); 169 | else 170 | exit(1); 171 | } else { 172 | // CUSTOM FUNCTION 173 | cell *function_body = eval(fn, env); 174 | #if CHECKS 175 | if (function_body == NULL) 176 | pi_error(LISP_ERROR, "unknown function "); 177 | if (!is_cons(function_body)) 178 | pi_error(LISP_ERROR, "trying to apply a non-lambda"); 179 | #endif 180 | if ((car(function_body) != symbol_macro) && eval_args) 181 | // eval args only if it s not a macro 182 | args = evlis(args, env); 183 | // the env knows the lambda 184 | return apply(function_body, args, env, false); 185 | } 186 | } 187 | 188 | cell *apply_composed_function(cell *fn, cell *args, cell *env, bool eval_args) { 189 | if (car(fn) == symbol_lambda) 190 | return apply_lambda(fn, args, env, eval_args); 191 | 192 | if (car(fn) == symbol_lasm) 193 | return apply_lasm(fn, args, env, eval_args); 194 | 195 | if (eq(car(fn), symbol_label)) 196 | return apply_label(fn, args, env, eval_args); 197 | 198 | if (car(fn) == symbol_macro) 199 | return apply_macro(fn, args, env, eval_args); 200 | 201 | return eval_lambda_and_apply(fn, args, env, eval_args); 202 | } 203 | 204 | cell *apply_lambda(cell *fn, cell *args, cell *env, bool eval_args) { 205 | if (eval_args) 206 | args = evlis(args, env); 207 | cell *old_env = env; 208 | env = pairlis(cadr(fn), args, env); 209 | cell *fn_body = caddr(fn); 210 | cell *res = eval(fn_body, env); 211 | cell_remove_lambda(env, old_env, args, fn); 212 | return res; 213 | } 214 | 215 | cell *apply_lasm(cell *fn, cell *args, cell *env, bool eval_args) { 216 | if (eval_args) 217 | args = evlis(args, env); 218 | cell *act_arg = args; 219 | // we save the base of our stack 220 | size_t stack_base = stack_pointer; 221 | while (act_arg) { 222 | // put everything on the stack 223 | stack_push(act_arg->car); 224 | act_arg = act_arg->cdr; 225 | } 226 | cell *res = asm_call_with_stack_base(cddr(fn), env, stack_base); 227 | stack_pointer = stack_pointer - cadr(fn)->value; 228 | #if CHECKS 229 | if (stack_pointer != stack_base) 230 | pi_error_stack(); 231 | #endif 232 | unsafe_cell_remove(cadr(fn)); 233 | unsafe_cell_remove(cdr(fn)); 234 | cell_remove_args(args); 235 | unsafe_cell_remove(fn); // cons of the lasm 236 | return res; 237 | } 238 | 239 | cell *apply_label(cell *fn, cell *args, cell *env, bool eval_args) { 240 | if (eval_args) 241 | args = evlis(args, env); 242 | cell *new_env = cons(cons(cadr(fn), caddr(fn)), env); 243 | cell *res = apply(caddr(fn), args, new_env, false); 244 | cell_remove_label(new_env, fn); 245 | return res; 246 | } 247 | 248 | cell *apply_macro(cell *fn, cell *args, cell *env, bool eval_args) { 249 | cell *old_env = env; 250 | env = pairlis(cadr(fn), args, env); 251 | cell *fn_body = caddr(fn); 252 | cell *res = eval(fn_body, env); 253 | res = eval(res, env); 254 | cell_remove_apply_macro(env, old_env, args, fn); 255 | return res; 256 | } 257 | 258 | cell *eval_lambda_and_apply(cell *fn, cell *args, cell *env, bool eval_args) { 259 | if (eval_args) 260 | args = evlis(args, env); 261 | cell *function_body = eval(fn, env); 262 | #if CHECKS 263 | if (function_body == NULL) 264 | pi_error(LISP_ERROR, "unknown function "); 265 | if (!is_cons(function_body)) 266 | pi_error(LISP_ERROR, "trying to apply env non-lambda"); 267 | #endif 268 | // the env knows the lambda 269 | return apply(function_body, args, env, false); 270 | } -------------------------------------------------------------------------------- /src/pierror.c: -------------------------------------------------------------------------------- 1 | #include "pierror.h" 2 | 3 | /** 4 | * @brief last error occurred 5 | * 6 | */ 7 | static int last_error = NO_ERROR; 8 | 9 | void pi_error(int CODE, char *message) { 10 | printf(ANSI_COLOR_LIGHT_RED " " " %s\n", message); 11 | mark(memory->global_env); 12 | sweep(memory); 13 | last_error = CODE; 14 | printf(ANSI_COLOR_RESET); 15 | longjmp(env_buf, jmp_destination); // jumps to the last saved destination 16 | } 17 | 18 | void pi_lisp_error(char *message) { pi_error(LISP_ERROR, message); } 19 | 20 | void pi_error_few_args() { pi_error(LISP_ERROR, "too few arguments"); } 21 | 22 | void pi_error_many_args() { pi_error(LISP_ERROR, "too many arguments"); } 23 | 24 | void pi_error_stack() { 25 | empty_stack(); 26 | pi_lisp_error("stack error: wrong stack pointer"); 27 | } 28 | 29 | void pi_error_stack_overflow() { 30 | empty_stack(); 31 | pi_error(LISP_ERROR, "stack error: there's something left on the stack"); 32 | } 33 | 34 | void pi_error_stack_undeflow() { 35 | empty_stack(); 36 | pi_error(LISP_ERROR, 37 | "stack error: something has removed too much args on the stack"); 38 | } 39 | 40 | int get_last_error() { return last_error; } 41 | 42 | void reset_error() { last_error = NO_ERROR; } 43 | 44 | bool had_error() { return last_error != NO_ERROR; } -------------------------------------------------------------------------------- /src/pifile.c: -------------------------------------------------------------------------------- 1 | #include "pifile.h" 2 | 3 | void write_program_to_file(char *file_name, char *program_text) { 4 | // write the program in a file 5 | FILE *program_file_write = fopen(file_name, "w"); 6 | int results = fputs(program_text, program_file_write); 7 | if (results == EOF) 8 | pi_error(MEMORY_ERROR, "error writing program file"); 9 | fclose(program_file_write); 10 | } 11 | 12 | cell *parse_file(char *file_path) { 13 | // execute the file 14 | FILE *program_file = fopen(file_path, "r"); 15 | if (!program_file) { 16 | char *err = "file not found: "; 17 | char result[ERROR_MESSAGE_LEN]; 18 | strcpy(result, err); 19 | strcat(result, file_path); 20 | pi_error(LISP_ERROR, result); 21 | } 22 | cell *res = NULL; 23 | while (!feof(program_file)) { 24 | cell *sexpr = read_sexpr(program_file); 25 | if (sexpr != symbol_file_ended) { 26 | res = eval(sexpr, memory->global_env); 27 | cell_remove_recursive(res); 28 | } 29 | } 30 | fclose(program_file); 31 | return res; 32 | } 33 | 34 | void write_compiler_expression_to_file(char *file_name, cell *to_compilate) { 35 | FILE *program_file_write = fopen(file_name, "w"); 36 | 37 | int results = fputs("(plc '", program_file_write); 38 | if (results == EOF) 39 | pi_error(MEMORY_ERROR, "error writing program file"); 40 | 41 | print_sexpr_to_file(to_compilate, program_file_write); 42 | 43 | results = fputs(")", program_file_write); 44 | if (results == EOF) 45 | pi_error(MEMORY_ERROR, "error writing program file"); 46 | 47 | fclose(program_file_write); 48 | } 49 | 50 | void write_compiler_to_file(char *file_name) { 51 | FILE *program_file_write = fopen(file_name, "w"); 52 | 53 | int results = fputs(get_compiler_source_hardcoded(), program_file_write); 54 | if (results == EOF) 55 | pi_error(MEMORY_ERROR, "error writing program file"); 56 | fclose(program_file_write); 57 | } -------------------------------------------------------------------------------- /src/pilisp.c: -------------------------------------------------------------------------------- 1 | #include "pilisp.h" 2 | 3 | int pi_prompt() { 4 | 5 | // printf("\n ____ ____ __ ____ ___ ____ \n ( _ \\(_ _)( ) (_ _)/ 6 | // __)( _ \\\n )___/ _)(_ )(__ _)(_ \\__ \\ )___/\n (__) 7 | // (____)(____)(____)(___/(__) \n\n"); 8 | 9 | // printf(COLOR1 "\n\t0000000000000000000000000000000\n\t00" COLOR2 10 | // " _ _ _ " COLOR1 "00\n\t00" COLOR2 11 | // " (_) (_) " COLOR1 "00\n\t00" COLOR2 12 | // " _ __ _| |_ ___ _ __ " COLOR1 "00\n\t00" COLOR2 13 | // " | '_ \\| | | / __| '_ \\ " COLOR1 "00\n\t00" COLOR2 14 | // " | |_) | | | \\__ \\ |_) | " COLOR1 "00\n\t00" COLOR2 15 | // " | .__/|_|_|_|___/ .__/ " COLOR1 "00\n\t00" COLOR2 16 | // " | | | | " COLOR1 "00\n\t00" COLOR2 17 | // " |_| |_| " COLOR1 "00\n\t00" COLOR2 18 | // " " COLOR1 19 | // "00\n\t0000000000000000000000000000000 \n\n" 20 | // ANSI_COLOR_RESET); 21 | 22 | printf( 23 | COLOR1 24 | "\n" 25 | "===============================================================\n" COLOR2 26 | COLOR1 "" COLOR2 27 | "\t 88 88 88 \n" COLOR1 "" COLOR2 28 | "\t \"\" 88 \"\" \n" COLOR1 29 | "" COLOR2 "\t 88 \n" COLOR1 30 | "" COLOR2 "\t8b,dPPYba, 88 88 88 ,adPPYba, 8b,dPPYba, \n" COLOR1 31 | "" COLOR2 32 | "\t88P' \"8a 88 88 88 I8[ \"\" 88P' \"8a \n" COLOR1 33 | "" COLOR2 "\t88 d8 88 88 88 `\"Y8ba, 88 d8 \n" COLOR1 34 | "" COLOR2 "\t88b, ,a8\" 88 88 88 aa ]8I 88b, ,a8\" \n" COLOR1 35 | "" COLOR2 36 | "\t88`YbbdP\"' 88 88 88 `\"YbbdP\"' 88`YbbdP\"' \n" COLOR1 37 | "" COLOR2 "\t88 88 \n" COLOR1 38 | "" COLOR2 "\t88 88 \n" COLOR1 39 | "===============================================================\n\n" 40 | 41 | ANSI_COLOR_RESET); 42 | 43 | bool repeat = true; 44 | while (repeat) { 45 | // sets the destination for longjump here if errors were encountered 46 | // during parsing 47 | jmp_destination = setjmp(env_buf); 48 | if (had_error()) { 49 | // skip line: ()))) will print just one error 50 | reset_error(); 51 | char ch; 52 | if (!scanf("%c", &ch)) 53 | pi_lisp_error("failed to read char"); 54 | while (ch != '\n') 55 | if (!scanf("%c", &ch)) 56 | pi_lisp_error("failed to read char"); 57 | } 58 | printf(ANSI_COLOR_BLUE "-> " ANSI_COLOR_RESET); 59 | cell *sexpression = read_sexpr(stdin); 60 | cell *result = eval(sexpression, memory->global_env); 61 | printf(ANSI_COLOR_GREEN " " ANSI_COLOR_RESET); 62 | print_sexpr(result); 63 | puts(""); 64 | if (result == symbol_bye) 65 | repeat = false; 66 | else 67 | cell_remove_recursive(result); 68 | } 69 | return 0; 70 | } 71 | 72 | int pi_parse_args_files(int argc, char **argv) { 73 | jmp_destination = setjmp(env_buf); 74 | if (had_error()) { 75 | exit(1); 76 | } 77 | // parse one or more files 78 | unsigned long i = 1; 79 | for (i = 1; i < argc; i++) { 80 | cell *res = parse_file(argv[i]); 81 | print_sexpr(res); // for every file prints the last result 82 | puts(""); 83 | } 84 | return 0; 85 | } -------------------------------------------------------------------------------- /src/piparser.c: -------------------------------------------------------------------------------- 1 | #include "piparser.h" 2 | 3 | /** 4 | * @brief text of a token 5 | * 6 | */ 7 | static char token_text[MAX_TOK_LEN]; 8 | 9 | /** 10 | * @brief value for numeric tokens 11 | * 12 | */ 13 | static long token_value; 14 | 15 | /** 16 | * @brief returns the next char in the input source. Skips the comments 17 | * 18 | * @param f the input stream 19 | * @return char the next char 20 | */ 21 | static char next_char(FILE *f) { 22 | char c; 23 | do { 24 | if (!f || feof(f)) 25 | return 0; 26 | int ch = fgetc(f); 27 | if (ch == EOF) 28 | return 0; 29 | c = (char)ch; 30 | if (c == ';') { // single-line comment 31 | do { 32 | ch = fgetc(f); 33 | if (ch == EOF) 34 | return 0; 35 | } while ((char)ch != '\n'); 36 | c = (char)ch; 37 | } 38 | } while (isspace(c)); 39 | return c; 40 | } 41 | 42 | /** 43 | * @brief returns true if a char can terminate a symbol (e.g. ), (space), \n) 44 | * 45 | * @param c the input char 46 | * @return true can terminate a symbol 47 | * @return false otherwise 48 | */ 49 | static bool char_is_sym_terminal(char c) { 50 | return c == '(' || c == ')' || c == ' ' || c == '\n' || c == 0 || c == -1 || 51 | c == '.' || c == EOF; 52 | } 53 | 54 | /** 55 | * @brief returs true if a char terminates a strings (e.g. ") 56 | * 57 | * @param c the input char 58 | * @return true c can terminate a string 59 | * @return false otherwise 60 | */ 61 | static bool char_is_str_terminal(char c) { return c == '\"'; } 62 | 63 | /** 64 | * @brief checks if the token text equals "NILL" 65 | * 66 | * @return true the token text equals "NILL" 67 | * @return false otherwise 68 | */ 69 | static bool token_text_is_nil() { 70 | char *nillstr = "NIL"; 71 | int i = 0; 72 | for (i = 0; i < 3; i++) { 73 | if (token_text[i] != nillstr[i]) 74 | return false; 75 | } 76 | return true; 77 | } 78 | 79 | /** 80 | * @brief reads and returns the identifier of the next token in f 81 | * 82 | * @param f the input source 83 | * @return int the code of the token 84 | */ 85 | int next_token(FILE *f) { 86 | int token = -1; 87 | char c = next_char(f); 88 | if (c == 0 || feof(f)) { 89 | token_text[0] = '\0'; 90 | return TOK_NONE; 91 | } 92 | if (c == '(') { 93 | token_text[0] = '\0'; 94 | token = TOK_OPEN; 95 | } else if (c == ')') { 96 | token_text[0] = '\0'; 97 | token = TOK_CLOSE; 98 | } else if (c == '.') { 99 | token_text[0] = '\0'; 100 | token = TOK_DOT; 101 | } else if (c == '\'') { 102 | token_text[0] = '\0'; 103 | token = TOK_QUOTE; 104 | } else { 105 | token = TOK_SYM; 106 | int i = 0; 107 | token_text[i++] = c; 108 | 109 | if (token_text[0] == '\"') { 110 | // the token is a string: has to be parsed in a different way: now we 111 | // can't skip spaces 112 | token = TOK_STR; 113 | i--; 114 | do { 115 | c = (char)fgetc(f); 116 | if (!char_is_str_terminal(c)) 117 | token_text[i++] = c; 118 | else { 119 | token_text[i] = '\0'; 120 | } 121 | } while (!char_is_str_terminal(c)); 122 | } else { 123 | // is not a string: we suppose it is a symbol 124 | do { 125 | token_text[0] = toupper(token_text[0]); 126 | c = (char)fgetc(f); 127 | if (!char_is_sym_terminal(c)) 128 | token_text[i++] = toupper(c); 129 | else { 130 | token_text[i] = '\0'; 131 | ungetc( 132 | c, 133 | f); // resets because he could have read something like 'symbol)' 134 | } 135 | } while (!char_is_sym_terminal(c)); 136 | // could be a number 137 | char *e; 138 | token_value = strtol(token_text, &e, 0); 139 | if (*e == '\0') 140 | // is effectively a number 141 | token = TOK_NUM; 142 | } 143 | } 144 | return token; 145 | } 146 | 147 | cell *read_sexpr(FILE *f) { 148 | int tok = next_token(f); 149 | if (tok != TOK_NONE) 150 | return read_sexpr_tok(f, tok); 151 | return symbol_file_ended; 152 | } 153 | 154 | cell *read_sexpr_tok(FILE *f, int tok) { 155 | cell *c = 0; 156 | switch (tok) { 157 | case TOK_NUM: 158 | c = mk_num(token_value); 159 | break; 160 | case TOK_STR: 161 | c = mk_str(token_text); 162 | break; 163 | case TOK_SYM: 164 | c = (token_text_is_nil() ? 0 165 | : mk_sym(token_text)); // can be a builtin lambda 166 | break; 167 | case TOK_CLOSE: 168 | pi_error(LISP_ERROR, "unexpected )"); 169 | case TOK_QUOTE: 170 | tok = next_token(f); 171 | return mk_cons(mk_sym("QUOTE"), mk_cons(read_sexpr_tok(f, tok), 0)); 172 | case TOK_OPEN: 173 | tok = next_token(f); 174 | if (tok == TOK_CLOSE) 175 | // () cell 176 | c = NULL; 177 | else { 178 | // read car 179 | cell *car = read_sexpr_tok(f, tok); 180 | cell *cdr = NULL; 181 | // read after head: we can have . || sexpr 182 | tok = next_token(f); 183 | if (tok == TOK_DOT) { 184 | // uses the dot notation 185 | tok = next_token(f); 186 | // read cdr 187 | cdr = read_sexpr_tok(f, tok); 188 | tok = next_token(f); 189 | if (tok != TOK_CLOSE) 190 | pi_error(LISP_ERROR, ") expected"); 191 | } else if (tok == TOK_CLOSE) { 192 | // found something like (a) = (a . NILL) 193 | // nothing to do: cdr=NULL is ok 194 | } else { 195 | // you are here: ( [car] [something that is not a dot or a ')', aka a 196 | // sexpr] .... 197 | 198 | cell *cdr_head = read_sexpr_tok(f, tok); 199 | cdr = mk_cons(cdr_head, NULL); 200 | 201 | tok = next_token(f); 202 | // this keeps track of the last cdr added, because we need to attach 203 | // list members to the end of the last cdr. Example: (a b c d) needs 204 | // to keep track of the last to create the nested structure (a . (b . 205 | // (c . (d . NILL)))) 206 | cell *last_cdr = cdr; 207 | while (tok != TOK_CLOSE) { 208 | 209 | if (tok == TOK_DOT) { 210 | // something like: ( {list} . => we have to read the last atom and 211 | // read a close 212 | cell *last_sexpr = read_sexpr(f); 213 | last_cdr->cdr = last_sexpr; 214 | tok = next_token(f); 215 | } else { 216 | // create a new level 217 | cell *new_cdr = mk_cons(read_sexpr_tok(f, tok), NULL); 218 | // update cycle variables 219 | last_cdr->cdr = new_cdr; 220 | last_cdr = new_cdr; 221 | tok = next_token(f); 222 | } 223 | 224 | } 225 | } 226 | // create the cell 227 | c = mk_cons(car, cdr); 228 | } 229 | break; 230 | case TOK_DOT: 231 | pi_error(LISP_ERROR, "unexpected ."); 232 | default: 233 | // error ? 234 | break; 235 | }; 236 | return c; 237 | } 238 | 239 | char *get_token_text() { return token_text; } -------------------------------------------------------------------------------- /src/piprint.c: -------------------------------------------------------------------------------- 1 | #include "piprint.h" 2 | 3 | static bool cell_was_printed(cell *c, cell **printed_cons_cells, 4 | unsigned long level) { 5 | unsigned long i; 6 | // start from the end 7 | for (i = 0; i < level; i++) 8 | if (printed_cons_cells[i] == c) 9 | return true; 10 | return false; 11 | } 12 | 13 | static void print_sexpr_rec_dot(cell *c, cell **printed_cons_cells, 14 | unsigned long level) { 15 | if (c) { 16 | switch (c->type) { 17 | 18 | case TYPE_NUM: 19 | printf("%i", c->value); 20 | break; 21 | 22 | case TYPE_STR: 23 | printf("\"%s\"", c->str); 24 | break; 25 | case TYPE_KEYWORD: 26 | case TYPE_BUILTINLAMBDA: 27 | case TYPE_BUILTINMACRO: 28 | case TYPE_SYM: 29 | printf("%s", c->sym); 30 | break; 31 | 32 | case TYPE_CONS: 33 | // could be a self referenced structure 34 | if (!cell_was_printed(c, printed_cons_cells, level)) { 35 | // mark the cell as printed 36 | printed_cons_cells[level++] = c; 37 | printf("("); 38 | print_sexpr_rec_dot(c->car, printed_cons_cells, level); 39 | printf(" . "); 40 | print_sexpr_rec_dot(c->cdr, printed_cons_cells, level); 41 | printf(")"); 42 | } 43 | break; 44 | 45 | default: 46 | pi_error(MODE_ERROR, "unknown cell type"); 47 | break; 48 | } 49 | } else { 50 | // empty cell 51 | printf("NIL"); 52 | } 53 | } 54 | 55 | static void print_sexpr_rec_list(cell *c, cell **printed_cons_cells, 56 | unsigned long level) { 57 | if (c) { 58 | switch (c->type) { 59 | case TYPE_NUM: 60 | printf("%i", c->value); 61 | break; 62 | case TYPE_STR: 63 | printf("\"%s\"", c->str); 64 | break; 65 | case TYPE_KEYWORD: 66 | case TYPE_BUILTINMACRO: 67 | case TYPE_BUILTINLAMBDA: 68 | printf("%s", c->sym); 69 | break; 70 | case TYPE_SYM: 71 | printf("%s", c->sym); 72 | break; 73 | case TYPE_CONS: 74 | if (!cell_was_printed(c, printed_cons_cells, level)) { 75 | printed_cons_cells[level++] = c; 76 | printf("("); 77 | while (c->cdr && c->cdr->type == TYPE_CONS) { 78 | print_sexpr_rec_list(c->car, printed_cons_cells, level); 79 | printf(" "); 80 | c = c->cdr; 81 | } 82 | print_sexpr_rec_list(c->car, printed_cons_cells, level); 83 | if (c->cdr) { 84 | printf(" . "); 85 | print_sexpr_rec_list(c->cdr, printed_cons_cells, level); 86 | } 87 | printf(")"); 88 | } 89 | break; 90 | case TYPE_FREE: 91 | printf("FREE"); 92 | break; 93 | default: 94 | pi_error(MODE_ERROR, "unknown cell type"); 95 | break; 96 | } 97 | } else { 98 | printf("NIL"); 99 | } 100 | } 101 | 102 | void pi_message(char *message) { 103 | printf("%s %s\n", PROMPT_STRING, message); 104 | } 105 | 106 | void print_token(int tok) { 107 | char *token_text = get_token_text(); 108 | switch (tok) { 109 | case TOK_NONE: 110 | printf("\t\t"); 111 | puts("NILL"); 112 | break; 113 | case TOK_OPEN: 114 | printf("\t"); 115 | puts("("); 116 | break; 117 | case TOK_CLOSE: 118 | printf("\t"); 119 | puts(")"); 120 | break; 121 | case TOK_DOT: 122 | printf("\t\t"); 123 | puts("."); 124 | break; 125 | case TOK_QUOTE: 126 | printf("\t\t"); 127 | puts("\'"); 128 | break; 129 | case TOK_SYM: 130 | printf("\t"); 131 | puts(token_text); 132 | break; 133 | case TOK_STR: 134 | printf("\t"); 135 | puts(token_text); 136 | break; 137 | case TOK_NUM: 138 | printf("\t"); 139 | puts(token_text); 140 | break; 141 | default: 142 | pi_error(MODE_ERROR, "unknown token type"); 143 | } 144 | } 145 | 146 | void print_sexpr(cell *c) { 147 | print_sexpr_mode(c, SEXPR_PRINT_DEFAULT); // default mode 148 | } 149 | 150 | void print_sexpr_mode(cell *c, unsigned char mode) { 151 | cell **printed_cons_cells = malloc(sizeof(cell *) * memory->n_cells); 152 | unsigned long level = 0; 153 | 154 | switch (mode) { 155 | case SEXPR_PRINT_VERBOSE: 156 | print_sexpr_rec_dot(c, printed_cons_cells, level); 157 | break; 158 | case SEXPR_PRINT_DEFAULT: 159 | print_sexpr_rec_list(c, printed_cons_cells, level); 160 | break; 161 | default: 162 | pi_error(MODE_ERROR, "unknown print mode"); 163 | } 164 | free(printed_cons_cells); 165 | } 166 | 167 | void print_cell_block(cell_block *block) { 168 | if (block) { 169 | size_t s = block->block_size; 170 | cell *arr = block->block; 171 | int i = 0; 172 | for (i = 0; i < s; i++) { 173 | #if PRINT_FREE_CELLS 174 | printf("%i\t", i); 175 | if (!cell_is_in_global_env(memory->global_env, (arr + i)) && 176 | !(arr + i)->marks) 177 | printf(ANSI_COLOR_GREEN); 178 | else if ((!cell_is_in_global_env(memory->global_env, (arr + i)) && 179 | (arr + i)->marks)) 180 | printf(ANSI_COLOR_RED); 181 | else 182 | printf(ANSI_COLOR_LIGHT_GREEN); 183 | 184 | printf("%p\t" ANSI_COLOR_RESET, arr + i); 185 | print_cell(arr + i); 186 | puts(""); 187 | #elif PRINT_ONLY_DANGLING_CELLS 188 | if ((arr + i)->type != TYPE_FREE && 189 | (!cell_is_in_global_env(memory->global_env, (arr + i)) && 190 | (arr + i)->marks)) { 191 | printf("%i\t", i); 192 | printf(ANSI_COLOR_RED); 193 | printf("%p\t" ANSI_COLOR_RESET, arr + i); 194 | print_cell(arr + i); 195 | puts(""); 196 | } 197 | #else 198 | if ((arr + i)->type != TYPE_FREE) { 199 | printf("%i\t", i); 200 | 201 | if (!cell_is_in_global_env(memory->global_env, (arr + i)) && 202 | !(arr + i)->marks) 203 | printf(ANSI_COLOR_GREEN); 204 | else if ((!cell_is_in_global_env(memory->global_env, (arr + i)) && 205 | (arr + i)->marks)) 206 | printf(ANSI_COLOR_RED); 207 | else 208 | printf(ANSI_COLOR_LIGHT_GREEN); 209 | 210 | printf("%p\t" ANSI_COLOR_RESET, arr + i); 211 | print_cell(arr + i); 212 | puts(""); 213 | } 214 | #endif 215 | } 216 | } 217 | } 218 | 219 | void print_cell(cell *cell) { 220 | if (cell) { 221 | printf(ANSI_COLOR_DARK_GRAY "(%d, %lu) " ANSI_COLOR_RESET, cell->marked, 222 | cell->marks); 223 | switch (cell->type) { 224 | case TYPE_CONS: 225 | printf("CONS\t" ANSI_COLOR_LIGHT_BLUE "( " ANSI_COLOR_RESET); 226 | if (!car(cell) || !is_cons(car(cell))) { 227 | // we can print here 228 | if (!car(cell)) 229 | printf("NILL"); 230 | else if (is_str(car(cell))) 231 | printf("%s", car(cell)->str); 232 | else if (is_sym(car(cell))) 233 | printf("%s", car(cell)->sym); 234 | else if (is_num(car(cell))) 235 | printf("%i", car(cell)->value); 236 | } else { 237 | // points to something we can't print 238 | printf("%p", cell->car); 239 | } 240 | printf(ANSI_COLOR_RED " . " ANSI_COLOR_RESET); 241 | if (!cdr(cell) || !is_cons(cdr(cell))) { 242 | // we can print here 243 | if (!cdr(cell)) 244 | printf("NILL"); 245 | else if (is_str(cdr(cell))) 246 | printf("%s", cdr(cell)->str); 247 | else if (is_sym(cdr(cell))) 248 | printf("%s", cdr(cell)->sym); 249 | else if (is_num(cdr(cell))) 250 | printf("%i", cdr(cell)->value); 251 | } else { 252 | // points to something we can't print 253 | printf("%p", cell->cdr); 254 | } 255 | printf(ANSI_COLOR_LIGHT_BLUE " ) " ANSI_COLOR_RESET); 256 | 257 | break; 258 | case TYPE_NUM: 259 | printf("NUM" ANSI_COLOR_LIGHT_BLUE "\t%i" ANSI_COLOR_RESET, cell->value); 260 | break; 261 | case TYPE_STR: 262 | printf("STR" ANSI_COLOR_LIGHT_BLUE "\t%s" ANSI_COLOR_RESET, cell->str); 263 | break; 264 | case TYPE_KEYWORD: 265 | printf("KEYW" ANSI_COLOR_LIGHT_BLUE "\t%s" ANSI_COLOR_RESET, cell->sym); 266 | break; 267 | case TYPE_BUILTINLAMBDA: 268 | case TYPE_BUILTINMACRO: 269 | case TYPE_SYM: 270 | printf("SYM" ANSI_COLOR_LIGHT_BLUE "\t%s" ANSI_COLOR_RESET, cell->sym); 271 | break; 272 | case TYPE_FREE: 273 | printf("FREE" ANSI_COLOR_LIGHT_BLUE "\t%p" ANSI_COLOR_RESET, 274 | cell->next_free_cell); 275 | break; 276 | } 277 | } else 278 | printf("NIL"); 279 | } 280 | 281 | void print_cell_space(cell_space *cs) { 282 | printf(ANSI_COLOR_BLUE "BUILTIN LAMBDAS\n" ANSI_COLOR_RESET); 283 | size_t i = 0; 284 | for (i = 0; i < builtin_lambdas_index; i++) { 285 | printf(ANSI_COLOR_LIGHT_BLUE "%lu" ANSI_COLOR_RESET "\t%s\t", i, 286 | BUILTIN_LAMBDAS[i].sym); 287 | if ((i + 1) % 5 == 0) 288 | puts(""); 289 | } 290 | 291 | printf(ANSI_COLOR_BLUE "\nBUILTIN MACROS\n" ANSI_COLOR_RESET); 292 | for (i = 0; i < builtin_macros_index; i++) { 293 | printf(ANSI_COLOR_LIGHT_BLUE "%lu" ANSI_COLOR_RESET "\t%s\t", i, 294 | BUILTIN_MACROS[i].sym); 295 | if ((i + 1) % 5 == 0) 296 | puts(""); 297 | } 298 | 299 | puts(""); 300 | printf(ANSI_COLOR_BLUE "GLOBAL ENV\n" ANSI_COLOR_RESET); 301 | print_global_env(cs->global_env); 302 | 303 | for (i = 0; i < cs->cell_space_size; i++) { 304 | printf(ANSI_COLOR_RED "Block %lu\n" ANSI_COLOR_RESET, i); 305 | print_cell_block(&cs->blocks[i]); 306 | } 307 | printf(ANSI_COLOR_YELLOW " > Free cells: \t\t%lu\n" ANSI_COLOR_RESET, 308 | cs->n_free_cells); 309 | printf(ANSI_COLOR_YELLOW " > First free cell: \t%p\n" ANSI_COLOR_RESET, 310 | cs->first_free); 311 | } 312 | 313 | void print_free_cells(cell_space *cs) { 314 | cell *free = cs->first_free; 315 | size_t i = 0; 316 | while (free) { 317 | printf("%lu\t" ANSI_COLOR_GREEN "%p\t" ANSI_COLOR_RED 318 | "%p\n" ANSI_COLOR_RESET, 319 | i, free, free->next_free_cell); 320 | i++; 321 | free = free->next_free_cell; 322 | } 323 | } 324 | 325 | void print_global_env(cell *env) { 326 | cell *act = env; 327 | printf("Head : %p\n", act); 328 | while (act) { 329 | cell *pair = car(act); 330 | printf(ANSI_COLOR_LIGHT_BLUE "%s\t" ANSI_COLOR_RESET, car(pair)->sym); 331 | print_sexpr(cdr(pair)); 332 | puts(""); 333 | act = cdr(act); 334 | } 335 | } 336 | 337 | void print_stack() { 338 | printf(ANSI_COLOR_GREEN "** Stack **\n" ANSI_COLOR_RESET); 339 | size_t i = 0; 340 | for (i = 0; i < stack_pointer; i++) { 341 | printf("%lu \t", i); 342 | print_sexpr(*(stack + i)); 343 | puts(""); 344 | } 345 | } 346 | 347 | static void print_sexpr_to_file_rec_default(cell *c, 348 | cell **printed_cons_cells, 349 | unsigned long level, FILE *f) { 350 | if (c) { 351 | switch (c->type) { 352 | case TYPE_NUM: 353 | fprintf(f, "%i", c->value); 354 | break; 355 | case TYPE_STR: 356 | fprintf(f, "\"%s\"", c->str); 357 | break; 358 | case TYPE_KEYWORD: 359 | case TYPE_BUILTINMACRO: 360 | case TYPE_BUILTINLAMBDA: 361 | fprintf(f, "%s", c->sym); 362 | break; 363 | case TYPE_SYM: 364 | fprintf(f, "%s", c->sym); 365 | break; 366 | case TYPE_CONS: 367 | if (!cell_was_printed(c, printed_cons_cells, level)) { 368 | printed_cons_cells[level++] = c; 369 | fprintf(f, "("); 370 | while (c->cdr && c->cdr->type == TYPE_CONS) { 371 | print_sexpr_to_file_rec_default(c->car, printed_cons_cells, level,f); 372 | fprintf(f, " "); 373 | c = c->cdr; 374 | } 375 | print_sexpr_to_file_rec_default(c->car, printed_cons_cells, level,f); 376 | if (c->cdr) { 377 | fprintf(f, " . "); 378 | print_sexpr_to_file_rec_default(c->cdr, printed_cons_cells, level,f); 379 | } 380 | fprintf(f, ")"); 381 | } 382 | break; 383 | case TYPE_FREE: 384 | fprintf(f, "FREE"); 385 | break; 386 | default: 387 | pi_error(MODE_ERROR, "unknown cell type"); 388 | break; 389 | } 390 | } else { 391 | fprintf(f, "NIL"); 392 | } 393 | } 394 | 395 | // file must be opened 396 | void print_sexpr_to_file(cell *c, FILE *f) { 397 | cell **printed_cons_cells = malloc(sizeof(cell *) * memory->n_cells); 398 | unsigned long level = 0; 399 | print_sexpr_to_file_rec_default(c, printed_cons_cells, level, f); 400 | free(printed_cons_cells); 401 | } -------------------------------------------------------------------------------- /src/piremove.c: -------------------------------------------------------------------------------- 1 | #include "piremove.h" 2 | 3 | void cell_remove_lambda(cell *env, cell *old_env, cell *args, cell *fn) { 4 | cell_remove_recursive(env->car->cdr); 5 | cell_remove_cars(args); // deep remove cars 6 | cell_remove_args(args); // remove args cons 7 | cell_remove_pairlis_deep(env, old_env); // remove associations 8 | unsafe_cell_remove(car(fn)); // function name 9 | cell_remove_recursive(cadr(fn)); // params 10 | unsafe_cell_remove(cddr(fn)); // cons pointing to body 11 | unsafe_cell_remove(cdr(fn)); // cons poining to param 12 | unsafe_cell_remove(fn); // cons pointing to lambda sym 13 | } 14 | 15 | void cell_remove_eval_macro(cell *new_env, cell *old_env, cell *expression) { 16 | cell_remove_pairlis(new_env, old_env); 17 | cell_remove_recursive(cdr(expression)); // params tree 18 | unsafe_cell_remove(cdr(cdar(expression))); // cons of the body 19 | cell_remove_recursive(cadar(expression)); // formal params 20 | unsafe_cell_remove(cdar(expression)); // cons of params 21 | cell_remove(caar(expression)); // symbol macro 22 | unsafe_cell_remove(car(expression)); // cons of macro 23 | unsafe_cell_remove(expression); // head of everything 24 | } 25 | 26 | void cell_remove_label(cell *new_env, cell *fn) { 27 | unsafe_cell_remove(cddr(fn)); // cons of the body 28 | unsafe_cell_remove(cadr(fn)); // symbol to bind 29 | unsafe_cell_remove(cdr(fn)); // cons of the top level 30 | unsafe_cell_remove(car(fn)); // symbol label 31 | unsafe_cell_remove(fn); // cons of everything 32 | unsafe_cell_remove(car(new_env)); // new cons of the pair of the new env 33 | cell_remove(new_env); // head of new env 34 | } 35 | 36 | void cell_remove_apply_macro(cell *env, cell *old_env, cell *args, cell *fn) { 37 | cell_remove_cars(args); // deep remove cars 38 | cell_remove_pairlis_deep(env, old_env); // remove associations 39 | unsafe_cell_remove(car(fn)); // function name 40 | cell_remove_recursive(cadr(fn)); // params 41 | unsafe_cell_remove(cddr(fn)); // cons pointing to body 42 | unsafe_cell_remove(cdr(fn)); // cons poining to param 43 | unsafe_cell_remove(fn); // cons pointing to lambda sym 44 | } 45 | 46 | void cell_remove_let_param(cell *params) { 47 | cell_remove(cdr(cdar(params))); 48 | cell_remove_recursive(cdar(params)); // maybe null 49 | unsafe_cell_remove(car(params)); // cons 50 | unsafe_cell_remove(params); 51 | } -------------------------------------------------------------------------------- /src/pistack.c: -------------------------------------------------------------------------------- 1 | #include "pistack.h" 2 | #include "picore.h" 3 | 4 | // EVERYTHING IS UNSAFE! 5 | 6 | void stack_push(cell *c) { 7 | stack[stack_pointer] = c; 8 | stack_pointer++; 9 | } 10 | 11 | cell *stack_pop() { 12 | cell *ret = stack[stack_pointer - 1]; 13 | stack_pointer--; 14 | return ret; 15 | } 16 | 17 | void empty_stack() { stack_pointer = 0; } 18 | 19 | void stack_car(size_t stack_base, unsigned char nargs) { 20 | stack_pointer--; 21 | if (stack[stack_base]) { 22 | cell *res = stack[stack_base]->car; 23 | cell_remove(stack[stack_base]); 24 | cell_remove_recursive(stack[stack_base]->cdr); 25 | stack_push(res); 26 | } else { 27 | stack_push(NULL); 28 | } 29 | } 30 | 31 | void stack_cdr(size_t stack_base, unsigned char nargs) { 32 | stack_pointer--; 33 | if (stack[stack_base]) { 34 | cell *res = stack[stack_base]->cdr; 35 | cell_remove(stack[stack_base]); 36 | cell_remove_recursive(stack[stack_base]->car); 37 | stack_push(res); 38 | } else { 39 | stack_push(NULL); 40 | } 41 | } 42 | 43 | void stack_list(size_t stack_base, unsigned char nargs) { 44 | cell *head = NULL; 45 | cell *last_created = NULL; 46 | unsigned char i = 0; 47 | for (i = 0; i < nargs; i++) { 48 | // stack_pointer--; 49 | if (i == 0) { 50 | last_created = head = mk_cons(stack[stack_base + i], NULL); 51 | } else { 52 | last_created->cdr = mk_cons(stack[stack_base + i], NULL); 53 | last_created = last_created->cdr; 54 | } 55 | } 56 | stack_pointer -= nargs; 57 | stack_push(head); 58 | } 59 | 60 | void stack_cons(size_t stack_base, unsigned char nargs) { 61 | stack_pointer -= 2; 62 | stack_push(cons(stack[stack_base],stack[stack_base+1])); 63 | } 64 | 65 | void stack_atom(size_t stack_base, unsigned char nargs) { 66 | stack_pointer--; 67 | stack_push( atom(stack[stack_base]) ? symbol_true : NULL); 68 | cell_remove(stack[stack_base]); 69 | } 70 | 71 | void stack_eq(size_t stack_base, unsigned char nargs) { 72 | stack_pointer -= 2; 73 | stack_push(eq(stack[stack_base], stack[stack_base+1]) ? symbol_true : NULL); 74 | cell_remove(stack[stack_base]); 75 | cell_remove(stack[stack_base+1]); 76 | } 77 | 78 | void stack_addition(size_t stack_base, unsigned char nargs) { 79 | size_t tot = 0; 80 | unsigned char i = 0; 81 | for (i = 0; i < nargs; i++) { 82 | tot += stack[stack_base + i]->value; 83 | unsafe_cell_remove(stack[stack_base + i]); 84 | } 85 | stack_pointer -= nargs; 86 | stack_push(mk_num(tot)); 87 | } 88 | 89 | cell *asm_call_with_stack_base(cell *args, cell *env, size_t stack_base) { 90 | cell *machine_code_cell = args->car; 91 | cell *initial_args = args; 92 | args = args->cdr; 93 | #if CHECKS 94 | if (!is_str(machine_code_cell)) 95 | pi_lisp_error("first arg of asm must be a machine code string"); 96 | #endif 97 | char *machine_code = machine_code_cell->str; 98 | size_t i = 0; 99 | size_t initial_stack_pointer = stack_pointer; 100 | char instruction; 101 | unsigned char nargs; 102 | cell *mutable_cell; // why this? beacuse first statement in a switch can' t be 103 | // a declaration, so we need to declare this first when we 104 | // would need a tmp var in the switch 105 | for (i = 0; i < strlen(machine_code); i++) { 106 | instruction = machine_code[i]; 107 | switch (instruction) { 108 | 109 | case '!': 110 | // load const 111 | stack_push(args->car); 112 | args = args->cdr; 113 | break; 114 | 115 | case '@': 116 | // load from stack 117 | nargs = (unsigned char)machine_code[i + 1] - 'A'; 118 | i++; 119 | size_t cell_index_in_stack = stack_base + nargs; 120 | cell *val = stack[cell_index_in_stack]; // calcola dove sta nello stack 121 | stack_push(val); 122 | break; 123 | 124 | case '$': 125 | // call builtin stack 126 | // get the next machine code: it will be the number of params 127 | nargs = (unsigned char)machine_code[i + 1] - 'A'; 128 | i++; 129 | cell *fun = args->car; 130 | args = args->cdr; 131 | fun->bs(stack_pointer - nargs, nargs); 132 | break; 133 | 134 | case '?': 135 | // extern name 136 | mutable_cell = assoc(args->car, env); 137 | stack_push(mutable_cell ? mutable_cell->cdr : NULL); 138 | args = args->cdr; 139 | break; 140 | 141 | default: 142 | pi_lisp_error("unknown machine code"); 143 | break; 144 | } 145 | } 146 | #if CHECKS 147 | if (stack_pointer > (initial_stack_pointer + 1)) 148 | pi_error_stack_overflow(); 149 | if (stack_pointer < (initial_stack_pointer + 1)) 150 | pi_error_stack_undeflow(); 151 | #endif 152 | unsafe_cell_remove(machine_code_cell); 153 | cell_remove_args(initial_args); 154 | return stack_pop(); 155 | } 156 | -------------------------------------------------------------------------------- /src/pitestutils.c: -------------------------------------------------------------------------------- 1 | #include "pitestutils.h" 2 | 3 | void parse_prompt() { 4 | printf("%s Welcome to the parser prompt, type sexpressions\n", PROMPT_STRING); 5 | while (1) { 6 | // sets the destination for longjump here if errors were encountered during 7 | // parsing 8 | jmp_destination = setjmp(env_buf); 9 | if (get_last_error() != NO_ERROR) { 10 | reset_error(); 11 | } else { 12 | pi_message("everything was ok with last sexpr"); 13 | } 14 | cell *root = read_sexpr(stdin); 15 | printf("lst> "); 16 | print_sexpr_mode(root, SEXPR_PRINT_DEFAULT); 17 | puts(""); 18 | printf("ext> "); 19 | print_sexpr_mode(root, SEXPR_PRINT_VERBOSE); 20 | puts(""); 21 | } 22 | } 23 | 24 | void lexer_prompt() { 25 | while (1) { 26 | printf("%s Welcome to the lexer prompt, type tokens\n", PROMPT_STRING); 27 | int token = 28 | next_token(stdin); // note: int, not char, required to handle EOF 29 | while (1) { 30 | print_token(token); 31 | token = next_token(stdin); 32 | } 33 | } 34 | } 35 | 36 | int lexer_file(FILE *f) { 37 | while (!feof(f)) 38 | read_sexpr(f); 39 | return 0; 40 | } 41 | 42 | void eval_prompt() { 43 | printf("%s Welcome to the eval prompt, type expressions to be evaluated\n", 44 | PROMPT_STRING); 45 | cell * env = memory->global_env; 46 | printf("env: "); 47 | print_sexpr(env); 48 | puts(""); 49 | while (1) { 50 | // sets the destination for longjump here if errors were encountered during 51 | // parsing 52 | jmp_destination = setjmp(env_buf); 53 | if (get_last_error() != NO_ERROR) { 54 | reset_error(); 55 | } 56 | printf("> "); 57 | cell *list1 = read_sexpr(stdin); 58 | cell *result = eval(list1, env); 59 | print_sexpr(result); 60 | puts(""); 61 | } 62 | } 63 | 64 | void pairlis_prompt() { 65 | printf("%s Welcome to the pairlis prompt, type pairs of sexpressions\n", 66 | PROMPT_STRING); 67 | printf("pairlis env: "); 68 | print_sexpr(memory->global_env); 69 | puts(""); 70 | cell * env = memory->global_env; 71 | while (1) { 72 | // sets the destination for longjump here if errors were encountered during 73 | // parsing 74 | jmp_destination = setjmp(env_buf); 75 | if (get_last_error() != NO_ERROR) { 76 | reset_error(); 77 | } 78 | pi_message("Type labels list: "); 79 | cell *list1 = read_sexpr(stdin); 80 | printf("First list> \t"); 81 | print_sexpr_mode(list1, SEXPR_PRINT_DEFAULT); 82 | puts(""); 83 | pi_message("Type values list: "); 84 | cell *list2 = read_sexpr(stdin); 85 | printf("Second list> \t"); 86 | print_sexpr_mode(list2, SEXPR_PRINT_DEFAULT); 87 | puts(""); 88 | 89 | cell *pairl = pairlis(list1, list2, env); 90 | printf("Pairlis> \t"); 91 | print_sexpr(pairl); 92 | puts(""); 93 | env = pairl; 94 | 95 | pi_message("Now insert one label"); 96 | cell *label = read_sexpr(stdin); 97 | cell *pair = assoc(label, env); 98 | print_sexpr(pair); 99 | puts(""); 100 | } 101 | } -------------------------------------------------------------------------------- /src/piutils.c: -------------------------------------------------------------------------------- 1 | #include "piutils.h" 2 | 3 | char *generate_pi_compile_tmp_file_name() { 4 | srand(time(NULL)); 5 | int r = rand(); 6 | 7 | char str[(int)((ceil(log10(r)) + 1) * sizeof(char))]; 8 | sprintf(str, "%d", r); 9 | char *file_name=malloc(strlen(PI_COMPILE_FILE_NAME_PREFIX) + strlen(str) + 1); 10 | file_name[0] = '\0'; 11 | strcat(file_name, PI_COMPILE_FILE_NAME_PREFIX); 12 | strcat(file_name, str); 13 | return file_name; 14 | } 15 | 16 | char *generate_pi_compiler_tmp_file_name() { 17 | srand(time(NULL)); 18 | int r = rand(); 19 | 20 | char str[(int)((ceil(log10(r)) + 1) * sizeof(char))]; 21 | sprintf(str, "%d", r); 22 | char *file_name=malloc(strlen(PI_COMPILER_FILE_NAME_PREFIX) + strlen(str) + 1); 23 | file_name[0] = '\0'; 24 | strcat(file_name, PI_COMPILER_FILE_NAME_PREFIX); 25 | strcat(file_name, str); 26 | return file_name; 27 | } -------------------------------------------------------------------------------- /test/bad_prints_test.c: -------------------------------------------------------------------------------- 1 | #include "pilisp.h" 2 | #include "pitestutils.h" 3 | #include 4 | 5 | int print_bad_cell_test() { 6 | jmp_destination = setjmp(env_buf); 7 | if (had_error()) { 8 | if (get_last_error() != MODE_ERROR) { 9 | // there was an error that was'nt the one we were looking for 10 | return 1; 11 | } else { 12 | // good: we had the rigth error 13 | return 0; 14 | } 15 | } 16 | cell * c = mk_cons(NULL,NULL); 17 | c->type = -1; 18 | print_sexpr(c); 19 | // if you arrive here you printed a bad cell 20 | return 1; 21 | } 22 | 23 | int print_verbose_bad_cell_test() { 24 | jmp_destination = setjmp(env_buf); 25 | if (had_error()) { 26 | if (get_last_error() != MODE_ERROR) { 27 | // there was an error that was'nt the one we were looking for 28 | return 1; 29 | } else { 30 | // good: we had the rigth error 31 | return 0; 32 | } 33 | } 34 | cell * c = mk_cons(NULL,NULL); 35 | c->type = -1; 36 | print_sexpr_mode(c,SEXPR_PRINT_VERBOSE); 37 | // if you arrive here you printed a bad cell 38 | return 1; 39 | } 40 | 41 | int print_bad_token_test() { 42 | jmp_destination = setjmp(env_buf); 43 | if (had_error()) { 44 | if (get_last_error() != MODE_ERROR) { 45 | // there was an error that was'nt the one we were looking for 46 | return 1; 47 | } else { 48 | // good: we had the rigth error 49 | return 0; 50 | } 51 | } 52 | int tok = -1; 53 | print_token(tok); 54 | // if you arrive here you printed a bad cell 55 | return 1; 56 | } 57 | 58 | int print_bad_mode_test() { 59 | jmp_destination = setjmp(env_buf); 60 | if (had_error()) { 61 | if (get_last_error() != MODE_ERROR) { 62 | // there was an error that was'nt the one we were looking for 63 | return 1; 64 | } else { 65 | // good: we had the rigth error 66 | return 0; 67 | } 68 | } 69 | print_sexpr_mode(NULL,-1); 70 | // if you arrive here you printed a bad cell 71 | return 1; 72 | } 73 | 74 | int main(int argc, char **argv) { 75 | init_pi(); 76 | return print_bad_cell_test() || print_verbose_bad_cell_test() || print_bad_token_test(); 77 | } -------------------------------------------------------------------------------- /test/expressions/atom.lisp: -------------------------------------------------------------------------------- 1 | 1 -------------------------------------------------------------------------------- /test/expressions/atoms.lisp: -------------------------------------------------------------------------------- 1 | 1 2 2 3 2 | ; commento 3 | 4 232323 "ciao" 2 "ciao" 2 hi 4 | ; ( . . . . .) ; not error because it's a comment 5 | 4 -------------------------------------------------------------------------------- /test/expressions/badexpressions/closedpar.lisp: -------------------------------------------------------------------------------- 1 | ) -------------------------------------------------------------------------------- /test/expressions/badexpressions/complicate.lisp: -------------------------------------------------------------------------------- 1 | ((1 . 2) . (1 . (() . "hello" .))) -------------------------------------------------------------------------------- /test/expressions/badexpressions/unfinished.lisp: -------------------------------------------------------------------------------- 1 | (1 . ) -------------------------------------------------------------------------------- /test/expressions/dotexpressions.lisp: -------------------------------------------------------------------------------- 1 | ((1 . 2) . (1 . 2)) 2 | () 3 | (1 . 2) 4 | (1 . 2) (1 . 2) 5 | (1 . 2)(1 . 2)(1 . 2)(1 . 2) 6 | ()() 7 | ;((1 . 2) . (1 . (() . "hello"))) 8 | ;(("hello" . world) . ()) 9 | ;; (()) ; error 10 | ;; (1) ; error 11 | ;() -------------------------------------------------------------------------------- /test/expressions/listnotation1.lisp: -------------------------------------------------------------------------------- 1 | ; these examples come from LISP 1.5 book, page 4 2 | (a b c) 3 | ((a b) c) 4 | (a b (c d)) 5 | (a) 6 | ((a)) 7 | (a (b .c)) 8 | ; the next are the dot version of the first group 9 | (a . (b . (c . NIL))) 10 | ((a.(b.NIL)).(c.NIL)) 11 | (a.(b.((c.(d.NIL)).NIL))) 12 | (a.NIL) 13 | ((a.NIL).NIL) 14 | (a.((b.c).NIL)) 15 | -------------------------------------------------------------------------------- /test/expressions/listnotation2.lisp: -------------------------------------------------------------------------------- 1 | (" hello " from 123 my ( alien . planet)) 2 | (123 123 123 (this is ( a ) test) my (planet)) 3 | ((this is ( a ) test) . (NIL)) ("hey" . "man") () 4 | (((((((a))))))) 5 | (a b c we) 6 | (A NILL) -------------------------------------------------------------------------------- /test/expressions/tokens.lisp: -------------------------------------------------------------------------------- 1 | ( ) ' . hello 123 "string" -------------------------------------------------------------------------------- /test/expressions/void.lisp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/phreppo/pilisp/55d559126e04fd1148748085877ee43c674b26ba/test/expressions/void.lisp -------------------------------------------------------------------------------- /test/lisp_program_load_test.c: -------------------------------------------------------------------------------- 1 | #include "pilisp.h" 2 | #include 3 | #include 4 | 5 | int fpeek(FILE *const fp) { 6 | const int c = getc(fp); 7 | return c == EOF ? 0 : ungetc(c, fp); 8 | } 9 | 10 | char *string_merge(char *str1, char *str2) { 11 | if (!str1) 12 | str1 = ""; 13 | if (!str2) 14 | str2 = ""; 15 | char *new_str = malloc(strlen(str1) + strlen(str2) + 1); 16 | new_str[0] = '\0'; // ensures the memory is an empty string 17 | strcat(new_str, str1); 18 | strcat(new_str, str2); 19 | return new_str; 20 | } 21 | 22 | // how to use: 23 | // [1] = program file path; 24 | // [2] = program to execute after the first; 25 | // [3] = sexpression result; 26 | // [4](optional) = file number. why [4]? beacuse when you run many tests at the 27 | // same you can occur in file opening errors 28 | // 29 | // Execution: load and parse the [1] program (write there your test functions) 30 | // => execute the program in [2] => check that the result of the last 31 | // sexpression in equal to [3] 32 | int main(int argc, char **argv) { 33 | init_pi(); 34 | char *load_file_name = argv[1]; 35 | parse_file(load_file_name); 36 | 37 | char *program = argv[2]; 38 | puts(program); 39 | 40 | char *result = argv[3]; 41 | 42 | char *file_number = (argc >= 4 ? argv[4] : 0); 43 | 44 | // write the program in a file 45 | char *program_file_name_no_ext = string_merge("sourcep", file_number); 46 | char *program_file_path = string_merge(program_file_name_no_ext, ".lisp"); 47 | free(program_file_name_no_ext); 48 | FILE *program_file_write = fopen(program_file_path, "w"); 49 | int results = fputs(program, program_file_write); 50 | if (results == EOF) { 51 | puts("error writing program file"); 52 | free(program_file_path); 53 | return 1; 54 | } 55 | fclose(program_file_write); 56 | 57 | // execute the file 58 | FILE *program_file_read = fopen(program_file_path, "r"); 59 | if (!program_file_read) { 60 | puts("error reading program file"); 61 | free(program_file_path); 62 | return 1; 63 | } 64 | cell *res = NULL; 65 | cell *env = memory->global_env; 66 | jmp_destination = setjmp(env_buf); 67 | if (had_error()) { 68 | puts("error processing program"); 69 | free(program_file_path); 70 | return 1; 71 | } 72 | while (!feof(program_file_read) && fpeek(program_file_read)) { 73 | cell *sexpr = read_sexpr(program_file_read); 74 | res = eval(sexpr, env); 75 | } 76 | fclose(program_file_read); 77 | free(program_file_path); 78 | printf("%i ", (res ? res->value : 0)); 79 | 80 | // write the raw result to a file 81 | char *result_file_name_no_ext = string_merge("resultp", file_number); 82 | char *result_file_path = string_merge(result_file_name_no_ext, ".lisp"); 83 | FILE *result_file_write = fopen(result_file_path, "w"); 84 | int r1 = fputs(result, result_file_write); 85 | if (r1 == EOF) { 86 | puts("error writing result file"); 87 | free(result_file_name_no_ext); 88 | free(result_file_path); 89 | return 1; 90 | } 91 | fclose(result_file_write); 92 | 93 | // read the raw result 94 | FILE *result_file_read = fopen(result_file_path, "r"); 95 | if (!result_file_read) { 96 | puts("error reading result file"); 97 | free(result_file_name_no_ext); 98 | free(result_file_path); 99 | return 1; 100 | } 101 | cell *expected_result = read_sexpr(result_file_read); 102 | fclose(result_file_read); 103 | free(result_file_name_no_ext); 104 | free(result_file_path); 105 | int ret = (total_eq(expected_result, res)); 106 | free_pi(); 107 | return !(ret); 108 | } 109 | -------------------------------------------------------------------------------- /test/lisp_program_test.c: -------------------------------------------------------------------------------- 1 | #include "picell.h" 2 | #include "pilisp.h" 3 | #include 4 | #include 5 | 6 | int fpeek(FILE *const fp) { 7 | const int c = getc(fp); 8 | return c == EOF ? 0 : ungetc(c, fp); 9 | } 10 | 11 | char *string_merge(char *str1, char *str2) { 12 | if (!str1) 13 | str1 = ""; 14 | if (!str2) 15 | str2 = ""; 16 | char *new_str = malloc(strlen(str1) + strlen(str2) + 1); 17 | new_str[0] = '\0'; // ensures the memory is an empty string 18 | strcat(new_str, str1); 19 | strcat(new_str, str2); 20 | return new_str; 21 | } 22 | 23 | // how to use: [1] = program text; [2] = sexpression result; [3](optional) = 24 | // file number. why [3]? beacuse when you run many tests at the same you can 25 | // occur in file opening errors 26 | int main(int argc, char **argv) { 27 | char *program = argv[1]; 28 | puts(program); 29 | char *result = argv[2]; 30 | 31 | char *file_number = (argc >= 3 ? argv[3] : 0); 32 | 33 | // write the program in a file 34 | char *program_file_name_no_ext = string_merge("sourcep", file_number); 35 | char *program_file_path = string_merge(program_file_name_no_ext, ".lisp"); 36 | FILE *program_file_write = fopen(program_file_path, "w"); 37 | int results = fputs(program, program_file_write); 38 | if (results == EOF) { 39 | puts("error writing program file"); 40 | free(program_file_path); 41 | free(program_file_name_no_ext); 42 | return 1; 43 | } 44 | fclose(program_file_write); 45 | 46 | // execute the file 47 | FILE *program_file_read = fopen(program_file_path, "r"); 48 | if (!program_file_read) { 49 | puts("error reading program file"); 50 | free(program_file_path); 51 | free(program_file_name_no_ext); 52 | return 1; 53 | } 54 | free(program_file_path); 55 | free(program_file_name_no_ext); 56 | 57 | init_pi(); 58 | cell *res = NULL; 59 | cell *env = memory->global_env; 60 | jmp_destination = setjmp(env_buf); 61 | if (had_error()) { 62 | puts("error processing program"); 63 | return 1; 64 | } 65 | while (!feof(program_file_read) && fpeek(program_file_read)) { 66 | cell *sexpr = read_sexpr(program_file_read); 67 | res = eval(sexpr, env); 68 | } 69 | fclose(program_file_read); 70 | // printf("%i ", res->value); 71 | 72 | // write the raw result to a file 73 | char *result_file_name_no_ext = string_merge("resultp", file_number); 74 | char *result_file_path = string_merge(result_file_name_no_ext, ".lisp"); 75 | FILE *result_file_write = fopen(result_file_path, "w"); 76 | int r1 = fputs(result, result_file_write); 77 | if (r1 == EOF) { 78 | puts("error writing result file"); 79 | free(result_file_path); 80 | free(result_file_name_no_ext); 81 | return 1; 82 | } 83 | fclose(result_file_write); 84 | 85 | // read the raw result 86 | FILE *result_file_read = fopen(result_file_path, "r"); 87 | if (!result_file_read) { 88 | puts("error reading result file"); 89 | free(result_file_path); 90 | free(result_file_name_no_ext); 91 | return 1; 92 | } 93 | cell *expected_result = read_sexpr(result_file_read); 94 | fclose(result_file_read); 95 | free(result_file_path); 96 | free(result_file_name_no_ext); 97 | int ret = (total_eq(expected_result, res)); 98 | free_pi(); 99 | return !ret; 100 | } 101 | -------------------------------------------------------------------------------- /test/lisp_programs/compilable_diff.lisp: -------------------------------------------------------------------------------- 1 | ;; (time (dotimes (n 100000) (d '(/ (+ (expt x 2) 1) (cos x))))) 2 | 3 | ;; needs the compiler to be loaded 4 | 5 | (defun first_arg (func) (car (cdr func)) ) 6 | (defun second_arg (func) (car (cdr (cdr func))) ) 7 | (defun fun_name (func) (car func) ) 8 | 9 | (defun mult (first second) (cons '* (cons first (cons second NIL))) ) 10 | (defun expo (first second) (cons 'expt (cons first (cons second NIL))) ) 11 | (defun sum (first second) (cons '+ (cons first (cons second NIL))) ) 12 | (defun diff (first second) (cons '- (cons first (cons second NIL))) ) 13 | (defun frac (first second) (cons '/ (cons first (cons second NIL))) ) 14 | 15 | (defun is_ln (func) (eq (car func) 'ln)) 16 | (defun is_exp (func) (eq (car func) 'exp)) 17 | (defun is_expt (func) (eq (car func) 'expt)) 18 | (defun is_sin (func) (eq (car func) 'sin)) 19 | (defun is_cos (func) (eq (car func) 'cos)) 20 | (defun is_tan (func) (eq (car func) 'tan)) 21 | (defun is_sum (func) (eq (car func) '+)) 22 | (defun is_mult (func) (eq (car func) '*)) 23 | (defun is_div (func) (eq (car func) '/)) 24 | 25 | (defun d (func) ( cond 26 | ((integerp func) 0) 27 | ((symbolp func) 1) 28 | (( is_ln func) 29 | ( mult 30 | ( frac 1 ( first_arg func)) 31 | ( d ( first_arg func)))) 32 | (( is_exp func) 33 | ( mult 34 | func 35 | ( d ( first_arg func)))) 36 | (( is_expt func) 37 | ( mult 38 | (cons 'expt (cons ( first_arg func) (- ( second_arg func ) 1))) 39 | ( second_arg func))) 40 | (( is_sin func) 41 | ( mult 42 | (cons 'cos (cons ( first_arg func) NIL)) 43 | ( d ( first_arg func)))) 44 | (( is_cos func) 45 | ( mult 46 | ( mult (cons 'sin (cons ( first_arg func) NIL)) -1) 47 | ( d ( first_arg func)))) 48 | (( is_tan func) 49 | ( mult 50 | ( frac 51 | 1 52 | ( expo (cons 'cos (cons ( first_arg func) NIL)) 2) ) 53 | ( d ( first_arg func)))) 54 | (( is_sum func) 55 | ( sum 56 | ( d ( first_arg func)) 57 | ( d ( second_arg func)))) 58 | (( is_mult func) 59 | ( sum 60 | ( mult ( d ( first_arg func)) ( second_arg func)) 61 | ( mult ( first_arg func) ( d ( second_arg func))))) 62 | (( is_div func) 63 | ( frac 64 | ( diff 65 | ( mult ( d ( first_arg func)) ( second_arg func)) 66 | ( mult ( first_arg func) ( d ( second_arg func)))) 67 | ( expo ( second_arg func) 2))) 68 | (t NIL))) 69 | 70 | t 71 | 72 | (compile first_arg) 73 | (compile second_arg) 74 | (compile fun_name) 75 | (compile mult) 76 | (compile expo) 77 | (compile sum) 78 | (compile diff) 79 | (compile frac) 80 | (compile is_ln) 81 | (compile is_exp) 82 | (compile is_expt) 83 | (compile is_sin) 84 | (compile is_cos) 85 | (compile is_tan) 86 | (compile is_sum) 87 | (compile is_mult) 88 | (compile is_div) 89 | 90 | t -------------------------------------------------------------------------------- /test/lisp_programs/diff.lisp: -------------------------------------------------------------------------------- 1 | (defun first_arg (func) (car (cdr func)) ) 2 | (defun second_arg (func) (car (cdr (cdr func))) ) 3 | (defun fun_name (func) (car func) ) 4 | 5 | (defun mult (first second) (cons '* (cons first (cons second NIL))) ) 6 | (defun expo (first second) (cons 'expt (cons first (cons second NIL))) ) 7 | (defun sum (first second) (cons '+ (cons first (cons second NIL))) ) 8 | (defun diff (first second) (cons '- (cons first (cons second NIL))) ) 9 | (defun frac (first second) (cons '/ (cons first (cons second NIL))) ) 10 | 11 | (defun is_ln (func) (eq (car func) 'ln)) 12 | (defun is_exp (func) (eq (car func) 'exp)) 13 | (defun is_expt (func) (eq (car func) 'expt)) 14 | (defun is_sin (func) (eq (car func) 'sin)) 15 | (defun is_cos (func) (eq (car func) 'cos)) 16 | (defun is_tan (func) (eq (car func) 'tan)) 17 | (defun is_sum (func) (eq (car func) '+)) 18 | (defun is_mult (func) (eq (car func) '*)) 19 | (defun is_div (func) (eq (car func) '/)) 20 | 21 | (defun d (func) ( cond 22 | ((integerp func) 0) 23 | ((symbolp func) 1) 24 | (( is_ln func) 25 | ( mult 26 | ( frac 1 ( first_arg func)) 27 | ( d ( first_arg func)))) 28 | (( is_exp func) 29 | ( mult 30 | func 31 | ( d ( first_arg func)))) 32 | (( is_expt func) 33 | ( mult 34 | (cons 'expt (cons ( first_arg func) (- ( second_arg func ) 1))) 35 | ( second_arg func))) 36 | (( is_sin func) 37 | ( mult 38 | (cons 'cos (cons ( first_arg func) NIL)) 39 | ( d ( first_arg func)))) 40 | (( is_cos func) 41 | ( mult 42 | ( mult (cons 'sin (cons ( first_arg func) NIL)) -1) 43 | ( d ( first_arg func)))) 44 | (( is_tan func) 45 | ( mult 46 | ( frac 47 | 1 48 | ( expo (cons 'cos (cons ( first_arg func) NIL)) 2) ) 49 | ( d ( first_arg func)))) 50 | (( is_sum func) 51 | ( sum 52 | ( d ( first_arg func)) 53 | ( d ( second_arg func)))) 54 | (( is_mult func) 55 | ( sum 56 | ( mult ( d ( first_arg func)) ( second_arg func)) 57 | ( mult ( first_arg func) ( d ( second_arg func))))) 58 | (( is_div func) 59 | ( frac 60 | ( diff 61 | ( mult ( d ( first_arg func)) ( second_arg func)) 62 | ( mult ( first_arg func) ( d ( second_arg func)))) 63 | ( expo ( second_arg func) 2))) 64 | (t NIL))) 65 | 66 | t -------------------------------------------------------------------------------- /test/lisp_programs/factorial.lisp: -------------------------------------------------------------------------------- 1 | (defun factorial (x) 2 | (cond 3 | ((or (not (integerp x)) (< x 0)) 4 | nil) 5 | ((eq x 0) 6 | 1) 7 | (t 8 | (* x (factorial (- x 1)))))) -------------------------------------------------------------------------------- /test/lisp_programs/ibeforee.lisp: -------------------------------------------------------------------------------- 1 | ; CHALLANGE TOOK FROM: https://www.reddit.com/r/dailyprogrammer/comments/8q96da/20180611_challenge_363_easy_i_before_e_except/ 2 | ; ********************************************** 3 | ; * I before E except after C 4 | ; ********************************************** 5 | ; Background 6 | ; "I before E except after C" is perhaps the most famous English spelling rule. For the purpose of this ; challenge, the rule says: 7 | ; 8 | ; if "ei" appears in a word, it must immediately follow "c". 9 | ; If "ie" appears in a word, it must not immediately follow "c". 10 | ; 11 | ; A word also follows the rule if neither "ei" nor "ie" appears anywhere in the word. Examples of words that ; follow this rule are: 12 | ; ====================== 13 | ; fiery hierarchy hieroglyphic 14 | ; ceiling inconceivable receipt 15 | ; daily programmer one two three 16 | ; ====================== 17 | ; 18 | ; There are many exceptions that don't follow this rule, such as: 19 | ; ====================== 20 | ; sleigh stein fahrenheit 21 | ; deifies either nuclei reimburse 22 | ; ancient juicier societies 23 | ; ====================== 24 | ; 25 | ; Challenge 26 | ; Write a function that tells you whether or not a given word follows the "I before E except after C" rule. 27 | ; 28 | ; check("a") => true 29 | ; check("zombie") => true 30 | ; check("transceiver") => true 31 | ; check("veil") => false 32 | ; check("icier") => false 33 | 34 | 35 | (defun string-include (string1 string2) 36 | (cond 37 | ((eq (length string1) 0) nil) 38 | ((> (length string1) (length string2)) nil) 39 | ((eq string1 (subseq string2 0 (length string1))) string1) 40 | (t ( string-include string1 (subseq string2 1))))) 41 | 42 | (defun check 43 | (word) 44 | (cond 45 | ((string-include "cie" word) NIL) 46 | ((and (string-include "ei" word) 47 | (not (string-include "cei" word))) NIL) 48 | (t t))) -------------------------------------------------------------------------------- /test/lisp_programs/list_operations.lisp: -------------------------------------------------------------------------------- 1 | (defun list_max_rec (l index act_max) 2 | (cond 3 | ((>= index (length l)) 4 | act_max) 5 | ((> (nth index l) act_max) 6 | (list_max_rec l (+ index 1) (nth index l))) 7 | (t 8 | (list_max_rec l (+ index 1) act_max)))) 9 | 10 | (defun list_max (l) 11 | (list_max_rec l 1 (nth 0 l))) 12 | 13 | (defmacro get-from-list(list pred) 14 | `(let ((ans (first ,list))) 15 | (do ((i 1 (1+ i))) 16 | ((>= i (length ,list)) ans) 17 | (when (,pred (nth i ,list) ans) 18 | (setf ans (nth i ,list)))))) 19 | 20 | (defun list_max_rec (l index act_max pred) 21 | (cond 22 | ((>= index (length l)) 23 | act_max) 24 | ((pred (nth index l) act_max) 25 | (list_max_rec l (+ index 1) (nth index l))) 26 | (t 27 | (list_max_rec l (+ index 1) act_max)))) 28 | -------------------------------------------------------------------------------- /test/lisp_programs/loadtest.lisp: -------------------------------------------------------------------------------- 1 | (set 'n 1) -------------------------------------------------------------------------------- /test/lisp_programs/maps.lisp: -------------------------------------------------------------------------------- 1 | (setq ' 2 | () 3 | ) -------------------------------------------------------------------------------- /test/lisp_programs/max.lisp: -------------------------------------------------------------------------------- 1 | (defun list_max_rec (l index act_max) 2 | (cond 3 | ((>= index (length l)) 4 | act_max) 5 | ((> (nth index l) act_max) 6 | (list_max_rec l (+ index 1) (nth index l))) 7 | (t 8 | (list_max_rec l (+ index 1) act_max)))) 9 | 10 | (defun list_max (l) 11 | (list_max_rec l 1 (nth 0 l))) -------------------------------------------------------------------------------- /test/lisp_programs/maze.lisp: -------------------------------------------------------------------------------- 1 | (setq maze1 '( 2 | (1) 3 | (0 3) 4 | (3 -1) 5 | (1 2) 6 | )) 7 | 8 | (setq maze2 '( 9 | (3 1) ;0 10 | (0 2 4) ;1 11 | (1 5) ;2 12 | (0 4) ;3 13 | (1 3) ;4 14 | (2 8) ;5 15 | (-1 7) ;6 16 | (6 8) ;7 17 | (5 7) ;8 18 | )) 19 | 20 | (setq maze3 '( 21 | (4) ; 0 22 | (2) ; 1 23 | (1 3) ; 2 24 | (2 7) ; 3 25 | (8 5 0) ; 4 26 | (4 6) ; 5 27 | (5 7) ; 6 28 | (3 11 6) ; 7 29 | (4) ; 8 30 | (10 13) ; 9 31 | (9 14) ; 10 32 | (7 15) ; 11 33 | (13 -1) ; 12 34 | (9 12) ; 13 35 | (10 15) ; 14 36 | (11 14) ; 15 37 | )) 38 | 39 | (defun sm1 (maze actualCell exploredCells doors) 40 | (cond 41 | ( (not doors) 42 | nil ) 43 | ( t 44 | (cond 45 | ( (not (solveMazeRec maze (car doors) exploredCells)) 46 | (sm1 maze actualCell exploredCells (cdr doors)) ) 47 | ( t 48 | (solveMazeRec maze (car doors) exploredCells) 49 | ) ) ) ) ) 50 | 51 | (defun solveMazeRec 52 | (maze actualCell exploredCells) 53 | (cond 54 | ((= actualCell -1) 55 | exploredCells 56 | ) 57 | ((member actualCell exploredCells) 58 | nil) 59 | (t 60 | (sm1 maze actualCell (cons actualCell exploredCells) (nth actualCell maze)) 61 | ) ) ) 62 | 63 | 64 | (defun solveMaze 65 | (maze) 66 | (solveMazeRec maze 0 '()) ) 67 | -------------------------------------------------------------------------------- /test/lisp_programs/maze_let.lisp: -------------------------------------------------------------------------------- 1 | (setq maze1 (quote ((1) (0 3) (3 -1) (1 2)))) 2 | 3 | (defun sm1 (maze actualCell exploredCells doors) 4 | (cond 5 | ((not doors) nil) 6 | (t 7 | (cond 8 | ( (not (solveMazeRec maze (car doors) exploredCells)) 9 | (sm1 maze actualCell exploredCells (cdr doors))) 10 | (t (solveMazeRec maze (car doors) exploredCells)))))) 11 | 12 | (defun solveMazeRec (maze actualCell exploredCells) 13 | (cond 14 | ((= actualCell -1) exploredCells) 15 | ((member actualCell exploredCells) nil) 16 | (t 17 | (let ((newExplored (cons actualCell exploredCells)) (doors (nth actualCell maze))) 18 | (cond 19 | ((not doors) nil) 20 | (t 21 | (cond 22 | ( (not (solveMazeRec maze (car doors) newExplored)) 23 | (sm1 maze actualCell newExplored (cdr doors))) 24 | (t (solveMazeRec maze (car doors) newExplored))))))))) 25 | 26 | (defun solveMaze (maze) (solveMazeRec maze 0 (quote ()))) 27 | 28 | ;((label solveMazeRec 29 | ; (lambda (maze actualCell exploredCells) 30 | ; (cond 31 | ; ((= actualCell -1) exploredCells) 32 | ; ((member actualCell exploredCells) nil) 33 | ; (t 34 | ; (let ((newExplored (cons actualCell exploredCells)) (doors (nth actualCell maze))) 35 | ; (cond 36 | ; ((not doors) nil) 37 | ; (t 38 | ; (cond 39 | ; ( (not (solveMazeRec maze (car doors) newExplored)) 40 | ; (sm1 maze actualCell newExplored (cdr doors))) 41 | ; (t (solveMazeRec maze (car doors) newExplored)))))))))) 42 | ; (quote ((1) (0 3) (3 -1) (1 2))) 0 (quote ())) 43 | ; 44 | ; solves! 45 | -------------------------------------------------------------------------------- /test/lisp_programs/maze_old.lisp: -------------------------------------------------------------------------------- 1 | (set 'maze1 '( 2 | (1) 3 | (0 3) 4 | (3 -1) 5 | (1 2) 6 | )) 7 | 8 | (set 'sm1 9 | (lambda (maze actualCell exploredCells doors) 10 | (cond 11 | ( 12 | (not doors) 13 | ; no exit 14 | nil 15 | ) ( 16 | t ; at least one door 17 | (cond 18 | ( (not (solveMazeRec maze (car doors) exploredCells)) 19 | ; => the result is not a valid path 20 | (sm1 maze actualCell exploredCells (cdr doors)) 21 | ) 22 | ( t ; => the result is a valid path 23 | (solveMazeRec maze (car doors) exploredCells) 24 | ) 25 | ) 26 | ) 27 | ) 28 | ) 29 | ) 30 | 31 | (set 'solveMazeRec 32 | (lambda (maze actualCell exploredCells) 33 | (cond 34 | ((= actualCell -1) 35 | ; finished 36 | exploredCells 37 | ) 38 | ((member actualCell exploredCells) 39 | ; already explored this path 40 | nil) 41 | (t 42 | ; not finished 43 | (sm1 maze actualCell (cons actualCell exploredCells) (nth actualCell maze)) 44 | ) 45 | ) 46 | ) 47 | ) 48 | 49 | (set 'solveMaze 50 | (lambda (maze) 51 | (solveMazeRec maze 0 '())) 52 | ) 53 | 54 | ; (solveMaze maze1) -------------------------------------------------------------------------------- /test/parser_accepted_strings_test.c: -------------------------------------------------------------------------------- 1 | #include "pilisp.h" 2 | #include "pitestutils.h" 3 | #include 4 | 5 | int parser_test(char *file_path_name) { 6 | FILE *fp; 7 | if ((fp = fopen(file_path_name, "r")) == NULL) { 8 | printf("Error opening file\n"); 9 | exit(1); 10 | } 11 | jmp_destination = setjmp(env_buf); 12 | if(get_last_error() == LISP_ERROR){ 13 | // there was an error reading good sexpressions 14 | return 1; 15 | } 16 | lexer_file(fp); 17 | fclose(fp); 18 | return 0; 19 | } 20 | 21 | int main(int argc, char **argv) { 22 | init_pi(); 23 | char *file_path_name = argv[1]; 24 | printf("File name: %s\n", file_path_name); 25 | return parser_test(file_path_name); 26 | } -------------------------------------------------------------------------------- /test/parser_rejected_strings_test.c: -------------------------------------------------------------------------------- 1 | #include "pilisp.h" 2 | #include "pitestutils.h" 3 | #include 4 | 5 | int parser_test(char *file_path_name) { 6 | FILE *fp; 7 | if ((fp = fopen(file_path_name, "r")) == NULL) { 8 | printf("Error opening file\n"); 9 | return 1; 10 | } 11 | jmp_destination = setjmp(env_buf); 12 | int error = get_last_error(); 13 | if (had_error()) { 14 | // good: we had an error 15 | if (error != LISP_ERROR) { 16 | // there wasn't an error reading bad sexpressions: test failed 17 | return 1; 18 | } else { 19 | // it is a LISP_ERROR: we recognized an invalid sexpression: test is valid! 20 | reset_error(); 21 | return 0; 22 | } 23 | } 24 | lexer_file(fp); 25 | fclose(fp); 26 | return 1; // an invaid sexpression had not rised an error: test failed 27 | } 28 | 29 | int main(int argc, char **argv) { 30 | char *file_path_name = argv[1]; 31 | init_pi(); 32 | // char file_path_name[] = "/home/phreppo/pilisp/test/expressions/badexpressions/badsexpr1.l"; 33 | printf("File name: %s\n", file_path_name); 34 | return parser_test(file_path_name); 35 | } -------------------------------------------------------------------------------- /test/print_lexer_test.c: -------------------------------------------------------------------------------- 1 | #include "pilisp.h" 2 | #include "pitestutils.h" 3 | #include 4 | 5 | int print_lexer_test(char *file_path_name) { 6 | FILE *fp; 7 | if ((fp = fopen(file_path_name, "r")) == NULL) { 8 | printf("Error opening file\n"); 9 | exit(1); 10 | } 11 | while (!feof(fp)) { 12 | int tok = next_token(fp); 13 | print_token(tok); 14 | } 15 | fseek(fp, 0, SEEK_SET); 16 | fclose(fp); 17 | return 0; 18 | } 19 | 20 | int main(int argc, char **argv) { 21 | char * file_path_name = argv[1]; 22 | // char file_path_name[] = "/home/phreppo/pilisp/test/expressions/dotexpressions.lisp";; 23 | printf("File name: %s\n", file_path_name); 24 | return print_lexer_test(file_path_name); 25 | } -------------------------------------------------------------------------------- /test/print_test.c: -------------------------------------------------------------------------------- 1 | #include "pilisp.h" 2 | #include "pitestutils.h" 3 | #include 4 | 5 | int print_parser_test(char *file_path_name) { 6 | FILE *fp; 7 | if ((fp = fopen(file_path_name, "r")) == NULL) { 8 | printf("Error opening file\n"); 9 | exit(1); 10 | } 11 | jmp_destination = setjmp(env_buf); 12 | if (get_last_error() == LISP_ERROR) { 13 | // there was an error reading good sexpressions 14 | return 1; 15 | } 16 | while (!feof(fp)) { 17 | cell * root = read_sexpr(fp); 18 | if (root) { 19 | print_sexpr(root); 20 | print_sexpr_mode(root, SEXPR_PRINT_DEFAULT); 21 | print_sexpr_mode(root, SEXPR_PRINT_VERBOSE); 22 | } 23 | } 24 | fseek(fp, 0, SEEK_SET); 25 | fclose(fp); 26 | return 0; 27 | } 28 | 29 | int main(int argc, char **argv) { 30 | init_pi(); 31 | char * file_path_name = argv[1]; 32 | // char file_path_name[] = "/home/phreppo/pilisp/test/expressions/dotexpressions.lisp";; 33 | pi_message("Welcome to pilisp"); 34 | printf("File name: %s\n", file_path_name); 35 | return print_parser_test(file_path_name); 36 | } -------------------------------------------------------------------------------- /test/recursive_structure_print_test.c: -------------------------------------------------------------------------------- 1 | #include "pilisp.h" 2 | #include "pitestutils.h" 3 | #include 4 | 5 | int main(int argc, char **argv) { 6 | init_pi(); 7 | cell * head = mk_cons(mk_num(1),NULL); 8 | cell * second = mk_cons(head,NULL); 9 | head->cdr = second; 10 | print_sexpr_mode(head,SEXPR_PRINT_VERBOSE); 11 | print_sexpr_mode(head,SEXPR_PRINT_DEFAULT); 12 | return 0; 13 | } -------------------------------------------------------------------------------- /test/sexpr_copy_test.c: -------------------------------------------------------------------------------- 1 | #include "pilisp.h" 2 | #include "pitestutils.h" 3 | #include 4 | 5 | int main(int argc, char **argv) { 6 | init_pi(); 7 | cell *num1 = mk_num(1); 8 | cell *str1 = mk_num(2); 9 | cell *sym1 = mk_sym("var1"); 10 | cell *cons1 = mk_cons(num1, mk_cons(str1,mk_cons(sym1,NULL))); 11 | print_sexpr(cons1); 12 | cell *cons2 = copy_cell(cons1); 13 | print_sexpr(cons2); 14 | return 0; 15 | } --------------------------------------------------------------------------------