├── .github └── workflows │ └── test.yml ├── LICENSE ├── Makefile ├── README.md ├── erlscheme.spec ├── make ├── erlscheme.in └── gen_es_uc_ctype.escript ├── priv └── scm │ └── es-init.scm ├── rebar.config ├── rebar.config.script └── src ├── erlscheme.app.src ├── es_ast_to_core.erl ├── es_compile.erl ├── es_ctype.erl ├── es_datum.erl ├── es_env.erl ├── es_error.erl ├── es_eval.erl ├── es_gloenv.erl ├── es_input_string_iodev.erl ├── es_lexer.erl ├── es_lexinput.erl ├── es_lib_scheme_base.erl ├── es_load.erl ├── es_macros.erl ├── es_main.erl ├── es_parse.erl ├── es_print.erl ├── es_read.erl ├── es_repl.erl ├── es_synenv.erl └── es_uc_ctype.erl /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: Erlang CI 2 | 3 | on: 4 | pull_request: 5 | push: 6 | branches: 7 | - master 8 | 9 | jobs: 10 | build: 11 | strategy: 12 | matrix: 13 | platform: [ubuntu-latest] 14 | otp-version: [25, 26, 27, 28] 15 | runs-on: ${{ matrix.platform }} 16 | container: 17 | image: erlang:${{ matrix.otp-version }} 18 | steps: 19 | - name: Checkout 20 | uses: actions/checkout@v4 21 | - name: Compile and Test 22 | run: make all 23 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "{}" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright {yyyy} {name of copyright owner} 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # Copyright 2014-2025 Mikael Pettersson 2 | # 3 | # Licensed under the Apache License, Version 2.0 (the "License"); 4 | # you may not use this file except in compliance with the License. 5 | # You may obtain a copy of the License at 6 | # 7 | # http://www.apache.org/licenses/LICENSE-2.0 8 | # 9 | # Unless required by applicable law or agreed to in writing, software 10 | # distributed under the License is distributed on an "AS IS" BASIS, 11 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | # See the License for the specific language governing permissions and 13 | # limitations under the License. 14 | # 15 | # Makefile for ErlScheme 16 | 17 | SHELL := $(shell command -v bash) 18 | REBAR3 := $(shell type -p rebar3 || echo ./rebar3) 19 | REBAR3_GIT = https://github.com/erlang/rebar3.git 20 | REBAR3_VSN = 3.25.0 21 | 22 | prefix=/usr/local 23 | exec_prefix=$(prefix) 24 | bindir=$(exec_prefix)/bin 25 | datarootdir=$(prefix)/share 26 | datadir=$(datarootdir) 27 | docdir=$(datarootdir)/doc/erlscheme-$(VSN) 28 | srcdir=. 29 | 30 | EBIN_DIR = _build/default/lib/erlscheme/ebin 31 | SCM_DIR = scm 32 | BIN_DIR = bin 33 | 34 | all: compile $(BIN_DIR)/erlscheme 35 | 36 | compile: $(REBAR3) src/es_uc_ctype.erl 37 | $(REBAR3) do compile, xref, dialyzer, eunit 38 | 39 | $(BIN_DIR)/erlscheme: 40 | mkdir -p $(BIN_DIR) 41 | sed "s,@EBIN_DIR@,$(EBIN_DIR),g" < make/erlscheme.in > $(BIN_DIR)/erlscheme 42 | chmod +x $(BIN_DIR)/erlscheme 43 | 44 | install: compile $(BIN_DIR)/erlscheme 45 | : install .beam files for compiled .erl or .scm code 46 | mkdir -p $(DESTDIR)$(datadir)/erlscheme/ebin 47 | cp $(EBIN_DIR)/*.beam $(DESTDIR)$(datadir)/erlscheme/ebin 48 | : install .scm files 49 | mkdir -p $(DESTDIR)$(datadir)/erlscheme/scm 50 | cp $(SCM_DIR)/*.scm $(DESTDIR)$(datadir)/erlscheme/scm 51 | : install the 'erlscheme' executable 52 | mkdir -p $(DESTDIR)$(bindir) 53 | sed "s,@EBIN_DIR@,$(datadir)/erlscheme/ebin,g" < make/erlscheme.in > $(DESTDIR)$(bindir)/erlscheme 54 | chmod +x $(DESTDIR)$(bindir)/erlscheme 55 | 56 | clean distclean realclean: 57 | rm -rf $(BIN_DIR) _build 58 | 59 | # generate src/es_uc_ctype.erl from UnicodeData.txt: 60 | # make UCD=/path/to/otp_src/lib/stdlib/uc_spec/UnicodeData.txt src/es_uc_ctype.erl 61 | src/es_uc_ctype.erl: 62 | @if [ -z "$(UCD)" ]; then echo UCD not set; exit 1; fi 63 | make/gen_es_uc_ctype.escript "$(UCD)" src/es_uc_ctype.erl 64 | 65 | ./rebar3: 66 | mkdir -p _build; \ 67 | cd _build; \ 68 | git clone --quiet $(REBAR3_GIT); \ 69 | cd rebar3; \ 70 | git checkout --quiet $(REBAR3_VSN); \ 71 | ./bootstrap; \ 72 | mv rebar3 ../../; \ 73 | cd ../..; \ 74 | rm -rf _build/rebar3 75 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Copyright 2014-2025 Mikael Pettersson 2 | 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | 7 | http://www.apache.org/licenses/LICENSE-2.0 8 | 9 | Unless required by applicable law or agreed to in writing, software 10 | distributed under the License is distributed on an "AS IS" BASIS, 11 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | See the License for the specific language governing permissions and 13 | limitations under the License. 14 | 15 | ErlScheme 16 | ========= 17 | 18 | ErlScheme is an implementation of the Scheme programming language for the 19 | Erlang/OTP virtual machine. 20 | 21 | ErlScheme aims for Scheme R7RS compatibility, with extensions for Erlang 22 | interoperability. ErlScheme added features include: 23 | 24 | - Calls to Erlang code. 25 | 26 | * (M:F A1 ... An) calls function F of arity n exported from module M 27 | 28 | * (lambda M:F/A) evaluates to function F of arity A exported from module M 29 | 30 | - Separately-compiled modules. A module like 31 | 32 | (module meaning) 33 | (export (/ life 0)) ; or (export life/0) 34 | (define (life) 42) 35 | 36 | in a file "meaning.scm" can be compiled to "meaning.beam", and then called 37 | from ErlScheme as (meaning:life) or from Erlang as meaning:life(). 38 | 39 | - Erlang-like exception handling: 40 | 41 | (try Expr 42 | (of Var Body) 43 | (catch EVar Handler) 44 | (after After)) 45 | 46 | ErlScheme exceptions have termination semantics, not resumption semantics 47 | as specified by R7RS. 48 | 49 | - Erlang-like case expressions and pattern matching: 50 | 51 | (case Expr 52 | ('x 'got_an_x) ; quote symbols to treat them as literals 53 | (y (when Guard) Body..) ; unquoted symbols are variables 54 | (_ Default)) 55 | 56 | Patterns are datums where symbols denote variables if unquoted, and literals 57 | when quoted. References to bound variables are equality constraints, as in 58 | Erlang. 59 | 60 | Scheme's original (case ...) expressions are not supported. They can be 61 | supported via a macro if so desired. (This author finds them pointless.) 62 | 63 | - Erlang processes and message passing. 64 | 65 | Some Scheme feature are not supported: 66 | 67 | - No mutable aggregate data structures. This means no set-car!, string-set!, 68 | vector-set!, or similar procedures. This is due to inherent limitations 69 | in the Erlang/OTP VM. 70 | 71 | - No call/cc. Supporting this would require a CPS-transform, which would 72 | make interoperability with Erlang code difficult. Note that the Erlang 73 | VM supports processes and exceptions, so call/cc is not needed to implement 74 | those features for ErlScheme. 75 | 76 | - No "full numeric tower". This is mainly due to the Erlang/OTP VM only 77 | supporting integers (fixnums and bignums) and flonums. 78 | 79 | - No variadic functions. The Erlang/OTP VM does not support this feature, 80 | and emulating it requires changing calling conventions which ends up making 81 | interoperability with Erlang code more difficult. 82 | 83 | - No resumption from exception handlers. Like call/cc, supporting this would 84 | require a CPS-transform, making interoperability with Erlang code difficult. 85 | 86 | ErlScheme is a Work In Progress 87 | =============================== 88 | 89 | ErlScheme is far from finished, so here is an incomplete list of known 90 | omissions and planned extensions: 91 | 92 | Omissions: 93 | - Most of the Scheme standard bindings are not yet implemented. 94 | - The R6RS/R7RS library system is not implemented, and may never be. 95 | - No documentation. 96 | - The macro / syntax system is old-fashioned and primitive. 97 | 98 | Planned extensions: 99 | - Write more of the system in ErlScheme itself. 100 | -------------------------------------------------------------------------------- /erlscheme.spec: -------------------------------------------------------------------------------- 1 | %global realname erlscheme 2 | 3 | Name: %{realname} 4 | Version: 0.1 5 | Release: 1%{?dist} 6 | Summary: Scheme implementation for the Erlang VM 7 | License: Apache-2.0 8 | Group: Development/Languages 9 | URL: http://github.com/mikpe/%{realname} 10 | Source0: %{realname}-%{version}.tar.xz 11 | BuildRoot: %(mktemp -ud %{_tmppath}/%{name}-%{version}-%{release}-XXXXXX) 12 | BuildArch: noarch 13 | 14 | Requires: erlang-compiler%{?_isa} 15 | Requires: erlang-erts%{?_isa} 16 | Requires: erlang-kernel%{?_isa} 17 | Requires: erlang-stdlib%{?_isa} 18 | 19 | %description 20 | ErlScheme is an implementation of the Scheme programming language, 21 | running on the Erlang/OTP virtual machine. 22 | 23 | %prep 24 | %setup -q -n %{realname}-%{version} 25 | 26 | %build 27 | make 28 | 29 | %install 30 | rm -rf %{buildroot} 31 | make datadir=%{_datadir} bindir=%{_bindir} DESTDIR=%{buildroot} install 32 | 33 | %clean 34 | rm -rf %{buildroot} 35 | 36 | %files 37 | %defattr(-,root,root,-) 38 | %doc LICENSE README.md 39 | %dir %{_datadir}/%{realname} 40 | %dir %{_datadir}/%{realname}/ebin 41 | %dir %{_datadir}/%{realname}/scm 42 | %{_datadir}/%{realname}/ebin/*.beam 43 | %{_datadir}/%{realname}/scm/*.scm 44 | %{_bindir}/erlscheme 45 | 46 | %changelog 47 | * Tue Jul 01 2014 Mikael Pettersson - 0.1-1 48 | - Initial build. 49 | -------------------------------------------------------------------------------- /make/erlscheme.in: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Path into the ErlScheme installation. 4 | EBIN_DIR=@EBIN_DIR@ 5 | 6 | ERL_ARGS= 7 | ES_ARGS= 8 | 9 | while [ $# -gt 0 ]; do 10 | case "$1" in 11 | --erl) 12 | shift 13 | if [ $# -eq 0 ]; then 14 | echo "option --erl: missing argument" 15 | exit 1 16 | fi 17 | ERL_ARGS="${ERL_ARGS} $1" 18 | ;; 19 | --) 20 | shift 21 | # Append remaining arguments to ERL_ARGS. 22 | break 23 | ;; 24 | *) 25 | # We prefix each ErlScheme argument with an "x" to prevent 26 | # it being interpreted as an emulator or init flag by erl. 27 | ES_ARGS="${ES_ARGS} x$1" 28 | ;; 29 | esac 30 | shift 31 | done 32 | 33 | while [ $# -gt 0 ]; do 34 | ERL_ARGS="${ERL_ARGS} $1" 35 | shift 36 | done 37 | 38 | # use -run not -s to avoid coercing argument strings to atoms 39 | exec erl -pa ${EBIN_DIR} -noshell ${ERL_ARGS} -run es_main start ${ES_ARGS} -run erlang halt 40 | -------------------------------------------------------------------------------- /make/gen_es_uc_ctype.escript: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env escript 2 | %% -*- erlang -*- 3 | %%! +Bd -noshell -smp auto 4 | 5 | %% Copyright 2022-2025 Mikael Pettersson 6 | %% 7 | %% Licensed under the Apache License, Version 2.0 (the "License"); 8 | %% you may not use this file except in compliance with the License. 9 | %% You may obtain a copy of the License at 10 | %% 11 | %% http://www.apache.org/licenses/LICENSE-2.0 12 | %% 13 | %% Unless required by applicable law or agreed to in writing, software 14 | %% distributed under the License is distributed on an "AS IS" BASIS, 15 | %% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | %% See the License for the specific language governing permissions and 17 | %% limitations under the License. 18 | %% 19 | %% gen_es_uc_ctype.escript 20 | %% 21 | %% Generate es_uc_ctype.erl from UnicodeData.txt 22 | %% 23 | %% Scheme has the following main character types (ctypes): 24 | %% 25 | %% - initial: letters and other characters that may start a symbol 26 | %% - subsequent: decimal digits and other characters that may follow 27 | %% the initial character in a symbol 28 | %% - whitespace: spaces, tabs, newlines, and similar 29 | %% - delimiter: characters like left and right parenthesis, semicolon, 30 | %% and whitespace that always delimit other tokens 31 | %% - digit: the decimal digits 0 to 9 32 | %% 33 | %% The first three ctypes are extended from ASCII to Unicode via the 34 | %% general category of each Unicode code point. The last two ctypes 35 | %% only contain ASCII code points. 36 | %% 37 | %% We already have es_ctype.erl with hand-crafted tables and code for 38 | %% ASCII ctypes. Therefore this module only caters for extending the 39 | %% first three ctypes to Unicode except ASCII (code points > 127). 40 | %% 41 | %% Subsequent includes initial, and is disjoint from whitespace. Therefore 42 | %% these ctypes can be treated as mutually exclusive (to check for subsequent 43 | %% also check for initial), so there are only four possibilities per code 44 | %% point (these three, and none), which fits in two bits. Hence we pack 45 | %% four ctypes in each byte in the Unicode lookup table. 46 | 47 | -define(IS_NONE, 0). 48 | -define(IS_WHITESPACE, 1). 49 | -define(IS_SUBSEQUENT, 2). % check for >= 2 to include initial 50 | -define(IS_INITIAL, 3). 51 | 52 | -mode(compile). 53 | 54 | -record(udata, {code :: non_neg_integer(), gc :: atom()}). 55 | 56 | main([InFile, OutFile]) -> 57 | UnicodeData = read_unicode_data(InFile), 58 | UnicodeCtype = make_unicode_ctype(UnicodeData), 59 | write_ctype_module(UnicodeCtype, OutFile). 60 | 61 | %% Write Ctype ----------------------------------------------------------------- 62 | %% 63 | %% Convert the ctype array to a module with access functions and a lookup table. 64 | 65 | write_ctype_module(UnicodeCtype, OutFile) -> 66 | {ok, IoDev} = file:open(OutFile, [write]), 67 | try 68 | do_write_ctype_module(UnicodeCtype, IoDev) 69 | after 70 | file:close(IoDev) 71 | end. 72 | 73 | do_write_ctype_module(UnicodeCtype, IoDev) -> 74 | io:format(IoDev, "%% -*- erlang-indent-level: 2 -*-\n", []), 75 | io:format(IoDev, "%%\n", []), 76 | io:format(IoDev, "%% Copyright 2022-2025 Mikael Pettersson\n", []), 77 | io:format(IoDev, "%%\n", []), 78 | io:format(IoDev, "%% Licensed under the Apache License, Version 2.0 (the \"License\");\n", []), 79 | io:format(IoDev, "%% you may not use this file except in compliance with the License.\n", []), 80 | io:format(IoDev, "%% You may obtain a copy of the License at\n", []), 81 | io:format(IoDev, "%%\n", []), 82 | io:format(IoDev, "%% http://www.apache.org/licenses/LICENSE-2.0\n", []), 83 | io:format(IoDev, "%%\n", []), 84 | io:format(IoDev, "%% Unless required by applicable law or agreed to in writing, software\n", []), 85 | io:format(IoDev, "%% distributed under the License is distributed on an \"AS IS\" BASIS,\n", []), 86 | io:format(IoDev, "%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.\n", []), 87 | io:format(IoDev, "%% See the License for the specific language governing permissions and\n", []), 88 | io:format(IoDev, "%% limitations under the License.\n", []), 89 | io:format(IoDev, "%%\n", []), 90 | io:format(IoDev, "%% es_uc_ctype.erl\n", []), 91 | io:format(IoDev, "%%\n", []), 92 | io:format(IoDev, "%% Unicode character classification for ErlScheme.\n", []), 93 | io:format(IoDev, "%%\n", []), 94 | io:format(IoDev, "%% This file was generated by gen_es_uc_ctype.escript -- DO NOT EDIT.\n", []), 95 | io:format(IoDev, "\n", []), 96 | io:format(IoDev, "-module(es_uc_ctype).\n", []), 97 | io:format(IoDev, "\n", []), 98 | io:format(IoDev, "-export([is_initial/1, is_subsequent/1, is_whitespace/1]).\n", []), 99 | io:format(IoDev, "\n", []), 100 | io:format(IoDev, "-compile({inline, [{unicode_tab, 1}, {unicode_tab, 0}]}).\n", []), 101 | io:format(IoDev, "\n", []), 102 | io:format(IoDev, "-spec is_initial(char()) -> boolean().\n", []), 103 | io:format(IoDev, "is_initial(Ch) -> unicode_tab(Ch) =:= ~p.\n", [?IS_INITIAL]), 104 | io:format(IoDev, "\n", []), 105 | io:format(IoDev, "-spec is_subsequent(char()) -> boolean().\n", []), 106 | io:format(IoDev, "is_subsequent(Ch) -> unicode_tab(Ch) >= ~p.\n", [?IS_SUBSEQUENT]), 107 | io:format(IoDev, "\n", []), 108 | io:format(IoDev, "-spec is_whitespace(char()) -> boolean().\n", []), 109 | io:format(IoDev, "is_whitespace(Ch) -> unicode_tab(Ch) =:= ~p.\n", [?IS_WHITESPACE]), 110 | io:format(IoDev, "\n", []), 111 | io:format(IoDev, "-spec unicode_tab(char()) -> 0..3.\n", []), 112 | io:format(IoDev, "unicode_tab(Ch) ->\n", []), 113 | io:format(IoDev, " Index = Ch bsr 2,\n", []), % Ch div 4 114 | io:format(IoDev, " Offset = (Ch band 3) * 2,\n", []), % Ch rem 4 115 | io:format(IoDev, " (binary:at(unicode_tab(), Index) bsr Offset) band 3.\n", []), 116 | io:format(IoDev, "\n", []), 117 | io:format(IoDev, "-spec unicode_tab() -> binary().\n", []), 118 | io:format(IoDev, "unicode_tab() ->\n", []), 119 | io:format(IoDev, " <<\"", []), 120 | write_byte_array(UnicodeCtype, IoDev), 121 | io:format(IoDev, "\">>.\n", []). 122 | 123 | write_byte_array(Array, IoDev) -> 124 | write_byte_array(0, array:size(Array), Array, IoDev). 125 | 126 | write_byte_array(I, Size, Array, IoDev) when I < Size -> 127 | case I band 15 of 128 | 0 -> io:format(IoDev, "\"\n \"", []); 129 | _ -> ok 130 | end, 131 | write_hex_byte(IoDev, array:get(I, Array)), 132 | write_byte_array(I + 1, Size, Array, IoDev); 133 | write_byte_array(I, Size, _Array, _IoDev) when I >= Size -> ok. 134 | 135 | write_hex_byte(IoDev, Byte) -> 136 | io:format(IoDev, "\\x~2.16.0b", [Byte]). 137 | 138 | %% Convert Unicode Data to Ctype ----------------------------------------------- 139 | 140 | make_unicode_ctype(UData) -> 141 | lists:foldl(fun record_ctype/2, array:new({default, 0}), UData). 142 | 143 | record_ctype(#udata{code = Code} = UData, Arr) -> 144 | case udata_ctype(UData) of 145 | ?IS_NONE -> 146 | Arr; 147 | Ctype when (Ctype band bnot 3) =:= 0 -> 148 | Index = Code bsr 2, % div 4 149 | Offset = (Code band 3) * 2, % rem 4 150 | Byte = array:get(Index, Arr), 151 | 0 = (Byte bsr Offset) band 3, % assert 152 | NewByte = Byte bor (Ctype bsl Offset), 153 | array:set(Index, NewByte, Arr) 154 | end. 155 | 156 | udata_ctype(#udata{code = Code, gc = GC}) -> 157 | case Code of 158 | 16#200C -> ?IS_INITIAL; % from R7RS, not in R6RS 159 | 16#200D -> ?IS_INITIAL; % from R7RS, not in R6RS 160 | %% TODO: R6RS compat: U+0085 needs lexer adjustments 161 | _ -> 162 | if Code < 128 -> ?IS_NONE; % covered by existing ASCII table+logic 163 | true -> gc_ctype(GC) 164 | end 165 | end. 166 | 167 | gc_ctype(GC) -> 168 | case GC of 169 | 'Lu' -> ?IS_INITIAL; 170 | 'Ll' -> ?IS_INITIAL; 171 | 'Lt' -> ?IS_INITIAL; 172 | 'Lm' -> ?IS_INITIAL; 173 | 'Lo' -> ?IS_INITIAL; 174 | 'Mn' -> ?IS_INITIAL; 175 | 'Mc' -> ?IS_SUBSEQUENT; 176 | 'Me' -> ?IS_SUBSEQUENT; 177 | 'Nd' -> ?IS_SUBSEQUENT; 178 | 'Nl' -> ?IS_INITIAL; 179 | 'No' -> ?IS_INITIAL; 180 | 'Pd' -> ?IS_INITIAL; 181 | 'Pc' -> ?IS_INITIAL; 182 | 'Po' -> ?IS_INITIAL; 183 | 'Sc' -> ?IS_INITIAL; 184 | 'Sm' -> ?IS_INITIAL; 185 | 'Sk' -> ?IS_INITIAL; 186 | 'So' -> ?IS_INITIAL; 187 | 'Co' -> ?IS_INITIAL; 188 | %% The whitespace extensions are from R6RS, R7RS does not have them. 189 | 'Zs' -> ?IS_WHITESPACE; 190 | %% TODO: R6RS compat: Zl (U+2028) and Zp (U+2029) need lexer adjustments 191 | _ -> ?IS_NONE 192 | end. 193 | 194 | %% Reading Unicode Data -------------------------------------------------------- 195 | %% 196 | %% This reads a UnicodeData.txt file and produces a list of #udata entries 197 | %% recording the general category for each code point. 198 | 199 | read_unicode_data(InFile) -> 200 | {ok, IoDev} = file:open(InFile, [read, raw, read_ahead]), 201 | try 202 | fold_lines(fun parse_udata/2, [], IoDev) 203 | after 204 | file:close(IoDev) 205 | end. 206 | 207 | parse_udata(Line, Acc) -> 208 | case parse_udata(Line) of 209 | false -> Acc; 210 | Data -> [Data | Acc] 211 | end. 212 | 213 | parse_udata(Line0) -> 214 | case string:chomp(Line0) of 215 | "" -> false; % ignore empty lines 216 | "#" ++ _ -> false; % ignore comment lines 217 | Line -> 218 | [ Code 219 | , _Name 220 | , GeneralCategory 221 | , _CombiningClass 222 | , _BiDiCategory 223 | , _Decomposition 224 | , _ 225 | , _ 226 | , _NumericValue 227 | , _BiDiMirrored 228 | , _Alias 229 | | _] = string:split(Line, ";", all), 230 | #udata{code = hex_to_int(Code), gc = string_to_gc(GeneralCategory)} 231 | end. 232 | 233 | hex_to_int(Str) -> 234 | list_to_integer(string:trim(Str), 16). 235 | 236 | string_to_gc(Str) -> 237 | list_to_atom(string:trim(Str)). 238 | 239 | fold_lines(Fun, Acc, IoDev) -> 240 | fold_lines(Fun, Acc, 1, IoDev). 241 | 242 | fold_lines(Fun, Acc, LineNr, IoDev) -> 243 | case file:read_line(IoDev) of 244 | {ok, Line} -> 245 | NewAcc = step_line(Fun, Line, Acc, LineNr), 246 | fold_lines(Fun, NewAcc, LineNr + 1, IoDev); 247 | eof -> Acc 248 | end. 249 | 250 | step_line(Fun, Line, Acc, LineNr) -> 251 | try Fun(Line, Acc) 252 | catch Class:Reason:Stack -> 253 | io:format(standard_error, "failed to parse line ~p: ~s\n~p:~p\n~p\n", 254 | [LineNr, Line, Class, Reason, Stack]), 255 | Acc 256 | end. 257 | -------------------------------------------------------------------------------- /priv/scm/es-init.scm: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2014-2022 Mikael Pettersson 2 | ;;; 3 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 4 | ;;; you may not use this file except in compliance with the License. 5 | ;;; You may obtain a copy of the License at 6 | ;;; 7 | ;;; http://www.apache.org/licenses/LICENSE-2.0 8 | ;;; 9 | ;;; Unless required by applicable law or agreed to in writing, software 10 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | ;;; See the License for the specific language governing permissions and 13 | ;;; limitations under the License. 14 | ;;; 15 | ;;; es-init.scm -- initialization code for ErlScheme 16 | 17 | ;; Currently nothing to do. 18 | -------------------------------------------------------------------------------- /rebar.config: -------------------------------------------------------------------------------- 1 | %% -*- erlang -*- 2 | %% 3 | %% Copyright (C) 2022-2023 Mikael Pettersson 4 | %% 5 | %% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %% you may not use this file except in compliance with the License. 7 | %% You may obtain a copy of the License at 8 | %% 9 | %% http://www.apache.org/licenses/LICENSE-2.0 10 | %% 11 | %% Unless required by applicable law or agreed to in writing, software 12 | %% distributed under the License is distributed on an "AS IS" BASIS, 13 | %% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %% See the License for the specific language governing permissions and 15 | %% limitations under the License. 16 | 17 | {eunit_opts, 18 | [ verbose 19 | ]}. 20 | 21 | {erl_opts, 22 | [ debug_info 23 | , warn_export_all 24 | , warn_obsolete_guard 25 | , warn_shadow_vars 26 | , warn_unused_import 27 | , warn_unused_vars 28 | , warnings_as_errors 29 | , {d, 'VSN', "undefined"} % rebar.config.script replaces this with the actual VSN 30 | ]}. 31 | 32 | {deps, 33 | [ 34 | ]}. 35 | 36 | {dialyzer, 37 | [ {warnings, [missing_return, unknown]} 38 | ]}. 39 | 40 | {xref_checks, 41 | [ deprecated_function_calls 42 | , deprecated_functions 43 | , exports_not_used 44 | , locals_not_used 45 | , undefined_function_calls 46 | , undefined_functions 47 | ]}. 48 | 49 | {xref_ignores, 50 | [ %% erlscheme script entry points 51 | {es_main, start, 0} 52 | , {es_main, start, 1} 53 | %% es_compile alternative entry point 54 | , {es_compile, file, 2} 55 | %% indirect calls 56 | , {es_datum, format_error, 1} 57 | , {es_eval, format_error, 1} 58 | , {es_lexer, format_error, 1} 59 | , {es_macros, format_error, 1} 60 | , {es_parse, format_error, 1} 61 | , {es_read, format_error, 1} 62 | %% called by generated code 63 | , {es_macros, enter_macro, 2} 64 | , {es_macros, enter_syntax, 2} 65 | %% dead code TODO: remove or use 66 | , {es_lexer, string_to_number, 2} 67 | , {es_lexinput, column, 1} 68 | , {es_lexinput, line, 1} 69 | , {es_lexinput, name, 1} 70 | , {es_print, write, 1} 71 | ]}. 72 | -------------------------------------------------------------------------------- /rebar.config.script: -------------------------------------------------------------------------------- 1 | %% -*- erlang -*- 2 | %% 3 | %% Copyright (C) 2022-2025 Mikael Pettersson 4 | %% 5 | %% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %% you may not use this file except in compliance with the License. 7 | %% You may obtain a copy of the License at 8 | %% 9 | %% http://www.apache.org/licenses/LICENSE-2.0 10 | %% 11 | %% Unless required by applicable law or agreed to in writing, software 12 | %% distributed under the License is distributed on an "AS IS" BASIS, 13 | %% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %% See the License for the specific language governing permissions and 15 | %% limitations under the License. 16 | 17 | case os:cmd("git describe --dirty") of 18 | "fatal: " ++ _ -> 19 | CONFIG; 20 | Output -> 21 | VSN = string:trim(Output), 22 | Opts = 23 | case lists:keyfind(erl_opts, 1, CONFIG) of 24 | false -> []; 25 | {erl_opts, Opts0} -> 26 | lists:filter(fun({d, 'VSN', _}) -> false; (_) -> true end, Opts0) 27 | end, 28 | NewOpts = [{d, 'VSN', VSN} | Opts], 29 | lists:keystore(erl_opts, 1, CONFIG, {erl_opts, NewOpts}) 30 | end. 31 | -------------------------------------------------------------------------------- /src/erlscheme.app.src: -------------------------------------------------------------------------------- 1 | %% -*- erlang -*- 2 | %% 3 | %% Copyright (C) 2022 Mikael Pettersson 4 | %% 5 | %% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %% you may not use this file except in compliance with the License. 7 | %% You may obtain a copy of the License at 8 | %% 9 | %% http://www.apache.org/licenses/LICENSE-2.0 10 | %% 11 | %% Unless required by applicable law or agreed to in writing, software 12 | %% distributed under the License is distributed on an "AS IS" BASIS, 13 | %% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %% See the License for the specific language governing permissions and 15 | %% limitations under the License. 16 | 17 | {application, erlscheme, 18 | [ {description, "A version of the Scheme programming language for the Erlang/OTP VM"} 19 | , {vsn, git} 20 | , {modules, []} 21 | , {applications, [kernel, stdlib, compiler]} 22 | ]}. 23 | -------------------------------------------------------------------------------- /src/es_ast_to_core.erl: -------------------------------------------------------------------------------- 1 | %%% -*- erlang-indent-level: 2 -*- 2 | %%% 3 | %%% Copyright 2017-2022 Mikael Pettersson 4 | %%% 5 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %%% you may not use this file except in compliance with the License. 7 | %%% You may obtain a copy of the License at 8 | %%% 9 | %%% http://www.apache.org/licenses/LICENSE-2.0 10 | %%% 11 | %%% Unless required by applicable law or agreed to in writing, software 12 | %%% distributed under the License is distributed on an "AS IS" BASIS, 13 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %%% See the License for the specific language governing permissions and 15 | %%% limitations under the License. 16 | %%% 17 | %%% es_ast_to_core.erl 18 | %%% 19 | %%% Translate ErlScheme modules from AST to Core Erlang. 20 | 21 | -module(es_ast_to_core). 22 | 23 | -export([ module/1 24 | ]). 25 | 26 | -type ast() :: term(). 27 | 28 | %% API ------------------------------------------------------------------------- 29 | 30 | -spec module(ast()) -> cerl:c_module(). 31 | module({'ES:MODULE', ModuleName, Exports, Defuns}) -> 32 | CerlModuleName = cerl:c_atom(ModuleName), 33 | %% Exports: add module_info/0 and module_info/1 34 | CerlExports = [modinfo0_fname(), modinfo1_fname() | lists:map(fun translate_export/1, Exports)], 35 | %% Compute a mapping FName -> Arity from the top-level defuns 36 | FEnv = build_fenv(Defuns), 37 | %% Translate each top-level (define (f ...) ...) 38 | %% Also define module_info/0 and module_info/1. 39 | CerlDefuns = [modinfo0_def(CerlModuleName), modinfo1_def(CerlModuleName) | 40 | lists:map(fun(Defun) -> translate_defun(Defun, FEnv) end, Defuns)], 41 | %% Assemble the module. 42 | cerl:c_module(CerlModuleName, CerlExports, CerlDefuns). 43 | 44 | %% Internals ------------------------------------------------------------------- 45 | 46 | translate_export({F, A}) -> 47 | cerl:c_fname(F, A). 48 | 49 | build_fenv(Defuns) -> 50 | lists:foldl(fun build_fenv/2, es_env:empty(), Defuns). 51 | 52 | build_fenv({'ES:DEFINE', Var, {'ES:LAMBDA', Formals, _Body}}, FEnv) -> 53 | none = es_env:lookup(FEnv, Var), % assert 54 | es_env:enter(FEnv, Var, length(Formals)). 55 | 56 | translate_defun({'ES:DEFINE', Var, {'ES:LAMBDA', Formals, Body}}, FEnv) -> 57 | CerlFVar = cerl:c_fname(Var, length(Formals)), 58 | CerlFun = translate_lambda(Formals, Body, FEnv), 59 | {CerlFVar, CerlFun}. 60 | 61 | translate_expr(AST, FEnv) -> 62 | case AST of 63 | {'ES:BEGIN', First, Next} -> 64 | translate_begin(First, Next, FEnv); 65 | {'ES:CASE', Expr, Clauses} -> 66 | translate_case(Expr, Clauses, FEnv); 67 | {'ES:CONS', Hd, Tl} -> 68 | translate_cons(Hd, Tl, FEnv); 69 | {'ES:GLOVAR', Var} -> 70 | translate_glovar(Var, FEnv); 71 | {'ES:IF', Pred, Then, Else} -> 72 | translate_if(Pred, Then, Else, FEnv); 73 | {'ES:LAMBDA', Formals, Body} -> 74 | translate_lambda(Formals, Body, FEnv); 75 | {'ES:LET', Bindings, Body} -> 76 | translate_let(Bindings, Body, FEnv); 77 | {'ES:LETREC', Bindings, Body} -> 78 | translate_letrec(Bindings, Body, FEnv); 79 | {'ES:LOCVAR', Var} -> 80 | translate_locvar(Var); 81 | {'ES:PRIMOP', PrimOp, Actuals} -> 82 | translate_primop(PrimOp, Actuals, FEnv); 83 | {'ES:QUOTE', Value} -> 84 | translate_quote(Value); 85 | {'ES:TRY', Expr, Var, Body, EVar, Handler, After} -> 86 | translate_try(Expr, Var, Body, EVar, Handler, After, FEnv); 87 | {'ES:TUPLE', Exprs} -> 88 | translate_tuple(Exprs, FEnv) 89 | end. 90 | 91 | translate_begin(First, Next, FEnv) -> 92 | cerl:c_seq(translate_expr(First, FEnv), translate_expr(Next, FEnv)). 93 | 94 | translate_case(Expr, Clauses, FEnv) -> 95 | cerl:c_case(translate_expr(Expr, FEnv), 96 | lists:map(fun(Clause) -> translate_clause(Clause, FEnv) end, Clauses)). 97 | 98 | translate_cons(Hd, Tl, FEnv) -> 99 | cerl:c_cons(translate_expr(Hd, FEnv), translate_expr(Tl, FEnv)). 100 | 101 | %% Variable references not bound in their top-level defun become ES:GLOVAR. 102 | %% In a module they can only reference top-level defuns in the same module. 103 | %% FEnv records those and lets us construct the required F/N fname. 104 | translate_glovar(Var, FEnv) -> 105 | Arity = es_env:get(FEnv, Var), 106 | cerl:c_fname(Var, Arity). 107 | 108 | translate_if(Pred, Then, Else, FEnv) -> 109 | %% Synthesize "case Pred of false -> Else; _ -> Then end". 110 | cerl:c_case(translate_expr(Pred, FEnv), 111 | [cerl:c_clause([cerl:c_atom('false')], translate_expr(Else, FEnv)), 112 | cerl:c_clause([wildpat()], translate_expr(Then, FEnv))]). 113 | 114 | translate_lambda(Formals, Body, FEnv) -> 115 | assemble_lambda(translate_formals(Formals), translate_expr(Body, FEnv)). 116 | 117 | assemble_lambda(Vars, Body) -> 118 | cerl:c_fun(Vars, Body). 119 | 120 | translate_formals(Formals) -> 121 | lists:map(fun cerl:c_var/1, Formals). 122 | 123 | translate_letrec(Bindings, Body, FEnv) -> 124 | assemble_letrec([translate_letrec_binding(Binding, FEnv) || Binding <- Bindings], 125 | translate_expr(Body, FEnv)). 126 | 127 | translate_letrec_binding({Var, Formals, Body}, FEnv) -> 128 | CerlFormals = translate_formals(Formals), 129 | Arity = length(CerlFormals), 130 | {cerl:c_fname(Var, Arity), CerlFormals, translate_expr(Body, FEnv)}. 131 | 132 | assemble_letrec(Bindings, Body) -> 133 | FVars = [FVar || {FVar, _Formals, _Body} <- Bindings], 134 | cerl:c_letrec([assemble_letrec_binding(FVars, Binding) || Binding <- Bindings], 135 | assemble_subst(FVars, Body)). 136 | 137 | assemble_letrec_binding(FVars, {FVar, Formals, Body}) -> 138 | {FVar, assemble_lambda(Formals, assemble_subst(FVars, Body))}. 139 | 140 | assemble_subst([], Body) -> Body; 141 | assemble_subst([FVar | FVars], Body) -> 142 | assemble_subst(FVars, cerl:c_let([cerl:c_var(cerl:fname_id(FVar))], FVar, Body)). 143 | 144 | translate_let(Bindings, Body, FEnv) -> 145 | Vars = lists:map(fun({Lhs, _Rhs}) -> translate_locvar(Lhs) end, Bindings), 146 | Args = lists:map(fun({_Lhs, Rhs}) -> translate_expr(Rhs, FEnv) end, Bindings), 147 | cerl:c_let(Vars, cerl:c_values(Args), translate_expr(Body, FEnv)). 148 | 149 | translate_locvar(Var) -> 150 | %% TODO: assumes Var is printable 151 | cerl:c_var(Var). 152 | 153 | translate_primop('ES:APPLY', [Fun | Args], FEnv) -> 154 | CerlActuals = lists:map(fun(Arg) -> translate_expr(Arg, FEnv) end, Args), 155 | case Fun of 156 | {'ES:PRIMOP', 'ES:COLON', [M, F, {'ES:QUOTE', A}]} when A =:= length(Args) -> 157 | cerl:c_call(translate_expr(M, FEnv), translate_expr(F, FEnv), CerlActuals); 158 | _ -> 159 | cerl:c_apply(translate_expr(Fun, FEnv), CerlActuals) 160 | end; 161 | translate_primop(PrimOp, Args, FEnv) -> 162 | CerlArgs = lists:map(fun(Arg) -> translate_expr(Arg, FEnv) end, Args), 163 | case {PrimOp, CerlArgs} of 164 | {'ES:COLON', [M, F, A]} -> make_fun(M, F, A); 165 | {'ES:LIST', _} -> cerl:make_list(CerlArgs); 166 | {'ES:RAISE', [Exn]} -> make_raise(Exn) 167 | end. 168 | 169 | make_fun(M, F, A) -> 170 | cerl:c_call(cerl:c_atom('erlang'), cerl:c_atom('make_fun'), [M, F, A]). 171 | 172 | make_raise(Exn) -> 173 | cerl:c_call(cerl:c_atom('es_datum'), cerl:c_atom('raise'), [Exn]). 174 | 175 | translate_quote(Value) -> 176 | %% This is a PRE for cerl:abstract/1, but may not be true for all possible 177 | %% quoted values. FIXME: how to represent other terms? 178 | true = cerl:is_literal_term(Value), 179 | cerl:abstract(Value). 180 | 181 | %% try 182 | %% Expr of 183 | %% Var -> 184 | %% Body 185 | %% catch Class:Reason:Stack -> 186 | %% EVar = {Class, Reason, Stack}, 187 | %% Handler 188 | %% after 189 | %% After % After=[] means it is absent 190 | %% end 191 | translate_try(Expr, Var, Body, EVar, Handler, After, FEnv) -> 192 | translate_after(translate_try(Expr, Var, Body, EVar, Handler, FEnv), After, FEnv). 193 | 194 | translate_try(Expr, Var, Body, EVar, Handler, FEnv) -> 195 | CVarClass = newvar(), 196 | CVarReason = newvar(), 197 | CVarRawStack = newvar(), 198 | CVarStack = newvar(), 199 | cerl:c_try(translate_expr(Expr, FEnv), 200 | [cerl:c_var(Var)], 201 | translate_expr(Body, FEnv), 202 | [CVarClass, CVarReason, CVarRawStack], 203 | cerl:c_let([CVarStack], cerl:c_primop(cerl:c_atom('build_stacktrace'), [CVarRawStack]), 204 | cerl:c_let([cerl:c_var(EVar)], cerl:c_tuple([CVarClass, CVarReason, CVarStack]), 205 | translate_expr(Handler, FEnv)))). 206 | 207 | translate_after(CInnerTry, _After = [], _FEnv) -> CInnerTry; 208 | translate_after(CInnerTry, After, FEnv) -> 209 | CVarAfter = newvar(), 210 | CVarOf = newvar(), 211 | CVarClass = newvar(), 212 | CVarReason = newvar(), 213 | CVarRawStack = newvar(), 214 | cerl:c_let([CVarAfter], cerl:c_fun([], translate_expr(After, FEnv)), 215 | cerl:c_try(CInnerTry, 216 | [CVarOf], 217 | cerl:c_seq(cerl:c_apply(CVarAfter, []), 218 | CVarOf), 219 | [CVarClass, CVarReason, CVarRawStack], 220 | cerl:c_seq(cerl:c_apply(CVarAfter, []), 221 | cerl:c_primop(cerl:c_atom('raise'), [CVarRawStack, CVarReason])))). 222 | 223 | translate_tuple(Exprs, FEnv) -> 224 | cerl:c_tuple(lists:map(fun(Expr) -> translate_expr(Expr, FEnv) end, Exprs)). 225 | 226 | %% Pattern matching ------------------------------------------------------------ 227 | 228 | translate_clause({Pat, Guard, Body}, FEnv) -> 229 | {CPat, Eqs} = translate_pat(Pat, []), 230 | CGuard = extend_guard(Eqs, translate_guard(Guard, FEnv)), 231 | cerl:c_clause([CPat], CGuard, translate_expr(Body, FEnv)). 232 | 233 | translate_guard(Guard, FEnv) -> 234 | CVar = newvar(), 235 | CVarClass = newvar(), 236 | CVarReason = newvar(), 237 | True = cerl:c_atom('true'), 238 | False = cerl:c_atom('false'), 239 | cerl:c_try(translate_expr(Guard, FEnv), 240 | [CVar], 241 | cerl:c_case(CVar, 242 | [cerl:c_clause([True], True), 243 | cerl:c_clause([wildpat()], False)]), 244 | [CVarClass, CVarReason], 245 | False). 246 | 247 | extend_guard([], CGuard) -> CGuard; 248 | extend_guard([{CV1, CV2} | Eqs], CGuard) -> 249 | cerl:c_case(cerl:c_call(cerl:c_atom('erlang'), cerl:c_atom('=:='), [CV1, CV2]), 250 | [cerl:c_clause([cerl:c_atom('true')], extend_guard(Eqs, CGuard)), 251 | cerl:c_clause([wildpat()], cerl:c_atom('false'))]). 252 | 253 | translate_pat(Pat, Eqs) -> 254 | case Pat of 255 | {'ES:BIND', Var, Pat2} -> % Var is not bound 256 | {CPat2, Eqs2} = translate_pat(Pat2, Eqs), 257 | {cerl:c_alias(cerl:c_var(Var), CPat2), Eqs2}; 258 | {'ES:CONS', Hd, Tl} -> 259 | {CHd, Eqs1} = translate_pat(Hd, Eqs), 260 | {CTl, Eqs2} = translate_pat(Tl, Eqs1), 261 | {cerl:c_cons(CHd, CTl), Eqs2}; 262 | {'ES:EQUAL', Var, Pat2} -> % Var is bound 263 | {CPat2, Eqs2} = translate_pat(Pat2, Eqs), 264 | CVar = newvar(), 265 | {cerl:c_alias(CVar, CPat2), [{CVar, cerl:c_var(Var)} | Eqs2]}; 266 | {'ES:QUOTE', Value} -> 267 | translate_quote(Value); 268 | {'ES:TUPLE', Pats} -> 269 | translate_tuple_pat(Pats, [], Eqs); 270 | 'ES:WILD' -> 271 | wildpat() 272 | end. 273 | 274 | translate_tuple_pat([], CPats, Eqs) -> 275 | {cerl:c_tuple(lists:reverse(CPats)), Eqs}; 276 | translate_tuple_pat([Pat | Pats], CPats, Eqs) -> 277 | {CPat, Eqs2} = translate_pat(Pat, Eqs), 278 | translate_tuple_pat(Pats, [CPat | CPats], Eqs2). 279 | 280 | %% Auxiliary helpers ----------------------------------------------------------- 281 | 282 | modinfo0_def(ModuleName) -> 283 | {modinfo0_fname(), 284 | cerl:c_fun([], cerl:c_call(cerl:c_atom('erlang'), cerl:c_atom('get_module_info'), [ModuleName]))}. 285 | 286 | modinfo0_fname() -> 287 | cerl:c_fname('module_info', 0). 288 | 289 | modinfo1_def(ModuleName) -> 290 | Var = cerl:c_var(1), 291 | {modinfo1_fname(), 292 | cerl:c_fun([Var], cerl:c_call(cerl:c_atom('erlang'), cerl:c_atom('get_module_info'), [ModuleName, Var]))}. 293 | 294 | modinfo1_fname() -> 295 | cerl:c_fname('module_info', 1). 296 | 297 | wildpat() -> 298 | newvar(). 299 | 300 | newvar() -> 301 | %% Neither cerl, core_lint, nor core_pp reject negative numeric variable names, 302 | %% but the BEAM compiler throws syntax errors on .core files containing them. 303 | cerl:c_var(erlang:unique_integer([positive])). 304 | -------------------------------------------------------------------------------- /src/es_compile.erl: -------------------------------------------------------------------------------- 1 | %%% -*- erlang-indent-level: 2 -*- 2 | %%% 3 | %%% Copyright 2017-2022 Mikael Pettersson 4 | %%% 5 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %%% you may not use this file except in compliance with the License. 7 | %%% You may obtain a copy of the License at 8 | %%% 9 | %%% http://www.apache.org/licenses/LICENSE-2.0 10 | %%% 11 | %%% Unless required by applicable law or agreed to in writing, software 12 | %%% distributed under the License is distributed on an "AS IS" BASIS, 13 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %%% See the License for the specific language governing permissions and 15 | %%% limitations under the License. 16 | %%% 17 | %%% es_compile.erl 18 | %%% 19 | %%% Compile ErlScheme modules to BEAM files. 20 | 21 | -module(es_compile). 22 | 23 | -export([ file/1 24 | , file/2 25 | ]). 26 | 27 | -type datum() :: term(). 28 | 29 | %% API ------------------------------------------------------------------------- 30 | 31 | -spec file(datum()) -> ok. 32 | file(Arg) -> 33 | file(Arg, _Opts = []). 34 | 35 | -spec file(datum(), proplists:proplist()) -> ok. 36 | file(Arg, Opts) -> 37 | %% Since we want to replace the extension of the file name with ++, 38 | %% we need it to be an Erlang string(), i.e. list(). 39 | FileName = unicode:characters_to_list(Arg), 40 | AST = es_load:module(FileName), 41 | BaseName = filename:basename(FileName, ".scm"), 42 | case proplists:get_bool(save_ast, Opts) of 43 | true -> 44 | ok = file:write_file(BaseName ++ ".ast", io_lib:format("~tp\n", [AST])); 45 | false -> 46 | ok 47 | end, 48 | CerlModule = es_ast_to_core:module(AST), 49 | {ok, _} = core_lint:module(CerlModule), 50 | case proplists:get_bool(save_core, Opts) of 51 | true -> 52 | ok = file:write_file(BaseName ++ ".core", 53 | io_lib:format("~ts\n", [core_pp:format(CerlModule)])); 54 | false -> 55 | ok 56 | end, 57 | {ok, _ModuleName, BeamBin} = compile:forms(CerlModule, [from_core, verbose, report_errors, report_warnings]), 58 | BeamName = BaseName ++ ".beam", 59 | BeamPath = 60 | case lists:keyfind(outdir, 1, Opts) of 61 | {outdir, OutDir} -> filename:join(OutDir, BeamName); 62 | false -> BeamName 63 | end, 64 | ok = file:write_file(BeamPath, BeamBin), 65 | ok. 66 | -------------------------------------------------------------------------------- /src/es_ctype.erl: -------------------------------------------------------------------------------- 1 | %%% -*- erlang-indent-level: 2 -*- 2 | %%% 3 | %%% Copyright 2014-2022 Mikael Pettersson 4 | %%% 5 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %%% you may not use this file except in compliance with the License. 7 | %%% You may obtain a copy of the License at 8 | %%% 9 | %%% http://www.apache.org/licenses/LICENSE-2.0 10 | %%% 11 | %%% Unless required by applicable law or agreed to in writing, software 12 | %%% distributed under the License is distributed on an "AS IS" BASIS, 13 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %%% See the License for the specific language governing permissions and 15 | %%% limitations under the License. 16 | %%% 17 | %%% es_ctype.erl 18 | %%% 19 | %%% Character classification for ErlScheme. 20 | %%% 21 | %%% Extensions: 22 | %%% - : and / are delimiters and thus excluded from initial and subsequent 23 | %%% - [ and ] are delimiters 24 | 25 | -module(es_ctype). 26 | 27 | -export([ char_is_delimiter/1 28 | , char_is_initial/1 29 | , char_is_numeric/1 30 | , char_is_subsequent/1 31 | , char_is_whitespace/1 32 | , char_value/1 33 | ]). 34 | 35 | %% API ------------------------------------------------------------------------- 36 | 37 | -spec char_is_delimiter(-1 | char()) -> boolean(). 38 | char_is_delimiter(Ch) -> 39 | if Ch < 128 -> char_is_type(Ch, 16#02); 40 | true -> false 41 | end. 42 | 43 | -spec char_is_initial(-1 | char()) -> boolean(). 44 | char_is_initial(Ch) -> 45 | if Ch < 128 -> char_is_type(Ch, 16#04); 46 | true -> es_uc_ctype:is_initial(Ch) 47 | end. 48 | 49 | -spec char_is_numeric(-1 | char()) -> boolean(). 50 | char_is_numeric(Ch) -> 51 | if Ch < 128 -> char_is_type(Ch, 16#08); 52 | true -> false 53 | end. 54 | 55 | -spec char_is_subsequent(-1 | char()) -> boolean(). 56 | char_is_subsequent(Ch) -> 57 | if Ch < 128 -> char_is_type(Ch, 16#10); 58 | true -> es_uc_ctype:is_subsequent(Ch) 59 | end. 60 | 61 | -spec char_is_whitespace(-1 | char()) -> boolean(). 62 | char_is_whitespace(Ch) -> 63 | if Ch < 128 -> char_is_type(Ch, 16#01); 64 | true -> es_uc_ctype:is_whitespace(Ch) 65 | end. 66 | 67 | -spec char_value(-1 | char()) -> 0..15 | 255. 68 | char_value(Ch) when Ch > 127 -> 255; 69 | char_value(Ch) -> 70 | ChValueTab = % indexed by [-1, 127] + 1 71 | << 72 | % EOF (-1) 73 | "\xFF" 74 | % NUL SOH STX ETX EOT ENQ ACK BEL BS HT LF VT FF CR SO SI (0-15) 75 | "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF" 76 | % DLE DC1 DC2 DC3 DC4 NAK SYN ETB CAN EM SUB ESC FS GS RS UA (16-31) 77 | "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF" 78 | % SPC ! " # $ % & ' ( ) * + , - . / (32-47) 79 | "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF" 80 | % 0 1 2 3 4 5 6 7 8 9 : ; < = > ? (48-63) 81 | "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\xFF\xFF\xFF\xFF\xFF\xFF" 82 | % @ A B C D E F G H I J K L M N O (64-79) 83 | "\xFF\x0A\x0B\x0C\x0D\x0E\x0F\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF" 84 | % P Q R S T U V W X Y Z [ \ ] ^ _ (80-95) 85 | "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF" 86 | % ` a b c d e f g h i j k l m n o (96-111) 87 | "\xFF\x0A\x0B\x0C\x0D\x0E\x0F\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF" 88 | % p q r s t u v w x y z { | } ~ DEL (112-127) 89 | "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF">>, 90 | binary:at(ChValueTab, Ch + 1). 91 | 92 | %% Internals ------------------------------------------------------------------- 93 | 94 | %% Character classification flag bits: 95 | %% 96 | %% 16#01: whitespace 97 | %% 16#02: delimiter 98 | %% 16#04: initial 99 | %% 16#08: numeric 100 | %% 16#10: subsequent 101 | 102 | char_is_type(Ch, Mask) -> 103 | ChTypeTab = % indexed by [-1, 127] + 1 104 | << 105 | % EOF (-1) 106 | "\x02" % EOF is a delimiter but not whitespace 107 | % NUL SOH STX ETX EOT ENQ ACK BEL BS HT LF VT FF CR SO SI (0-15) 108 | "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x03\x00\x03\x03\x00\x00" 109 | % DLE DC1 DC2 DC3 DC4 NAK SYN ETB CAN EM SUB ESC FS GS RS UA (16-31) 110 | "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00" 111 | % SPC ! " # $ % & ' ( ) * + , - . / (32-47) 112 | "\x03\x14\x02\x00\x14\x14\x14\x00\x02\x02\x14\x10\x00\x10\x10\x02" 113 | % 0 1 2 3 4 5 6 7 8 9 : ; < = > ? (48-63) 114 | "\x18\x18\x18\x18\x18\x18\x18\x18\x18\x18\x02\x02\x14\x14\x14\x14" 115 | % @ A B C D E F G H I J K L M N O (64-79) 116 | "\x14\x14\x14\x14\x14\x14\x14\x14\x14\x14\x14\x14\x14\x14\x14\x14" 117 | % P Q R S T U V W X Y Z [ \ ] ^ _ (80-95) 118 | "\x14\x14\x14\x14\x14\x14\x14\x14\x14\x14\x14\x02\x00\x02\x14\x14" 119 | % ` a b c d e f g h i j k l m n o (96-111) 120 | "\x00\x14\x14\x14\x14\x14\x14\x14\x14\x14\x14\x14\x14\x14\x14\x14" 121 | % p q r s t u v w x y z { | } ~ DEL (112-127) 122 | "\x14\x14\x14\x14\x14\x14\x14\x14\x14\x14\x14\x00\x02\x00\x14\x00">>, 123 | (binary:at(ChTypeTab, Ch + 1) band Mask) =/= 0. 124 | -------------------------------------------------------------------------------- /src/es_datum.erl: -------------------------------------------------------------------------------- 1 | %%% -*- erlang-indent-level: 2 -*- 2 | %%% 3 | %%% Copyright 2014-2025 Mikael Pettersson 4 | %%% 5 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %%% you may not use this file except in compliance with the License. 7 | %%% You may obtain a copy of the License at 8 | %%% 9 | %%% http://www.apache.org/licenses/LICENSE-2.0 10 | %%% 11 | %%% Unless required by applicable law or agreed to in writing, software 12 | %%% distributed under the License is distributed on an "AS IS" BASIS, 13 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %%% See the License for the specific language governing permissions and 15 | %%% limitations under the License. 16 | %%% 17 | %%% es_datum.erl 18 | %%% 19 | %%% Maps between Scheme datums and their Erlang representations. 20 | %%% 21 | %%% Scheme Erlang 22 | %%% ====== ====== 23 | %%% 24 | %%% Straight-forward mappings: 25 | %%% 26 | %%% null [] 27 | %%% number integer() or float() 28 | %%% symbol atom() except boolean() 29 | %%% 30 | %%% Slightly non-obvious mappings: 31 | %%% 32 | %%% pair [_ | _] 33 | %%% 34 | %%% Scheme pairs are similar to Erlang list cells, except 35 | %%% for the fact that list cells are immutable. We map pairs 36 | %%% to list cells, and accept that mutation is unavailable. 37 | %%% 38 | %%% #t true 39 | %%% #f false 40 | %%% 41 | %%% Scheme requires booleans to be disjoint from symbols, 42 | %%% but Erlang considers booleans to be special-case atoms. 43 | %%% We follow the Erlang convention. 44 | %%% 45 | %%% vector tuple() 46 | %%% 47 | %%% Scheme vectors are similar to Erlang tuples, except 48 | %%% for the fact that tuples are immutable. We map vectors 49 | %%% to tuples, and accept that mutation is unavailable. 50 | %%% 51 | %%% character char() 52 | %%% 53 | %%% Scheme requires characters to be a distinct type, but 54 | %%% Erlang considers them to be a sub-range of the integers. 55 | %%% We represent them as unadorned integers. 56 | %%% 57 | %%% eof-object fun es_datum:the_eof_object/0 58 | %%% 59 | %%% Scheme requires the eof-object to be a distinct type. 60 | %%% We relax that requirement and represent it as procedure 61 | %%% referencing es_datum:the_eof_object/0. 62 | %%% R5RS did not require this to be a distinct type. 63 | %%% 64 | %%% unspecified [] 65 | %%% 66 | %%% Scheme specifies that certain expressions evaluate to an 67 | %%% unspecified value. For simplicity we use '() for that. 68 | %%% 69 | %%% string binary() 70 | %%% bytevector 71 | %%% 72 | %%% Scheme requires strings and bytevectors to be distinct types, 73 | %%% but Erlang considers strings to be lists of characters while 74 | %%% bytevectors closely resemble Erlang binaries. We represent both 75 | %%% as unadorned binaries, strings in UTF-8 encoding, and accept that 76 | %%% mutation is unavailable. 77 | %%% R5RS did not have bytevectors, they were added in R6RS and R7RS. 78 | %%% 79 | %%% port 80 | %%% 81 | %%% [NYI] 82 | %%% Scheme requires ports to be a distinct type. We relax that 83 | %%% requirement and represent a port as an arity-0 function closure 84 | %%% that returns the corresponding handle (Pid). The function closures 85 | %%% need to come from a reserved module to enable checking their type. 86 | %%% 87 | %%% procedure Fun/N 88 | %%% 89 | %%% A Scheme procedure becomes an Erlang function of the same arity. 90 | %%% Variable-arity procedures are not supported. 91 | %%% 92 | %%% exception {Class, Reason, Stack} 93 | %%% 94 | %%% A caught exception becomes a 3-tuple of the Class (atom 'error', 95 | %%% 'exit', or 'throw'), Reason (any value), and Stack (list). 96 | %%% 97 | %%% tid pid 98 | %%% 99 | %%% RnRS Scheme does not have threads, but ErlScheme adds threads 100 | %%% and maps them to Erlang processes. 101 | %%% 102 | %%% TODO: 103 | %%% - R6RS record types? 104 | %%% - R6RS exception values? 105 | 106 | -module(es_datum). 107 | 108 | %% API 109 | -export([ format_error/1 110 | , is_eof_object/1 111 | , is_string/1 112 | , is_symbol/1 113 | , integer_to_char/1 114 | , list_to_vector/1 115 | , mk_eof_object/0 116 | , raise/1 117 | , unspecified/0 118 | ]). 119 | 120 | %% private exports 121 | -export([ the_eof_object/0 122 | ]). 123 | 124 | %% API ------------------------------------------------------------------------- 125 | 126 | %% Characters 127 | 128 | integer_to_char(I) -> I. 129 | 130 | %% EOF object 131 | 132 | -define(the_eof_object, the_eof_object). 133 | 134 | is_eof_object(X) -> 135 | case is_function(X, 0) of 136 | true -> 137 | case erlang:fun_info(X, name) of 138 | {name, ?the_eof_object} -> {module, ?MODULE} =:= erlang:fun_info(X, module); 139 | {name, _} -> false 140 | end; 141 | false -> 142 | false 143 | end. 144 | 145 | %% This has to return an exported fun to make fun_info(_, name) well-defined. 146 | mk_eof_object() -> fun ?MODULE:?the_eof_object/0. 147 | 148 | ?the_eof_object() -> error({?MODULE, eof_object_was_called}). 149 | 150 | %% Strings 151 | 152 | is_string(X) -> is_binary(X). 153 | 154 | %% Symbols 155 | 156 | is_symbol(X) -> is_atom(X) andalso not erlang:is_boolean(X). 157 | 158 | %% Vectors 159 | 160 | list_to_vector(L) -> erlang:list_to_tuple(L). 161 | 162 | %% Unspecified 163 | 164 | unspecified() -> []. 165 | 166 | %% Exceptions 167 | 168 | %% This re-raises a caught exception. 169 | raise({error, Reason, _Stack}) -> erlang:error(Reason); 170 | raise({exit, Reason, _Stack}) -> erlang:exit(Reason); 171 | raise({throw, Reason, _Stack}) -> erlang:throw(Reason). 172 | 173 | %% Error Formatting ------------------------------------------------------------ 174 | 175 | -spec format_error(term()) -> io_lib:chars(). 176 | format_error(Reason) -> 177 | case Reason of 178 | eof_object_was_called -> 179 | "eof-object was called"; 180 | _ -> 181 | io_lib:format("~tp", [Reason]) 182 | end. 183 | -------------------------------------------------------------------------------- /src/es_env.erl: -------------------------------------------------------------------------------- 1 | %%% -*- erlang-indent-level: 2 -*- 2 | %%% 3 | %%% Copyright 2014-2022 Mikael Pettersson 4 | %%% 5 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %%% you may not use this file except in compliance with the License. 7 | %%% You may obtain a copy of the License at 8 | %%% 9 | %%% http://www.apache.org/licenses/LICENSE-2.0 10 | %%% 11 | %%% Unless required by applicable law or agreed to in writing, software 12 | %%% distributed under the License is distributed on an "AS IS" BASIS, 13 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %%% See the License for the specific language governing permissions and 15 | %%% limitations under the License. 16 | %%% 17 | %%% es_env.erl 18 | %%% 19 | %%% Var -> Val environment abstraction for ErlScheme. 20 | 21 | -module(es_env). 22 | 23 | -export([ empty/0 24 | , enter/3 25 | , get/2 26 | , is_bound/2 27 | , lookup/2 28 | , map/2 29 | , overlay/2 30 | ]). 31 | 32 | -export_type([ env/0 33 | ]). 34 | 35 | -type env() :: map(). 36 | 37 | -spec empty() -> env(). 38 | empty() -> 39 | maps:new(). 40 | 41 | -spec get(env(), any()) -> any(). 42 | get(Env, Var) -> 43 | maps:get(Var, Env). 44 | 45 | -spec enter(env(), any(), any()) -> env(). 46 | enter(Env, Var, Val) -> 47 | maps:put(Var, Val, Env). 48 | 49 | -spec is_bound(env(), any()) -> boolean(). 50 | is_bound(Env, Var) -> 51 | maps:is_key(Var, Env). 52 | 53 | -spec lookup(env(), any()) -> none | {value, any()}. 54 | lookup(Env, Var) -> 55 | case maps:is_key(Var, Env) of 56 | true -> {value, maps:get(Var, Env)}; 57 | false -> none 58 | end. 59 | 60 | -spec map(env(), fun((any(), any()) -> any())) -> env(). 61 | map(Env, Fn) -> 62 | maps:map(Fn, Env). 63 | 64 | -spec overlay(env(), env()) -> env(). 65 | overlay(Env1, Env2) -> 66 | maps:merge(Env1, Env2). 67 | -------------------------------------------------------------------------------- /src/es_error.erl: -------------------------------------------------------------------------------- 1 | %%% -*- erlang-indent-level: 2 -*- 2 | %%% 3 | %%% Copyright 2019-2022 Mikael Pettersson 4 | %%% 5 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %%% you may not use this file except in compliance with the License. 7 | %%% You may obtain a copy of the License at 8 | %%% 9 | %%% http://www.apache.org/licenses/LICENSE-2.0 10 | %%% 11 | %%% Unless required by applicable law or agreed to in writing, software 12 | %%% distributed under the License is distributed on an "AS IS" BASIS, 13 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %%% See the License for the specific language governing permissions and 15 | %%% limitations under the License. 16 | %%% 17 | %%% es_error.erl 18 | %%% 19 | %%% Format error terms for output in end-user visible diagnostics. 20 | %%% 21 | %%% Our standard representation of error terms is as {Module, Reason} 2-tuples, 22 | %%% where Module:format_error(Reason) returns a textual representation of Reason. 23 | %%% These error terms are typically returned as {error, {Module, Reason}} values 24 | %%% or thrown as error exceptions. 25 | %%% 26 | %%% This code will _not_ attempt to load Module. 27 | 28 | -module(es_error). 29 | 30 | -export([format/1]). 31 | 32 | -spec format(term()) -> io_lib:chars(). 33 | format({Module, Reason} = Error) when is_atom(Module) -> 34 | case erlang:function_exported(Module, format_error, 1) of 35 | true -> 36 | try Module:format_error(Reason) 37 | catch _:_ -> default_format(Error) 38 | end; 39 | false -> default_format(Error) 40 | end; 41 | format(Error) -> default_format(Error). 42 | 43 | default_format(Error) -> 44 | io_lib:format("~tp", [Error]). 45 | -------------------------------------------------------------------------------- /src/es_eval.erl: -------------------------------------------------------------------------------- 1 | %%% -*- erlang-indent-level: 2 -*- 2 | %%% 3 | %%% Copyright 2014-2022 Mikael Pettersson 4 | %%% 5 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %%% you may not use this file except in compliance with the License. 7 | %%% You may obtain a copy of the License at 8 | %%% 9 | %%% http://www.apache.org/licenses/LICENSE-2.0 10 | %%% 11 | %%% Unless required by applicable law or agreed to in writing, software 12 | %%% distributed under the License is distributed on an "AS IS" BASIS, 13 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %%% See the License for the specific language governing permissions and 15 | %%% limitations under the License. 16 | %%% 17 | %%% es_eval.erl 18 | %%% 19 | %%% An R7RS Core Forms Evaluator for ErlScheme. 20 | %%% 21 | %%% Notes: 22 | %%% - LETREC is implemented via finite unfolding of a local 23 | %%% non-recursive environment fragment 24 | %%% - Evaluation is a two-step process: a top-level S-expression is 25 | %%% first parsed and converted to an abstract syntax tree (AST), 26 | %%% which is then interpreted. Function closures record their 27 | %%% bodies as ASTs, not as S-expressions. 28 | %%% - Variadic functions (with "rest" parameters) are not supported, since 29 | %%% they mess up calling conventions and interoperability with Erlang. 30 | %%% - (set! ...) is restricted to assigning global variables in the REPL. 31 | %%% 32 | %%% Extensions: 33 | %%% - (: M F A) is equivalent to Erlang's fun M:F/A 34 | %%% - (case ...) performs Erlang-like pattern-matching with optional guards, 35 | %%% Scheme's (case ...) is not supported 36 | 37 | -module(es_eval). 38 | 39 | -export([ eval/2 40 | , format_error/1 41 | ]). 42 | 43 | -type sexpr() :: term(). 44 | -type datum() :: term(). 45 | 46 | %% API ------------------------------------------------------------------------- 47 | 48 | -spec eval(sexpr(), es_macros:synenv()) -> {datum(), es_macros:synenv()}. 49 | eval(Sexpr, SynEnv) -> 50 | %% io:format("before expand:\n~tp\n", [Sexpr]), 51 | {Expanded, NewSynEnv} = es_macros:expand_toplevel(Sexpr, SynEnv), 52 | %% io:format("after expand:\n~tp\n", [Expanded]), 53 | AST = es_parse:toplevel(Expanded), 54 | %% io:format("after parse:\n~tp\n", [AST]), 55 | Datum = interpret(AST, es_env:empty()), 56 | {Datum, NewSynEnv}. 57 | 58 | %% Internals (AST interpreter) ------------------------------------------------- 59 | 60 | interpret(AST, Env) -> 61 | case AST of 62 | {'ES:BEGIN', First, Next} -> 63 | interpret_begin(First, Next, Env); 64 | {'ES:CASE', Expr, Clauses} -> 65 | interpret_case(Expr, Clauses, Env); 66 | {'ES:CONS', Hd, Tl} -> 67 | interpret_cons(Hd, Tl, Env); 68 | {'ES:DEFINE', Var, Expr} -> 69 | interpret_define(Var, Expr, Env); 70 | {'ES:GLOVAR', Var} -> 71 | interpret_glovar(Var); 72 | {'ES:IF', Pred, Then, Else} -> 73 | interpret_if(Pred, Then, Else, Env); 74 | {'ES:LAMBDA', Formals, Body} -> 75 | interpret_lambda(Formals, Body, Env); 76 | {'ES:LET', Bindings, Body} -> 77 | interpret_let(Bindings, Body, Env); 78 | {'ES:LETREC', Bindings, Body} -> 79 | interpret_letrec(Bindings, Body, Env); 80 | {'ES:LOCVAR', Var} -> 81 | interpret_locvar(Var, Env); 82 | {'ES:PRIMOP', PrimOp, Actuals} -> 83 | interpret_primop(PrimOp, Actuals, Env); 84 | {'ES:QUOTE', Value} -> 85 | interpret_quote(Value); 86 | {'ES:SET!', Var, Expr} -> 87 | 'interpret_set!'(Var, Expr, Env); 88 | {'ES:TRY', Expr, Var, Body, EVar, Handler, After} -> 89 | interpret_try(Expr, Var, Body, EVar, Handler, After, Env); 90 | {'ES:TUPLE', Exprs} -> 91 | interpret_tuple(Exprs, Env) 92 | end. 93 | 94 | interpret_begin(First, Next, Env) -> 95 | interpret(First, Env), 96 | interpret(Next, Env). 97 | 98 | interpret_case(Expr, Clauses, Env) -> 99 | {Body, NewEnv} = interpret_clauses(Clauses, interpret(Expr, Env), Env), 100 | interpret(Body, NewEnv). 101 | 102 | interpret_cons(Hd, Tl, Env) -> 103 | [interpret(Hd, Env) | interpret(Tl, Env)]. 104 | 105 | interpret_define(Var, Expr, Env) -> 106 | %% This is restricted, by macro-expansion and parsing, to the top-level. 107 | es_gloenv:enter_var(Var, interpret(Expr, Env)). 108 | 109 | interpret_glovar(Var) -> 110 | case es_gloenv:lookup_var(Var) of 111 | {value, Val} -> Val; 112 | none -> eval_error({unbound_variable, Var}) 113 | end. 114 | 115 | interpret_if(Pred, Then, Else, Env) -> 116 | interpret(case interpret(Pred, Env) of false -> Else; _ -> Then end, Env). 117 | 118 | interpret_lambda(Formals, Body, Env) -> 119 | make_function( 120 | Formals, 121 | fun (Actuals) -> 122 | interpret_lambda_body(Formals, Actuals, Body, Env) 123 | end). 124 | 125 | interpret_lambda_body(Formals, Actuals, Body, Env) -> 126 | interpret(Body, bind_formals(Formals, Actuals, Env)). 127 | 128 | interpret_let(Bindings, Body, Env) -> 129 | interpret(Body, es_env:overlay(Env, interpret_let_bindings(Bindings, Env))). 130 | 131 | interpret_let_bindings(Bindings, Env) -> 132 | lists:foldl(fun ({Var, Expr}, NestedEnv) -> 133 | es_env:enter(NestedEnv, Var, interpret(Expr, Env)) 134 | end, 135 | es_env:empty(), Bindings). 136 | 137 | interpret_letrec(Bindings, Body, Env) -> 138 | interpret(Body, es_env:overlay(Env, interpret_letrec_bindings(Bindings, Env))). 139 | 140 | interpret_letrec_bindings(Bindings, Env) -> 141 | RecEnv2 = lists:foldl(fun ({Var, Formals, Body}, RecEnv1) -> 142 | es_env:enter(RecEnv1, Var, {Formals, Body, Env}) 143 | end, 144 | es_env:empty(), Bindings), 145 | unfold_recenv(RecEnv2). 146 | 147 | unfold_recenv(RecEnv) -> 148 | es_env:map(RecEnv, 149 | fun (_Var, {Formals, Body, Env}) -> 150 | make_function( 151 | Formals, 152 | fun (Actuals) -> 153 | %% The recursive unfolding is delayed until the function is 154 | %% applied, making it finite. 155 | RecEnv2 = unfold_recenv(RecEnv), 156 | Env2 = es_env:overlay(Env, RecEnv2), 157 | interpret_lambda_body(Formals, Actuals, Body, Env2) 158 | end) 159 | end). 160 | 161 | interpret_locvar(Var, Env) -> 162 | es_env:get(Env, Var). 163 | 164 | interpret_primop(PrimOp, Args0, Env) -> 165 | Args = [interpret(Arg, Env) || Arg <- Args0], 166 | case {PrimOp, Args} of 167 | {'ES:APPLY', [F | Rest]} -> apply(F, Rest); 168 | {'ES:COLON', [M, F, A]} -> fun M:F/A; 169 | {'ES:LIST', _} -> Args; 170 | {'ES:RAISE', [Exn]} -> es_datum:raise(Exn) 171 | end. 172 | 173 | interpret_quote(Value) -> 174 | Value. 175 | 176 | 'interpret_set!'(Var, Expr, Env) -> 177 | %% This can only assign global variables. 178 | case es_gloenv:is_bound_var(Var) of 179 | true -> es_gloenv:enter_var(Var, interpret(Expr, Env)); 180 | false -> eval_error({unbound_variable, Var}) 181 | end. 182 | 183 | interpret_try(Expr, Var, Body, EVar, Handler, _After = [], Env) -> 184 | interpret_try(Expr, Var, Body, EVar, Handler, Env); 185 | interpret_try(Expr, Var, Body, EVar, Handler, After, Env) -> 186 | try interpret_try(Expr, Var, Body, EVar, Handler, Env) 187 | after interpret(After, Env) 188 | end. 189 | 190 | interpret_try(Expr, Var, Body, EVar, Handler, Env) -> 191 | try 192 | interpret(Expr, Env) of 193 | Res -> 194 | interpret(Body, bind_formals([Var], [Res], Env)) 195 | catch Class:Reason:Stack -> 196 | interpret(Handler, bind_formals([EVar], [{Class, Reason, Stack}], Env)) 197 | end. 198 | 199 | interpret_tuple(Exprs, Env) -> 200 | list_to_tuple(lists:map(fun (Expr) -> interpret(Expr, Env) end, Exprs)). 201 | 202 | %% Pattern matching ------------------------------------------------------------ 203 | %% 204 | %% Patterns follow the Erlang convention of classifying variables as bindings if 205 | %% not already bound in the pattern or in the surrounding scope, and as equality 206 | %% constraints otherwise. Plain variable patterns are represented as (= Var _). 207 | 208 | -define(nomatch, nomatch). 209 | 210 | interpret_clauses([], _Val, _Env) -> ?nomatch; 211 | interpret_clauses([Clause | Clauses], Val, Env) -> 212 | case interpret_clause(Clause, Val, Env) of 213 | ?nomatch -> interpret_clauses(Clauses, Val, Env); 214 | {_Body, _NewEnv} = Match -> Match 215 | end. 216 | 217 | interpret_clause({Pat, Guard, Body}, Val, Env) -> 218 | case match_pat(Pat, Val, Env) of 219 | ?nomatch -> ?nomatch; 220 | NewEnv -> 221 | case interpret_guard(Guard, NewEnv) of 222 | true -> {Body, NewEnv}; 223 | false -> ?nomatch 224 | end 225 | end. 226 | 227 | interpret_guard(Guard, Env) -> 228 | try interpret(Guard, Env) of 229 | true -> true; 230 | _ -> false 231 | catch _:_ -> false 232 | end. 233 | 234 | match_pat(Pat, Val, Env) -> 235 | case Pat of 236 | {'ES:BIND', Var, Pat2} -> % Var is not bound 237 | match_pat(Pat2, Val, es_env:enter(Env, Var, Val)); 238 | {'ES:CONS', Hd, Tl} -> 239 | case Val of 240 | [X | Y] -> 241 | case match_pat(Hd, X, Env) of 242 | ?nomatch -> ?nomatch; 243 | Env2 -> match_pat(Tl, Y, Env2) 244 | end; 245 | _ -> ?nomatch 246 | end; 247 | {'ES:EQUAL', Var, Pat2} -> % Var is bound, may be global 248 | case Val == get_pat_var(Var, Env) of 249 | true -> match_pat(Pat2, Val, Env); 250 | false -> ?nomatch 251 | end; 252 | {'ES:QUOTE', Val2} -> 253 | case Val == Val2 of 254 | true -> Env; 255 | false -> ?nomatch 256 | end; 257 | {'ES:TUPLE', Pats} -> 258 | case is_tuple(Val) of 259 | true -> 260 | case tuple_size(Val) =:= length(Pats) of 261 | true -> match_tuple(Pats, 1, Val, Env); 262 | false -> ?nomatch 263 | end; 264 | false -> ?nomatch 265 | end; 266 | 'ES:WILD' -> 267 | Env 268 | end. 269 | 270 | get_pat_var(Var, Env) -> 271 | case es_env:lookup(Env, Var) of 272 | {value, Val} -> Val; 273 | none -> interpret_glovar(Var) 274 | end. 275 | 276 | match_tuple([], _I, _Tuple, Env) -> Env; 277 | match_tuple([Pat | Pats], I, Tuple, Env) -> 278 | case match_pat(Pat, element(I, Tuple), Env) of 279 | ?nomatch -> ?nomatch; 280 | Env2 -> match_tuple(Pats, I + 1, Tuple, Env2) 281 | end. 282 | 283 | %% Auxiliary helpers ----------------------------------------------------------- 284 | 285 | bind_formals([], [], Env) -> 286 | Env; 287 | bind_formals([F|Fs], [A|As], Env) -> 288 | bind_formals(Fs, As, es_env:enter(Env, F, A)). 289 | 290 | make_function(Formals, BodyFn) -> 291 | %% Synthesize a function of the correct arity. 292 | %% This is ugly, but erl_eval.erl does the same thing. 293 | case length(Formals) of 294 | 0 -> 295 | fun () -> 296 | BodyFn([]) 297 | end; 298 | 1 -> 299 | fun (A1) -> 300 | BodyFn([A1]) 301 | end; 302 | 2 -> 303 | fun (A1, A2) -> 304 | BodyFn([A1, A2]) 305 | end; 306 | 3 -> 307 | fun (A1, A2, A3) -> 308 | BodyFn([A1, A2, A3]) 309 | end; 310 | 4 -> 311 | fun (A1, A2, A3, A4) -> 312 | BodyFn([A1, A2, A3, A4]) 313 | end; 314 | 5 -> 315 | fun (A1, A2, A3, A4, A5) -> 316 | BodyFn([A1, A2, A3, A4, A5]) 317 | end; 318 | 6 -> 319 | fun (A1, A2, A3, A4, A5, A6) -> 320 | BodyFn([A1, A2, A3, A4, A5, A6]) 321 | end; 322 | 7 -> 323 | fun (A1, A2, A3, A4, A5, A6, A7) -> 324 | BodyFn([A1, A2, A3, A4, A5, A6, A7]) 325 | end; 326 | 8 -> 327 | fun (A1, A2, A3, A4, A5, A6, A7, A8) -> 328 | BodyFn([A1, A2, A3, A4, A5, A6, A7, A8]) 329 | end; 330 | 9 -> 331 | fun (A1, A2, A3, A4, A5, A6, A7, A8, A9) -> 332 | BodyFn([A1, A2, A3, A4, A5, A6, A7, A8, A9]) 333 | end; 334 | 10 -> 335 | fun (A1, A2, A3, A4, A5, A6, A7, A8, A9, A10) -> 336 | BodyFn([A1, A2, A3, A4, A5, A6, A7, A8, A9, A10]) 337 | end; 338 | Arity -> 339 | eval_error({argument_limit, Arity}) 340 | end. 341 | 342 | %% Error Formatting ------------------------------------------------------------ 343 | 344 | eval_error(Reason) -> 345 | error({?MODULE, Reason}). 346 | 347 | -spec format_error(term()) -> io_lib:chars(). 348 | format_error(Reason) -> 349 | case Reason of 350 | {unbound_variable, Var} -> 351 | io_lib:format("unbound variable: ~tp", [Var]); 352 | {argument_limit, Arity} -> 353 | io_lib:format("arity limit exceeded: ~tp", [Arity]); 354 | _ -> 355 | io_lib:format("~tp", [Reason]) 356 | end. 357 | -------------------------------------------------------------------------------- /src/es_gloenv.erl: -------------------------------------------------------------------------------- 1 | %%% -*- erlang-indent-level: 2 -*- 2 | %%% 3 | %%% Copyright 2014-2022 Mikael Pettersson 4 | %%% 5 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %%% you may not use this file except in compliance with the License. 7 | %%% You may obtain a copy of the License at 8 | %%% 9 | %%% http://www.apache.org/licenses/LICENSE-2.0 10 | %%% 11 | %%% Unless required by applicable law or agreed to in writing, software 12 | %%% distributed under the License is distributed on an "AS IS" BASIS, 13 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %%% See the License for the specific language governing permissions and 15 | %%% limitations under the License. 16 | %%% 17 | %%% es_gloenv.erl 18 | %%% 19 | %%% Global Name -> {Tag, Value} store for ErlScheme. 20 | %%% 21 | %%% Used for global variables and macros in the repl / user environment. 22 | %%% Global variables and macros share name space so that binding an identifier 23 | %%% as one kind simultaneously removes its binding as the other kind. 24 | 25 | -module(es_gloenv). 26 | 27 | -export([ enter_expander/2 28 | , enter_var/2 29 | , init/0 30 | , is_bound_var/1 31 | , lookup_expander/1 32 | , lookup_var/1 33 | ]). 34 | 35 | -define(es_gloenv_tab, es_gloenv_tab). 36 | -define(tag_expander, '%expander'). 37 | -define(tag_var, '%var'). 38 | 39 | -type name() :: atom(). 40 | 41 | %% API ------------------------------------------------------------------------- 42 | 43 | -spec init() -> ok. 44 | init() -> 45 | ets:new(?es_gloenv_tab, [public, named_table, {read_concurrency, true}]), 46 | ok. 47 | 48 | -spec enter_expander(name(), term()) -> true. 49 | enter_expander(Name, Value) -> 50 | insert(Name, ?tag_expander, Value). 51 | 52 | -spec enter_var(name(), term()) -> true. 53 | enter_var(Name, Value) -> 54 | insert(Name, ?tag_var, Value). 55 | 56 | -spec is_bound_var(name()) -> boolean(). 57 | is_bound_var(Name) -> 58 | case lookup(Name, ?tag_var) of 59 | {value, _} -> true; 60 | none -> false 61 | end. 62 | 63 | -spec lookup_expander(name()) -> {value, term()} | none. 64 | lookup_expander(Name) -> 65 | lookup(Name, ?tag_expander). 66 | 67 | -spec lookup_var(name()) -> {value, term()} | none. 68 | lookup_var(Name) -> 69 | lookup(Name, ?tag_var). 70 | 71 | %% Internals ------------------------------------------------------------------- 72 | 73 | -spec insert(name(), ?tag_var|?tag_expander, term()) -> true. 74 | insert(Name, Tag, Val) -> 75 | ets:insert(?es_gloenv_tab, {Name, {Tag, Val}}). 76 | 77 | -spec lookup(name(), ?tag_var|?tag_expander) -> {value, term()} | none. 78 | lookup(Name, Tag) -> 79 | case lookup(Name) of 80 | {Tag, Value} -> {value, Value}; 81 | {_OtherTag, _Value} -> none; 82 | none -> none 83 | end. 84 | 85 | -spec lookup(name()) -> {?tag_var|?tag_expander, term()} | none. 86 | lookup(Name) -> 87 | try 88 | ets:lookup_element(?es_gloenv_tab, Name, 2) 89 | catch 90 | error:badarg -> none 91 | end. 92 | -------------------------------------------------------------------------------- /src/es_input_string_iodev.erl: -------------------------------------------------------------------------------- 1 | %%% -*- erlang-indent-level: 2 -*- 2 | %%% 3 | %%% Copyright 2023 Mikael Pettersson 4 | %%% 5 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %%% you may not use this file except in compliance with the License. 7 | %%% You may obtain a copy of the License at 8 | %%% 9 | %%% http://www.apache.org/licenses/LICENSE-2.0 10 | %%% 11 | %%% Unless required by applicable law or agreed to in writing, software 12 | %%% distributed under the License is distributed on an "AS IS" BASIS, 13 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %%% See the License for the specific language governing permissions and 15 | %%% limitations under the License. 16 | %%% 17 | %%% es_input_string_iodev.erl 18 | %%% 19 | %%% An Erlang I/O protocol server that implements sequential single-character 20 | %%% reads from strings. 21 | %%% 22 | %%% The I/O server is required to convert from sequences of octets to Unicode 23 | %%% characters. This needs a fair amount of code, so we support reading from 24 | %%% binaries by converting them to strings first. 25 | %%% 26 | %%% See https://www.erlang.org/doc/apps/stdlib/io_protocol.html for details 27 | %%% about the Erlang I/O protocol. 28 | 29 | -module(es_input_string_iodev). 30 | -behaviour(gen_server). 31 | 32 | %% API 33 | -export([ close/1 34 | , open/1 35 | ]). 36 | 37 | %% gen_server callbacks 38 | -export([ init/1 39 | , handle_call/3 40 | , handle_cast/2 41 | , handle_info/2 42 | , terminate/2 43 | , code_change/3 44 | ]). 45 | 46 | -define(close, close). 47 | 48 | %% API ------------------------------------------------------------------------- 49 | 50 | -spec close(pid()) -> ok. 51 | close(Pid) -> 52 | ok = gen_server:call(Pid, ?close, infinity). 53 | 54 | -spec open(string() | binary()) -> pid(). 55 | open(Binary) when is_binary(Binary) -> open(unicode:characters_to_list(Binary)); 56 | open(String) when is_list(String) -> 57 | {ok, Pid} = gen_server:start_link(?MODULE, String, []), 58 | Pid. 59 | 60 | %% gen_server callbacks -------------------------------------------------------- 61 | 62 | -type state() :: string(). 63 | 64 | init(String) -> 65 | {ok, String}. 66 | 67 | handle_call(Req, _From, State) -> 68 | case Req of 69 | ?close -> 70 | {stop, normal, ok, []}; 71 | _ -> 72 | {reply, {error, {bad_call, Req}}, State} 73 | end. 74 | 75 | handle_cast(_Req, State) -> 76 | {noreply, State}. 77 | 78 | %% All I/O commands come in here. 79 | handle_info(Info, State) -> 80 | %% io:format(standard_error, ?MODULE_STRING ": handle_info: info=~p state=~p\n", [Info, State]), 81 | case Info of 82 | {io_request, From, ReplyAs, Request} -> 83 | {Reply, NewState} = 84 | try io_request(Request, State) 85 | catch _Class:Reason:_ST -> 86 | %% io:format(standard_error, ?MODULE_STRING ": crashed with ~p:~p\n~p\n", [_Class, Reason, _ST]), 87 | {{error, Reason}, State} 88 | end, 89 | %% io:format(standard_error, ?MODULE_STRING ": reply ~p to ~p\n", [Reply, From]), 90 | io_reply(From, ReplyAs, Reply), 91 | {noreply, NewState}; 92 | _ -> 93 | {noreply, State} 94 | end. 95 | 96 | terminate(_Reason, _State) -> 97 | ok. 98 | 99 | code_change(_OldVsn, State, _Extra) -> 100 | {ok, State}. 101 | 102 | %% I/O server specifics -------------------------------------------------------- 103 | 104 | -type io_request() :: term(). 105 | -type io_result() :: string() | eof | {error, term()}. 106 | 107 | -spec io_reply(pid(), term(), io_result()) -> any(). 108 | io_reply(From, ReplyAs, Reply) -> 109 | From ! {io_reply, ReplyAs, Reply}. 110 | 111 | -spec io_request(io_request(), state()) -> {io_result(), state()}. 112 | io_request(Request, State) -> 113 | case Request of 114 | %% This is enough to support io:get_chars(StringDev, "", 1). 115 | {get_chars, unicode, _Prompt, 1} -> get_char(State); 116 | %% We return {error, enotsup} for unimplemented commands and {error, request} 117 | %% for unrecognized commands, as per recommendations in the documentation. 118 | {get_chars, _Encoding, _Prompt, _N} -> error_enotsup(State); 119 | {get_until, _Encoding, _Prompt, _Mod, _Func, _Args} -> error_enotsup(State); 120 | {get_line, _Encoding, _Prompt} -> error_enotsup(State); 121 | {setopts, _Opts} -> error_enotsup(State); 122 | getopts -> error_enotsup(State); 123 | {requests, _Requests} -> error_enotsup(State); 124 | {get_geometry, _Geometry} -> error_enotsup(State); 125 | {put_chars, _Encoding, _Chars} -> error_enotsup(State); 126 | {put_chars, _Encoding, _Module, _Function, _Args} -> error_enotsup(State); 127 | _ -> error_request(State) 128 | end. 129 | 130 | get_char(String) -> 131 | case String of 132 | [Ch | Rest] -> {[Ch], Rest}; 133 | [] -> {eof, []} 134 | end. 135 | 136 | error_enotsup(State) -> 137 | {{error, enotsup}, State}. 138 | 139 | error_request(State) -> 140 | {{error, request}, State}. 141 | -------------------------------------------------------------------------------- /src/es_lexer.erl: -------------------------------------------------------------------------------- 1 | %%% -*- erlang-indent-level: 2 -*- 2 | %%% 3 | %%% Copyright 2014-2023 Mikael Pettersson 4 | %%% 5 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %%% you may not use this file except in compliance with the License. 7 | %%% You may obtain a copy of the License at 8 | %%% 9 | %%% http://www.apache.org/licenses/LICENSE-2.0 10 | %%% 11 | %%% Unless required by applicable law or agreed to in writing, software 12 | %%% distributed under the License is distributed on an "AS IS" BASIS, 13 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %%% See the License for the specific language governing permissions and 15 | %%% limitations under the License. 16 | %%% 17 | %%% es_lexer.erl 18 | %%% 19 | %%% R7RS-like Lexical Analyzer for ErlScheme. 20 | %%% 21 | %%% Limitations: 22 | %%% - #!fold-case and #!no-fold-case are not yet implemented 23 | %%% - "#u8(" for the syntax is not yet implemented 24 | %%% - the polar, rectangular, and rational number syntaxes are not supported 25 | %%% 26 | %%% Extensions: 27 | %%% - recognizes [ and ] for R6RS bracketed list syntax (and other LISPs before that) 28 | %%% - : and / are delimiters which read as single-character symbols 29 | 30 | -module(es_lexer). 31 | 32 | -export([ format_error/1 33 | , string_to_number/2 34 | , token/1 35 | ]). 36 | 37 | -export_type([ token/0 38 | ]). 39 | 40 | -type token() :: atom() | {atom(), term()}. 41 | 42 | %% API ------------------------------------------------------------------------- 43 | 44 | -spec token(es_lexinput:lexinput()) -> token(). 45 | token(LI) -> 46 | case skip_intertoken_space(LI) of 47 | -1 -> 48 | token_eof; 49 | 40 -> % left-paren, messes up erlang-mode :-( 50 | token_lparen; 51 | 41 -> % right-paren, messes up erlang-mode :-( 52 | token_rparen; 53 | 91 -> % left-bracket, messes up erlang-mode :-( 54 | token_lbracket; 55 | 93 -> % right-bracket, messes up erlang-mode :-( 56 | token_rbracket; 57 | 39 -> % single-quote, messes up erlang-mode :-( 58 | token_squote; 59 | $` -> 60 | token_backquote; 61 | $, -> 62 | scan_comma(LI); 63 | 34 -> % double-quote, messes up erlang-mode :-( 64 | scan_string(LI); 65 | $# -> 66 | scan_hash(LI); 67 | 46 -> % dot, messes up erlang-mode :-( 68 | scan_pi_dot(LI, [46], false); 69 | $+ -> 70 | scan_pi_sign(LI, $+, false); 71 | $- -> 72 | scan_pi_sign(LI, $-, true); 73 | $| -> 74 | scan_vertical_identifier(LI); 75 | $: -> % ErlScheme extension 76 | {token_identifier, ":"}; 77 | $/ -> % ErlScheme extension 78 | {token_identifier, "/"}; 79 | Ch -> 80 | case es_ctype:char_is_initial(Ch) of 81 | true -> 82 | scan_simple_identifier(LI, [Ch]); 83 | false -> 84 | Val = es_ctype:char_value(Ch), 85 | if Val < 10 -> 86 | case decimal_q3(LI, Val, false, false) of 87 | Num when is_number(Num) -> 88 | {token_number, Num}; 89 | false -> 90 | lexer_error(invalid_number) 91 | end; 92 | true -> 93 | lexer_error({invalid_character, Ch}) 94 | end 95 | end 96 | end. 97 | 98 | -spec string_to_number(string(), integer()) -> number() | false. 99 | string_to_number(String, Radix) -> 100 | LI = es_lexinput:open_string(String), 101 | try 102 | case number_q0(LI, Radix) of 103 | Num when is_number(Num) -> 104 | case es_lexinput:peek_char(LI) of 105 | -1 -> 106 | Num; 107 | _ -> 108 | false 109 | end; 110 | false -> 111 | false 112 | end 113 | after 114 | es_lexinput:close(LI) 115 | end. 116 | 117 | %% Internals ------------------------------------------------------------------- 118 | 119 | %% scan_hash: read what follows a '#' 120 | %% (a , , start, start, or ) 121 | %% #| ... |# comments have already been eliminated by skip_intertoken_space. 122 | 123 | scan_hash(LI) -> 124 | Ch = es_lexinput:peek_char(LI), 125 | case scan_hash_norm(Ch) of 126 | $\\ -> 127 | es_lexinput:read_char(LI), 128 | scan_character(LI); 129 | 40 -> % left-paren, messes up erlang-mode :-( 130 | es_lexinput:read_char(LI), 131 | token_hash_lparen; 132 | $; -> 133 | es_lexinput:read_char(LI), 134 | token_hash_semi; 135 | % $! -> % TODO: NYI: start of 136 | % $U -> % TODO: NYI: start of 137 | $T -> 138 | es_lexinput:read_char(LI), 139 | scan_boolean(LI, Ch); 140 | $F -> 141 | es_lexinput:read_char(LI), 142 | scan_boolean(LI, Ch); 143 | _ -> 144 | case number_q1(LI, 10) of 145 | Num when is_number(Num) -> 146 | {token_number, Num}; 147 | false -> 148 | lexer_error(invalid_number) 149 | end 150 | end. 151 | 152 | scan_hash_norm(Ch) -> % normalize case of relevant characters 153 | case Ch of 154 | $t -> $T; 155 | $f -> $F; 156 | _ -> Ch 157 | end. 158 | 159 | scan_boolean(LI, Ch) -> 160 | {token_identifier, String} = scan_simple_identifier(LI, [Ch]), 161 | %% R6RS and R7RS both state that booleans are case-insensitive. 162 | String2 = string:to_lower(String), 163 | if String2 =:= "t"; String2 =:= "true" -> % R7RS added #true 164 | token_true; 165 | String2 =:= "f"; String2 =:= "false" -> % R7RS added #false 166 | token_false; 167 | true -> 168 | lexer_error({invalid_boolean, String}) 169 | end. 170 | 171 | %% 172 | %% -> 173 | %% | * 174 | %% | "." * 175 | %% | "." * 176 | %% (TODO: == \ ) 177 | %% -> 178 | %% | "." 179 | %% (TODO: == \ \ ".") 180 | %% -> 181 | %% | 182 | %% | "@" 183 | %% 184 | %% -> "+" | "-" 185 | 186 | scan_pi_sign(LI, Ch0, IsNegative) -> 187 | Ch1 = es_lexinput:peek_char(LI), 188 | case es_ctype:char_is_subsequent(Ch1) of 189 | true -> 190 | case es_ctype:char_is_numeric(Ch1) of 191 | true -> 192 | case decimal_q1(LI, false, IsNegative) of 193 | Num when is_number(Num) -> 194 | {token_number, Num}; 195 | false -> 196 | lexer_error(invalid_number) 197 | end; 198 | false -> 199 | if Ch1 =:= 46 -> % dot, messes up erlang-mode :-( 200 | es_lexinput:read_char(LI), 201 | scan_pi_dot(LI, [Ch1, Ch0], IsNegative); 202 | true -> % 203 | es_lexinput:read_char(LI), 204 | scan_simple_identifier(LI, [Ch1, Ch0]) 205 | end 206 | end; 207 | false -> 208 | case es_ctype:char_is_delimiter(Ch1) of 209 | true -> 210 | {token_identifier, [Ch0]}; 211 | false -> 212 | lexer_error({invalid_identifier, [Ch0], Ch1}) 213 | end 214 | end. 215 | 216 | scan_pi_dot(LI, Acc, IsNegative) -> 217 | Ch = es_lexinput:peek_char(LI), 218 | case es_ctype:char_is_subsequent(Ch) of 219 | true -> 220 | case es_ctype:char_is_numeric(Ch) of 221 | true -> 222 | case decimal_q2(LI, IsNegative) of 223 | Num when is_number(Num) -> 224 | {token_number, Num}; 225 | false -> 226 | lexer_error(invalid_number) 227 | end; 228 | false -> % 229 | es_lexinput:read_char(LI), 230 | scan_simple_identifier(LI, [Ch | Acc]) 231 | end; 232 | false -> 233 | case es_ctype:char_is_delimiter(Ch) of 234 | true -> 235 | case Acc of % detect if this is "." (Ok) or "[+-]." (invalid) 236 | [46] -> 237 | token_dot; 238 | [46, _] -> 239 | lexer_error({invalid_identifier, lists:reverse(Acc)}) 240 | end; 241 | false -> 242 | lexer_error({invalid_identifier, lists:reverse(Acc), Ch}) 243 | end 244 | end. 245 | 246 | %% scan_simple_identifier: scan * after seeing 247 | 248 | scan_simple_identifier(LI, Acc) -> 249 | Ch = es_lexinput:peek_char(LI), 250 | case es_ctype:char_is_subsequent(Ch) of 251 | true -> 252 | es_lexinput:read_char(LI), 253 | scan_simple_identifier(LI, [Ch | Acc]); 254 | false -> 255 | case es_ctype:char_is_delimiter(Ch) of 256 | true -> 257 | {token_identifier, lists:reverse(Acc)}; 258 | false -> 259 | lexer_error({invalid_identifier, lists:reverse(Acc), Ch}) 260 | end 261 | end. 262 | 263 | %% scan_vertical_identifier 264 | 265 | scan_vertical_identifier(LI) -> 266 | scan_vi(LI, []). 267 | 268 | scan_vi(LI, Acc) -> 269 | Ch = es_lexinput:read_char(LI), 270 | case Ch of 271 | -1 -> 272 | lexer_error(premature_eof); 273 | $| -> 274 | {token_identifier, lists:reverse(Acc)}; 275 | $\\ -> 276 | scan_vi_backslash(LI, Acc); 277 | Ch -> 278 | scan_vi(LI, [Ch | Acc]) 279 | end. 280 | 281 | scan_vi_backslash(LI, Acc) -> 282 | case scan_inline_escape(LI) of 283 | Ch when is_integer(Ch) -> 284 | scan_vi(LI, [Ch | Acc]); 285 | {error, Ch} -> 286 | lexer_error({invalid_character, Ch}) 287 | end. 288 | 289 | %% seen ",", check for ",@" 290 | 291 | scan_comma(LI) -> 292 | case es_lexinput:peek_char(LI) of 293 | $@ -> 294 | es_lexinput:read_char(LI), 295 | token_comma_at; 296 | _ -> 297 | token_comma 298 | end. 299 | 300 | %% scan_character: read a character literal after seeing #\ 301 | 302 | scan_character(LI) -> 303 | Ch1 = es_lexinput:read_char(LI), 304 | Ch2 = es_lexinput:peek_char(LI), 305 | case es_ctype:char_is_delimiter(Ch2) of 306 | true -> 307 | {token_character, Ch1}; 308 | false -> 309 | if Ch1 =:= $x; Ch1 =:= $X -> 310 | {token_character, scan_hex_scalar_value(LI, true)}; 311 | true -> 312 | {token_identifier, String} = scan_simple_identifier(LI, [Ch1]), 313 | {token_character, 314 | case String of % note that case is significant in 315 | "alarm" -> 7; 316 | "backspace" -> 8; 317 | "delete" -> 127; 318 | "escape" -> 27; 319 | "newline" -> 10; 320 | "null" -> 0; 321 | "return" -> 13; 322 | "space" -> 32; 323 | "tab" -> 9; 324 | _ -> lexer_error({invalid_character_name, String}) 325 | end} 326 | end 327 | end. 328 | 329 | %% scan_string: read a string literal after seeing the first " 330 | 331 | scan_string(LI) -> 332 | scan_string(LI, []). 333 | 334 | scan_string(LI, Acc) -> 335 | scan_string(es_lexinput:read_char(LI), LI, Acc). 336 | 337 | scan_string(Ch, LI, Acc) -> 338 | case Ch of 339 | -1 -> 340 | lexer_error(premature_eof); 341 | 34 -> % double-quote, messes up erlang-mode :-( 342 | {token_string, lists:reverse(Acc)}; 343 | $\\ -> 344 | scan_string_backslash(LI, Acc); 345 | Ch -> 346 | scan_string(LI, [Ch | Acc]) 347 | end. 348 | 349 | scan_string_backslash(LI, Acc) -> 350 | case scan_inline_escape(LI) of 351 | Ch when is_integer(Ch) -> 352 | scan_string(LI, [Ch | Acc]); 353 | {error, Ch} -> 354 | case es_ctype:char_is_whitespace(Ch) of 355 | true -> 356 | scan_string_gap1(LI, Acc); 357 | false -> 358 | lexer_error({invalid_character, Ch}) 359 | end 360 | end. 361 | 362 | %% Shared function for handling the common cases of and 363 | %% , after seeing a backslash. Apart from , 364 | %% the differences between and in R7RS 365 | %% 7.1.1 seem like documentation mistakes, so we deliberately allow the 366 | %% same escape sequences for both contexts. (R7RSSmallErrata.txt agrees, 367 | %% stating that \| should be permitted in strings, and that strings and 368 | %% symbols should accept the same escape sequences.) is 369 | %% handled by tagging and returning any unrecognized character, letting 370 | %% the context determine whether that character is valid or not. 371 | 372 | scan_inline_escape(LI) -> % return Char or {error, Ch} 373 | case es_lexinput:read_char(LI) of 374 | -1 -> 375 | lexer_error(premature_eof); 376 | $a -> % alarm 377 | 7; 378 | $b -> % backspace 379 | 8; 380 | $t -> % tab 381 | 9; 382 | $n -> % linefeed 383 | 10; 384 | $r -> % carriage return 385 | 13; 386 | %% This case is missing from R7RS 7.1.1 . 387 | %% However, 2.1 "Identifiers" states that 388 | %% allows the same escape sequences that are allowed in strings. 389 | 34 -> % double-quote, messes up erlang-mode :-( 390 | 34; 391 | %% This case is missing from R7RS 7.1.1 . 392 | %% However, 2.1 "Identifiers" states that 393 | %% allows the same escape sequences that are allowed in strings. 394 | $\\ -> 395 | 92; 396 | %% This case is missing from R7RS 7.1.1 . 397 | %% However, 6.7 "Strings" lists it. 398 | $| -> % vertical line 399 | 124; 400 | $x -> % inline hex escape 401 | scan_hex_scalar_value(LI, ';'); 402 | Ch -> 403 | {error, Ch} 404 | end. 405 | 406 | scan_hex_scalar_value(LI, Delimiter) -> 407 | Ch = es_lexinput:read_char(LI), 408 | Val = es_ctype:char_value(Ch), 409 | if Val < 16 -> 410 | scan_hex_scalar_value(LI, Delimiter, Val); 411 | true -> 412 | lexer_error({expected_hex_digit, Ch}) 413 | end. 414 | 415 | scan_hex_scalar_value(LI, Delimiter, Num) -> 416 | Ch = es_lexinput:peek_char(LI), 417 | Val = es_ctype:char_value(Ch), 418 | if Val < 16 -> 419 | es_lexinput:read_char(LI), 420 | scan_hex_scalar_value(LI, Delimiter, (Num * 16) + Val); 421 | true -> 422 | case Delimiter of 423 | true -> 424 | case es_ctype:char_is_delimiter(Ch) of 425 | true -> 426 | []; 427 | false -> 428 | lexer_error({expected_delimiter, Ch}) 429 | end; 430 | ';' -> 431 | case Ch =:= $; of 432 | true -> 433 | es_lexinput:read_char(LI); 434 | false -> 435 | lexer_error({expected_semicolon, Ch}) 436 | end 437 | end, 438 | Num 439 | end. 440 | 441 | scan_string_gap1(LI, Acc) -> % before 442 | case es_lexinput:read_char(LI) of 443 | -1 -> 444 | lexer_error(premature_eof); 445 | 10 -> % linefeed 446 | scan_string_gap3(LI, Acc); 447 | 13 -> % carriage return 448 | scan_string_gap2(LI, Acc); 449 | Ch -> 450 | case es_ctype:char_is_whitespace(Ch) of 451 | true -> 452 | scan_string_gap1(LI, Acc); 453 | false -> 454 | lexer_error({invalid_character, Ch}) 455 | end 456 | end. 457 | 458 | scan_string_gap2(LI, Acc) -> % after 459 | case es_lexinput:read_char(LI) of 460 | -1 -> 461 | lexer_error(premature_eof); 462 | 10 -> % linefeed 463 | scan_string_gap3(LI, Acc); 464 | Ch -> 465 | scan_string_gap3(Ch, LI, Acc) 466 | end. 467 | 468 | scan_string_gap3(LI, Acc) -> % after 469 | scan_string_gap3(es_lexinput:read_char(LI), LI, Acc). 470 | 471 | scan_string_gap3(Ch, LI, Acc) -> % after 472 | case Ch of 473 | -1 -> 474 | lexer_error(premature_eof); 475 | _ -> 476 | case es_ctype:char_is_whitespace(Ch) of 477 | true -> 478 | scan_string_gap3(LI, Acc); 479 | false -> 480 | scan_string(Ch, LI, Acc) 481 | end 482 | end. 483 | 484 | %% The following implements a scanner for numbers: 485 | %% 486 | %% -> 487 | %% -> 488 | %% [remaining alternatives omitted] 489 | %% -> 490 | %% [remaining alternatives omitted] 491 | %% -> 492 | %% | 493 | %% [remaining alternatives omitted] 494 | %% -> 495 | %% | "." + 496 | %% | + "." * 497 | %% -> + 498 | %% -> 499 | %% | 500 | %% -> 501 | %% | + 502 | %% -> "e" 503 | %% -> | "+" | "-" 504 | %% -> | "#i" | "#e" 505 | %% -> "#b" 506 | %% -> "#o" 507 | %% -> | "#d" 508 | %% -> "#x" 509 | %% -> [0-1] 510 | %% -> [0-7] 511 | %% -> [0-9] 512 | %% -> [0-9a-f] 513 | %% 514 | %% Notes: 515 | %% 1) All alphabetic characters used in these rules may appear 516 | %% in either upper or lower case. 517 | %% 2) Returns false on failure. 518 | 519 | number_q0(LI, Radix) -> 520 | Ch = es_lexinput:peek_char(LI), 521 | case Ch of 522 | $# -> 523 | es_lexinput:read_char(LI), 524 | number_q1(LI, Radix); 525 | $+ -> 526 | es_lexinput:read_char(LI), 527 | choose_decimal_q1_or_integer_q1(LI, Radix, false, false); 528 | $- -> 529 | es_lexinput:read_char(LI), 530 | choose_decimal_q1_or_integer_q1(LI, Radix, false, true); 531 | _ -> 532 | Val = es_ctype:char_value(Ch), 533 | if Val < Radix -> 534 | es_lexinput:read_char(LI), 535 | choose_decimal_q3_or_integer_q2(LI, Radix, Val, false); 536 | true -> 537 | false 538 | end 539 | end. 540 | 541 | number_q1(LI, Radix) -> % after "#" 542 | Ch = es_lexinput:peek_char(LI), 543 | case number_q1_norm(Ch) of 544 | $B -> 545 | es_lexinput:read_char(LI), 546 | number_q2(LI, 2); 547 | $O -> 548 | es_lexinput:read_char(LI), 549 | number_q2(LI, 8); 550 | $D -> 551 | es_lexinput:read_char(LI), 552 | number_q2(LI, 10); 553 | $X -> 554 | es_lexinput:read_char(LI), 555 | number_q2(LI, 16); 556 | $E -> 557 | es_lexinput:read_char(LI), 558 | number_q4(LI, Radix, false); 559 | $I -> 560 | es_lexinput:read_char(LI), 561 | number_q4(LI, Radix, true); 562 | _ -> 563 | false 564 | end. 565 | 566 | number_q1_norm(Ch) -> % normalize case of relevant characters 567 | case Ch of 568 | $b -> $B; 569 | $o -> $O; 570 | $d -> $D; 571 | $x -> $X; 572 | $e -> $E; 573 | $i -> $I; 574 | _ -> Ch 575 | end. 576 | 577 | number_q2(LI, Radix) -> % after "#{B,O,D,X}" 578 | case es_lexinput:peek_char(LI) of 579 | $# -> 580 | es_lexinput:read_char(LI), 581 | number_q3(LI, Radix); 582 | $+ -> 583 | es_lexinput:read_char(LI), 584 | choose_decimal_q1_or_integer_q1(LI, Radix, false, false); 585 | $- -> 586 | es_lexinput:read_char(LI), 587 | choose_decimal_q1_or_integer_q1(LI, Radix, false, true); 588 | Ch -> 589 | Val = es_ctype:char_value(Ch), 590 | if Val < Radix -> 591 | es_lexinput:read_char(LI), 592 | choose_decimal_q3_or_integer_q2(LI, Radix, Val, false); 593 | true -> 594 | false 595 | end 596 | end. 597 | 598 | number_q3(LI, Radix) -> % after "#{B,O,D,X}#" 599 | Ch = es_lexinput:peek_char(LI), 600 | case number_q3_norm(Ch) of 601 | $E -> 602 | es_lexinput:read_char(LI), 603 | choose_decimal_q0_or_integer_q0(LI, Radix, false); 604 | $I -> 605 | es_lexinput:read_char(LI), 606 | choose_decimal_q0_or_integer_q0(LI, Radix, true); 607 | _ -> 608 | false 609 | end. 610 | 611 | number_q3_norm(Ch) -> % normalize case of relevant characters 612 | case Ch of 613 | $e -> $E; 614 | $i -> $I; 615 | _ -> Ch 616 | end. 617 | 618 | number_q4(LI, Radix, IsInexact) -> % after "#{E,I}" 619 | case es_lexinput:peek_char(LI) of 620 | $# -> 621 | es_lexinput:read_char(LI), 622 | number_q5(LI, IsInexact); 623 | $+ -> 624 | es_lexinput:read_char(LI), 625 | choose_decimal_q1_or_integer_q1(LI, Radix, IsInexact, false); 626 | $- -> 627 | es_lexinput:read_char(LI), 628 | choose_decimal_q1_or_integer_q1(LI, Radix, IsInexact, true); 629 | Ch -> 630 | Val = es_ctype:char_value(Ch), 631 | if Val < Radix -> 632 | es_lexinput:read_char(LI), 633 | choose_decimal_q3_or_integer_q2(LI, Radix, Val, IsInexact); 634 | true -> 635 | false 636 | end 637 | end. 638 | 639 | number_q5(LI, IsInexact) -> % after "#{E,I}#" 640 | Ch = es_lexinput:peek_char(LI), 641 | case number_q5_norm(Ch) of 642 | $B -> 643 | es_lexinput:read_char(LI), 644 | integer_q0(LI, 2, IsInexact); 645 | $O -> 646 | es_lexinput:read_char(LI), 647 | integer_q0(LI, 8, IsInexact); 648 | $X -> 649 | es_lexinput:read_char(LI), 650 | integer_q0(LI, 16, IsInexact); 651 | $D -> 652 | es_lexinput:read_char(LI), 653 | decimal_q0(LI, IsInexact); 654 | _ -> 655 | false 656 | end. 657 | 658 | number_q5_norm(Ch) -> % normalize case of relevant characters 659 | case Ch of 660 | $b -> $B; 661 | $o -> $O; 662 | $x -> $X; 663 | $d -> $D; 664 | _ -> Ch 665 | end. 666 | 667 | choose_decimal_q0_or_integer_q0(LI, Radix, IsInexact) -> % after "#[BODX]#[EI]" 668 | if Radix =:= 10 -> 669 | decimal_q0(LI, IsInexact); 670 | true -> 671 | integer_q0(LI, Radix, IsInexact) 672 | end. 673 | 674 | choose_decimal_q1_or_integer_q1(LI, Radix, IsInexact, IsNegative) -> % after (#[BODXEI])?[+-] 675 | if Radix =:= 10 -> 676 | decimal_q1(LI, IsInexact, IsNegative); 677 | true -> 678 | integer_q1(LI, Radix, IsInexact, IsNegative) 679 | end. 680 | 681 | choose_decimal_q3_or_integer_q2(LI, Radix, Num, IsInexact) -> % after (#[BODXEI]?) 682 | if Radix =:= 10 -> 683 | decimal_q3(LI, Num, IsInexact, false); 684 | true -> 685 | integer_q2(LI, Radix, Num, IsInexact, false) 686 | end. 687 | 688 | %% Scan 689 | 690 | integer_q0(LI, Radix, IsInexact) -> 691 | case es_lexinput:peek_char(LI) of 692 | $+ -> 693 | es_lexinput:read_char(LI), 694 | integer_q1(LI, Radix, IsInexact, false); 695 | $- -> 696 | es_lexinput:read_char(LI), 697 | integer_q1(LI, Radix, IsInexact, true); 698 | Ch -> 699 | Val = es_ctype:char_value(Ch), 700 | if Val < Radix -> 701 | es_lexinput:read_char(LI), 702 | integer_q2(LI, Radix, Val, IsInexact, false); 703 | true -> 704 | false 705 | end 706 | end. 707 | 708 | integer_q1(LI, Radix, IsInexact, IsNegative) -> 709 | Ch = es_lexinput:peek_char(LI), 710 | Val = es_ctype:char_value(Ch), 711 | if Val < Radix -> 712 | es_lexinput:read_char(LI), 713 | Num = if IsNegative -> -Val; true -> Val end, 714 | integer_q2(LI, Radix, Num, IsInexact, IsNegative); 715 | true -> 716 | false 717 | end. 718 | 719 | integer_q2(LI, Radix, Num, IsInexact, IsNegative) -> 720 | Ch = es_lexinput:peek_char(LI), 721 | Val = es_ctype:char_value(Ch), 722 | if Val < Radix -> 723 | es_lexinput:read_char(LI), 724 | Num2 = Num * Radix, 725 | Num3 = if IsNegative -> Num2 - Val; true -> Num2 + Val end, 726 | integer_q2(LI, Radix, Num3, IsInexact, IsNegative); 727 | true -> 728 | %% R5RS allowed "#" to be used as a zero that also 729 | %% forced the resulting number to become inexact, e.g. 730 | %% 15## became 1500.0. This is not supported in R7RS. 731 | case es_ctype:char_is_delimiter(Ch) of 732 | true -> 733 | if IsInexact -> 734 | float(Num); 735 | true -> 736 | Num 737 | end; 738 | false -> 739 | false 740 | end 741 | end. 742 | 743 | %% Scan 744 | 745 | decimal_q0(LI, IsInexact) -> 746 | case es_lexinput:peek_char(LI) of 747 | 46 -> % dot, messes up erlang-mode :-( 748 | es_lexinput:read_char(LI), 749 | decimal_q2(LI, false); 750 | $+ -> 751 | es_lexinput:read_char(LI), 752 | decimal_q1(LI, IsInexact, false); 753 | $- -> 754 | es_lexinput:read_char(LI), 755 | decimal_q1(LI, IsInexact, true); 756 | Ch -> 757 | Val = es_ctype:char_value(Ch), 758 | if Val < 10 -> 759 | es_lexinput:read_char(LI), 760 | decimal_q3(LI, Val, IsInexact, false); 761 | true -> 762 | false 763 | end 764 | end. 765 | 766 | decimal_q1(LI, IsInexact, IsNegative) -> 767 | case es_lexinput:peek_char(LI) of 768 | 46 -> % dot, messes up erlang-mode :-( 769 | decimal_q2(LI, IsNegative); 770 | Ch -> 771 | Val = es_ctype:char_value(Ch), 772 | if Val < 10 -> 773 | es_lexinput:read_char(LI), 774 | Num = if IsNegative -> -Val; true -> Val end, 775 | decimal_q3(LI, Num, IsInexact, IsNegative); 776 | true -> 777 | false 778 | end 779 | end. 780 | 781 | decimal_q2(LI, IsNegative) -> 782 | Ch = es_lexinput:peek_char(LI), 783 | Val = es_ctype:char_value(Ch), 784 | if Val < 10 -> 785 | es_lexinput:read_char(LI), 786 | Num = if IsNegative -> -Val; true -> Val end, 787 | decimal_q4(LI, Num, -1, IsNegative); 788 | true -> 789 | false 790 | end. 791 | 792 | decimal_q3(LI, Num, IsInexact, IsNegative) -> 793 | Ch = es_lexinput:peek_char(LI), 794 | if Ch =:= 46 -> % dot, messes up erlang-mode :-( 795 | es_lexinput:read_char(LI), 796 | decimal_q4(LI, Num, 0, IsNegative); 797 | %% R5RS allowed "#" to be used as a zero that also 798 | %% forced the resulting number to become inexact, e.g. 799 | %% 15## became 1500.0. This is not supported in R7RS. 800 | Ch =:= $E; Ch =:= $e -> 801 | es_lexinput:read_char(LI), 802 | decimal_q7(LI, Num, 0); 803 | true -> 804 | Val = es_ctype:char_value(Ch), 805 | if Val < 10 -> 806 | es_lexinput:read_char(LI), 807 | Num2 = Num * 10, 808 | Num3 = if IsNegative -> Num2 - Val; true -> Num2 + Val end, 809 | decimal_q3(LI, Num3, IsInexact, IsNegative); 810 | true -> 811 | if IsInexact -> 812 | float(Num); 813 | true -> 814 | Num 815 | end 816 | end 817 | end. 818 | 819 | decimal_q4(LI, Num, Shift, IsNegative) -> 820 | Ch = es_lexinput:peek_char(LI), 821 | if Ch =:= $E; Ch =:= $e -> 822 | es_lexinput:read_char(LI), 823 | decimal_q7(LI, Num, Shift); 824 | %% R5RS allowed "#" to be used as a zero that also 825 | %% forced the resulting number to become inexact, e.g. 826 | %% 15## became 1500.0. This is not supported in R7RS. 827 | true -> 828 | Val = es_ctype:char_value(Ch), 829 | if Val < 10 -> 830 | es_lexinput:read_char(LI), 831 | Num2 = Num * 10, 832 | Num3 = if IsNegative -> Num2 - Val; true -> Num2 + Val end, 833 | decimal_q4(LI, Num3, Shift - 1, IsNegative); 834 | true -> 835 | decimal_scale(Num, 0.10, -Shift) 836 | end 837 | end. 838 | 839 | decimal_q7(LI, Num, Shift) -> 840 | case es_lexinput:peek_char(LI) of 841 | $+ -> 842 | es_lexinput:read_char(LI), 843 | decimal_q8(LI, Num, Shift, false); 844 | $- -> 845 | es_lexinput:read_char(LI), 846 | decimal_q8(LI, Num, Shift, true); 847 | Ch -> 848 | Val = es_ctype:char_value(Ch), 849 | if Val < 10 -> 850 | es_lexinput:read_char(LI), 851 | decimal_q9(LI, Num, Shift, false, Val); 852 | true -> 853 | false 854 | end 855 | end. 856 | 857 | decimal_q8(LI, Num, Shift, IsNegative) -> 858 | Ch = es_lexinput:peek_char(LI), 859 | Val = es_ctype:char_value(Ch), 860 | if Val < 10 -> 861 | es_lexinput:read_char(LI), 862 | Val2 = if IsNegative -> -Val; true -> Val end, 863 | decimal_q9(LI, Num, Shift, IsNegative, Val2); 864 | true -> 865 | false 866 | end. 867 | 868 | decimal_q9(LI, Num, Shift, IsNegative, Exp) -> 869 | Ch = es_lexinput:peek_char(LI), 870 | Val = es_ctype:char_value(Ch), 871 | if Val < 10 -> 872 | es_lexinput:read_char(LI), 873 | Exp2 = Exp * 10, 874 | Exp3 = if IsNegative -> Exp2 - Val; true -> Exp2 + Val end, 875 | decimal_q9(LI, Num, Shift, IsNegative, Exp3); 876 | true -> 877 | Shift2 = Shift + Exp, 878 | if Shift2 < 0 -> 879 | decimal_scale(Num, 0.10, -Shift2); 880 | true -> 881 | decimal_scale(Num, 10.0, Shift2) 882 | end 883 | end. 884 | 885 | decimal_scale(Num, Scale, Shift) -> 886 | if Shift > 0 -> 887 | decimal_scale(Num * Scale, Scale, Shift - 1); 888 | true -> 889 | float(Num) 890 | end. 891 | 892 | %% skip_intertoken_space: Skip over whitespace, ";..\n" comments and properly 893 | %% nested "#|..|#" block comments. Return first non-blank character or EOF. 894 | %% May generate an error if there is a premature EOF in a block comment. 895 | %% "#;" comments are handled in the parser. 896 | 897 | skip_intertoken_space(LI) -> 898 | case es_lexinput:read_char(LI) of 899 | -1 -> 900 | -1; 901 | $; -> 902 | skip_line_comment(LI); 903 | $# -> 904 | skip_hash(LI); 905 | Ch -> 906 | case es_ctype:char_is_whitespace(Ch) of 907 | true -> 908 | skip_intertoken_space(LI); 909 | false -> 910 | Ch 911 | end 912 | end. 913 | 914 | skip_line_comment(LI) -> 915 | case es_lexinput:read_char(LI) of 916 | -1 -> 917 | -1; % permit ";..." without \n before the 918 | $\n -> 919 | skip_intertoken_space(LI); 920 | $\r -> 921 | skip_intertoken_space(LI); 922 | _ -> 923 | skip_line_comment(LI) 924 | end. 925 | 926 | skip_hash(LI) -> 927 | case es_lexinput:peek_char(LI) of 928 | $| -> 929 | es_lexinput:read_char(LI), 930 | skip_block(LI, 1); 931 | _ -> 932 | $# 933 | end. 934 | 935 | skip_block(LI, Level) -> 936 | case es_lexinput:read_char(LI) of 937 | -1 -> 938 | lexer_error(premature_eof); 939 | $# -> 940 | skip_block_hash(LI, Level); 941 | $| -> 942 | skip_block_bar(LI, Level); 943 | _ -> 944 | skip_block(LI, Level) 945 | end. 946 | 947 | skip_block_hash(LI, Level) -> 948 | case es_lexinput:read_char(LI) of 949 | -1 -> 950 | lexer_error(premature_eof); 951 | $# -> 952 | skip_block_hash(LI, Level); 953 | $| -> 954 | skip_block(LI, Level + 1); 955 | _ -> 956 | skip_block(LI, Level) 957 | end. 958 | 959 | skip_block_bar(LI, Level) -> 960 | case es_lexinput:read_char(LI) of 961 | -1 -> 962 | lexer_error(premature_eof); 963 | $| -> 964 | skip_block_bar(LI, Level); 965 | $# -> 966 | if Level > 1 -> 967 | skip_block(LI, Level - 1); 968 | true -> 969 | skip_intertoken_space(LI) 970 | end; 971 | _ -> 972 | skip_block(LI, Level) 973 | end. 974 | 975 | %% Error Formatting ------------------------------------------------------------ 976 | 977 | lexer_error(Reason) -> 978 | error({?MODULE, Reason}). 979 | 980 | -spec format_error(term()) -> io_lib:chars(). 981 | format_error(Reason) -> 982 | case Reason of 983 | {expected_delimiter, Ch} -> 984 | io_lib:format("expected delimiter, got: ~tc", [Ch]); 985 | {expected_hex_digit, Ch} -> 986 | io_lib:format("expected hex digit, got: ~tc", [Ch]); 987 | {expected_semicolon, Ch} -> 988 | io_lib:format("expected ';', got: ~tc", [Ch]); 989 | {invalid_boolean, Str} -> 990 | io_lib:format("invalid boolean: ~ts", [Str]); 991 | {invalid_character, Ch} -> 992 | io_lib:format("invalid character: ~tc", [Ch]); 993 | {invalid_character_name, Str} -> 994 | io_lib:format("invalid character name: ~ts", [Str]); 995 | {invalid_identifier, Str} -> 996 | io_lib:format("invalid identifier: ~ts", [Str]); 997 | {invalid_identifier, Str, Ch} -> 998 | io_lib:format("invalid identifier: ~ts followed by non-delimiter ~tc", [Str, Ch]); 999 | invalid_number -> 1000 | "invalid number"; 1001 | premature_eof -> 1002 | "premature EOF"; 1003 | _ -> 1004 | io_lib:format("~tp", [Reason]) 1005 | end. 1006 | -------------------------------------------------------------------------------- /src/es_lexinput.erl: -------------------------------------------------------------------------------- 1 | %%% -*- erlang-indent-level: 2 -*- 2 | %%% 3 | %%% Copyright 2014-2023 Mikael Pettersson 4 | %%% 5 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %%% you may not use this file except in compliance with the License. 7 | %%% You may obtain a copy of the License at 8 | %%% 9 | %%% http://www.apache.org/licenses/LICENSE-2.0 10 | %%% 11 | %%% Unless required by applicable law or agreed to in writing, software 12 | %%% distributed under the License is distributed on an "AS IS" BASIS, 13 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %%% See the License for the specific language governing permissions and 15 | %%% limitations under the License. 16 | %%% 17 | %%% es_lexinput.erl 18 | %%% 19 | %%% Wraps an input port with a gen_server to maintain line number and column, 20 | %%% the latest peeked character (if any), and its file name (if any). 21 | 22 | -module(es_lexinput). 23 | -behaviour(gen_server). 24 | 25 | %% API 26 | -export([ close/1 27 | , column/1 28 | , line/1 29 | , name/1 30 | , open_file/1 31 | , open_stdin/0 32 | , open_string/1 33 | , peek_char/1 34 | , read_char/1 35 | ]). 36 | 37 | %% gen_server callbacks 38 | -export([ init/1 39 | , handle_call/3 40 | , handle_cast/2 41 | , handle_info/2 42 | , terminate/2 43 | , code_change/3 44 | ]). 45 | 46 | -export_type([ lexinput/0 47 | ]). 48 | 49 | -type lexinput() :: pid(). 50 | 51 | %% commands 52 | -define(close, close). 53 | -define(column, column). 54 | -define(file, file). 55 | -define(line, line). 56 | -define(name, name). 57 | -define(peek_char, peek_char). 58 | -define(read_char, read_char). 59 | -define(stdin, stdin). 60 | -define(string, string). 61 | 62 | %% API ------------------------------------------------------------------------- 63 | 64 | -spec close(lexinput()) -> ok. 65 | close(LI) -> 66 | call(LI, ?close). 67 | 68 | -spec column(lexinput()) -> integer(). 69 | column(LI) -> 70 | call(LI, ?column). 71 | 72 | -spec line(lexinput()) -> integer(). 73 | line(LI) -> 74 | call(LI, ?line). 75 | 76 | -spec name(lexinput()) -> file:filename_all(). 77 | name(LI) -> 78 | call(LI, ?name). 79 | 80 | -spec open_file(file:filename_all()) -> lexinput(). 81 | open_file(Path) -> 82 | open({?file, Path}). 83 | 84 | -spec open_stdin() -> lexinput(). 85 | open_stdin() -> 86 | open(?stdin). 87 | 88 | -spec open_string(string() | binary()) -> lexinput(). 89 | open_string(String) -> 90 | open({?string, String}). 91 | 92 | -spec peek_char(lexinput()) -> integer(). 93 | peek_char(LI) -> 94 | call(LI, ?peek_char). 95 | 96 | -spec read_char(lexinput()) -> integer(). 97 | read_char(LI) -> 98 | call(LI, ?read_char). 99 | 100 | %% API Internals --------------------------------------------------------------- 101 | 102 | call(Pid, Cmd) -> 103 | %% deliberately throw in case of error 104 | {ok, Res} = gen_server:call(Pid, Cmd, 'infinity'), 105 | Res. 106 | 107 | open(Arg) -> 108 | case gen_server:start(?MODULE, Arg, []) of 109 | {ok, Pid} -> Pid; 110 | {error, {shutdown, Reason}} -> error(Reason) 111 | end. 112 | 113 | %% gen_server callbacks -------------------------------------------------------- 114 | 115 | -record(state, 116 | { %% name and access functions don't change after init 117 | name 118 | , kind 119 | %% standard Erlang I/O device handle 120 | , iodev 121 | %% if peeked is =/= [] it is the value of the last retrieved character, 122 | %% which was peeked not read, and line and column have not been updated 123 | , peeked 124 | %% line and column give the position of the next character to be retrieved 125 | , line 126 | , column 127 | }). 128 | 129 | init(Arg) -> 130 | case handle_open(Arg) of 131 | {ok, {Name, Kind, IoDev}} -> 132 | {ok, #state{ name = Name 133 | , kind = Kind 134 | , iodev = IoDev 135 | , peeked = [] 136 | , line = 1 137 | , column = 0 138 | }}; 139 | {error, Reason} -> 140 | %% The {shutdown, ...} wrapper prevents an unwanted crash report. 141 | {stop, {shutdown, Reason}} 142 | end. 143 | 144 | handle_call(Req, _From, State) -> 145 | case Req of 146 | ?close -> 147 | Result = handle_close(State), 148 | {stop, normal, Result, []}; 149 | ?column -> 150 | Result = handle_column(State), 151 | {reply, Result, State}; 152 | ?line -> 153 | Result = handle_line(State), 154 | {reply, Result, State}; 155 | ?name -> 156 | Result = handle_name(State), 157 | {reply, Result, State}; 158 | ?peek_char -> 159 | {Result, NewState} = handle_peek_char(State), 160 | {reply, Result, NewState}; 161 | ?read_char -> 162 | {Result, NewState} = handle_read_char(State), 163 | {reply, Result, NewState}; 164 | _ -> 165 | {reply, {error, {bad_call, Req}}, State} 166 | end. 167 | 168 | handle_cast(_Req, State) -> 169 | {noreply, State}. 170 | 171 | handle_info(_Info, State) -> 172 | {noreply, State}. 173 | 174 | terminate(_Reason, _State = []) -> % terminating due to explicit close 175 | ok; 176 | terminate(_Reason, State) -> 177 | _ = handle_close(State), 178 | ok. 179 | 180 | code_change(_OldVsn, State, _Extra) -> 181 | {ok, State}. 182 | 183 | %% gen_server internals -------------------------------------------------------- 184 | 185 | handle_open(Arg) -> 186 | case Arg of 187 | {?file, Path} -> file_open(Path); 188 | ?stdin -> stdin_open(); 189 | {?string, String} -> string_open(String) 190 | end. 191 | 192 | handle_close(State) -> 193 | {ok, iodev_close(State)}. 194 | 195 | handle_column(State) -> 196 | {ok, State#state.column}. 197 | 198 | handle_line(State) -> 199 | {ok, State#state.line}. 200 | 201 | handle_name(State) -> 202 | {ok, State#state.name}. 203 | 204 | handle_peek_char(State) -> 205 | case State#state.peeked of 206 | [] -> 207 | Ch = iodev_read_char(State), 208 | {{ok, Ch}, State#state{peeked = Ch}}; 209 | Ch -> 210 | {{ok, Ch}, State} 211 | end. 212 | 213 | handle_read_char(State0) -> 214 | {Ch, State} = 215 | case State0#state.peeked of 216 | [] -> {iodev_read_char(State0), State0}; 217 | Peeked -> {Peeked, State0#state{peeked = []}} 218 | end, 219 | NewState = 220 | case Ch of 221 | $\n -> 222 | Line = State#state.line, 223 | State#state{line = Line + 1, column = 0}; 224 | $\t -> 225 | Column = State#state.column, 226 | State#state{column = ((Column + 8) div 8) * 8}; 227 | -1 -> 228 | State; 229 | _ -> 230 | Column = State#state.column, 231 | State#state{column = Column + 1} 232 | end, 233 | {{ok, Ch}, NewState}. 234 | 235 | %% IoDev operations ------------------------------------------------------------ 236 | 237 | iodev_close(#state{kind = Kind, iodev = IoDev}) -> 238 | case Kind of 239 | ?file -> 240 | case file:close(IoDev) of 241 | ok -> ok; 242 | {error, Reason} -> {error, {file, Reason}} 243 | end; 244 | ?stdin -> ok; 245 | ?string -> es_input_string_iodev:close(IoDev) 246 | end. 247 | 248 | iodev_read_char(#state{iodev = IoDev}) -> 249 | case io:get_chars(IoDev, [], 1) of 250 | [Ch] -> Ch; 251 | eof -> -1 252 | end. 253 | 254 | %% file operations ------------------------------------------------------------- 255 | 256 | file_open(Path) -> 257 | case file:open(Path, [read, {encoding, utf8}, read_ahead]) of 258 | {ok, IoDev} -> 259 | {ok, {filename:basename(Path), ?file, IoDev}}; 260 | {error, Reason} -> 261 | {error, {file, Reason}} 262 | end. 263 | 264 | %% stdin operations ------------------------------------------------------------ 265 | 266 | stdin_open() -> 267 | {ok, {"", ?stdin, standard_io}}. 268 | 269 | %% string operations ----------------------------------------------------------- 270 | 271 | string_open(String) -> 272 | {ok, {"", ?string, es_input_string_iodev:open(String)}}. 273 | -------------------------------------------------------------------------------- /src/es_lib_scheme_base.erl: -------------------------------------------------------------------------------- 1 | %%% -*- erlang-indent-level: 2 -*- 2 | %%% 3 | %%% Copyright 2014-2022 Mikael Pettersson 4 | %%% 5 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %%% you may not use this file except in compliance with the License. 7 | %%% You may obtain a copy of the License at 8 | %%% 9 | %%% http://www.apache.org/licenses/LICENSE-2.0 10 | %%% 11 | %%% Unless required by applicable law or agreed to in writing, software 12 | %%% distributed under the License is distributed on an "AS IS" BASIS, 13 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %%% See the License for the specific language governing permissions and 15 | %%% limitations under the License. 16 | %%% 17 | %%% es_lib_scheme_base.erl 18 | %%% 19 | %%% Implements the Base Library (scheme base) for ErlScheme. 20 | 21 | -module(es_lib_scheme_base). 22 | 23 | %% API 24 | -export([ env/0 25 | ]). 26 | 27 | %% Base Library functions implemented in this module 28 | -export([ caar/1 29 | , cadr/1 30 | , caddr/1 31 | , cddr/1 32 | , cdddr/1 33 | , cons/2 34 | , eval/1 35 | , 'list?'/1 36 | , load/1 37 | , memq/2 38 | , 'null?'/1 39 | , 'pair?'/1 40 | , 'zero?'/1 41 | ]). 42 | 43 | %% API ------------------------------------------------------------------------- 44 | 45 | env() -> 46 | #{ '*' => fun erlang:'*'/2 47 | , '+' => fun erlang:'+'/2 48 | , 'eq?' => fun erlang:'=:='/2 49 | , 'memq' => fun ?MODULE:memq/2 50 | , 'symbol?' => fun es_datum:is_symbol/1 51 | , 'zero?' => fun ?MODULE:'zero?'/1 52 | , 'null?' => fun ?MODULE:'null?'/1 53 | , 'pair?' => fun ?MODULE:'pair?'/1 54 | , 'list?' => fun ?MODULE:'list?'/1 55 | , 'cons' => fun ?MODULE:cons/2 56 | , 'append' => fun erlang:'++'/2 57 | , 'reverse' => fun lists:reverse/1 58 | , 'car' => fun erlang:hd/1 59 | , 'cdr' => fun erlang:tl/1 60 | , 'caar' => fun ?MODULE:caar/1 61 | , 'cadr' => fun ?MODULE:cadr/1 62 | , 'cddr' => fun ?MODULE:cddr/1 63 | , 'caddr' => fun ?MODULE:caddr/1 64 | , 'cdddr' => fun ?MODULE:cdddr/1 65 | , 'vector?' => fun erlang:is_tuple/1 66 | , 'eval' => fun ?MODULE:eval/1 67 | , 'load' => fun ?MODULE:load/1 68 | , 'compile' => fun es_compile:file/1 69 | }. 70 | 71 | %% Internals ------------------------------------------------------------------- 72 | 73 | 'memq'(X, L = [X | _]) -> L; 74 | 'memq'(X, [_ | L]) -> 'memq'(X, L); 75 | 'memq'(_, []) -> false. 76 | 77 | 'zero?'(X) -> 78 | X == 0. 79 | 80 | 'null?'(X) -> 81 | case X of [] -> true; _ -> false end. 82 | 83 | 'pair?'(X) -> 84 | case X of [_ | _] -> true; _ -> false end. 85 | 86 | 'list?'(X) -> 87 | try length(X) of _ -> true catch _:_ -> false end. 88 | 89 | 'cons'(X, Y) -> [X | Y]. 90 | 91 | 'caar'([[X | _] | _]) -> 92 | X. 93 | 94 | 'cadr'([_, X | _]) -> 95 | X. 96 | 97 | 'cddr'([_, _ | Y]) -> 98 | Y. 99 | 100 | 'caddr'([_, _, X | _]) -> 101 | X. 102 | 103 | 'cdddr'([_, _, _ | Y]) -> 104 | Y. 105 | 106 | 'eval'(X) -> % TODO: this should be /2 and take an environment specifier 107 | {Value, _SynEnv} = es_eval:eval(X, es_synenv:gloenv()), 108 | Value. 109 | 110 | 'load'(X) -> % TODO: should this take an environment specifier like eval? 111 | es_load:load(X, es_synenv:gloenv()). 112 | -------------------------------------------------------------------------------- /src/es_load.erl: -------------------------------------------------------------------------------- 1 | %%% -*- erlang-indent-level: 2 -*- 2 | %%% 3 | %%% Copyright 2014-2023 Mikael Pettersson 4 | %%% 5 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %%% you may not use this file except in compliance with the License. 7 | %%% You may obtain a copy of the License at 8 | %%% 9 | %%% http://www.apache.org/licenses/LICENSE-2.0 10 | %%% 11 | %%% Unless required by applicable law or agreed to in writing, software 12 | %%% distributed under the License is distributed on an "AS IS" BASIS, 13 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %%% See the License for the specific language governing permissions and 15 | %%% limitations under the License. 16 | %%% 17 | %%% es_load.erl 18 | %%% 19 | %%% Loads S-expressions from file. 20 | 21 | -module(es_load). 22 | 23 | -export([ load/2 24 | , module/1 25 | ]). 26 | 27 | -type ast() :: term(). 28 | -type datum() :: term(). 29 | -type synenv() :: es_macros:synenv(). 30 | 31 | %% API ------------------------------------------------------------------------- 32 | 33 | -spec load(datum(), synenv()) -> ok. 34 | load(Name, SynEnv) -> 35 | case es_datum:is_string(Name) of 36 | true -> % (load "Name.scm") 37 | load_file(Name, SynEnv); 38 | false -> % (load 'Name) 39 | true = es_datum:is_symbol(Name), 40 | load_module(Name) 41 | end, 42 | ok. 43 | 44 | -spec module(string()) -> ast(). 45 | module(FileName) -> 46 | SynEnv = 47 | lists:foldl( 48 | fun ({Name, Expander}, SynEnv0) -> 49 | es_synenv:enter(SynEnv0, Name, Expander) 50 | end, es_synenv:empty(), es_macros:initial()), 51 | {RevSexprs, _SynEnv} = load(fun do_expand/2, {[], SynEnv}, FileName), 52 | Sexprs = lists:reverse(RevSexprs), 53 | es_parse:module(Sexprs). 54 | 55 | %% Internals ------------------------------------------------------------------- 56 | 57 | load_module(Name) -> 58 | code:is_loaded(Name) orelse begin {module, _} = code:load_file(Name), true end. 59 | 60 | load_file(FileName, SynEnv) -> 61 | load(fun do_eval/2, SynEnv, FileName). 62 | 63 | do_eval(Datum, SynEnv) -> 64 | {_Result, NewSynEnv} = es_eval:eval(Datum, SynEnv), 65 | NewSynEnv. 66 | 67 | do_expand(Datum, {Acc, SynEnv}) -> 68 | {Expanded, NewSynEnv} = es_macros:expand_toplevel(Datum, SynEnv), 69 | {[Expanded | Acc], NewSynEnv}. 70 | 71 | load(Fun, Acc, FileName) -> 72 | OldPrefix = erlang:get('es_load_prefix'), 73 | NewPath = filename:join(OldPrefix, FileName), 74 | LI = es_lexinput:open_file(NewPath), 75 | try 76 | erlang:put('es_load_prefix', filename:dirname(NewPath)), 77 | try 78 | loop(Fun, Acc, LI) 79 | after 80 | erlang:put('es_load_prefix', OldPrefix) 81 | end 82 | after 83 | es_lexinput:close(LI) 84 | end. 85 | 86 | loop(Fun, Acc, LI) -> 87 | Datum = es_read:read(LI), 88 | case es_datum:is_eof_object(Datum) of 89 | false -> 90 | loop(Fun, Fun(Datum, Acc), LI); 91 | true -> 92 | Acc 93 | end. 94 | -------------------------------------------------------------------------------- /src/es_macros.erl: -------------------------------------------------------------------------------- 1 | %%% -*- erlang-indent-level: 2 -*- 2 | %%% 3 | %%% Copyright 2014-2022 Mikael Pettersson 4 | %%% 5 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %%% you may not use this file except in compliance with the License. 7 | %%% You may obtain a copy of the License at 8 | %%% 9 | %%% http://www.apache.org/licenses/LICENSE-2.0 10 | %%% 11 | %%% Unless required by applicable law or agreed to in writing, software 12 | %%% distributed under the License is distributed on an "AS IS" BASIS, 13 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %%% See the License for the specific language governing permissions and 15 | %%% limitations under the License. 16 | %%% 17 | %%% es_macros.erl 18 | %%% 19 | %%% Macro expansion for ErlScheme. 20 | %%% 21 | %%% - expand ( ...) forms of 22 | %%% - recognize special syntactic forms and propagate macro expansion to 23 | %%% nested s, while not expanding parts that aren't 24 | %%% - optionally lower special syntactic forms to simpler core constructs 25 | 26 | -module(es_macros). 27 | 28 | %% compiler API 29 | -export([ expand_toplevel/2 30 | , format_error/1 31 | , initial/0 32 | ]). 33 | 34 | %% runtime API 35 | -export([ enter_macro/2 36 | , enter_syntax/2 37 | ]). 38 | 39 | -export_type([ synenv/0 40 | ]). 41 | 42 | -define(macro, '%macro'). 43 | -define(syntax, '%syntax'). 44 | 45 | -type sexpr() :: term(). 46 | -type expander() :: fun((sexpr(), synenv()) -> {sexpr(), synenv()}). 47 | -type synenv() :: es_synenv:synenv(). % atom() -> expander() 48 | 49 | %% API ------------------------------------------------------------------------- 50 | 51 | -spec expand_toplevel(sexpr(), synenv()) -> {sexpr(), synenv()}. 52 | expand_toplevel(Sexpr, SynEnv) -> 53 | case Sexpr of 54 | [Hd | Tl] when is_atom(Hd) -> 55 | case find_expander(SynEnv, Hd) of 56 | false -> 57 | {[Hd | expand_list(Tl, SynEnv)], SynEnv}; 58 | Expander -> 59 | Expander(Sexpr, SynEnv) 60 | end; 61 | [_ | _] -> 62 | {expand_list(Sexpr, SynEnv), SynEnv}; 63 | _ -> 64 | {Sexpr, SynEnv} 65 | end. 66 | 67 | -spec initial() -> [{atom(), expander()}]. 68 | initial() -> 69 | lists:map( 70 | fun ({Name, Type, Expander}) -> {Name, wrap_expander(Type, Expander)} end, 71 | [ {'begin', ?syntax, fun expand_begin/2} 72 | , {'case', ?syntax, fun expand_case/2} 73 | , {'compiler-syntax', ?syntax, fun expand_compiler_syntax/2} 74 | , {'cond', ?syntax, fun expand_cond/2} 75 | , {'define', ?syntax, fun expand_define/2} 76 | , {'lambda', ?syntax, fun expand_lambda/2} 77 | , {'let', ?syntax, fun expand_let/2} 78 | , {'let*', ?syntax, fun 'expand_let*'/2} 79 | , {'letrec', ?syntax, fun expand_let_or_letrec/2} 80 | , {'macro', ?syntax, fun expand_macro/2} 81 | , {'quasiquote', ?macro, fun expand_quasiquote/2} 82 | , {'quote', ?syntax, fun expand_quote/2} 83 | , {'set!', ?syntax, fun 'expand_set!'/2} 84 | , {'try', ?syntax, fun expand_try/2} 85 | ]). 86 | 87 | -spec enter_macro(atom(), expander()) -> true. 88 | enter_macro(Name, Expander) -> 89 | enter_expander(Name, wrap_expander(?macro, Expander)). 90 | 91 | -spec enter_syntax(atom(), expander()) -> true. 92 | enter_syntax(Name, Expander) -> 93 | enter_expander(Name, wrap_expander(?syntax, Expander)). 94 | 95 | %% Built-in macro and syntax expanders ----------------------------------------- 96 | 97 | %% (macro ) 98 | %% only valid at toplevel (repl, module, or body) 99 | expand_macro([_Macro, Name, Expr], SynEnv) -> 100 | case es_synenv:is_gloenv(SynEnv) of 101 | true -> 102 | Expander = expand_expr(Expr, SynEnv), 103 | {[['quote', 'es_macros'], ':', ['quote', 'enter_macro'], ['quote', Name], Expander], SynEnv}; 104 | false -> 105 | {Expander, _SynEnv} = es_eval:eval(Expr, SynEnv), 106 | {['begin'], bind_expander({Name, ?macro, Expander}, SynEnv)} 107 | end. 108 | 109 | %% (compiler-syntax ) 110 | %% only valid at toplevel (repl, module, or body) 111 | expand_compiler_syntax([_CompilerSyntax, Name, Expr], SynEnv) -> 112 | case es_synenv:is_gloenv(SynEnv) of 113 | true -> 114 | Expander = expand_expr(Expr, SynEnv), 115 | {[['quote', 'es_macros'], ':', ['quote', 'enter_syntax'], ['quote', Name], Expander], SynEnv}; 116 | false -> 117 | {Expander, _SynEnv} = es_eval:eval(Expr, SynEnv), 118 | {['begin'], bind_expander({Name, ?syntax, Expander}, SynEnv)} 119 | end. 120 | 121 | %% (quote ) 122 | expand_quote([_Quote, _] = Sexpr, SynEnv) -> 123 | {Sexpr, SynEnv}. 124 | 125 | %% (set! ) 126 | 'expand_set!'([Set, Var, Val], SynEnv) -> 127 | {[Set, Var, expand_expr(Val, SynEnv)], SynEnv}. 128 | 129 | %% (case ( [(when )] +)+) 130 | %% This is the ErlScheme-specific (case ...), NOT Scheme's pointless version. 131 | expand_case([Case, Expr0 | Clauses0], SynEnv) -> 132 | Expr = expand_expr(Expr0, SynEnv), 133 | Clauses = lists:map(fun (Clause) -> expand_case_clause(Clause, SynEnv) end, Clauses0), 134 | {[Case, Expr | Clauses], SynEnv}. 135 | 136 | expand_case_clause([Pat, ['when', Expr] | Exprs], SynEnv) -> 137 | SynEnvClause = bind_pat_vars(Pat, nested(SynEnv)), 138 | [Pat, ['when', expand_expr(Expr, SynEnvClause)], ['begin' | expand_list(Exprs, SynEnvClause)]]; 139 | expand_case_clause([Pat | Exprs], SynEnv) -> 140 | SynEnvClause = bind_pat_vars(Pat, nested(SynEnv)), 141 | [Pat, ['begin' | expand_list(Exprs, SynEnvClause)]]. 142 | 143 | %% (cond +) 144 | expand_cond([Cond | Clauses], SynEnv) -> 145 | {[Cond | lists:map(fun (Clause) -> expand_cond_clause(Clause, SynEnv) end, Clauses)], SynEnv}. 146 | 147 | expand_cond_clause(['else' | Exprs], SynEnv) -> 148 | ['else' | ['begin' | expand_list(Exprs, SynEnv)]]; 149 | expand_cond_clause([Test], SynEnv) -> 150 | [expand_expr(Test, SynEnv)]; 151 | expand_cond_clause([Test, '=>', Expr], SynEnv) -> 152 | [expand_expr(Test, SynEnv), '=>', expand_expr(Expr, SynEnv)]; 153 | expand_cond_clause([Test | Exprs], SynEnv) -> 154 | [expand_expr(Test, SynEnv), ['begin' | expand_list(Exprs, SynEnv)]]. 155 | 156 | %% (lambda m:f/a) 157 | %% (lambda +) 158 | expand_lambda([Lambda | Tl], SynEnv) -> 159 | case Tl of 160 | [M, ':', F, '/', A] -> 161 | {[Lambda, expand_expr(M, SynEnv), ':', expand_expr(F, SynEnv), '/', expand_expr(A, SynEnv)], SynEnv}; 162 | [Formals | Body] -> 163 | SynEnvBody = bind_vars(Formals, nested(SynEnv)), 164 | {[Lambda, Formals | expand_body(Body, SynEnvBody)], SynEnv} 165 | end. 166 | 167 | %% (define ) 168 | %% (define ( *) +) 169 | expand_define([Define, [Var | Formals] | Body], SynEnv) -> 170 | {Expanded, _SynEnv} = expand_lambda(['lambda', Formals | Body], SynEnv), 171 | {[Define, Var, Expanded], bind_var(Var, SynEnv)}; 172 | expand_define([Define, Var, Val], SynEnv) -> 173 | {[Define, Var, expand_expr(Val, SynEnv)], bind_var(Var, SynEnv)}. 174 | 175 | %% (let +) 176 | %% (letrec +) 177 | expand_let_or_letrec([LetOrLetRec, Bindings | Body], SynEnv) -> 178 | Vars = lists:map(fun ([Var, _Init]) -> Var end, Bindings), 179 | SynEnvBody = bind_vars(Vars, nested(SynEnv)), 180 | {[LetOrLetRec, 181 | lists:map(fun ([Var, Init]) -> [Var, expand_expr(Init, SynEnvBody)] end, Bindings) | 182 | expand_body(Body, SynEnvBody)], 183 | SynEnv}. 184 | 185 | %% (let* +) 186 | 'expand_let*'([_LetStar, Bindings | Body], SynEnv) -> 187 | {'expand_let*'(Bindings, Body, SynEnv), SynEnv}. 188 | 189 | 'expand_let*'([], Body, SynEnv) -> ['let', [] | expand_body(Body, nested(SynEnv))]; 190 | 'expand_let*'([[Var, Init] | Bindings], Body, SynEnv) -> 191 | ['let', [[Var, expand_expr(Init, SynEnv)]], 'expand_let*'(Bindings, Body, do_bind_var(Var, nested(SynEnv)))]. 192 | 193 | %% (let +) 194 | %% (let +) 195 | expand_let([_Let, Name, Bindings | Body], SynEnv) when is_atom(Name) -> 196 | Formals = lists:map(fun ([Var, _Init]) -> Var end, Bindings), 197 | Inits = lists:map(fun ([_Var, Init]) -> expand_expr(Init, SynEnv) end, Bindings), 198 | SynEnvBody = bind_vars([Name | Formals], nested(SynEnv)), 199 | Lambda = ['lambda', Formals | expand_body(Body, SynEnvBody)], 200 | {[['letrec', [[Name, Lambda]], Name] | Inits], SynEnv}; 201 | expand_let(Form, SynEnv) -> expand_let_or_letrec(Form, SynEnv). 202 | 203 | %% (try (of +) (catch +) (after +)) 204 | expand_try([Try, Expr0 | RestExpr], SynEnv) -> 205 | Expr = expand_expr(Expr0, SynEnv), 206 | {MaybeOf, RestOf} = expand_try_clause('of', RestExpr, SynEnv), 207 | {MaybeCatch, RestCatch} = expand_try_clause('catch', RestOf, SynEnv), 208 | After = expand_try_after(RestCatch, SynEnv), 209 | {[Try, Expr | (MaybeOf ++ (MaybeCatch ++ After))], SynEnv}. 210 | 211 | expand_try_clause(Tag, [[Tag, Var | Exprs] | Rest], SynEnv) when is_atom(Var) -> 212 | {[[Tag, Var, ['begin' | expand_list(Exprs, do_bind_var(Var, nested(SynEnv)))]]], Rest}; 213 | expand_try_clause(_Tag, Rest, _SynEnv) -> 214 | {[], Rest}. 215 | 216 | expand_try_after([['after' | Exprs]], SynEnv) -> 217 | [['after', ['begin' | expand_list(Exprs, SynEnv)]]]; 218 | expand_try_after([], _SynEnv) -> 219 | []. 220 | 221 | %% (begin ..) 222 | %% Begin is special since it essentially "disappears" in and . 223 | %% For those contexts it needs an expander that propagates SynEnv updates. 224 | expand_begin([Begin | Forms], SynEnv) -> 225 | {NewForms, NewSynEnv} = expand_toplevel_forms(Forms, SynEnv, []), 226 | {[Begin | NewForms], NewSynEnv}. 227 | 228 | %% Expander helpers ------------------------------------------------------------ 229 | 230 | expand_expr(Sexpr, SynEnv) -> 231 | {Expanded, _} = expand_toplevel(Sexpr, SynEnv), 232 | Expanded. 233 | 234 | expand_list(List, SynEnv) -> 235 | lists:map(fun (Sexpr) -> expand_expr(Sexpr, SynEnv) end, List). 236 | 237 | %% expand (define ...) forms at the start of a body to (letrec ...) 238 | expand_body(Body, SynEnv) -> 239 | {ExpandedBody, _NewSynEnv} = expand_toplevel_forms(Body, SynEnv, []), 240 | expand_body_scan(ExpandedBody, []). 241 | 242 | expand_body_scan([['define', Var, Val] | Body], Bindings) -> 243 | expand_body_scan(Body, [[Var, Val] | Bindings]); 244 | expand_body_scan([['begin' | Rest] | Body], Bindings) -> 245 | %% a (begin ...) at the top-level of a is essentially spliced into the 246 | expand_body_scan(Rest ++ Body, Bindings); 247 | expand_body_scan(Body = [_ | _], Bindings) -> 248 | %% No more (define ...), body must be non-empty, assemble the result 249 | case Bindings of 250 | [] -> Body; 251 | [_|_] -> ['letrec', Bindings | Body] 252 | end. 253 | 254 | expand_toplevel_forms([Form | Forms], SynEnv, Acc) -> 255 | {Expanded, NewSynEnv} = expand_toplevel(Form, SynEnv), 256 | expand_toplevel_forms(Forms, NewSynEnv, [Expanded | Acc]); 257 | expand_toplevel_forms(_Forms = [], SynEnv, Acc) -> 258 | {lists:reverse(Acc), SynEnv}. 259 | 260 | bind_pat_vars(Pat, SynEnv) -> 261 | case Pat of 262 | '_' -> 263 | SynEnv; 264 | Var when is_atom(Var) -> 265 | bind_one_pat_var(Var, SynEnv); 266 | ['quote', Atom] when is_atom(Atom) -> 267 | SynEnv; 268 | ['=', Var, Pat2] when is_atom(Var), Var =/= '_' -> 269 | bind_pat_vars(Pat2, bind_one_pat_var(Var, SynEnv)); 270 | [Pat1 | Pat2] -> 271 | bind_pat_vars(Pat2, bind_pat_vars(Pat1, SynEnv)); 272 | Tuple when is_tuple(Tuple) -> 273 | lists:foldl(fun bind_pat_vars/2, SynEnv, tuple_to_list(Tuple)); 274 | _ -> 275 | SynEnv 276 | end. 277 | 278 | bind_one_pat_var(Var, SynEnv) -> 279 | case es_synenv:lookup(SynEnv, Var) of 280 | {value, false} -> SynEnv; % Var is already bound as a variable 281 | _Other -> bind_var(Var, SynEnv) % Var gets bound here 282 | end. 283 | 284 | %% Quasiquote expander --------------------------------------------------------- 285 | %% 286 | %% Originally based on qquote.s from MIT C-Scheme: 287 | %% 288 | %% Copyright (c) 1987 Massachusetts Institute of Technology 289 | %% 290 | %% This material was developed by the Scheme project at the 291 | %% Massachusetts Institute of Technology, Department of 292 | %% Electrical Engineering and Computer Science. Permission to 293 | %% copy this software, to redistribute it, and to use it for any 294 | %% purpose is granted, subject to the following restrictions and 295 | %% understandings. 296 | %% 297 | %% 1. Any copy made of this software must include this copyright 298 | %% notice in full. 299 | %% 300 | %% 2. Users of this software agree to make their best efforts (a) 301 | %% to return to the MIT Scheme project any improvements or 302 | %% extensions that they make, so that these may be included in 303 | %% future releases; and (b) to inform MIT of noteworthy uses of 304 | %% this software. 305 | %% 306 | %% 3. All materials developed as a consequence of the use of this 307 | %% software shall duly acknowledge such use, in accordance with 308 | %% the usual standards of acknowledging credit in academic 309 | %% research. 310 | %% 311 | %% 4. MIT has made no warrantee or representation that the 312 | %% operation of this software will be error-free, and MIT is 313 | %% under no obligation to provide any services, by way of 314 | %% maintenance, update, or otherwise. 315 | %% 316 | %% 5. In conjunction with products arising from the use of this 317 | %% material, there shall be no use of the name of the 318 | %% Massachusetts Institute of Technology nor of any adaptation 319 | %% thereof in any advertising, promotional, or sales literature 320 | %% without prior written consent from MIT in each case. 321 | 322 | descend_quasiquote(X, Level, Return) -> 323 | case X of 324 | [_ | _] -> descend_quasiquote_pair(X, Level, Return); 325 | _ when is_tuple(X) -> descend_quasiquote_vector(X, Level, Return); 326 | _ -> Return('quote', X) 327 | end. 328 | 329 | %% hoisted out of descend_quasiquote_pair/3 and eta-expanded 330 | 'descend_quasiquote_pair*'([CarX | CdrX] = X, Level, Return) -> 331 | descend_quasiquote(CarX, Level, 332 | fun (CarMode, CarArg) -> 333 | descend_quasiquote(CdrX, Level, 334 | fun (CdrMode, CdrArg) -> 335 | if CarMode =:= 'quote' andalso CdrMode =:= 'quote' -> 336 | Return('quote', X); 337 | CarMode =:= 'unquote-splicing' -> 338 | if CdrMode =:= 'quote' andalso CdrArg =:= [] -> 339 | Return('unquote', CarArg); 340 | true -> 341 | Return(system('append'), 342 | [CarArg, finalize_quasiquote(CdrMode, CdrArg)]) 343 | end; 344 | CdrMode =:= 'quote' andalso CdrArg =:= [] -> 345 | Return('list', 346 | [CarArg, finalize_quasiquote(CarMode, CarArg)]); 347 | CdrMode =:= 'quote' -> 348 | case is_proper_list(CdrArg) of 349 | true -> 350 | Return('list', 351 | [finalize_quasiquote(CarMode, CarArg) | 352 | lists:map(fun (El) -> finalize_quasiquote('quote', El) end, CdrArg)]); 353 | false -> % same as the default clause below 354 | Return('cons', 355 | [finalize_quasiquote(CarMode, CarArg), 356 | finalize_quasiquote(CdrMode, CdrArg)]) 357 | end; 358 | CdrMode =:= 'list' orelse CdrMode =:= 'cons' -> 359 | Return(CdrMode, [finalize_quasiquote(CarMode, CarArg) | CdrArg]); 360 | true -> 361 | Return('cons', 362 | [finalize_quasiquote(CarMode, CarArg), 363 | finalize_quasiquote(CdrMode, CdrArg)]) 364 | end 365 | end) 366 | end). 367 | 368 | descend_quasiquote_pair([CarX | _] = X, Level, Return) -> 369 | if CarX =:= 'quasiquote' -> 370 | 'descend_quasiquote_pair*'(X, Level + 1, Return); 371 | CarX =:= 'unquote' orelse CarX =:= 'unquote-splicing' -> 372 | if Level =:= 0 -> Return(CarX, hd(tl(X))); 373 | true -> 'descend_quasiquote_pair*'(X, Level - 1, Return) 374 | end; 375 | true -> 376 | 'descend_quasiquote_pair*'(X, Level, Return) 377 | end. 378 | 379 | descend_quasiquote_vector(X, Level, Return) -> 380 | descend_quasiquote(tuple_to_list(X), Level, 381 | fun (Mode, Arg) -> 382 | case Mode of 383 | 'quote' -> 384 | Return('quote', X); 385 | 'list' -> 386 | Return(system('vector'), Arg); 387 | _ -> 388 | Return(system('list->vector'), 389 | [finalize_quasiquote(Mode, Arg)]) 390 | end 391 | end). 392 | 393 | finalize_quasiquote(Mode, Arg) -> 394 | case Mode of 395 | 'quote' -> ['quote', Arg]; 396 | 'unquote' -> Arg; 397 | 'unquote-splicing' -> macro_error({invalid_unquote_splicing, Arg}); 398 | 'list' -> [system('list') | Arg]; 399 | 'cons' -> 400 | case Arg of 401 | [_, _] -> [system('cons') | Arg]; % (= (length arg) 2) 402 | _ -> 'finalize_cons*'(Arg) 403 | end; 404 | _ -> [Mode | Arg] 405 | end. 406 | 407 | %% C-Scheme synthesized (cons* ... ) here. 408 | %% We synthesize (append (list ... ) ) to avoid 409 | %% variadic procedures (list is a built-in constructor). 410 | 'finalize_cons*'([Arg]) -> Arg; 411 | 'finalize_cons*'(Args) -> 412 | RevArgs = lists:reverse(Args), 413 | [Last | RevButLast] = RevArgs, 414 | ButLast = lists:reverse(RevButLast), 415 | [system('append'), [system('list') | ButLast], Last]. 416 | 417 | system(Name) -> 418 | %% TODO: generate the "system" definition of a standard procedure 419 | %% (append, vector, list->vector, list, or cons). This needs to 420 | %% work even if the user has rebound that identifier. 421 | Name. 422 | 423 | expand_quasiquote([_QQ, X], SynEnv) -> 424 | {descend_quasiquote(X, _Level = 0, _Return = fun finalize_quasiquote/2), SynEnv}. 425 | 426 | is_proper_list([_ | Tl]) -> is_proper_list(Tl); 427 | is_proper_list([]) -> true; 428 | is_proper_list(_) -> false. 429 | 430 | %% Syntax Environment Operations ----------------------------------------------- 431 | 432 | enter_expander(Name, Expander) -> 433 | es_gloenv:enter_expander(Name, Expander). 434 | 435 | find_expander(SynEnv, Name) -> 436 | case es_synenv:lookup(SynEnv, Name) of 437 | {value, Expander} when Expander =/= false -> Expander; 438 | _ -> false % none (unbound) or {value, false} (shadowed) 439 | end. 440 | 441 | bind_expander({Name, Type, Expander}, SynEnv) -> 442 | es_synenv:enter(SynEnv, Name, wrap_expander(Type, Expander)). 443 | 444 | wrap_expander(?syntax, Expander) -> Expander; 445 | wrap_expander(?macro, Expander) -> 446 | fun (Sexpr, SynEnv) -> 447 | {NewSexpr, NewSynEnv} = Expander(Sexpr, SynEnv), 448 | expand_toplevel(NewSexpr, NewSynEnv) 449 | end. 450 | 451 | bind_vars(Vars, SynEnv) -> 452 | false = es_synenv:is_gloenv(SynEnv), % assert 453 | lists:foldl(fun do_bind_var/2, SynEnv, Vars). 454 | 455 | bind_var(Var, SynEnv) -> 456 | case es_synenv:is_gloenv(SynEnv) of 457 | true -> 458 | SynEnv; % toplevel (define ..), nothing for us to do 459 | false -> 460 | do_bind_var(Var, SynEnv) 461 | end. 462 | 463 | %% Variables are bound to false, as opposed to expanders which are bound to functions. 464 | do_bind_var(Var, SynEnv) -> 465 | es_synenv:enter(SynEnv, Var, false). 466 | 467 | nested(SynEnv) -> 468 | es_synenv:nested(SynEnv). 469 | 470 | %% Error Formatting ------------------------------------------------------------ 471 | 472 | macro_error(Reason) -> 473 | error({?MODULE, Reason}). 474 | 475 | -spec format_error(term()) -> io_lib:chars(). 476 | format_error(Reason) -> 477 | case Reason of 478 | {invalid_unquote_splicing, Arg} -> 479 | io_lib:format("invalid context for ',@': ~tp", [Arg]); 480 | _ -> 481 | io_lib:format("~tp", [Reason]) 482 | end. 483 | -------------------------------------------------------------------------------- /src/es_main.erl: -------------------------------------------------------------------------------- 1 | %%% -*- erlang-indent-level: 2 -*- 2 | %%% 3 | %%% Copyright 2022 Mikael Pettersson 4 | %%% 5 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %%% you may not use this file except in compliance with the License. 7 | %%% You may obtain a copy of the License at 8 | %%% 9 | %%% http://www.apache.org/licenses/LICENSE-2.0 10 | %%% 11 | %%% Unless required by applicable law or agreed to in writing, software 12 | %%% distributed under the License is distributed on an "AS IS" BASIS, 13 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %%% See the License for the specific language governing permissions and 15 | %%% limitations under the License. 16 | %%% 17 | %%% es_main.erl 18 | %%% 19 | %%% Main entry point for ErlScheme. 20 | 21 | -module(es_main). 22 | 23 | -export([start/0, start/1]). 24 | 25 | start() -> 26 | start([]). 27 | 28 | start(PreArgv) -> 29 | Argv = lists:map(fun([$x | Arg]) -> Arg end, PreArgv), 30 | case Argv of 31 | ["-c" | Files] -> 32 | compile(Files); 33 | ["--compile" | Files] -> 34 | compile(Files); 35 | [] -> 36 | es_repl:start(); 37 | _ -> 38 | io:format(standard_error, "erlscheme: invalid arguments: ~p\n", [Argv]), 39 | halt(1) 40 | end. 41 | 42 | compile(Files) -> 43 | lists:foreach(fun do_compile/1, Files). 44 | 45 | do_compile(File) -> 46 | erlang:put('es_load_prefix', "."), 47 | es_compile:file(File). 48 | -------------------------------------------------------------------------------- /src/es_parse.erl: -------------------------------------------------------------------------------- 1 | %%% -*- erlang-indent-level: 2 -*- 2 | %%% 3 | %%% Copyright 2014-2022 Mikael Pettersson 4 | %%% 5 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %%% you may not use this file except in compliance with the License. 7 | %%% You may obtain a copy of the License at 8 | %%% 9 | %%% http://www.apache.org/licenses/LICENSE-2.0 10 | %%% 11 | %%% Unless required by applicable law or agreed to in writing, software 12 | %%% distributed under the License is distributed on an "AS IS" BASIS, 13 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %%% See the License for the specific language governing permissions and 15 | %%% limitations under the License. 16 | %%% 17 | %%% es_parse.erl 18 | %%% 19 | %%% Parses a top-level S-expression and converts it to an abstract syntax 20 | %%% tree (AST). 21 | %%% 22 | %%% Checks bindings, variable references, and export declarations. (This is not 23 | %%% postponed to a "lint" module since this processing is needed anyway in order 24 | %%% to generate correct AST for variable references and ":" operands.) 25 | %%% 26 | %%% Notes: 27 | %%% - Variadic functions (with "rest" parameters) are not supported, since 28 | %%% they mess up calling conventions and interoperability with Erlang. 29 | %%% - (set! ...) is restricted to assigning global variables in the REPL. 30 | %%% 31 | %%% Extensions: 32 | %%% - (lambda M:F/A) evaluates to the function F of arity A exported from module M, 33 | %%% M, F, and A are all evaluated except that if M or F are unbound variables, they 34 | %%% are implicitly quoted to become literal symbols 35 | %%% - (M:F A1 ... An) is equivalent to ((lambda M:F/n) A1 ... An) 36 | %%% - (try ...) is the exception handling primitive, modelled after Erlang's try 37 | %%% - (case ...) is the pattern-matching primitive, modelled after Erlang's case, 38 | %%% Scheme's (case ...) is not supported 39 | 40 | -module(es_parse). 41 | 42 | -export([ format_error/1 43 | , module/1 44 | , toplevel/1 45 | ]). 46 | 47 | -type sexpr() :: term(). 48 | -type ast() :: term(). 49 | 50 | %% API ------------------------------------------------------------------------- 51 | 52 | -spec module([sexpr()]) -> ast(). 53 | module(Sexprs) -> 54 | {Name, Sexprs1} = parse_module_decl(Sexprs), 55 | {Exports, Sexprs2} = parse_export_decl(Sexprs1), 56 | PreDefuns = parse_pre_defuns(Sexprs2), 57 | ModEnv = build_modenv(PreDefuns), 58 | Defuns = parse_defuns(PreDefuns, ModEnv), 59 | check_exports(Exports, ModEnv), 60 | {'ES:MODULE', Name, Exports, Defuns}. 61 | 62 | -spec toplevel(sexpr()) -> ast(). 63 | toplevel(Sexpr) -> 64 | parse(Sexpr, empty_repl_env(), true). 65 | 66 | %% Internals: Modules ---------------------------------------------------------- 67 | 68 | parse_module_decl(Sexprs) -> 69 | case Sexprs of 70 | [['module', Name] | Rest] -> 71 | {Name, Rest}; 72 | [X | _] -> 73 | parse_error({bad_module_decl, X}); 74 | [] -> 75 | parse_error(bad_module_decl_missing) 76 | end. 77 | 78 | parse_export_decl(Sexprs) -> 79 | case Sexprs of 80 | [['export' | Exports] | Rest] -> 81 | {parse_exports(Exports, []), Rest}; 82 | _ -> 83 | parse_error(bad_export_decl_missing) 84 | end. 85 | 86 | parse_exports(Exports, Acc) -> 87 | case Exports of 88 | [] -> 89 | lists:reverse(Acc); 90 | [F, '/', A | Rest] when is_atom(F), is_integer(A), A >= 0 -> 91 | parse_exports(Rest, [{F, A} | Acc]); 92 | [['/', F, A] | Rest] when is_atom(F), is_integer(A), A >= 0 -> 93 | parse_exports(Rest, [{F, A} | Acc]); 94 | _ -> 95 | parse_error({bad_export_decl, Exports}) 96 | end. 97 | 98 | check_exports(Exports, ModEnv) -> 99 | lists:foreach(fun (Export) -> check_export(Export, ModEnv) end, Exports). 100 | 101 | check_export({F, A}, ModEnv) -> 102 | case es_env:lookup(ModEnv, F) of 103 | {value, A} -> ok; 104 | {value, B} -> parse_error({bad_export_arity, F, A, B}); 105 | none -> parse_error({bad_export_undef, F, A}) 106 | end. 107 | 108 | parse_pre_defuns(Sexprs) -> 109 | lists:map(fun parse_pre_defun/1, Sexprs). 110 | 111 | parse_pre_defun(Sexpr) -> 112 | case Sexpr of 113 | ['define', Name, ['lambda', Formals, Body]] when is_atom(Name) -> 114 | try length(Formals) of 115 | _Arity -> {Name, Formals, Body} 116 | catch error:badarg -> 117 | parse_error({bad_formals, Formals}) 118 | end; 119 | _ -> 120 | parse_error({bad_defun, Sexpr}) 121 | end. 122 | 123 | build_modenv(PreDefuns) -> 124 | lists:foldl(fun build_modenv/2, empty_module_env(), PreDefuns). 125 | 126 | build_modenv({Name, Formals, _Body}, Env) -> 127 | Arity = length(Formals), 128 | case es_env:is_bound(Env, Name) of 129 | true -> parse_error({bad_fun_binding, Name, Arity}); 130 | false -> es_env:enter(Env, Name, Arity) 131 | end. 132 | 133 | parse_defuns(PreDefuns, ModEnv) -> 134 | lists:map(fun (PreDefun) -> parse_defun(PreDefun, ModEnv) end, PreDefuns). 135 | 136 | parse_defun({Name, Formals, Body}, ModEnv) -> 137 | {'ES:DEFINE', Name, parse_plain_lambda(Formals, Body, ModEnv)}. 138 | 139 | %% Internals: Expressions ------------------------------------------------------ 140 | 141 | parse(Sexpr, Env) -> 142 | parse(Sexpr, Env, false). 143 | 144 | parse(Sexpr, Env, IsToplevel) -> 145 | case Sexpr of 146 | [Hd | Tl] -> 147 | parse_form(Hd, Tl, Env, IsToplevel); 148 | Symbol when is_atom(Symbol) -> 149 | parse_atom(Symbol, Env); 150 | _ -> 151 | case is_self_evaluating(Sexpr) of 152 | true -> 153 | {'ES:QUOTE', Sexpr}; 154 | false -> 155 | parse_error({bad_expression, Sexpr}) 156 | end 157 | end. 158 | 159 | is_self_evaluating(Sexpr) -> 160 | case Sexpr of 161 | _ when is_number(Sexpr) -> true; % includes characters 162 | true -> true; 163 | false -> true; 164 | _ when is_binary(Sexpr) -> true; % strings 165 | %% bytevectors (since R6RS/R7RS) are also self-evaluating 166 | _ when is_tuple(Sexpr) -> true; % vectors are self-evaluating since R7RS 167 | _ -> false 168 | end. 169 | 170 | parse_form(Hd, Tl, Env, IsToplevel) -> 171 | case Hd of 172 | 'and' -> 173 | parse_and(Tl, Env); 174 | 'begin' -> 175 | parse_begin(Tl, Env, IsToplevel); 176 | 'case' -> 177 | parse_case(Tl, Env); 178 | 'cond' -> 179 | parse_cond(Tl, Env); 180 | 'define' -> 181 | parse_define(Tl, Env, IsToplevel); 182 | 'if' -> 183 | parse_if(Tl, Env); 184 | 'lambda' -> 185 | parse_lambda(Tl, Env); 186 | 'let' -> 187 | parse_let(Tl, Env); 188 | 'letrec' -> 189 | parse_letrec(Tl, Env); 190 | 'quote' -> 191 | parse_quote(Tl); 192 | 'set!' -> 193 | 'parse_set!'(Tl, Env); 194 | 'try' -> 195 | parse_try(Tl, Env); 196 | _ -> 197 | parse_call(Hd, Tl, Env) 198 | end. 199 | 200 | parse_and(Tl, Env) -> 201 | case Tl of 202 | [Expr] -> 203 | parse(Expr, Env); 204 | [Expr | Rest] -> 205 | {'ES:IF', parse(Expr, Env), parse_and(Rest, Env), {'ES:QUOTE', false}}; 206 | [] -> 207 | {'ES:QUOTE', true}; 208 | _ -> 209 | parse_error({bad_and, Tl}) 210 | end. 211 | 212 | parse_atom(Atom, Env) -> 213 | parse_atom(Atom, Env, _QuoteIfGlovar = false). 214 | 215 | parse_atom(Atom, Env, QuoteIfGlovar) -> 216 | case Atom of 217 | true -> 218 | {'ES:QUOTE', Atom}; 219 | false -> 220 | {'ES:QUOTE', Atom}; 221 | _ -> 222 | case es_env:lookup(Env, Atom) of 223 | {value, []} -> 224 | {'ES:LOCVAR', Atom}; 225 | {value, A} when is_integer(A) -> 226 | if QuoteIfGlovar -> % this is the M or F in M:F 227 | {'ES:QUOTE', Atom}; 228 | true -> 229 | {'ES:GLOVAR', Atom} 230 | end; 231 | none when QuoteIfGlovar -> % this is the M or F in M:F 232 | {'ES:QUOTE', Atom}; 233 | none -> 234 | %% In modules replace global variables with the MFAs they denote. 235 | case is_module(Env) andalso es_env:lookup(es_lib_scheme_base:env(), Atom) of 236 | {value, Fun} when is_function(Fun) -> 237 | case erlang:fun_info(Fun, type) of 238 | {type, external} -> 239 | {module, M} = erlang:fun_info(Fun, module), 240 | {name, F} = erlang:fun_info(Fun, name), 241 | {arity, A} = erlang:fun_info(Fun, arity), 242 | {'ES:PRIMOP', 'ES:COLON', [{'ES:QUOTE', M}, {'ES:QUOTE', F}, {'ES:QUOTE', A}]}; 243 | {type, local} -> 244 | {'ES:GLOVAR', Atom} 245 | end; 246 | _ -> 247 | {'ES:GLOVAR', Atom} 248 | end 249 | end 250 | end. 251 | 252 | parse_begin(Tl, Env, IsToplevel) -> 253 | case Tl of 254 | [Expr] -> 255 | parse(Expr, Env, IsToplevel); 256 | [Expr | Rest] -> 257 | {'ES:BEGIN', parse(Expr, Env, IsToplevel), parse_begin(Rest, Env, IsToplevel)}; 258 | [] when IsToplevel -> % (begin) is valid at the top-level 259 | {'ES:QUOTE', es_datum:unspecified()}; 260 | _ -> 261 | parse_error({bad_begin, Tl}) 262 | end. 263 | 264 | parse_call(Hd, Tl, Env) -> 265 | {Fun, Args1} = 266 | case Tl of 267 | [':', F0 | Args0] -> 268 | M = quote_if_glovar(Hd, Env), 269 | F = quote_if_glovar(F0, Env), 270 | A = {'ES:QUOTE', length(Args0)}, 271 | {{'ES:PRIMOP', 'ES:COLON', [M, F, A]}, Args0}; 272 | _ -> 273 | {parse(Hd, Env), Tl} 274 | end, 275 | Args = [parse(Arg, Env) || Arg <- Args1], 276 | %% Recognize calls to special built-ins: 277 | %% - (list ...) becomes a built-in to avoid needing a variadic list/N function 278 | {PrimOp, PrimArgs} = 279 | case Fun of 280 | {'ES:GLOVAR', 'list'} -> {'ES:LIST', Args}; 281 | _ -> {'ES:APPLY', [Fun | Args]} 282 | end, 283 | {'ES:PRIMOP', PrimOp, PrimArgs}. 284 | 285 | parse_case(Tl, Env) -> 286 | case Tl of 287 | [Expr | Clauses] -> 288 | {'ES:CASE', parse(Expr, Env), parse_clauses(Clauses, default_case_clause(), Env)}; 289 | _ -> 290 | parse_error({bad_case, Tl}) 291 | end. 292 | 293 | default_case_clause() -> 294 | %% Synthesize (_ (erlang:error 'case_clause)) 295 | ErrorFun = {'ES:PRIMOP', 'ES:COLON', [{'ES:QUOTE', 'erlang'}, {'ES:QUOTE', 'error'}, {'ES:QUOTE', 1}]}, 296 | ErrorExpr = {'ES:PRIMOP', 'ES:APPLY', [ErrorFun, {'ES:QUOTE', 'case_clause'}]}, 297 | [{'ES:WILD', {'ES:QUOTE', 'true'}, ErrorExpr}]. 298 | 299 | parse_cond(Tl, Env) -> 300 | case Tl of 301 | [Clause | Clauses] -> 302 | parse_cond_clauses(Clause, Clauses, Env); 303 | _ -> 304 | parse_error({bad_cond, Tl}) 305 | end. 306 | 307 | parse_cond_clauses(['else' | Exprs], [], Env) -> 308 | %% (begin ..) 309 | parse_begin(Exprs, Env, _IsToplevel = false); 310 | parse_cond_clauses([Test], Rest, Env) -> 311 | %% (let (( )) (if (cond ..))) 312 | Var = newvar(), 313 | VarExp = {'ES:LOCVAR', Var}, 314 | {'ES:LET', [{Var, parse(Test, Env)}], 315 | {'ES:IF', VarExp, VarExp, parse_cond_clauses(Rest, Env)}}; 316 | parse_cond_clauses([Test, '=>', Expr], Rest, Env) -> 317 | %% (let (( )) (if ( ) (cond ..))) 318 | Var = newvar(), 319 | VarExp = {'ES:LOCVAR', Var}, 320 | {'ES:LET', [{Var, parse(Test, Env)}], 321 | {'ES:IF', VarExp, 322 | {'ES:PRIMOP', 'ES:APPLY', [parse(Expr, Env), VarExp]}, 323 | parse_cond_clauses(Rest, Env)}}; 324 | parse_cond_clauses([Test | Exprs], Rest, Env) -> 325 | %% (if (begin ..) (cond ..)) 326 | {'ES:IF', parse(Test, Env), 327 | parse_begin(Exprs, Env, _IsToplevel = false), 328 | parse_cond_clauses(Rest, Env)}. 329 | 330 | parse_cond_clauses([Clause | Rest], Env) -> parse_cond_clauses(Clause, Rest, Env); 331 | parse_cond_clauses([], _Env) -> {'ES:QUOTE', es_datum:unspecified()}. 332 | 333 | parse_define(Tl, Env, IsToplevel) -> 334 | case {Tl, IsToplevel} of 335 | {[Var, Expr], true} when is_atom(Var) -> 336 | {'ES:DEFINE', Var, parse(Expr, Env)}; 337 | _ -> 338 | parse_error({bad_define, Tl}) 339 | end. 340 | 341 | parse_if(Tl, Env) -> 342 | case Tl of 343 | [Pred, Then, Else] -> 344 | {'ES:IF', parse(Pred, Env), parse(Then, Env), parse(Else, Env)}; 345 | [Pred, Then] -> 346 | {'ES:IF', parse(Pred, Env), parse(Then, Env), {'ES:QUOTE', es_datum:unspecified()}}; 347 | _ -> 348 | parse_error({bad_if, Tl}) 349 | end. 350 | 351 | parse_lambda(Tl, Env) -> 352 | case Tl of 353 | [M, ':', F, '/', A] -> 354 | {'ES:PRIMOP', 'ES:COLON', [quote_if_glovar(M, Env), quote_if_glovar(F, Env), parse(A, Env)]}; 355 | [Formals, Body] -> 356 | parse_plain_lambda(Formals, Body, Env); 357 | _ -> 358 | parse_error({bad_lambda, Tl}) 359 | end. 360 | 361 | parse_plain_lambda(Formals, Body, Env) -> 362 | ScopeEnv = parse_formals(Formals, es_env:empty()), 363 | {'ES:LAMBDA', Formals, parse(Body, es_env:overlay(Env, ScopeEnv))}. 364 | 365 | quote_if_glovar(Sexpr, Env) -> 366 | if is_atom(Sexpr) -> 367 | parse_atom(Sexpr, Env, _QuoteIfGlovar = true); 368 | true -> 369 | parse(Sexpr, Env) 370 | end. 371 | 372 | parse_formals(Formals, ScopeEnv) -> 373 | case Formals of 374 | [] -> 375 | ScopeEnv; 376 | [Formal | RestFormals] when is_atom(Formal) -> 377 | parse_formals(RestFormals, bind(Formal, ScopeEnv)); 378 | _ -> 379 | parse_error({bad_formals, Formals}) 380 | end. 381 | 382 | bind(Var, ScopeEnv) when is_atom(Var) -> 383 | case es_env:is_bound(ScopeEnv, Var) of 384 | true -> parse_error({bad_var_binding, Var}); 385 | false -> es_env:enter(ScopeEnv, Var, []) 386 | end. 387 | 388 | parse_let(Tl, Env) -> 389 | case Tl of 390 | [Bindings, Body] -> 391 | {NewBindings, ScopeEnv} = parse_let_bindings(Bindings, Env), 392 | {'ES:LET', NewBindings, parse(Body, es_env:overlay(Env, ScopeEnv))}; 393 | _ -> 394 | parse_error({bad_let, tl}) 395 | end. 396 | 397 | parse_let_bindings(Bindings, Env) -> 398 | NewBindings = [parse_let_binding(Binding, Env) || Binding <- Bindings], 399 | ScopeEnv = lists:foldl(fun bind_let/2, es_env:empty(), NewBindings), 400 | {NewBindings, ScopeEnv}. 401 | 402 | parse_let_binding(Binding, Env) -> 403 | case Binding of 404 | [Var, Expr] when is_atom(Var) -> 405 | {Var, parse(Expr, Env)}; 406 | _ -> 407 | parse_error({bad_let_binding, Binding}) 408 | end. 409 | 410 | bind_let({Var, _Expr}, ScopeEnv) -> 411 | bind(Var, ScopeEnv). 412 | 413 | parse_letrec(Tl, Env) -> 414 | case Tl of 415 | [Bindings, Body] -> 416 | {NewBindings, NewEnv} = parse_letrec_bindings(Bindings, Env), 417 | {'ES:LETREC', NewBindings, parse(Body, NewEnv)}; 418 | _ -> 419 | parse_error({bad_letrec, Tl}) 420 | end. 421 | 422 | parse_letrec_bindings(Bindings, Env) -> 423 | ScopeEnv = lists:foldl(fun bind_letrec/2, es_env:empty(), Bindings), 424 | NewEnv = es_env:overlay(Env, ScopeEnv), 425 | NewBindings = [parse_letrec_binding(Binding, NewEnv) || Binding <- Bindings], 426 | {NewBindings, NewEnv}. 427 | 428 | parse_letrec_binding(Binding, NewEnv) -> 429 | case Binding of 430 | [Var, ['lambda', Formals, Body]] when is_atom(Var) -> 431 | ScopeEnv = parse_formals(Formals, es_env:empty()), 432 | {Var, Formals, parse(Body, es_env:overlay(NewEnv, ScopeEnv))}; 433 | _ -> 434 | parse_error({bad_letrec_binding, Binding}) 435 | end. 436 | 437 | bind_letrec(Binding, ScopeEnv) -> 438 | case Binding of 439 | [Var, _Lambda] when is_atom(Var) -> 440 | bind(Var, ScopeEnv); 441 | _ -> 442 | parse_error({bad_letrec_binding, Binding}) 443 | end. 444 | 445 | parse_quote(Tl) -> 446 | case Tl of 447 | [Value] -> 448 | {'ES:QUOTE', Value}; 449 | _ -> 450 | parse_error({bad_quote, Tl}) 451 | end. 452 | 453 | 'parse_set!'(Tl, Env) -> 454 | case Tl of 455 | [Var, Expr] when is_atom(Var) -> 456 | case is_global_in_repl(Env, Var) of 457 | true -> 458 | {'ES:SET!', Var, parse(Expr, Env)}; 459 | false -> 460 | parse_error({'bad_set!_disallowed', Var}) 461 | end; 462 | _ -> 463 | parse_error({'bad_set!', Tl}) 464 | end. 465 | 466 | %% Erlang-like try construct: 467 | %% 468 | %% (try Expr 469 | %% (of Var Body) 470 | %% (catch EVar Handler) 471 | %% (after After)) 472 | %% 473 | %% Expr is evaluated in a dynamic context with a new current exception handler. 474 | %% 475 | %% If Expr evaluates to Val without raising an exception, Body is evaluated with 476 | %% Var bound to Val in the original context of the try, i.e. without the new 477 | %% exception handler present, and the value of Body becomes the value of the try. 478 | %% If (of Var Body) is absent it is treated as (of x x) for some fresh variable x. 479 | %% 480 | %% If the evaluation of Expr raises an exception E, Handler is evaluated with EVar 481 | %% bound to E in the original context of the try, i.e. without the new exception 482 | %% handler present, and the value of Handler becomes the value of the try. 483 | %% If (catch Var Handler) is absent it is treated as (catch x (raise x)) for some 484 | %% fresh variable x. 485 | %% 486 | %% If (after After) is present, After is evaluated and its value ignored in the 487 | %% original context of the try, i.e. without the new handler present, immediately 488 | %% before the try returns or raises to the original context of the try. 489 | %% 490 | %% The of, catch, and after clauses are all optional, but at least one of catch 491 | %% or after must be present. 492 | parse_try(Tl, Env) -> 493 | case Tl of 494 | [Expr0 | RestExpr] -> 495 | Expr = parse(Expr0, Env), 496 | {MaybeOf, RestOf} = parse_try_clause('of', RestExpr, Env), 497 | {MaybeCatch, RestHandle} = parse_try_clause('catch', RestOf, Env), 498 | {After, RestAfter} = parse_try_after(RestHandle, Env), 499 | case (RestAfter =:= []) andalso (MaybeCatch =/= [] orelse After =/= []) of 500 | true -> 501 | {Var, Body} = fixup_try_of(MaybeOf), 502 | {EVar, Handler} = fixup_try_catch(MaybeCatch), 503 | {'ES:TRY', Expr, Var, Body, EVar, Handler, After}; 504 | false -> 505 | parse_error({bad_try, Tl}) 506 | end; 507 | [] -> 508 | parse_error({bad_try, Tl}) 509 | end. 510 | 511 | parse_try_clause(Tag, [[Tag, Var, Expr] | Rest], Env) when is_atom(Var) -> 512 | {{Var, parse(Expr, es_env:enter(Env, Var, []))}, Rest}; 513 | parse_try_clause(Tag, [[Tag | _] = Clause | _Rest], _Env) -> 514 | parse_error({bad_try_clause, Clause}); 515 | parse_try_clause(_Tag, Rest, _Env) -> 516 | {[], Rest}. 517 | 518 | parse_try_after([['after', Expr] | Rest], Env) -> 519 | {parse(Expr, Env), Rest}; 520 | parse_try_after(Rest, _Env) -> 521 | {[], Rest}. 522 | 523 | fixup_try_of(MaybeOf) -> 524 | case MaybeOf of 525 | {_Var, _Body} -> MaybeOf; 526 | [] -> 527 | Var = newvar(), 528 | {Var, {'ES:LOCVAR', Var}} 529 | end. 530 | 531 | fixup_try_catch(MaybeCatch) -> 532 | case MaybeCatch of 533 | {_EVar, _Handler} -> MaybeCatch; 534 | [] -> 535 | EVar = newvar(), 536 | Handler = {'ES:PRIMOP', 'ES:RAISE', [{'ES:LOCVAR', EVar}]}, 537 | {EVar, Handler} 538 | end. 539 | 540 | %% Pattern matching ------------------------------------------------------------ 541 | 542 | parse_clauses([Clause | Clauses], Tail, Env) -> 543 | [parse_clause(Clause, Env) | parse_clauses(Clauses, Tail, Env)]; 544 | parse_clauses([], Tail, _Env) -> 545 | Tail. 546 | 547 | parse_clause(Clause, Env) -> 548 | case Clause of 549 | [Pat, ['when', Guard], Body] -> 550 | parse_clause(Pat, {ok, Guard}, Body, Env); 551 | [Pat, Body] -> 552 | parse_clause(Pat, false, Body, Env); 553 | _ -> 554 | parse_error({bad_clause, Clause}) 555 | end. 556 | 557 | parse_clause(Pat, MaybeGuard, Body, Env) -> 558 | {ParsedPat, ClauseEnv} = parse_pat(Pat, Env), 559 | ParsedGuard = 560 | case MaybeGuard of 561 | {ok, Guard} -> parse_guard(Guard, ClauseEnv); 562 | false -> {'ES:QUOTE', 'true'} 563 | end, 564 | {ParsedPat, ParsedGuard, parse(Body, ClauseEnv)}. 565 | 566 | parse_pat(Sexpr, Env) -> 567 | case Sexpr of 568 | '_' -> 569 | {'ES:WILD', Env}; 570 | Var when is_atom(Var) -> % unquoted x means the variable x 571 | case is_bound_in_pat(Env, Var) of 572 | true -> 573 | {{'ES:EQUAL', Var, 'ES:WILD'}, Env}; 574 | false -> 575 | {{'ES:BIND', Var, 'ES:WILD'}, bind(Var, Env)} 576 | end; 577 | ['quote', Atom] when is_atom(Atom) -> % 'x means the symbol x 578 | {{'ES:QUOTE', Atom}, Env}; 579 | ['=', Var, Pat2] when is_atom(Var), Var =/= '_' -> 580 | case is_bound_in_pat(Env, Var) of 581 | true -> 582 | {ParsedPat2, Env2} = parse_pat(Pat2, Env), 583 | {{'ES:EQUAL', Var, ParsedPat2}, Env2}; 584 | false -> 585 | {ParsedPat2, Env2} = parse_pat(Pat2, bind(Var, Env)), 586 | {{'ES:BIND', Var, ParsedPat2}, Env2} 587 | end; 588 | [Pat1 | Pat2] -> 589 | {ParsedPat1, Env1} = parse_pat(Pat1, Env), 590 | {ParsedPat2, Env2} = parse_pat(Pat2, Env1), 591 | {{'ES:CONS', ParsedPat1, ParsedPat2}, Env2}; 592 | Tuple when is_tuple(Tuple) -> 593 | parse_tuple_pat(tuple_to_list(Tuple), [], Env); 594 | [] -> 595 | {{'ES:QUOTE', []}, Env}; 596 | _ -> 597 | case is_self_evaluating(Sexpr) of 598 | true -> 599 | {{'ES:QUOTE', Sexpr}, Env}; 600 | false -> 601 | parse_error({bad_pattern, Sexpr}) 602 | end 603 | end. 604 | 605 | parse_tuple_pat([], ParsedPats, Env) -> 606 | {{'ES:TUPLE', lists:reverse(ParsedPats)}, Env}; 607 | parse_tuple_pat([Pat | Pats], ParsedPats, Env) -> 608 | {ParsedPat, NewEnv} = parse_pat(Pat, Env), 609 | parse_tuple_pat(Pats, [ParsedPat | ParsedPats], NewEnv). 610 | 611 | %% Guards ---------------------------------------------------------------------- 612 | 613 | parse_guard(Sexpr, Env) -> 614 | Guard = parse(Sexpr, Env), 615 | check_guard(Guard), 616 | Guard. 617 | 618 | check_guard(Guard) -> 619 | case Guard of 620 | {'ES:BEGIN', _, _} -> % only useful for side-effects 621 | invalid_guard(Guard); 622 | {'ES:CASE', _, _} -> % can fail 623 | invalid_guard(Guard); 624 | {'ES:CONS', Hd, Tl} -> 625 | check_guard(Hd), 626 | check_guard(Tl); 627 | {'ES:DEFINE', _, _} -> 628 | invalid_guard(Guard); 629 | {'ES:GLOVAR', _} -> 630 | ok; 631 | {'ES:IF', Pred, Then, Else} -> 632 | check_guard(Pred), 633 | check_guard(Then), 634 | check_guard(Else); 635 | {'ES:LAMBDA', _, _} -> % safe, but pointless since it can't be applied 636 | ok; 637 | {'ES:LET', Bindings, Body} -> 638 | lists:foreach(fun({_Lhs, Rhs}) -> check_guard(Rhs) end, Bindings), 639 | check_guard(Body); 640 | {'ES:LETREC', _, _} -> % can loop/recurse 641 | invalid_guard(Guard); 642 | {'ES:LOCVAR', _} -> 643 | ok; 644 | {'ES:PRIMOP', PrimOp, Args} -> 645 | case {PrimOp, Args} of 646 | {'ES:APPLY', [ {'ES:PRIMOP', 'ES:COLON', [{'ES:QUOTE', 'erlang'}, {'ES:QUOTE', F}, {'ES:QUOTE', A}]} 647 | | Rest]} -> 648 | case A =:= length(Rest) andalso erl_internal:guard_bif(F, A) of 649 | true -> lists:foreach(fun check_guard/1, Rest); 650 | false -> invalid_guard(Guard) 651 | end; 652 | {'ES:COLON', _} -> % safe but pointless in isolation 653 | invalid_guard(Guard); 654 | {'ES:LIST', _} -> 655 | lists:foreach(fun check_guard/1, Args); 656 | {'ES:RAISE', _} -> 657 | invalid_guard(Guard) 658 | end; 659 | {'ES:QUOTE', _} -> 660 | ok; 661 | {'ES:SET!', _, _} -> 662 | invalid_guard(Guard); 663 | {'ES:TRY', _, _, _, _, _, _} -> 664 | invalid_guard(Guard); 665 | {'ES:TUPLE', Exprs} -> 666 | lists:foreach(fun check_guard/1, Exprs) 667 | end. 668 | 669 | -dialyzer({no_return, invalid_guard/1}). 670 | invalid_guard(Expr) -> 671 | parse_error({bad_guard, Expr}). 672 | 673 | %% Auxiliary helpers ----------------------------------------------------------- 674 | 675 | %% The parse-time environment records lexically bound variables, and in modules 676 | %% also the toplevel defuns. Global variables need to be considered bound in 677 | %% in some contexts in the REPL, so the environment has a marker to distinguish 678 | %% modules from the REPL. 679 | 680 | -define(MARKER_KEY, []). % no ErlScheme variable has name [] 681 | 682 | empty_module_env() -> 683 | es_env:enter(es_env:empty(), ?MARKER_KEY, 'module'). 684 | 685 | empty_repl_env() -> 686 | es_env:enter(es_env:empty(), ?MARKER_KEY, 'repl'). 687 | 688 | %% For patterns in the REPL we need to classify global variables as bound. 689 | is_bound_in_pat(Env, Var) -> 690 | es_env:is_bound(Env, Var) orelse 691 | (es_env:get(Env, ?MARKER_KEY) =:= 'repl' andalso 692 | es_gloenv:is_bound_var(Var)). 693 | 694 | is_global_in_repl(Env, Var) -> 695 | (not es_env:is_bound(Env, Var)) andalso (es_env:get(Env, ?MARKER_KEY) =:= 'repl'). 696 | 697 | is_module(Env) -> 698 | es_env:get(Env, ?MARKER_KEY) =:= 'module'. 699 | 700 | newvar() -> 701 | erlang:unique_integer([positive]). 702 | 703 | %% Error Formatting ------------------------------------------------------------ 704 | 705 | parse_error(Reason) -> 706 | error({?MODULE, Reason}). 707 | 708 | -spec format_error(term()) -> io_lib:chars(). 709 | format_error(Reason) -> 710 | case Reason of 711 | {bad_module_decl, X} -> 712 | io_lib:format("invalid (module ..) declaration: ~tp", [X]); 713 | bad_module_decl_missing -> 714 | "missing (module ..) declaration"; 715 | bad_export_decl_missing -> 716 | "missing (export ..) declaration"; 717 | {bad_export_decl, X} -> 718 | io_lib:format("invalid (export ..) declaration: ~tp", [X]); 719 | {bad_export_arity, F, A, B} -> 720 | io_lib:format("bad export ~tp: expected arity ~tp, actual arity ~tp", [F, A, B]); 721 | {bad_export_undef, F, A} -> 722 | io_lib:format("bad export of undefined ~tp/~tp", [F, A]); 723 | {bad_formals, X} -> 724 | io_lib:format("formal parameters is not a proper list: ~tp", [X]); 725 | {bad_defun, X} -> 726 | io_lib:format("invalid toplevel function definition: ~tp", [X]); 727 | {bad_fun_binding, F, A} -> 728 | io_lib:format("toplevel function ~tp/~tp: already defined", [F, A]); 729 | {bad_var_binding, V} -> 730 | io_lib:format("variable ~tp already bound in local scope", [V]); 731 | {bad_expression, X} -> 732 | io_lib:format("invalid expression: ~tp", [X]); 733 | {bad_and, X} -> 734 | io_lib:format("invalid (and ..) expression: ~tp", [X]); 735 | {bad_begin, X} -> 736 | io_lib:format("invalid (begin ..) expression: ~tp", [X]); 737 | {bad_case, X} -> 738 | io_lib:format("invalid (case ..) expression: ~tp", [X]); 739 | {bad_cond, X} -> 740 | io_lib:format("invalid (cond ..) expression: ~tp", [X]); 741 | {bad_define, X} -> 742 | io_lib:format("malformed or malplaced (define ..) expression: ~tp", [X]); 743 | {bad_if, X} -> 744 | io_lib:format("invalid (if ..) expression: ~tp", [X]); 745 | {bad_lambda, X} -> 746 | io_lib:format("invalid (lambda ..) expression: ~tp", [X]); 747 | {bad_let, X} -> 748 | io_lib:format("invalid (let ..) expression: ~tp", [X]); 749 | {bad_let_binding, X} -> 750 | io_lib:format("invalid binding in let: ~tp", [X]); 751 | {bad_letrec, X} -> 752 | io_lib:format("invalid (letrec ..) expression: ~tp", [X]); 753 | {bad_letrec_binding, X} -> 754 | io_lib:format("invalid binding in letrec: ~tp", [X]); 755 | {bad_quote, X} -> 756 | io_lib:format("invalid (quote ..) expression: ~tp", [X]); 757 | {'bad_set!', X} -> 758 | io_lib:format("invalid (set! ..) expression: ~tp", [X]); 759 | {'bad_set!_disallowed', V} -> 760 | io_lib:format("not allowed: (set! ~tp ..)", [V]); 761 | {bad_try, X} -> 762 | io_lib:format("invalid (try ..) expression: ~tp", [X]); 763 | {bad_try_clause, X} -> 764 | io_lib:format("invalid (try ..) clause: ~tp", [X]); 765 | {bad_clause, X} -> 766 | io_lib:format("invalid pattern-matching clause: ~tp", [X]); 767 | {bad_pattern, X} -> 768 | io_lib:format("invalid pattern: ~tp", [X]); 769 | {bad_guard, X} -> 770 | io_lib:format("invalid guard: ~tp", [X]); 771 | _ -> 772 | io_lib:format("~tp", [Reason]) 773 | end. 774 | -------------------------------------------------------------------------------- /src/es_print.erl: -------------------------------------------------------------------------------- 1 | %%% -*- erlang-indent-level: 2 -*- 2 | %%% 3 | %%% Copyright 2014-2022 Mikael Pettersson 4 | %%% 5 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %%% you may not use this file except in compliance with the License. 7 | %%% You may obtain a copy of the License at 8 | %%% 9 | %%% http://www.apache.org/licenses/LICENSE-2.0 10 | %%% 11 | %%% Unless required by applicable law or agreed to in writing, software 12 | %%% distributed under the License is distributed on an "AS IS" BASIS, 13 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %%% See the License for the specific language governing permissions and 15 | %%% limitations under the License. 16 | %%% 17 | %%% es_print.erl 18 | %%% 19 | %%% A term printer for ErlScheme. 20 | 21 | -module(es_print). 22 | 23 | -export([ display/1 24 | , write/1 25 | ]). 26 | 27 | -type datum() :: term(). 28 | 29 | %% API ------------------------------------------------------------------------- 30 | 31 | -spec display(datum()) -> ok. 32 | display(Term) -> 33 | print(Term, _Depth = 10, _Width = 20, _IsDisplay = true). 34 | 35 | -spec write(datum()) -> ok. 36 | write(Term) -> 37 | Infinity = infinity(), 38 | print(Term, _Depth = Infinity, _Width = Infinity, _IsDisplay = false). 39 | 40 | %% Internals ------------------------------------------------------------------- 41 | 42 | %% For Depth and Width limited output we need Limit values that act 43 | %% like finite non-negative integers with "decrement" and "is-zero" 44 | %% operations, while also supporting a reserved value representing 45 | %% positive infinity for unlimited output. We use "-1" as +infinity. 46 | 47 | -define(infinity, -1). 48 | 49 | infinity() -> ?infinity. 50 | 51 | decrement(?infinity) -> ?infinity; 52 | decrement(N) when N > 0 -> N - 1. 53 | 54 | print(_, 0, _, _) -> 55 | io:format("..."); 56 | print(Term, DepthLim, WidthLim, IsDisplay) -> 57 | case Term of 58 | [Hd | Tl] -> 59 | io:format("("), 60 | print_list(Hd, Tl, WidthLim, DepthLim, WidthLim, IsDisplay), 61 | io:format(")"); 62 | [] -> io:format("()"); 63 | true -> io:format("#t"); 64 | false -> io:format("#f"); 65 | _ when is_number(Term) -> io:format("~tp", [Term]); % includes characters 66 | _ when is_atom(Term) -> print_symbol(Term, IsDisplay); 67 | _ when is_function(Term) -> % includes eof-object and ports 68 | io:format("#", [erlang:fun_to_list(Term)]); 69 | _ when is_binary(Term) -> print_string(Term, IsDisplay); 70 | _ when is_tuple(Term) -> print_tuple(Term, DepthLim, WidthLim, IsDisplay) 71 | end. 72 | 73 | print_list(_, _, 0, _, _, _) -> 74 | io:format("...)"); 75 | print_list(Hd, Tl, WL, DepthLim, WidthLim, IsDisplay) -> 76 | print(Hd, decrement(DepthLim), WidthLim, IsDisplay), 77 | case Tl of 78 | [] -> 79 | []; 80 | [Hd2 | Tl2] -> 81 | io:format(" "), 82 | print_list(Hd2, Tl2, decrement(WL), DepthLim, WidthLim, IsDisplay); 83 | _ -> 84 | io:format(" . "), 85 | case decrement(WL) of 86 | 0 -> io:format("..."); 87 | _ -> print(Tl, DepthLim, WidthLim, IsDisplay) 88 | end 89 | end. 90 | 91 | print_tuple(Tuple, DepthLim, WidthLim, IsDisplay) -> 92 | io:format("#("), 93 | print_vector(Tuple, 0, DepthLim, WidthLim, IsDisplay), 94 | io:format(")"). 95 | 96 | print_vector(Tuple, I, DepthLim, WidthLim, IsDisplay) -> 97 | if I + 1 > size(Tuple) -> 98 | []; 99 | true -> 100 | if I > 0 -> io:format(" "); 101 | true -> [] 102 | end, 103 | if I >= WidthLim -> 104 | io:format("..."); 105 | true -> 106 | print(element(I + 1, Tuple), decrement(DepthLim), WidthLim, IsDisplay), 107 | print_vector(Tuple, I + 1, DepthLim, WidthLim, IsDisplay) 108 | end 109 | end. 110 | 111 | print_string(Binary, IsDisplay) -> 112 | case IsDisplay of 113 | true -> 114 | io:format("~ts", [Binary]); 115 | false -> 116 | io:format("\""), 117 | escape_string(unicode:characters_to_list(Binary)), 118 | io:format("\"") 119 | end. 120 | 121 | escape_string([]) -> []; 122 | escape_string([Ch | Rest]) -> 123 | case Ch of 124 | 7 -> 125 | io:format("\\a"); 126 | 8 -> 127 | io:format("\\b"); 128 | 9 -> 129 | io:format("\\t"); 130 | 10 -> 131 | io:format("\\n"); 132 | 13 -> 133 | io:format("\\r"); 134 | 34 -> 135 | io:format("\\\""); 136 | 92 -> 137 | io:format("\\\\"); 138 | _ when Ch < 32; Ch >= 127 -> 139 | io:format("\\x~.16B;", [Ch]); 140 | _ -> 141 | io:format("~tc", [Ch]) 142 | end, 143 | escape_string(Rest). 144 | 145 | print_symbol(Symbol, IsDisplay) -> 146 | case IsDisplay of 147 | true -> 148 | io:format("~tp", [Symbol]); 149 | false -> 150 | Pname = atom_to_list(Symbol), 151 | case pname_needs_escape(Pname) of 152 | false -> 153 | io:format("~tp", [Symbol]); 154 | true -> 155 | escape_pname(Pname) 156 | end 157 | end. 158 | 159 | pname_needs_escape([]) -> true; 160 | pname_needs_escape([Ch | Rest]) -> 161 | case es_ctype:char_is_initial(Ch) of 162 | true -> pname_rest_needs_escape(Rest); 163 | false -> true 164 | end. 165 | 166 | pname_rest_needs_escape([]) -> false; 167 | pname_rest_needs_escape([Ch | Rest]) -> 168 | case es_ctype:char_is_subsequent(Ch) of 169 | true -> pname_rest_needs_escape(Rest); 170 | false -> true 171 | end. 172 | 173 | escape_pname([]) -> io:format("||"); 174 | escape_pname([Ch | Rest]) -> 175 | case es_ctype:char_is_initial(Ch) of 176 | true -> io:format("|~tc", [Ch]); 177 | false -> io:format("|\\x~.16B;", [Ch]) 178 | end, 179 | escape_pname_rest(Rest). 180 | 181 | escape_pname_rest([]) -> io:format("|"); 182 | escape_pname_rest([Ch | Rest]) -> 183 | case es_ctype:char_is_subsequent(Ch) of 184 | true -> io:format("~tc", [Ch]); 185 | false -> io:format("\\x~.16B;", [Ch]) 186 | end, 187 | escape_pname_rest(Rest). 188 | -------------------------------------------------------------------------------- /src/es_read.erl: -------------------------------------------------------------------------------- 1 | %%% -*- erlang-indent-level: 2 -*- 2 | %%% 3 | %%% Copyright 2014-2022 Mikael Pettersson 4 | %%% 5 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %%% you may not use this file except in compliance with the License. 7 | %%% You may obtain a copy of the License at 8 | %%% 9 | %%% http://www.apache.org/licenses/LICENSE-2.0 10 | %%% 11 | %%% Unless required by applicable law or agreed to in writing, software 12 | %%% distributed under the License is distributed on an "AS IS" BASIS, 13 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %%% See the License for the specific language governing permissions and 15 | %%% limitations under the License. 16 | %%% 17 | %%% es_read.erl 18 | %%% 19 | %%% An R7RS Reader for ErlScheme. 20 | %%% 21 | %%% Extensions: 22 | %%% - allows bracketed list syntax from R6RS and other LISPs 23 | 24 | -module(es_read). 25 | 26 | -export([ format_error/1 27 | , read/1 28 | ]). 29 | 30 | -type datum() :: term(). 31 | 32 | %% API ------------------------------------------------------------------------- 33 | 34 | -spec read(es_lexinput:lexinput()) -> datum(). 35 | read(LI) -> 36 | read_dispatch(LI, token(LI), true). 37 | 38 | %% Internals ------------------------------------------------------------------- 39 | 40 | read_no_eof(LI) -> 41 | read_dispatch_no_eof(LI, token(LI)). 42 | 43 | read_dispatch_no_eof(LI, Token) -> 44 | read_dispatch(LI, Token, false). 45 | 46 | read_dispatch(LI, Token, EofOK) -> 47 | case Token of 48 | token_lparen -> 49 | read_list(LI, token_rparen, []); 50 | token_lbracket -> 51 | read_list(LI, token_rbracket, []); 52 | token_squote -> 53 | read_squote(LI); 54 | token_backquote -> 55 | read_backquote(LI); 56 | {token_number, Num} -> 57 | Num; 58 | token_hash_lparen -> 59 | read_vector(LI, []); 60 | {token_identifier, String} -> 61 | list_to_atom(String); 62 | token_true -> 63 | true; 64 | token_false -> 65 | false; 66 | token_comma_at -> 67 | read_comma_at(LI); 68 | token_comma -> 69 | read_comma(LI); 70 | {token_character, Ch} -> 71 | es_datum:integer_to_char(Ch); 72 | {token_string, String} -> 73 | unicode:characters_to_binary(String); 74 | token_eof -> 75 | case EofOK of 76 | true -> es_datum:mk_eof_object(); 77 | false -> read_error(premature_eof) 78 | end; 79 | token_rparen -> 80 | read_error(expected_datum_got_rparen); 81 | token_rbracket -> 82 | read_error(expected_datum_got_rbracket); 83 | token_dot -> 84 | read_error(expected_datum_got_dot) 85 | %% token_hash_semi is filtered out by token/1 86 | end. 87 | 88 | read_squote(LI) -> 89 | ['quote', read_no_eof(LI)]. 90 | 91 | read_backquote(LI) -> 92 | ['quasiquote', read_no_eof(LI)]. 93 | 94 | read_comma(LI) -> 95 | ['unquote', read_no_eof(LI)]. 96 | 97 | read_comma_at(LI) -> 98 | ['unquote-splicing', read_no_eof(LI)]. 99 | 100 | read_list(LI, RightDelimiter, Acc) -> 101 | case token(LI) of 102 | RightDelimiter -> 103 | lists:reverse(Acc); 104 | token_dot -> 105 | X = read_no_eof(LI), 106 | case token(LI) of 107 | RightDelimiter -> 108 | lists:reverse(Acc, X) 109 | end; 110 | Token -> 111 | X = read_dispatch_no_eof(LI, Token), 112 | read_list(LI, RightDelimiter, [X | Acc]) 113 | end. 114 | 115 | read_vector(LI, Acc) -> 116 | case token(LI) of 117 | token_rparen -> 118 | es_datum:list_to_vector(lists:reverse(Acc)); 119 | Token -> 120 | X = read_dispatch_no_eof(LI, Token), 121 | read_vector(LI, [X | Acc]) 122 | end. 123 | 124 | %% return the next from the 125 | %% skip "#;" comments 126 | %% TODO: handle "#!{no-,}fold-case" directives here? 127 | 128 | token(LI) -> 129 | case es_lexer:token(LI) of 130 | token_hash_semi -> 131 | read_no_eof(LI), 132 | token(LI); 133 | Token -> 134 | Token 135 | end. 136 | 137 | %% Error Formatting ------------------------------------------------------------ 138 | 139 | read_error(Reason) -> 140 | error({?MODULE, Reason}). 141 | 142 | -spec format_error(term()) -> io_lib:chars(). 143 | format_error(Reason) -> 144 | case Reason of 145 | expected_datum_got_got -> 146 | "expected , got '.'"; 147 | expected_datum_got_rbrack -> 148 | "expected , got ']'"; 149 | expected_datum_got_rparen -> 150 | "expected , got ')'"; 151 | premature_eof -> 152 | "premature EOF"; 153 | _ -> 154 | io_lib:format("~tp", [Reason]) 155 | end. 156 | -------------------------------------------------------------------------------- /src/es_repl.erl: -------------------------------------------------------------------------------- 1 | %%% -*- erlang-indent-level: 2 -*- 2 | %%% 3 | %%% Copyright 2014-2023 Mikael Pettersson 4 | %%% 5 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %%% you may not use this file except in compliance with the License. 7 | %%% You may obtain a copy of the License at 8 | %%% 9 | %%% http://www.apache.org/licenses/LICENSE-2.0 10 | %%% 11 | %%% Unless required by applicable law or agreed to in writing, software 12 | %%% distributed under the License is distributed on an "AS IS" BASIS, 13 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %%% See the License for the specific language governing permissions and 15 | %%% limitations under the License. 16 | %%% 17 | %%% es_repl.erl 18 | %%% 19 | %%% Read-Eval-Print-Loop for ErlScheme. 20 | 21 | -module(es_repl). 22 | 23 | -export([start/0]). 24 | 25 | start() -> 26 | case init() of 27 | false -> false; 28 | LI -> repl(1, LI) 29 | end. 30 | 31 | init() -> 32 | try 33 | io:format("Welcome to ErlScheme version ~ts\n", [?VSN]), 34 | io:format("~ts\n", [erlang:system_info(system_version)]), 35 | es_gloenv:init(), 36 | es_lib_scheme_base_init(), 37 | es_macros_init(), 38 | es_load_init(), 39 | es_lexinput:open_stdin() 40 | catch 41 | Class:Reason:Stack -> 42 | io:format("fatal ~tp during startup: ~ts\n", [Class, es_error:format(Reason)]), 43 | io:format("stack trace:\n~tp\n", [Stack]), 44 | false 45 | end. 46 | 47 | es_lib_scheme_base_init() -> 48 | maps:foreach(fun es_gloenv:enter_var/2, es_lib_scheme_base:env()). 49 | 50 | es_macros_init() -> 51 | lists:foreach( 52 | fun ({Name, Expander}) -> 53 | es_gloenv:enter_expander(Name, Expander) 54 | end, es_macros:initial()). 55 | 56 | es_load_init() -> 57 | io:format("Loading es_init.scm ..."), 58 | PrivDir = code:priv_dir(erlscheme), 59 | ScmPrefix = filename:join(PrivDir, "scm"), 60 | true = filelib:is_dir(ScmPrefix), 61 | erlang:put('es_load_prefix', ScmPrefix), 62 | es_load:load(<<"es-init.scm">>, es_synenv:gloenv()), 63 | io:format(" done\n\n"). 64 | 65 | repl(N, LI) -> 66 | case rep(N, LI) of 67 | ok -> repl(N + 1, LI); 68 | false -> ok 69 | end. 70 | 71 | rep(N, LI) -> 72 | try 73 | io:format("ErlScheme_~tp> ", [N]), 74 | Sexpr = es_read:read(LI), 75 | case es_datum:is_eof_object(Sexpr) of 76 | false -> 77 | erlang:put('es_load_prefix', "."), 78 | {Term, _SynEnv} = es_eval:eval(Sexpr, es_synenv:gloenv()), 79 | es_print:display(Term), 80 | io:format("\n"); 81 | true -> 82 | false 83 | end 84 | catch 85 | Class:Reason:Stack -> 86 | io:format("caught ~tp: ~ts\n", [Class, format_exn(Class, Reason)]), 87 | io:format("stack trace:\n~tp\n", [Stack]) 88 | end. 89 | 90 | format_exn(error, Reason) -> es_error:format(Reason); 91 | format_exn(_, Reason) -> io_lib:format("~tp", [Reason]). 92 | -------------------------------------------------------------------------------- /src/es_synenv.erl: -------------------------------------------------------------------------------- 1 | %%% -*- erlang-indent-level: 2 -*- 2 | %%% 3 | %%% Copyright 2022 Mikael Pettersson 4 | %%% 5 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 6 | %%% you may not use this file except in compliance with the License. 7 | %%% You may obtain a copy of the License at 8 | %%% 9 | %%% http://www.apache.org/licenses/LICENSE-2.0 10 | %%% 11 | %%% Unless required by applicable law or agreed to in writing, software 12 | %%% distributed under the License is distributed on an "AS IS" BASIS, 13 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | %%% See the License for the specific language governing permissions and 15 | %%% limitations under the License. 16 | %%% 17 | %%% es_synenv.erl 18 | %%% 19 | %%% Syntax Environment for ErlScheme. 20 | %%% 21 | %%% - supports a subset of standard environment (es_env API) operations 22 | %%% (empty/0, lookup/2, enter/3) 23 | %%% - supports layering a side-effect free env (es_env) on top of a stateful env 24 | %%% (es_gloenv), this is used for nested scopes in the repl / user environment 25 | 26 | -module(es_synenv). 27 | 28 | %% standard es_env API (subset) 29 | -export([ empty/0 30 | , enter/3 31 | , lookup/2 32 | ]). 33 | 34 | %% layering API 35 | -export([ gloenv/0 36 | , is_gloenv/1 37 | , nested/1 38 | ]). 39 | 40 | -export_type([ synenv/0 41 | ]). 42 | 43 | -define(gloenv, gloenv). 44 | -define(env, env). 45 | -define(nested, nested). 46 | 47 | -type synenv() :: ?gloenv 48 | | {?env, es_env:env()} 49 | | {?nested, es_env:env()}. 50 | 51 | %% API ------------------------------------------------------------------------- 52 | 53 | -spec empty() -> synenv(). 54 | empty() -> {?env, es_env:empty()}. 55 | 56 | %% This rejects entering to es_gloenv. Global bindings are translated to code 57 | %% that updates the global environment as it executes. 58 | -spec enter(synenv(), atom(), term()) -> synenv(). 59 | enter({?env, Env}, Var, Val) -> {?env, es_env:enter(Env, Var, Val)}; 60 | enter({?nested, Env}, Var, Val) -> {?nested, es_env:enter(Env, Var, Val)}. 61 | 62 | %% Lookup an identifier in the syntax environment. Returns: 63 | %% none if the identifier is not bound at all 64 | %% {value, false} if the identifier is bound as a variable 65 | %% {value, Expander} if the identifier is bound as an expander 66 | -spec lookup(synenv(), atom()) -> {value, term()} | none. 67 | lookup(?gloenv, Var) -> lookup_gloenv(Var); 68 | lookup({env, Env}, Var) -> es_env:lookup(Env, Var); 69 | lookup({?nested, Env}, Var) -> 70 | case es_env:lookup(Env, Var) of 71 | {value, _} = Result -> Result; 72 | none -> lookup_gloenv(Var) 73 | end. 74 | 75 | -spec gloenv() -> synenv(). 76 | gloenv() -> ?gloenv. 77 | 78 | -spec is_gloenv(synenv()) -> boolean(). 79 | is_gloenv(?gloenv) -> true; 80 | is_gloenv(_) -> false. 81 | 82 | -spec nested(synenv()) -> synenv(). 83 | nested(?gloenv) -> {?nested, es_env:empty()}; 84 | nested(SynEnv) -> SynEnv. 85 | 86 | %% Internals ------------------------------------------------------------------- 87 | 88 | lookup_gloenv(Var) -> 89 | case es_gloenv:lookup_expander(Var) of 90 | {value, _} = Result -> Result; 91 | none -> 92 | case es_gloenv:is_bound_var(Var) of 93 | true -> {value, false}; 94 | false -> none 95 | end 96 | end. 97 | --------------------------------------------------------------------------------