-
-Copyright (c) 2012, Michael D. Lowis<br>
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without modification,
-are permitted provided that the following conditions are met:
-
-* Redistributions of source code must retain the above copyright notice, this
- list of conditions and the following disclaimer.
-
-* Redistributions in binary form must reproduce the above copyright notice,
- this list of conditions and the following disclaimer in the documentation
- and/or other materials provided with the distribution.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+\r
+Copyright (c) 2012, Michael D. Lowis<br>\r
+All rights reserved.\r
+\r
+Redistribution and use in source and binary forms, with or without modification,\r
+are permitted provided that the following conditions are met:\r
+\r
+* Redistributions of source code must retain the above copyright notice, this\r
+ list of conditions and the following disclaimer.\r
+\r
+* Redistributions in binary form must reproduce the above copyright notice,\r
+ this list of conditions and the following disclaimer in the documentation\r
+ and/or other materials provided with the distribution.\r
+\r
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND\r
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\r
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\r
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE\r
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\r
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR\r
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER\r
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,\r
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\r
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r
-SCLPL
-==============================================
-
- Version: 0.1
- Created By: Michael D. Lowis
- Email: mike@mdlowis.com
-
-About This Project
-----------------------------------------------
-
-License
-----------------------------------------------
-Unless explicitly stated otherwise, all code and documentation contained within
-this repository is released under the BSD 2-Clause license. The text for this
-license can be found in the LICENSE.md file.
-
-Requirements For Building
-----------------------------------------------
-The only external dependencies currently required to build this library are as
-follows:
-
-* Chciken Scheme
-* SConstruct
-
-Build Instructions
-----------------------------------------------
-This project uses SConstruct to build all binaries and libraries. To build the
-software simply execute the following command at the root of the project:
-
- scons
-
-Project Files and Directories
-----------------------------------------------
-
- build/ This is the directory where all output files will be placed.
- source/ The source for the project.
- tests/ Unit test and mock files.
- tools/ Tools required by the build system.
- Doxyfile Doxygen documentation generator configuration.
- LICENSE.md The software license notification.
- premake4.lua A premake4 configuration file for generating build scripts.
- project.vim A VIM script with project specific configurations.
- README.md You're reading this file right now!
-
+SCLPL\r
+==============================================\r
+\r
+ Version: 0.1\r
+ Created By: Michael D. Lowis\r
+ Email: mike@mdlowis.com\r
+\r
+About This Project\r
+----------------------------------------------\r
+\r
+License\r
+----------------------------------------------\r
+Unless explicitly stated otherwise, all code and documentation contained within\r
+this repository is released under the BSD 2-Clause license. The text for this\r
+license can be found in the LICENSE.md file.\r
+\r
+Requirements For Building\r
+----------------------------------------------\r
+The only external dependencies currently required to build this library are as\r
+follows:\r
+\r
+* Chciken Scheme\r
+* SConstruct\r
+\r
+Build Instructions\r
+----------------------------------------------\r
+This project uses SConstruct to build all binaries and libraries. To build the\r
+software simply execute the following command at the root of the project:\r
+\r
+ scons\r
+\r
+Project Files and Directories\r
+----------------------------------------------\r
+\r
+ build/ This is the directory where all output files will be placed.\r
+ source/ The source for the project.\r
+ tests/ Unit test and mock files.\r
+ tools/ Tools required by the build system.\r
+ Doxyfile Doxygen documentation generator configuration.\r
+ LICENSE.md The software license notification.\r
+ premake4.lua A premake4 configuration file for generating build scripts.\r
+ project.vim A VIM script with project specific configurations.\r
+ README.md You're reading this file right now!\r
+\r
#------------------------------------------------------------------------------
# Clang Toolchain Targets
#------------------------------------------------------------------------------
-CLANG_BUILD_DIR = 'build/llvm'
-CLANG_BIN_DIR = 'build/llvm/bin'
-CLANG_BIN_NAME = 'clang'
-CLANG_SRC_DIR = 'source/vendor/llvm-3.4.2'
-CLANG_CMAKE_GENERATOR = ENV['CMAKE_GENERATOR'] || "Unix Makefiles"
-CLANG_CMAKE_OPTS = [ '-DCMAKE_BUILD_TYPE=Release' ]
-CLANG_MAKE_CMD = windows? ? 'nmake' : 'make'
-
-file "#{CLANG_BUILD_DIR}/Makefile" => FileList["#{CLANG_SRC_DIR}/cmake/**/*"] do
- FileUtils.mkdir_p(CLANG_BUILD_DIR)
- FileUtils.cd(CLANG_BUILD_DIR) do
- sh "cmake #{CLANG_CMAKE_OPTS.join} -G\"#{CLANG_CMAKE_GENERATOR}\" ../../#{CLANG_SRC_DIR}"
- end
-end
-
-file "#{CLANG_BIN_DIR}/#{CLANG_BIN_NAME}" => ["#{CLANG_BUILD_DIR}/Makefile"] + FileList["#{CLANG_SRC_DIR}/tools/clang/**/*.c"] do
- FileUtils.cd(CLANG_BUILD_DIR) do
- sh "#{CLANG_MAKE_CMD} clang"
- end
-end
-
-task :clang => ["#{CLANG_BIN_DIR}/#{CLANG_BIN_NAME}"] do
- ENV['PATH'] = "#{CLANG_BIN_DIR}#{windows? ? ';':':'}#{ENV['PATH']}"
-end
+#CLANG_BUILD_DIR = 'build/llvm'
+#CLANG_BIN_DIR = 'build/llvm/bin'
+#CLANG_BIN_NAME = 'clang'
+#CLANG_SRC_DIR = 'source/vendor/llvm-3.4.2'
+#CLANG_CMAKE_GENERATOR = ENV['CMAKE_GENERATOR'] || "Unix Makefiles"
+#CLANG_CMAKE_OPTS = [ '-DCMAKE_BUILD_TYPE=Release' ]
+#CLANG_MAKE_CMD = windows? ? 'nmake' : 'make'
+#
+#file "#{CLANG_BUILD_DIR}/Makefile" => FileList["#{CLANG_SRC_DIR}/cmake/**/*"] do
+# FileUtils.mkdir_p(CLANG_BUILD_DIR)
+# FileUtils.cd(CLANG_BUILD_DIR) do
+# sh "cmake #{CLANG_CMAKE_OPTS.join} -G\"#{CLANG_CMAKE_GENERATOR}\" ../../#{CLANG_SRC_DIR}"
+# end
+#end
+#
+#file "#{CLANG_BIN_DIR}/#{CLANG_BIN_NAME}" => ["#{CLANG_BUILD_DIR}/Makefile"] + FileList["#{CLANG_SRC_DIR}/tools/clang/**/*.c"] do
+# FileUtils.cd(CLANG_BUILD_DIR) do
+# sh "#{CLANG_MAKE_CMD} clang"
+# end
+#end
+#
+#task :clang => ["#{CLANG_BIN_DIR}/#{CLANG_BIN_NAME}"] do
+# ENV['PATH'] = "#{CLANG_BIN_DIR}#{windows? ? ';':':'}#{ENV['PATH']}"
+#end
+task :clang
#------------------------------------------------------------------------------
# Envrionment Definitions
# Define the compiler environment
BaseEnv = Environment.new(echo: :command) do |env|
env.build_dir('source','build/obj/source')
- env['CC'] = 'clang'
- env['CXX'] = 'clang'
- env['LD'] = 'clang'
- env["CFLAGS"] += ['-Wall', '-Wextra' ]#, '-Werror']
+# env['CC'] = 'clang'
+# env['CXX'] = 'clang'
+# env['LD'] = 'clang'
+ env["CFLAGS"] += ['--std=gnu99', '-Wall', '-Wextra' ]#, '-Werror']
end
#------------------------------------------------------------------------------
-#LyX 2.0 created this file. For more info see http://www.lyx.org/
-\lyxformat 413
-\begin_document
-\begin_header
-\textclass article
-\use_default_options true
-\maintain_unincluded_children false
-\language english
-\language_package default
-\inputencoding auto
-\fontencoding global
-\font_roman default
-\font_sans default
-\font_typewriter default
-\font_default_family default
-\use_non_tex_fonts false
-\font_sc false
-\font_osf false
-\font_sf_scale 100
-\font_tt_scale 100
-
-\graphics default
-\default_output_format default
-\output_sync 0
-\bibtex_command default
-\index_command default
-\paperfontsize default
-\spacing single
-\use_hyperref false
-\papersize letterpaper
-\use_geometry true
-\use_amsmath 1
-\use_esint 1
-\use_mhchem 1
-\use_mathdots 1
-\cite_engine basic
-\use_bibtopic false
-\use_indices false
-\paperorientation portrait
-\suppress_date false
-\use_refstyle 1
-\index Index
-\shortcut idx
-\color #008000
-\end_index
-\leftmargin 0.5in
-\topmargin 0.5in
-\rightmargin 0.5in
-\bottommargin 0.5in
-\secnumdepth 3
-\tocdepth 3
-\paragraph_separation indent
-\paragraph_indentation default
-\quotes_language english
-\papercolumns 1
-\papersides 1
-\paperpagestyle default
-\tracking_changes false
-\output_changes false
-\html_math_output 0
-\html_css_as_file 0
-\html_be_strict false
-\end_header
-
-\begin_body
-
-\begin_layout Title
-SCLPL - Simple Concurrent List Processing Language
-\end_layout
-
-\begin_layout Author
-Michael D.
- Lowis
-\end_layout
-
-\begin_layout Date
-08/13/13
-\end_layout
-
-\begin_layout Standard
-\begin_inset Newpage pagebreak
-\end_inset
-
-
-\end_layout
-
-\begin_layout Standard
-\begin_inset CommandInset toc
-LatexCommand tableofcontents
-
-\end_inset
-
-
-\end_layout
-
-\begin_layout Standard
-\begin_inset Newpage pagebreak
-\end_inset
-
-
-\end_layout
-
-\begin_layout Section
-Introduction
-\end_layout
-
-\begin_layout Subsection
-Rationale
-\end_layout
-
-\begin_layout Subsection
-Historical Influences
-\end_layout
-
-\begin_layout Standard
-\begin_inset Newpage pagebreak
-\end_inset
-
-
-\end_layout
-
-\begin_layout Section
-Conventions and Semantics
-\end_layout
-
-\begin_layout Subsection
-Syntax
-\end_layout
-
-\begin_layout Subsection
-Whitepspace and Comments
-\end_layout
-
-\begin_layout Subsection
-Identifiers and Naming Conventions
-\end_layout
-
-\begin_layout Standard
-\begin_inset Newpage pagebreak
-\end_inset
-
-
-\end_layout
-
-\begin_layout Section
-Core Concepts
-\end_layout
-
-\begin_layout Subsection
-Variables and Syntactic Keywords
-\end_layout
-
-\begin_layout Subsection
-External Representations
-\end_layout
-
-\begin_layout Subsection
-Data Storage Model
-\end_layout
-
-\begin_layout Subsection
-Proper Tail Recursion
-\end_layout
-
-\begin_layout Subsection
-Immutability
-\end_layout
-
-\begin_layout Subsection
-Concurrency Model
-\end_layout
-
-\begin_layout Standard
-\begin_inset Newpage pagebreak
-\end_inset
-
-
-\end_layout
-
-\begin_layout Section
-Language Semantics
-\end_layout
-
-\begin_layout Subsection
-Expressions
-\end_layout
-
-\begin_layout Subsubsection
-Primitive Expressions
-\end_layout
-
-\begin_layout Subsubsection
-Literal Expressions
-\end_layout
-
-\begin_layout Subsubsection
-Procedure Calls
-\end_layout
-
-\begin_layout Subsubsection
-Procedures
-\end_layout
-
-\begin_layout Subsubsection
-Conditionals
-\end_layout
-
-\begin_layout Subsubsection
-Assignments
-\end_layout
-
-\begin_layout Subsection
-Definitions
-\end_layout
-
-\begin_layout Subsection
-Syntactic Extensions
-\end_layout
-
-\begin_layout Standard
-\begin_inset Newpage pagebreak
-\end_inset
-
-
-\end_layout
-
-\begin_layout Section
-Datatypes and the Type System
-\end_layout
-
-\begin_layout Subsection
-Atomic Types
-\end_layout
-
-\begin_layout Subsubsection
-Booleans
-\end_layout
-
-\begin_layout Subsubsection
-Characters
-\end_layout
-
-\begin_layout Subsubsection
-Numbers
-\end_layout
-
-\begin_layout Subsection
-Aggregate Types
-\end_layout
-
-\begin_layout Subsubsection
-Pairs and Lists
-\end_layout
-
-\begin_layout Subsubsection
-Strings
-\end_layout
-
-\begin_layout Subsubsection
-Vectors
-\end_layout
-
-\begin_layout Subsubsection
-Bytevectors
-\end_layout
-
-\begin_layout Subsubsection
-Maps
-\end_layout
-
-\begin_layout Subsubsection
-Records
-\end_layout
-
-\begin_layout Subsubsection
-Unions
-\end_layout
-
-\begin_layout Subsection
-Procedures
-\end_layout
-
-\begin_layout Subsection
-Ports
-\end_layout
-
-\begin_layout Standard
-\begin_inset Newpage pagebreak
-\end_inset
-
-
-\end_layout
-
-\begin_layout Section
-Input and Output
-\end_layout
-
-\begin_layout Standard
-\begin_inset Newpage pagebreak
-\end_inset
-
-
-\end_layout
-
-\begin_layout Section
-Concurrency
-\end_layout
-
-\begin_layout Standard
-\begin_inset Newpage pagebreak
-\end_inset
-
-
-\end_layout
-
-\begin_layout Section
-Program Structure
-\end_layout
-
-\begin_layout Subsection
-Programs
-\end_layout
-
-\begin_layout Subsection
-Import Statements
-\end_layout
-
-\begin_layout Subsection
-Definitions
-\end_layout
-
-\begin_layout Subsection
-Libraries
-\end_layout
-
-\begin_layout Standard
-\begin_inset Newpage pagebreak
-\end_inset
-
-
-\end_layout
-
-\begin_layout Section
-Standard Library
-\end_layout
-
-\begin_layout Subsection
-Procedures
-\end_layout
-
-\begin_layout Subsection
-Language Extensions
-\end_layout
-
-\begin_layout Subsubsection
-Conditional forms
-\end_layout
-
-\begin_layout Subsubsection
-Binding Forms
-\end_layout
-
-\begin_layout Standard
-\begin_inset Newpage pagebreak
-\end_inset
-
-
-\end_layout
-
-\begin_layout Section
-\start_of_appendix
-Formal Syntax
-\end_layout
-
-\begin_layout Section
-References
-\end_layout
-
-\end_body
-\end_document
+#LyX 2.0 created this file. For more info see http://www.lyx.org/\r
+\lyxformat 413\r
+\begin_document\r
+\begin_header\r
+\textclass article\r
+\use_default_options true\r
+\maintain_unincluded_children false\r
+\language english\r
+\language_package default\r
+\inputencoding auto\r
+\fontencoding global\r
+\font_roman default\r
+\font_sans default\r
+\font_typewriter default\r
+\font_default_family default\r
+\use_non_tex_fonts false\r
+\font_sc false\r
+\font_osf false\r
+\font_sf_scale 100\r
+\font_tt_scale 100\r
+\r
+\graphics default\r
+\default_output_format default\r
+\output_sync 0\r
+\bibtex_command default\r
+\index_command default\r
+\paperfontsize default\r
+\spacing single\r
+\use_hyperref false\r
+\papersize letterpaper\r
+\use_geometry true\r
+\use_amsmath 1\r
+\use_esint 1\r
+\use_mhchem 1\r
+\use_mathdots 1\r
+\cite_engine basic\r
+\use_bibtopic false\r
+\use_indices false\r
+\paperorientation portrait\r
+\suppress_date false\r
+\use_refstyle 1\r
+\index Index\r
+\shortcut idx\r
+\color #008000\r
+\end_index\r
+\leftmargin 0.5in\r
+\topmargin 0.5in\r
+\rightmargin 0.5in\r
+\bottommargin 0.5in\r
+\secnumdepth 3\r
+\tocdepth 3\r
+\paragraph_separation indent\r
+\paragraph_indentation default\r
+\quotes_language english\r
+\papercolumns 1\r
+\papersides 1\r
+\paperpagestyle default\r
+\tracking_changes false\r
+\output_changes false\r
+\html_math_output 0\r
+\html_css_as_file 0\r
+\html_be_strict false\r
+\end_header\r
+\r
+\begin_body\r
+\r
+\begin_layout Title\r
+SCLPL - Simple Concurrent List Processing Language\r
+\end_layout\r
+\r
+\begin_layout Author\r
+Michael D.\r
+ Lowis\r
+\end_layout\r
+\r
+\begin_layout Date\r
+08/13/13\r
+\end_layout\r
+\r
+\begin_layout Standard\r
+\begin_inset Newpage pagebreak\r
+\end_inset\r
+\r
+\r
+\end_layout\r
+\r
+\begin_layout Standard\r
+\begin_inset CommandInset toc\r
+LatexCommand tableofcontents\r
+\r
+\end_inset\r
+\r
+\r
+\end_layout\r
+\r
+\begin_layout Standard\r
+\begin_inset Newpage pagebreak\r
+\end_inset\r
+\r
+\r
+\end_layout\r
+\r
+\begin_layout Section\r
+Introduction\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Rationale\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Historical Influences\r
+\end_layout\r
+\r
+\begin_layout Standard\r
+\begin_inset Newpage pagebreak\r
+\end_inset\r
+\r
+\r
+\end_layout\r
+\r
+\begin_layout Section\r
+Conventions and Semantics\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Syntax\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Whitepspace and Comments\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Identifiers and Naming Conventions\r
+\end_layout\r
+\r
+\begin_layout Standard\r
+\begin_inset Newpage pagebreak\r
+\end_inset\r
+\r
+\r
+\end_layout\r
+\r
+\begin_layout Section\r
+Core Concepts\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Variables and Syntactic Keywords\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+External Representations\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Data Storage Model\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Proper Tail Recursion\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Immutability\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Concurrency Model\r
+\end_layout\r
+\r
+\begin_layout Standard\r
+\begin_inset Newpage pagebreak\r
+\end_inset\r
+\r
+\r
+\end_layout\r
+\r
+\begin_layout Section\r
+Language Semantics\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Expressions\r
+\end_layout\r
+\r
+\begin_layout Subsubsection\r
+Primitive Expressions\r
+\end_layout\r
+\r
+\begin_layout Subsubsection\r
+Literal Expressions\r
+\end_layout\r
+\r
+\begin_layout Subsubsection\r
+Procedure Calls\r
+\end_layout\r
+\r
+\begin_layout Subsubsection\r
+Procedures\r
+\end_layout\r
+\r
+\begin_layout Subsubsection\r
+Conditionals\r
+\end_layout\r
+\r
+\begin_layout Subsubsection\r
+Assignments\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Definitions\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Syntactic Extensions\r
+\end_layout\r
+\r
+\begin_layout Standard\r
+\begin_inset Newpage pagebreak\r
+\end_inset\r
+\r
+\r
+\end_layout\r
+\r
+\begin_layout Section\r
+Datatypes and the Type System\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Atomic Types\r
+\end_layout\r
+\r
+\begin_layout Subsubsection\r
+Booleans\r
+\end_layout\r
+\r
+\begin_layout Subsubsection\r
+Characters\r
+\end_layout\r
+\r
+\begin_layout Subsubsection\r
+Numbers\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Aggregate Types\r
+\end_layout\r
+\r
+\begin_layout Subsubsection\r
+Pairs and Lists\r
+\end_layout\r
+\r
+\begin_layout Subsubsection\r
+Strings\r
+\end_layout\r
+\r
+\begin_layout Subsubsection\r
+Vectors\r
+\end_layout\r
+\r
+\begin_layout Subsubsection\r
+Bytevectors\r
+\end_layout\r
+\r
+\begin_layout Subsubsection\r
+Maps\r
+\end_layout\r
+\r
+\begin_layout Subsubsection\r
+Records\r
+\end_layout\r
+\r
+\begin_layout Subsubsection\r
+Unions\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Procedures\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Ports\r
+\end_layout\r
+\r
+\begin_layout Standard\r
+\begin_inset Newpage pagebreak\r
+\end_inset\r
+\r
+\r
+\end_layout\r
+\r
+\begin_layout Section\r
+Input and Output\r
+\end_layout\r
+\r
+\begin_layout Standard\r
+\begin_inset Newpage pagebreak\r
+\end_inset\r
+\r
+\r
+\end_layout\r
+\r
+\begin_layout Section\r
+Concurrency\r
+\end_layout\r
+\r
+\begin_layout Standard\r
+\begin_inset Newpage pagebreak\r
+\end_inset\r
+\r
+\r
+\end_layout\r
+\r
+\begin_layout Section\r
+Program Structure\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Programs\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Import Statements\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Definitions\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Libraries\r
+\end_layout\r
+\r
+\begin_layout Standard\r
+\begin_inset Newpage pagebreak\r
+\end_inset\r
+\r
+\r
+\end_layout\r
+\r
+\begin_layout Section\r
+Standard Library\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Procedures\r
+\end_layout\r
+\r
+\begin_layout Subsection\r
+Language Extensions\r
+\end_layout\r
+\r
+\begin_layout Subsubsection\r
+Conditional forms\r
+\end_layout\r
+\r
+\begin_layout Subsubsection\r
+Binding Forms\r
+\end_layout\r
+\r
+\begin_layout Standard\r
+\begin_inset Newpage pagebreak\r
+\end_inset\r
+\r
+\r
+\end_layout\r
+\r
+\begin_layout Section\r
+\start_of_appendix\r
+Formal Syntax\r
+\end_layout\r
+\r
+\begin_layout Section\r
+References\r
+\end_layout\r
+\r
+\end_body\r
+\end_document\r
-
-(define-syntax def-test
- (syntax-rules ()
- ((_ desc body ...)
- (register-test!
- (cons desc
- (lambda () body ...))))))
-
-(define-syntax check-error
- (syntax-rules ()
- ((_ expect expr)
- (let ((prev error))
- (define result
- (call/cc
- (lambda (err)
- (set! error err)
- expr)))
- (set! error prev)
- (equal? expect result)))))
-
-(define-syntax check-exception
- (syntax-rules ()
- ((_ expect expr)
- (equal? expect
- (call/cc
- (lambda (cont)
- (with-exception-handler
- (lambda (x) (cont x))
- (lambda () expr))))))))
-
-(define-syntax check-parse-error
- (syntax-rules ()
- ((_ expect expr)
- (begin
- (define etyp-matches? #f)
- (define emsg
- (with-output-to-string
- (lambda ()
- (set! etyp-matches?
- (equal? 'parse-error
- (call/cc
- (lambda (cont)
- (with-exception-handler
- (lambda (x) (cont x))
- (lambda () expr)))))))))
- ;(print "----")
- ;(print etyp-matches? " " (equal? emsg expect))
- ;(print "\"" emsg "\"\n")
- ;(print "\"" expect "\"\n")
- ;(print "----")
- (and etyp-matches? (equal? emsg expect))))))
-
+\r
+(define-syntax def-test\r
+ (syntax-rules ()\r
+ ((_ desc body ...)\r
+ (register-test!\r
+ (cons desc\r
+ (lambda () body ...))))))\r
+\r
+(define-syntax check-error\r
+ (syntax-rules ()\r
+ ((_ expect expr)\r
+ (let ((prev error))\r
+ (define result\r
+ (call/cc\r
+ (lambda (err)\r
+ (set! error err)\r
+ expr)))\r
+ (set! error prev)\r
+ (equal? expect result)))))\r
+\r
+(define-syntax check-exception\r
+ (syntax-rules ()\r
+ ((_ expect expr)\r
+ (equal? expect\r
+ (call/cc\r
+ (lambda (cont)\r
+ (with-exception-handler\r
+ (lambda (x) (cont x))\r
+ (lambda () expr))))))))\r
+\r
+(define-syntax check-parse-error\r
+ (syntax-rules ()\r
+ ((_ expect expr)\r
+ (begin\r
+ (define etyp-matches? #f)\r
+ (define emsg\r
+ (with-output-to-string\r
+ (lambda ()\r
+ (set! etyp-matches?\r
+ (equal? 'parse-error\r
+ (call/cc\r
+ (lambda (cont)\r
+ (with-exception-handler\r
+ (lambda (x) (cont x))\r
+ (lambda () expr)))))))))\r
+ ;(print "----")\r
+ ;(print etyp-matches? " " (equal? emsg expect))\r
+ ;(print "\"" emsg "\"\n")\r
+ ;(print "\"" expect "\"\n")\r
+ ;(print "----")\r
+ (and etyp-matches? (equal? emsg expect))))))\r
+\r
-/**
- @file libsof.h
- @brief TODO: Describe this file
- $Revision$
- $HeadURL$
- */
-#ifndef LIBSOF_H
-#define LIBSOF_H
-
-#include "sof.h"
-#include <stdbool.h>
-#include <stdint.h>
-#include <stddef.h>
-
-typedef struct {
- sof_header_t* header;
- sof_st_entry_t* symbols;
- char* strings;
- uint8_t* data;
- uint32_t* code;
-} sof_file_t;
-
-sof_file_t* libsof_read_obj(char const* fname);
-bool libsof_write_obj(sof_file_t* obj, char const* fname);
-sof_file_t* libsof_new_obj(void);
-void libsof_free_obj(sof_file_t* obj);
-size_t libsof_get_symbol_table_size(sof_file_t* obj);
-size_t libsof_get_string_table_size(sof_file_t* obj);
-size_t libsof_get_data_segment_size(sof_file_t* obj);
-size_t libsof_get_code_segment_size(sof_file_t* obj);
-size_t libsof_get_num_symbols(sof_file_t* obj);
-size_t libsof_add_symbol(sof_file_t* obj, const char* name, uint32_t value, uint32_t size, uint32_t info);
-size_t libsof_add_st_entry(sof_file_t* obj, uint32_t name, uint32_t value, uint32_t size, uint32_t info);
-sof_st_entry_t const* libsof_get_st_entry(sof_file_t* obj, size_t offset);
-size_t libsof_add_string(sof_file_t* obj, char const* name);
-char const* libsof_get_string(sof_file_t* obj, size_t offset);
-size_t libsof_add_data(sof_file_t* obj, uint8_t const* data, size_t length);
-uint8_t const* libsof_get_data(sof_file_t* obj, size_t offset);
-size_t libsof_add_code(sof_file_t* obj, uint32_t const* code, size_t length);
-uint32_t const* libsof_get_code(sof_file_t* obj, size_t offset);
-
-#endif /* LIBSOF_H */
+/**\r
+ @file libsof.h\r
+ @brief TODO: Describe this file\r
+ $Revision$\r
+ $HeadURL$\r
+ */\r
+#ifndef LIBSOF_H\r
+#define LIBSOF_H\r
+\r
+#include "sof.h"\r
+#include <stdbool.h>\r
+#include <stdint.h>\r
+#include <stddef.h>\r
+\r
+typedef struct {\r
+ sof_header_t* header;\r
+ sof_st_entry_t* symbols;\r
+ char* strings;\r
+ uint8_t* data;\r
+ uint32_t* code;\r
+} sof_file_t;\r
+\r
+sof_file_t* libsof_read_obj(char const* fname);\r
+bool libsof_write_obj(sof_file_t* obj, char const* fname);\r
+sof_file_t* libsof_new_obj(void);\r
+void libsof_free_obj(sof_file_t* obj);\r
+size_t libsof_get_symbol_table_size(sof_file_t* obj);\r
+size_t libsof_get_string_table_size(sof_file_t* obj);\r
+size_t libsof_get_data_segment_size(sof_file_t* obj);\r
+size_t libsof_get_code_segment_size(sof_file_t* obj);\r
+size_t libsof_get_num_symbols(sof_file_t* obj);\r
+size_t libsof_add_symbol(sof_file_t* obj, const char* name, uint32_t value, uint32_t size, uint32_t info);\r
+size_t libsof_add_st_entry(sof_file_t* obj, uint32_t name, uint32_t value, uint32_t size, uint32_t info);\r
+sof_st_entry_t const* libsof_get_st_entry(sof_file_t* obj, size_t offset);\r
+size_t libsof_add_string(sof_file_t* obj, char const* name);\r
+char const* libsof_get_string(sof_file_t* obj, size_t offset);\r
+size_t libsof_add_data(sof_file_t* obj, uint8_t const* data, size_t length);\r
+uint8_t const* libsof_get_data(sof_file_t* obj, size_t offset);\r
+size_t libsof_add_code(sof_file_t* obj, uint32_t const* code, size_t length);\r
+uint32_t const* libsof_get_code(sof_file_t* obj, size_t offset);\r
+\r
+#endif /* LIBSOF_H */\r
-/**
- @file sof.h
- @brief TODO: Describe this file
- $Revision$
- $HeadURL$
- */
-#ifndef SOF_H
-#define SOF_H
-
-#include <stdint.h>
-
-/*
- SCLPL Object File Layout
-
- -----------------------
- | SOF Header |
- -----------------------
- | Symbol Table |
- -----------------------
- | Symbol String Table |
- -----------------------
- | Data Segment |
- -----------------------
- | Code Segment |
- -----------------------
-
-*/
-
-/* Macro for generating a 32-bit date code based on year, month, and day */
-#define DATE_CODE(year,month,day) (year << 16) | (month << 8) | (day)
-
-/* The version of the SOF format supported by this library represented as a
- * 32-bit date code */
-#define SOF_VERSION DATE_CODE(2013,9,10)
-
-/* Definition of the SOF file header. The header appears at the beginning of any
- * SOF file and contains information about the SOF version of the file and the
- * sizes of each section in the file. */
-typedef struct {
- /* 32-bit date code representing the version of SOF format used by the file */
- uint32_t version;
- /* This size of the symbol table in bytes. A value of 0 indicates that the
- * symbol table segment has been omitted from the file */
- uint32_t sym_tbl_sz;
- /* The size of the symbol string table segment in bytes. Each entry in the
- * symbol string table consists of an array of bytes terminated by a NULL
- * byte (0x00). */
- uint32_t sym_str_tbl_sz;
- /* The size in bytes of the constant data segment. This segment contains
- * constant data that is referenced by the code segment. */
- uint32_t data_sz;
- /* The size of the code segment in bytes. Each instruction is represented by
- * a 32-bit value and represents a single action to be performed by the
- * bytecode interpreter. */
- uint32_t code_sz;
-} sof_header_t;
-
-/* Definition of the SOF symbol table entry */
-typedef struct {
- /* Offset into the string section where the string for the symbol is
- * located */
- uint32_t name;
- uint32_t value;
- uint32_t size;
- uint32_t info;
-} sof_st_entry_t;
-
-#endif /* SOF_H */
+/**\r
+ @file sof.h\r
+ @brief TODO: Describe this file\r
+ $Revision$\r
+ $HeadURL$\r
+ */\r
+#ifndef SOF_H\r
+#define SOF_H\r
+\r
+#include <stdint.h>\r
+\r
+/*\r
+ SCLPL Object File Layout\r
+\r
+ -----------------------\r
+ | SOF Header |\r
+ -----------------------\r
+ | Symbol Table |\r
+ -----------------------\r
+ | Symbol String Table |\r
+ -----------------------\r
+ | Data Segment |\r
+ -----------------------\r
+ | Code Segment |\r
+ -----------------------\r
+\r
+*/\r
+\r
+/* Macro for generating a 32-bit date code based on year, month, and day */\r
+#define DATE_CODE(year,month,day) (year << 16) | (month << 8) | (day)\r
+\r
+/* The version of the SOF format supported by this library represented as a\r
+ * 32-bit date code */\r
+#define SOF_VERSION DATE_CODE(2013,9,10)\r
+\r
+/* Definition of the SOF file header. The header appears at the beginning of any\r
+ * SOF file and contains information about the SOF version of the file and the\r
+ * sizes of each section in the file. */\r
+typedef struct {\r
+ /* 32-bit date code representing the version of SOF format used by the file */\r
+ uint32_t version;\r
+ /* This size of the symbol table in bytes. A value of 0 indicates that the\r
+ * symbol table segment has been omitted from the file */\r
+ uint32_t sym_tbl_sz;\r
+ /* The size of the symbol string table segment in bytes. Each entry in the\r
+ * symbol string table consists of an array of bytes terminated by a NULL\r
+ * byte (0x00). */\r
+ uint32_t sym_str_tbl_sz;\r
+ /* The size in bytes of the constant data segment. This segment contains\r
+ * constant data that is referenced by the code segment. */\r
+ uint32_t data_sz;\r
+ /* The size of the code segment in bytes. Each instruction is represented by\r
+ * a 32-bit value and represents a single action to be performed by the\r
+ * bytecode interpreter. */\r
+ uint32_t code_sz;\r
+} sof_header_t;\r
+\r
+/* Definition of the SOF symbol table entry */\r
+typedef struct {\r
+ /* Offset into the string section where the string for the symbol is\r
+ * located */\r
+ uint32_t name;\r
+ uint32_t value;\r
+ uint32_t size;\r
+ uint32_t info;\r
+} sof_st_entry_t;\r
+\r
+#endif /* SOF_H */\r
-#include <stdio.h>
-#include <libsof.h>
-
-#define GET_VERSION_YEAR(version) (version >> 16)
-#define GET_VERSION_MONTH(version) ((version >> 8) & 0xFF)
-#define GET_VERSION_DAY(version) (version & 0xFF)
-
-void print_obj(sof_file_t* obj);
-void print_hex(char const* header, uint8_t const* buffer, size_t length);
-
-void create_obj_file(char* fname)
-{
- sof_file_t* obj = libsof_new_obj();
-
- libsof_add_symbol(obj, "foo", 0x11223344, 0x22222222, 0x33333333);
-
- uint8_t data[] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 };
- libsof_add_data(obj, data, 16);
- libsof_add_data(obj, data, 16);
- libsof_add_data(obj, data, 16);
-
- uint32_t code[] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 };
- libsof_add_code(obj, code, 16);
- libsof_add_code(obj, code, 16);
- libsof_add_code(obj, code, 16);
-
- libsof_write_obj(obj,fname);
- libsof_free_obj(obj);
-}
-
-void print_obj(sof_file_t* obj)
-{
- /* print header metadata */
- printf("SOF Version:\t%#x (%d/%d/%d)\n",
- obj->header->version,
- GET_VERSION_DAY(obj->header->version),
- GET_VERSION_MONTH(obj->header->version),
- GET_VERSION_YEAR(obj->header->version));
- printf("Symbol Table:\t%d bytes\n", obj->header->sym_tbl_sz);
- printf("String Table:\t%d bytes\n", obj->header->sym_str_tbl_sz);
- printf("Data Size:\t%d bytes\n", obj->header->data_sz);
- printf("Code Size:\t%d bytes\n", obj->header->code_sz);
-
- /* print symbol table */
- printf("\nIndex\tValue\t\tSize\t\tInfo\t\tName\n");
- for(size_t i = 0; i < libsof_get_num_symbols(obj); i++)
- {
- sof_st_entry_t const* symbol = libsof_get_st_entry(obj,i);
- char const* name = libsof_get_string(obj,symbol->name);
- printf("[%d]\t%#x\t%#x\t%#x\t%s\n", i, symbol->value, symbol->size, symbol->info, name);
- }
-
- /* print segments as hex listing */
- print_hex("Data Segment", (uint8_t const *)libsof_get_data(obj,0), libsof_get_data_segment_size(obj));
- print_hex("Code Segment", (uint8_t const *)libsof_get_code(obj,0), libsof_get_code_segment_size(obj));
-}
-
-void print_hex(char const* header, uint8_t const* buffer, size_t length)
-{
- printf("\n\n%s\n",header);
- printf("----------------------------------------------------------");
- for(size_t i = 0; i < length; i++)
- {
- if ((i%16) == 0)
- {
- printf("\n0x%04x\t", i);
- }
- else if ((i%4) == 0)
- {
- printf(" ");
- }
- printf("%02x ", buffer[i]);
- }
-}
-
-int main(int argc, char** argv)
-{
- if (argc == 1)
- {
- printf("%s: no input files.\n", argv[0]);
- }
- else
- {
- create_obj_file(argv[1]);
- for (uint32_t i = 1; i < argc; i++)
- {
- printf("\nFilename:\t%s\n", argv[i]);
- sof_file_t* obj = libsof_read_obj(argv[i]);
- print_obj(obj);
- libsof_free_obj(obj);
- }
- }
-}
-
+#include <stdio.h>\r
+#include <libsof.h>\r
+\r
+#define GET_VERSION_YEAR(version) (version >> 16)\r
+#define GET_VERSION_MONTH(version) ((version >> 8) & 0xFF)\r
+#define GET_VERSION_DAY(version) (version & 0xFF)\r
+\r
+void print_obj(sof_file_t* obj);\r
+void print_hex(char const* header, uint8_t const* buffer, size_t length);\r
+\r
+void create_obj_file(char* fname)\r
+{\r
+ sof_file_t* obj = libsof_new_obj();\r
+\r
+ libsof_add_symbol(obj, "foo", 0x11223344, 0x22222222, 0x33333333);\r
+\r
+ uint8_t data[] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 };\r
+ libsof_add_data(obj, data, 16);\r
+ libsof_add_data(obj, data, 16);\r
+ libsof_add_data(obj, data, 16);\r
+\r
+ uint32_t code[] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 };\r
+ libsof_add_code(obj, code, 16);\r
+ libsof_add_code(obj, code, 16);\r
+ libsof_add_code(obj, code, 16);\r
+\r
+ libsof_write_obj(obj,fname);\r
+ libsof_free_obj(obj);\r
+}\r
+\r
+void print_obj(sof_file_t* obj)\r
+{\r
+ /* print header metadata */\r
+ printf("SOF Version:\t%#x (%d/%d/%d)\n",\r
+ obj->header->version,\r
+ GET_VERSION_DAY(obj->header->version),\r
+ GET_VERSION_MONTH(obj->header->version),\r
+ GET_VERSION_YEAR(obj->header->version));\r
+ printf("Symbol Table:\t%d bytes\n", obj->header->sym_tbl_sz);\r
+ printf("String Table:\t%d bytes\n", obj->header->sym_str_tbl_sz);\r
+ printf("Data Size:\t%d bytes\n", obj->header->data_sz);\r
+ printf("Code Size:\t%d bytes\n", obj->header->code_sz);\r
+\r
+ /* print symbol table */\r
+ printf("\nIndex\tValue\t\tSize\t\tInfo\t\tName\n");\r
+ for(size_t i = 0; i < libsof_get_num_symbols(obj); i++)\r
+ {\r
+ sof_st_entry_t const* symbol = libsof_get_st_entry(obj,i);\r
+ char const* name = libsof_get_string(obj,symbol->name);\r
+ printf("[%d]\t%#x\t%#x\t%#x\t%s\n", i, symbol->value, symbol->size, symbol->info, name);\r
+ }\r
+\r
+ /* print segments as hex listing */\r
+ print_hex("Data Segment", (uint8_t const *)libsof_get_data(obj,0), libsof_get_data_segment_size(obj));\r
+ print_hex("Code Segment", (uint8_t const *)libsof_get_code(obj,0), libsof_get_code_segment_size(obj));\r
+}\r
+\r
+void print_hex(char const* header, uint8_t const* buffer, size_t length)\r
+{\r
+ printf("\n\n%s\n",header);\r
+ printf("----------------------------------------------------------");\r
+ for(size_t i = 0; i < length; i++)\r
+ {\r
+ if ((i%16) == 0)\r
+ {\r
+ printf("\n0x%04x\t", i);\r
+ }\r
+ else if ((i%4) == 0)\r
+ {\r
+ printf(" ");\r
+ }\r
+ printf("%02x ", buffer[i]);\r
+ }\r
+}\r
+\r
+int main(int argc, char** argv)\r
+{\r
+ if (argc == 1)\r
+ {\r
+ printf("%s: no input files.\n", argv[0]);\r
+ }\r
+ else\r
+ {\r
+ create_obj_file(argv[1]);\r
+ for (uint32_t i = 1; i < argc; i++)\r
+ {\r
+ printf("\nFilename:\t%s\n", argv[i]);\r
+ sof_file_t* obj = libsof_read_obj(argv[i]);\r
+ print_obj(obj);\r
+ libsof_free_obj(obj);\r
+ }\r
+ }\r
+}\r
+\r
-(declare (uses library))
-
-(define usage
-"\nUsage: slas <INFILE> <OUTFILE>
-
-Assemble <INFILE> to SCLPL bytecode and write the result to <OUTFILE>.\n")
-
-; Control Routines
-;------------------------------------------------------------------------------
-(define (assemble-file infile outfile)
- (define iprt (open-input-file infile))
- (define oprt (open-output-file outfile))
- (generate-bytecode iprt oprt))
-
-(define (generate-bytecode iprt oprt) '())
-
-; Main routine
-;------------------------------------------------------------------------------
-(if (= 2 (length (command-line-arguments)))
- (apply assemble-file (command-line-arguments))
- (print usage))
-(exit)
+(declare (uses library))\r
+\r
+(define usage\r
+"\nUsage: slas <INFILE> <OUTFILE>\r
+\r
+Assemble <INFILE> to SCLPL bytecode and write the result to <OUTFILE>.\n")\r
+\r
+; Control Routines\r
+;------------------------------------------------------------------------------\r
+(define (assemble-file infile outfile)\r
+ (define iprt (open-input-file infile))\r
+ (define oprt (open-output-file outfile))\r
+ (generate-bytecode iprt oprt))\r
+\r
+(define (generate-bytecode iprt oprt) '())\r
+\r
+; Main routine\r
+;------------------------------------------------------------------------------\r
+(if (= 2 (length (command-line-arguments)))\r
+ (apply assemble-file (command-line-arguments))\r
+ (print usage))\r
+(exit)\r
-(declare (uses posix))
-(use posix)
-
-; Task Definition and Interaction
-;------------------------------------------------------------------------------
-(define-record task name desc active? deps actions)
-
-(define top-level-tasks '())
-
-(define current-namespace
- (make-parameter '()))
-
-(define current-desc
- (make-parameter #f))
-
-(define (task-register! task)
- (define name (task-name task))
- (define entry (assoc name top-level-tasks))
- (if (not entry)
- (set! top-level-tasks (cons (cons name task) top-level-tasks))
- (set-cdr! entry (task-merge (cdr entry) task))))
-
-(define (task-merge task1 task2)
- (make-task (task-name task1) (task-desc task1) #t
- (append (task-deps task1)
- (task-deps task2))
- (append (task-actions task1)
- (task-actions task2))))
-
-(define (task-lookup name)
- (define entry (assoc name top-level-tasks))
- (if (not entry)
- (error (string-append "No such task: " name))
- (cdr entry)))
-
-(define (task-invoke! name)
- (define task (task-lookup name))
- (if (task-active? task)
- (begin (task-active?-set! task #f)
- (map task-invoke! (task-deps task))
- (map (lambda (fn) (fn)) (task-actions task)))))
-
-(define (gen-task-name name)
- (define namespace (current-namespace))
- (if (not (null? namespace))
- (string-append namespace ":" name)
- name))
-
-; Environment Functions
-;------------------------------------------------------------------------------
-(define-record builder defaults action)
-
-(define (get-sys-env)
- (get-environment-variables))
-
-(define (set-sys-env! newenv)
- (clear-sys-env!)
- (map (lambda (p) (setenv (car p) (cdr p)))
- newenv))
-
-(define (clear-sys-env!)
- (map (lambda (p) (unsetenv (car p)))
- (get-environment-variables)))
-
-(define current-env
- (let [(curr-env (get-sys-env))]
- (lambda args
- (if (> (length args) 0)
- (begin (set-sys-env! (car args))
- (set! curr-env (car args)))
- curr-env))))
-
-(define (env-clone env . vars)
- (define newenv (map (lambda (p) (cons (car p) (cdr p))) env))
- (define newvals '())
- (map (lambda (e)
- (define entry (assoc (car e) newenv))
- (if entry
- (set-cdr! entry (cdr e))
- (set! newvals (cons e newvals))))
- vars)
- (append newvals newenv))
-
-(define (env-get env key)
- (define entry (assoc key env))
- (if entry (cdr entry) #f))
-
-(define (env-set env key value)
- (cons (cons key value)
- (env-unset env key)))
-
-(define (env-unset env key)
- (cond [(null? env) '()]
- [(string=? (caar env) key) (env-unset (cdr env) key)]
- [else (cons (car env) (env-unset (cdr env) key))]))
-
-(define (env-extend env . vars)
- (foldl (lambda (env p)
- (env-set env (car p) (cdr p)))
- env
- vars))
-
-(define (env-substitute env str)
- (list->string (sub-vars (string->list str) env)))
-
-(define (env-prepend-path env path)
- '())
-
-(define (env-append-path env path)
- '())
-
-(define (env-add-builders env . builders)
- '())
-
-; Builders
-;------------------------------------------------------------------------------
-
-
-; System Utility Functions
-;------------------------------------------------------------------------------
-(define verbose #f)
-
-(define (build type . args)
- (define bldr (assoc type (assoc "builders" (current-env))))
- (define bldr-env (env-merge (builder-defaults bldr) (current-env)))
- (apply (builder-action bldr) (cons bldr-env args)))
-
-(define (run . args)
- (define cmd (env-substitute (current-env) (string-join args " ")))
- (if verbose (print cmd))
- (if (not (= 0 (system cmd)))
- (fail-build cmd)))
-
-(define (fail-build cmd)
- (print "Error: Command returned a non-zero status")
- (exit 1))
-
-; Directories
-(define cd change-directory)
-(define curdir current-directory)
-(define mkdir create-directory)
-(define rmdir delete-directory)
-(define lsdir directory)
-(define dir? directory?)
-; glob
-
-; Files
-(define cp '())
-(define mv '())
-(define rm delete-file)
-
-; String Templating
-;------------------------------------------------------------------------------
-(define (sub-vars chlst env)
- (cond [(null? chlst) '()]
- [(char=? #\$ (car chlst)) (let [(pair (replace-var (cdr chlst) env))]
- (append (string->list (car pair))
- (sub-vars (cdr pair) env)))]
- [else (cons (car chlst) (sub-vars (cdr chlst) env))]))
-
-(define (replace-var chlst env)
- (define tok '())
- (define (collect-var-chars chlst)
- (if (or (null? chlst) (char=? (car chlst) #\space))
- (set! tok (cons (list->string (reverse tok)) chlst))
- (begin (set! tok (cons (car chlst) tok))
- (collect-var-chars (cdr chlst)))))
- (collect-var-chars chlst)
- (let [(var (env-get env (car tok)))]
- (if var
- (cons var (cdr tok))
- (cons "" (cdr tok)))))
-
-;(define (scan-tok chlst tok)
-; (cond [(or (null? chlst) (char=? #\space (car chlst)))
-; (list->string (reverse tok))]
-
-; System Utility Functions
-;------------------------------------------------------------------------------
-(define (string-join strlst jstr)
- (foldl (lambda (a b) (string-append a b jstr)) "" strlst))
-
-; DSL Definition
-;------------------------------------------------------------------------------
-(define-syntax task
- (syntax-rules (=>)
- [(_ name => (deps ...))
- (task-register! (make-task (gen-task-name name) (current-desc) #t '(deps ...) '()))]
- [(_ name => (deps ...) exp1 expn ...)
- (task-register!
- (make-task (gen-task-name name) (current-desc) #t '(deps ...)
- (list (lambda () exp1 expn ...))))]
- [(_ name exp1 expn ...)
- (task-register!
- (make-task (gen-task-name name) (current-desc) #t '()
- (list (lambda () exp1 expn ...))))]))
-
-(define-syntax namespace
- (syntax-rules ()
- [(_ name body ...)
- (let [(prev-ns (current-namespace))]
- (current-namespace (gen-task-name name))
- body ...
- (current-namespace prev-ns))]))
-
-(define (desc str)
- (current-desc str))
-
-(define-syntax environment
- (syntax-rules (<=)
- [(_ name <= parent vars ...)
- (define name (env-extend parent vars ...))]
- [(_ name vars ...)
- (define name (env-extend (current-env) vars ...))]))
-
-(define-syntax builder
- (syntax-rules (defaults action)
- [(_ (defaults vars ...) (action args body ...))
- (make-builder '(vars ...) (lambda args body ...))]))
-
-; Core Tasks
-;------------------------------------------------------------------------------
-(task "verbose"
- (set! verbose #t))
-
-(task "help"
- (map (lambda (t)
- (if (task-desc (cdr t))
- (print (string-append (task-name (cdr t)) " - " (task-desc (cdr t))))))
- top-level-tasks))
-; Main
-;------------------------------------------------------------------------------
-(define (run-top-level-tasks!)
- (map task-invoke!
- (if (= 0 (length (command-line-arguments)))
- '("default")
- (command-line-arguments))))
-
-(load "Spadefile")
-(run-top-level-tasks!)
-
+(declare (uses posix))\r
+(use posix)\r
+\r
+; Task Definition and Interaction\r
+;------------------------------------------------------------------------------\r
+(define-record task name desc active? deps actions)\r
+\r
+(define top-level-tasks '())\r
+\r
+(define current-namespace\r
+ (make-parameter '()))\r
+\r
+(define current-desc\r
+ (make-parameter #f))\r
+\r
+(define (task-register! task)\r
+ (define name (task-name task))\r
+ (define entry (assoc name top-level-tasks))\r
+ (if (not entry)\r
+ (set! top-level-tasks (cons (cons name task) top-level-tasks))\r
+ (set-cdr! entry (task-merge (cdr entry) task))))\r
+\r
+(define (task-merge task1 task2)\r
+ (make-task (task-name task1) (task-desc task1) #t\r
+ (append (task-deps task1)\r
+ (task-deps task2))\r
+ (append (task-actions task1)\r
+ (task-actions task2))))\r
+\r
+(define (task-lookup name)\r
+ (define entry (assoc name top-level-tasks))\r
+ (if (not entry)\r
+ (error (string-append "No such task: " name))\r
+ (cdr entry)))\r
+\r
+(define (task-invoke! name)\r
+ (define task (task-lookup name))\r
+ (if (task-active? task)\r
+ (begin (task-active?-set! task #f)\r
+ (map task-invoke! (task-deps task))\r
+ (map (lambda (fn) (fn)) (task-actions task)))))\r
+\r
+(define (gen-task-name name)\r
+ (define namespace (current-namespace))\r
+ (if (not (null? namespace))\r
+ (string-append namespace ":" name)\r
+ name))\r
+\r
+; Environment Functions\r
+;------------------------------------------------------------------------------\r
+(define-record builder defaults action)\r
+\r
+(define (get-sys-env)\r
+ (get-environment-variables))\r
+\r
+(define (set-sys-env! newenv)\r
+ (clear-sys-env!)\r
+ (map (lambda (p) (setenv (car p) (cdr p)))\r
+ newenv))\r
+\r
+(define (clear-sys-env!)\r
+ (map (lambda (p) (unsetenv (car p)))\r
+ (get-environment-variables)))\r
+\r
+(define current-env\r
+ (let [(curr-env (get-sys-env))]\r
+ (lambda args\r
+ (if (> (length args) 0)\r
+ (begin (set-sys-env! (car args))\r
+ (set! curr-env (car args)))\r
+ curr-env))))\r
+\r
+(define (env-clone env . vars)\r
+ (define newenv (map (lambda (p) (cons (car p) (cdr p))) env))\r
+ (define newvals '())\r
+ (map (lambda (e)\r
+ (define entry (assoc (car e) newenv))\r
+ (if entry\r
+ (set-cdr! entry (cdr e))\r
+ (set! newvals (cons e newvals))))\r
+ vars)\r
+ (append newvals newenv))\r
+\r
+(define (env-get env key)\r
+ (define entry (assoc key env))\r
+ (if entry (cdr entry) #f))\r
+\r
+(define (env-set env key value)\r
+ (cons (cons key value)\r
+ (env-unset env key)))\r
+\r
+(define (env-unset env key)\r
+ (cond [(null? env) '()]\r
+ [(string=? (caar env) key) (env-unset (cdr env) key)]\r
+ [else (cons (car env) (env-unset (cdr env) key))]))\r
+\r
+(define (env-extend env . vars)\r
+ (foldl (lambda (env p)\r
+ (env-set env (car p) (cdr p)))\r
+ env\r
+ vars))\r
+\r
+(define (env-substitute env str)\r
+ (list->string (sub-vars (string->list str) env)))\r
+\r
+(define (env-prepend-path env path)\r
+ '())\r
+\r
+(define (env-append-path env path)\r
+ '())\r
+\r
+(define (env-add-builders env . builders)\r
+ '())\r
+\r
+; Builders\r
+;------------------------------------------------------------------------------\r
+\r
+\r
+; System Utility Functions\r
+;------------------------------------------------------------------------------\r
+(define verbose #f)\r
+\r
+(define (build type . args)\r
+ (define bldr (assoc type (assoc "builders" (current-env))))\r
+ (define bldr-env (env-merge (builder-defaults bldr) (current-env)))\r
+ (apply (builder-action bldr) (cons bldr-env args)))\r
+\r
+(define (run . args)\r
+ (define cmd (env-substitute (current-env) (string-join args " ")))\r
+ (if verbose (print cmd))\r
+ (if (not (= 0 (system cmd)))\r
+ (fail-build cmd)))\r
+\r
+(define (fail-build cmd)\r
+ (print "Error: Command returned a non-zero status")\r
+ (exit 1))\r
+\r
+; Directories\r
+(define cd change-directory)\r
+(define curdir current-directory)\r
+(define mkdir create-directory)\r
+(define rmdir delete-directory)\r
+(define lsdir directory)\r
+(define dir? directory?)\r
+; glob\r
+\r
+; Files\r
+(define cp '())\r
+(define mv '())\r
+(define rm delete-file)\r
+\r
+; String Templating\r
+;------------------------------------------------------------------------------\r
+(define (sub-vars chlst env)\r
+ (cond [(null? chlst) '()]\r
+ [(char=? #\$ (car chlst)) (let [(pair (replace-var (cdr chlst) env))]\r
+ (append (string->list (car pair))\r
+ (sub-vars (cdr pair) env)))]\r
+ [else (cons (car chlst) (sub-vars (cdr chlst) env))]))\r
+\r
+(define (replace-var chlst env)\r
+ (define tok '())\r
+ (define (collect-var-chars chlst)\r
+ (if (or (null? chlst) (char=? (car chlst) #\space))\r
+ (set! tok (cons (list->string (reverse tok)) chlst))\r
+ (begin (set! tok (cons (car chlst) tok))\r
+ (collect-var-chars (cdr chlst)))))\r
+ (collect-var-chars chlst)\r
+ (let [(var (env-get env (car tok)))]\r
+ (if var\r
+ (cons var (cdr tok))\r
+ (cons "" (cdr tok)))))\r
+\r
+;(define (scan-tok chlst tok)\r
+; (cond [(or (null? chlst) (char=? #\space (car chlst)))\r
+; (list->string (reverse tok))]\r
+\r
+; System Utility Functions\r
+;------------------------------------------------------------------------------\r
+(define (string-join strlst jstr)\r
+ (foldl (lambda (a b) (string-append a b jstr)) "" strlst))\r
+\r
+; DSL Definition\r
+;------------------------------------------------------------------------------\r
+(define-syntax task\r
+ (syntax-rules (=>)\r
+ [(_ name => (deps ...))\r
+ (task-register! (make-task (gen-task-name name) (current-desc) #t '(deps ...) '()))]\r
+ [(_ name => (deps ...) exp1 expn ...)\r
+ (task-register!\r
+ (make-task (gen-task-name name) (current-desc) #t '(deps ...)\r
+ (list (lambda () exp1 expn ...))))]\r
+ [(_ name exp1 expn ...)\r
+ (task-register!\r
+ (make-task (gen-task-name name) (current-desc) #t '()\r
+ (list (lambda () exp1 expn ...))))]))\r
+\r
+(define-syntax namespace\r
+ (syntax-rules ()\r
+ [(_ name body ...)\r
+ (let [(prev-ns (current-namespace))]\r
+ (current-namespace (gen-task-name name))\r
+ body ...\r
+ (current-namespace prev-ns))]))\r
+\r
+(define (desc str)\r
+ (current-desc str))\r
+\r
+(define-syntax environment\r
+ (syntax-rules (<=)\r
+ [(_ name <= parent vars ...)\r
+ (define name (env-extend parent vars ...))]\r
+ [(_ name vars ...)\r
+ (define name (env-extend (current-env) vars ...))]))\r
+\r
+(define-syntax builder\r
+ (syntax-rules (defaults action)\r
+ [(_ (defaults vars ...) (action args body ...))\r
+ (make-builder '(vars ...) (lambda args body ...))]))\r
+\r
+; Core Tasks\r
+;------------------------------------------------------------------------------\r
+(task "verbose"\r
+ (set! verbose #t))\r
+\r
+(task "help"\r
+ (map (lambda (t)\r
+ (if (task-desc (cdr t))\r
+ (print (string-append (task-name (cdr t)) " - " (task-desc (cdr t))))))\r
+ top-level-tasks))\r
+; Main\r
+;------------------------------------------------------------------------------\r
+(define (run-top-level-tasks!)\r
+ (map task-invoke!\r
+ (if (= 0 (length (command-line-arguments)))\r
+ '("default")\r
+ (command-line-arguments))))\r
+\r
+(load "Spadefile")\r
+(run-top-level-tasks!)\r
+\r
-; Regex Matching Macro
-;------------------------------------------------------------------------------
-(use regex ports extras)
-
-(define-syntax regex-case
- (syntax-rules (else)
- ((_ item (else result1 result2 ...))
- (begin result1 result2 ...))
-
- ((_ item (regex result1 result2 ...))
- (if (string-match regex item) (begin result1 result2 ...)))
-
- ((_ item (regex result1 result2 ...) clause1 clause2 ...)
- (if (string-match regex item)
- (begin result1 result2 ...)
- (regex-case item clause1 clause2 ...)))))
-
-; Reader Phase
-;------------------------------------------------------------------------------
-; This phase is responsible reading input from a port and constructing the
-; expression that the input represents.
-
-(define (sclpl-read port)
- (let [(tok (read-token port))]
- (if (eof-object? tok)
- tok
- (cond [(list-op? tok) (read-sexp port (get-sexp-term tok))]
- [(equal? "'" tok) `(quote ,(sclpl-read port))]
- [(equal? "`" tok) `(quasiquote ,(sclpl-read port))]
- [else (classify-atom tok)]))))
-
-(define (read-sexp port term)
- (define expr (sclpl-read port))
- (cond [(equal? expr term) '()]
- [(wrong-term? expr term) (error "Incorrectly matched list terminator")]
- [(equal? '|.| expr) (read-and-term port term)]
- [else (cons expr (read-sexp port term))]))
-
-
-(define (read-and-term port term)
- (define val (sclpl-read port))
- (define tval (sclpl-read port))
- (cond [(member val '(#\) #\] #\})) (error "")]
- [(equal? tval term) val]
- [(wrong-term? tval term) (error "")]
- [else (error "")]))
-
-(define (classify-atom atom)
- (regex-case atom
- ["nil" '()]
- ["true" #t]
- ["false" #f]
- ["^\".*\"$" (dequote atom)]
- ["^\\\\.+" (atom->char atom)]
- ["[{[()\\]}]" (string-ref atom 0)]
- ["#[dbox](#[ie])?.+" (or (string->number atom) (string->symbol atom))]
- ["[+-]?[0-9].*" (or (string->number atom) (string->symbol atom))]
- [else (if (string-literal? atom)
- (dequote atom)
- (string->symbol atom))]))
-
-(define (list-op? tok)
- (member (string-ref tok 0) '(#\( #\[ #\{)))
-
-(define (get-sexp-term tok)
- (define pairs '((#\( . #\)) (#\[ . #\]) (#\{ . #\})))
- (define term (assv (string-ref tok 0) pairs))
- (if term (cdr term) (error "Not a valid s-expression delimiter")))
-
-(define (wrong-term? expr term)
- (define terms '(#\) #\] #\}))
- (and (not (equal? expr term))
- (member expr terms)))
-
-(define (string-literal? atom)
- (and (char=? #\" (string-ref atom 0))
- (char=? #\" (string-ref atom (- (string-length atom) 1)))))
-
-(define (dequote str)
- (substring str 1 (- (string-length str) 1)))
-
-(define (atom->char atom)
- (define ch-name (substring atom 1))
- (define ch (if (= 1 (string-length ch-name))
- (string-ref ch-name 0)
- (char-name (string->symbol ch-name))))
- (or ch (error (string-append "Invalid character name: " ch-name))))
-
-;------------------------------------------------------------------------------
-
-(define whitespace (string->list " \t\r\n"))
-(define punctuation (string->list "()[]{}'`:,"))
-(define delimiters (string->list "()[]{}'`:,; \t\r\n"))
-(define doublequote '(#\"))
-
-(define (read-token port)
- (define ch (peek-char port))
- (define tok
- (cond [(eof-object? ch) ch]
- [(member ch whitespace) (consume-whitespace port)]
- [(char=? ch #\;) (consume-comment port)]
- [(char=? ch #\") (read-till-next #t port doublequote)]
- [(member ch punctuation) (string (read-char port))]
- [else (read-till-next #f port delimiters)]))
- (if (list? tok) (list->string tok) tok))
-
-(define (consume-whitespace port)
- (if (member (peek-char port) whitespace)
- (read-char port))
- (read-token port))
-
-(define (consume-comment port)
- (if (not (char=? #\newline (peek-char port)))
- (begin (read-char port)
- (consume-comment port))
- (begin (read-char port)
- (read-token port))))
-
-(define (read-till-next inc port delims)
- (cons (read-char port)
- (if (or (member (peek-char port) delims)
- (eof-object? (peek-char port)))
- (if inc (cons (read-char port) '()) '())
- (read-till-next inc port delims))))
-
-; Macro Expansion Phase
-;------------------------------------------------------------------------------
-; This phase is responsible for taking the expressions read from the input port
-; and performing macro expansion on them to get the resulting expression.
-
-(define (expand-macros expr)
- expr)
-
-; Desugaring Phase
-;------------------------------------------------------------------------------
-; The desugaring phase is responsible for taking user friendly extensions to
-; the core SCLPL syntax and deconstructing them into the low-level counterparts
-; defined by the "core" SCLPL syntax. This allows the code generator to work on
-; a small and well-defined subset of the SCLPL language.
-
-(define (desugar expr)
- (cond [(not (pair? expr)) expr]
- [(eqv? 'def (car expr)) (desugar-def expr)]
- [(eqv? 'if (car expr)) (desugar-if expr)]
- [(eqv? 'fn (car expr)) (append (list 'fn (cadr expr))
- (map desugar (cddr expr)))]
- [else (map desugar expr)]))
-
-(define (desugar-def expr)
- (cond [(annotated-def? expr) (desugar-annotated-def expr)]
- [(sugared-def? expr) (desugar-sugared-def expr)]
- [else (map desugar expr)]))
-
-(define (annotated-def? expr)
- (and (form-structure-valid? 'def >= 4 expr)
- (eqv? ': (caddr expr))))
-
-(define (sugared-def? expr)
- (and (form-structure-valid? 'def >= 2 expr)
- (arg-list-valid? (cadr expr))))
-
-(define (desugar-annotated-def expr)
- (let [(proto (cadr expr))
- (type (cadddr expr))
- (body (cddddr expr))]
- (if (pair? proto)
- (append `(def (,(car proto) ,type))
- (list (append `(fn ,(cdr proto)) (map desugar body))))
- (append `(def (,proto ,type))
- (map desugar body)))))
-
-(define (desugar-sugared-def expr)
- (if (pair? (cadr expr))
- (append `(def (,(caadr expr) ()))
- (list (append `(fn ,(cdadr expr)) (map desugar (cddr expr)))))
- (append `(def (,(cadr expr) ())) (map desugar (cddr expr)))))
-
-(define (desugar-if expr)
- (if (form-structure-valid? 'if = 3 expr)
- (map desugar (append expr '('())))
- (map desugar expr)))
-
-; Analysis Phase
-;------------------------------------------------------------------------------
-; The analysis phase is responsible for verifying that the provided expression
-; conforms to the requirements of the "core" SCLPL syntax. This phase will throw
-; an error for any invalid expression or simply return the provided expression
-; if it is valid.
-
-(define (analyze expr)
- (if (list? expr)
- (analyze-form expr)
- expr))
-
-(define (analyze-form expr)
- (if (null? expr)
- (error-msg 'non-atomic expr)
- (case (car expr)
- [(def) (analyze-def expr)]
- [(fn) (analyze-fn expr)]
- [(if) (validate-and-analyze 'if = 4 expr)]
- [(do) (validate-and-analyze 'do >= 1 expr)]
- [(quote) (validate-and-analyze 'quote = 2 expr)]
- [else (map analyze expr)])))
-
-(define (analyze-def expr)
- (validate-form 'def = 3 expr)
- (validate-signature (cadr expr))
- expr)
-
-(define (analyze-fn expr)
- (if (and (form-structure-valid? 'fn >= 3 expr)
- (arg-list-valid? (cadr expr)))
- (append (list 'fn (cadr expr))
- (map analyze (cddr expr)))
- (error-msg 'invalid-fn expr)))
-
-(define (validate-and-analyze type cmpop nargs expr)
- (validate-form type cmpop nargs expr)
- (map analyze expr))
-
-(define (validate-form type cmpop nargs expr)
- (cond [(not (pair? expr)) (error-msg 'not-an-sexp expr)]
- [(not (eqv? type (car expr))) (error-msg 'wrong-form-type expr)]
- [(not (cmpop (length expr) nargs)) (error-msg 'num-args expr)]))
-
-(define (validate-signature sig)
- (cond [(not (list? sig)) (error-msg 'sig-not-list sig)]
- [(not (= 2 (length sig))) (error-msg 'sig-num-entries sig)]
- [(not (variable? (car sig))) (error-msg 'sig-variable sig)]
- ;[(not (type? (cadr sig))) (error-msg 'expect-type sig)]))
- ))
-
-; Type Checking Phase
-;------------------------------------------------------------------------------
-; This phase is responsible for performing type reconstruction and verifying
-; that the expression is well-typed before being passed to the optimization and
-; compilation phases
-
-(define (check-type expr env)
- expr)
-
-; CPS-Conversion Phase
-;------------------------------------------------------------------------------
-; This phase translates the fully macro-expanded, desugared, and analyzed
-; program into continuation-passing style so various optimizations can be
-; performed before code is generated.
-
-(define (cps-convert expr)
- expr)
-
-; SCLPL to Scheme Phase
-;------------------------------------------------------------------------------
-
-(define (sclpl->scheme expr)
- expr)
-
-; Error Messages
-;------------------------------------------------------------------------------
-(define (error-msg type expr . args)
- (let [(handler (assoc type error-handlers))]
- (if handler (apply (cdr handler) args) (apply unknown-error args))
- (log-msg (with-output-to-string (lambda () (pretty-print expr))))
- (fail expr)))
-
-(define (non-atomic-expr)
- (log-msg "Error: Illegal non-atomic object"))
-
-(define (invalid-fn)
- (log-msg "Error: Invalid function form"))
-
-(define (not-an-sexpr)
- (log-msg "Error: Not an s-expression"))
-
-(define (wrong-form-type)
- (log-msg "Error: Incorrect form type"))
-
-(define (wrong-num-args)
- (log-msg "Error: Incorrect number of args for form"))
-
-(define (sig-is-not-a-list)
- (log-msg "Error: Function signature is not a list"))
-
-(define (wrong-num-sig-parts)
- (log-msg "Error: Function signature has incorrect number of parts"))
-
-(define (sig-name-not-var)
- (log-msg "Error: Name part of function signature is not a variable"))
-
-(define (expected-:)
- (log-msg "Error: Expected a :"))
-
-(define (unknown-error . args)
- (log-msg "Error: Unknown error occurred in the following expression"))
-
-(define error-handlers
- `((non-atomic . ,non-atomic-expr)
- (invalid-fn . ,invalid-fn)
- (not-an-sexp . ,not-an-sexpr)
- (wrong-form-type . ,wrong-form-type)
- (num-args . ,wrong-num-args)
- (sig-not-list . ,sig-is-not-a-list)
- (sig-num-entries . ,wrong-num-sig-parts)
- (sig-variable . ,sig-name-not-var)
- (expect-: . ,expected-:)))
-
-; Helper Predicates
-;------------------------------------------------------------------------------
-; This collection of predicate functions is used to assist the earlier phases
-; when dealing with similar data-structures.
-
-(define (form-structure-valid? type cmpop nargs expr)
- (and (pair? expr)
- (eqv? type (car expr))
- (cmpop (length expr) nargs)))
-
-(define (arg-list-valid? arglst)
- (or (variable? arglst)
- (and (or (list? arglst) (pair? arglst))
- (list-of? variable? arglst))))
-
-(define (list-of? type lst)
- (if (null? lst) #t
- (if (type (car lst))
- (if (type (cdr lst)) #t (list-of? type (cdr lst)))
- #f)))
-
-(define (variable? sym)
- (and (symbol? sym)
- (not (type-name? sym))
- (not (type-var? sym))))
-
-(define (atomic-base-type? type)
- (if (member type '(Any Number Symbol String Char Bool)) #t #f))
-
-(define (type? expr)
- (cond [(null? expr) #f]
- [(member '-> expr) (fn-type? expr)]
- [(list? expr) (and (> (length expr) 1)
- (apply list-and? (map type? expr)))]
- [else (or (type-name? expr) (type-var? expr))]))
-
-(define (type-name? sym)
- (and (symbol? sym)
- (let [(ch (string-ref (symbol->string sym) 0))]
- (and (char>=? ch #\A) (char<=? ch #\Z)))))
-
-(define (type-var? sym)
- (and (symbol? sym)
- (let [(ch (string-ref (symbol->string sym) 0))]
- (char=? ch #\?))))
-
-(define (fn-type? expr)
- (define (is-fn-type? prev expr)
- (if (null? expr) #t
- (case (car expr)
- [(...) (and (type? prev)
- (>= (length (cdr expr)) 1)
- (equal? '-> (cadr expr))
- (is-fn-type? #f (cdr expr)))]
- [(->) (and (= 2 (length expr))
- (is-fn-type? (car expr) (cdr expr)))]
- [else (and (type? (car expr))
- (is-fn-type? (car expr) (cdr expr)))])))
- (is-fn-type? #f expr))
-
-(define (list-and? . args)
- (if (null? args) #t (and (car args) (apply list-and? (cdr args)))))
-
-; Main
-;------------------------------------------------------------------------------
-
-(define fail error)
-
-(define log-msg (lambda args '()))
-
-;(define (print-data . args)
-; (apply print
-; (map (lambda (e)
-; (if (string? e)
-; e
-; (with-output-to-string (lambda () (pretty-print e)))))
-; args)))
-
-;(define (interpret port)
-; (call/cc (lambda (k)
-; (set! fail k)
-; (set! log-msg print)
-; (display (string-append ":" (sexp-count) "> "))
-; ; Read and type and analyze all expressions from input
-; (define expr (sclpl-read port))
-; (print-data "Read Phase: \n" expr)
-; (set! expr (expand-macros expr))
-; (print-data "Macro Expansion Phase: \n" expr)
-; (set! expr (desugar expr))
-; (print-data "Desugar Phase: \n" expr)
-; (set! expr (analyze expr))
-; (print-data "Analysis Phase: \n" expr)))
-; (interpret port))
-;(interpret (current-input-port))
-;(exit)
-
-(define (read-program port)
- (define expr (sclpl-read port))
- (if (eof-object? expr)
- '()
- (cons (analyze (desugar (expand-macros expr)))
- (read-program port))))
-
-(print (read-program (current-input-port)))
-
-
+; Regex Matching Macro\r
+;------------------------------------------------------------------------------\r
+(use regex ports extras)\r
+\r
+(define-syntax regex-case\r
+ (syntax-rules (else)\r
+ ((_ item (else result1 result2 ...))\r
+ (begin result1 result2 ...))\r
+\r
+ ((_ item (regex result1 result2 ...))\r
+ (if (string-match regex item) (begin result1 result2 ...)))\r
+\r
+ ((_ item (regex result1 result2 ...) clause1 clause2 ...)\r
+ (if (string-match regex item)\r
+ (begin result1 result2 ...)\r
+ (regex-case item clause1 clause2 ...)))))\r
+\r
+; Reader Phase\r
+;------------------------------------------------------------------------------\r
+; This phase is responsible reading input from a port and constructing the\r
+; expression that the input represents.\r
+\r
+(define (sclpl-read port)\r
+ (let [(tok (read-token port))]\r
+ (if (eof-object? tok)\r
+ tok\r
+ (cond [(list-op? tok) (read-sexp port (get-sexp-term tok))]\r
+ [(equal? "'" tok) `(quote ,(sclpl-read port))]\r
+ [(equal? "`" tok) `(quasiquote ,(sclpl-read port))]\r
+ [else (classify-atom tok)]))))\r
+\r
+(define (read-sexp port term)\r
+ (define expr (sclpl-read port))\r
+ (cond [(equal? expr term) '()]\r
+ [(wrong-term? expr term) (error "Incorrectly matched list terminator")]\r
+ [(equal? '|.| expr) (read-and-term port term)]\r
+ [else (cons expr (read-sexp port term))]))\r
+\r
+\r
+(define (read-and-term port term)\r
+ (define val (sclpl-read port))\r
+ (define tval (sclpl-read port))\r
+ (cond [(member val '(#\) #\] #\})) (error "")]\r
+ [(equal? tval term) val]\r
+ [(wrong-term? tval term) (error "")]\r
+ [else (error "")]))\r
+\r
+(define (classify-atom atom)\r
+ (regex-case atom\r
+ ["nil" '()]\r
+ ["true" #t]\r
+ ["false" #f]\r
+ ["^\".*\"$" (dequote atom)]\r
+ ["^\\\\.+" (atom->char atom)]\r
+ ["[{[()\\]}]" (string-ref atom 0)]\r
+ ["#[dbox](#[ie])?.+" (or (string->number atom) (string->symbol atom))]\r
+ ["[+-]?[0-9].*" (or (string->number atom) (string->symbol atom))]\r
+ [else (if (string-literal? atom)\r
+ (dequote atom)\r
+ (string->symbol atom))]))\r
+\r
+(define (list-op? tok)\r
+ (member (string-ref tok 0) '(#\( #\[ #\{)))\r
+\r
+(define (get-sexp-term tok)\r
+ (define pairs '((#\( . #\)) (#\[ . #\]) (#\{ . #\})))\r
+ (define term (assv (string-ref tok 0) pairs))\r
+ (if term (cdr term) (error "Not a valid s-expression delimiter")))\r
+\r
+(define (wrong-term? expr term)\r
+ (define terms '(#\) #\] #\}))\r
+ (and (not (equal? expr term))\r
+ (member expr terms)))\r
+\r
+(define (string-literal? atom)\r
+ (and (char=? #\" (string-ref atom 0))\r
+ (char=? #\" (string-ref atom (- (string-length atom) 1)))))\r
+\r
+(define (dequote str)\r
+ (substring str 1 (- (string-length str) 1)))\r
+\r
+(define (atom->char atom)\r
+ (define ch-name (substring atom 1))\r
+ (define ch (if (= 1 (string-length ch-name))\r
+ (string-ref ch-name 0)\r
+ (char-name (string->symbol ch-name))))\r
+ (or ch (error (string-append "Invalid character name: " ch-name))))\r
+\r
+;------------------------------------------------------------------------------\r
+\r
+(define whitespace (string->list " \t\r\n"))\r
+(define punctuation (string->list "()[]{}'`:,"))\r
+(define delimiters (string->list "()[]{}'`:,; \t\r\n"))\r
+(define doublequote '(#\"))\r
+\r
+(define (read-token port)\r
+ (define ch (peek-char port))\r
+ (define tok\r
+ (cond [(eof-object? ch) ch]\r
+ [(member ch whitespace) (consume-whitespace port)]\r
+ [(char=? ch #\;) (consume-comment port)]\r
+ [(char=? ch #\") (read-till-next #t port doublequote)]\r
+ [(member ch punctuation) (string (read-char port))]\r
+ [else (read-till-next #f port delimiters)]))\r
+ (if (list? tok) (list->string tok) tok))\r
+\r
+(define (consume-whitespace port)\r
+ (if (member (peek-char port) whitespace)\r
+ (read-char port))\r
+ (read-token port))\r
+\r
+(define (consume-comment port)\r
+ (if (not (char=? #\newline (peek-char port)))\r
+ (begin (read-char port)\r
+ (consume-comment port))\r
+ (begin (read-char port)\r
+ (read-token port))))\r
+\r
+(define (read-till-next inc port delims)\r
+ (cons (read-char port)\r
+ (if (or (member (peek-char port) delims)\r
+ (eof-object? (peek-char port)))\r
+ (if inc (cons (read-char port) '()) '())\r
+ (read-till-next inc port delims))))\r
+\r
+; Macro Expansion Phase\r
+;------------------------------------------------------------------------------\r
+; This phase is responsible for taking the expressions read from the input port\r
+; and performing macro expansion on them to get the resulting expression.\r
+\r
+(define (expand-macros expr)\r
+ expr)\r
+\r
+; Desugaring Phase\r
+;------------------------------------------------------------------------------\r
+; The desugaring phase is responsible for taking user friendly extensions to\r
+; the core SCLPL syntax and deconstructing them into the low-level counterparts\r
+; defined by the "core" SCLPL syntax. This allows the code generator to work on\r
+; a small and well-defined subset of the SCLPL language.\r
+\r
+(define (desugar expr)\r
+ (cond [(not (pair? expr)) expr]\r
+ [(eqv? 'def (car expr)) (desugar-def expr)]\r
+ [(eqv? 'if (car expr)) (desugar-if expr)]\r
+ [(eqv? 'fn (car expr)) (append (list 'fn (cadr expr))\r
+ (map desugar (cddr expr)))]\r
+ [else (map desugar expr)]))\r
+\r
+(define (desugar-def expr)\r
+ (cond [(annotated-def? expr) (desugar-annotated-def expr)]\r
+ [(sugared-def? expr) (desugar-sugared-def expr)]\r
+ [else (map desugar expr)]))\r
+\r
+(define (annotated-def? expr)\r
+ (and (form-structure-valid? 'def >= 4 expr)\r
+ (eqv? ': (caddr expr))))\r
+\r
+(define (sugared-def? expr)\r
+ (and (form-structure-valid? 'def >= 2 expr)\r
+ (arg-list-valid? (cadr expr))))\r
+\r
+(define (desugar-annotated-def expr)\r
+ (let [(proto (cadr expr))\r
+ (type (cadddr expr))\r
+ (body (cddddr expr))]\r
+ (if (pair? proto)\r
+ (append `(def (,(car proto) ,type))\r
+ (list (append `(fn ,(cdr proto)) (map desugar body))))\r
+ (append `(def (,proto ,type))\r
+ (map desugar body)))))\r
+\r
+(define (desugar-sugared-def expr)\r
+ (if (pair? (cadr expr))\r
+ (append `(def (,(caadr expr) ()))\r
+ (list (append `(fn ,(cdadr expr)) (map desugar (cddr expr)))))\r
+ (append `(def (,(cadr expr) ())) (map desugar (cddr expr)))))\r
+\r
+(define (desugar-if expr)\r
+ (if (form-structure-valid? 'if = 3 expr)\r
+ (map desugar (append expr '('())))\r
+ (map desugar expr)))\r
+\r
+; Analysis Phase\r
+;------------------------------------------------------------------------------\r
+; The analysis phase is responsible for verifying that the provided expression\r
+; conforms to the requirements of the "core" SCLPL syntax. This phase will throw\r
+; an error for any invalid expression or simply return the provided expression\r
+; if it is valid.\r
+\r
+(define (analyze expr)\r
+ (if (list? expr)\r
+ (analyze-form expr)\r
+ expr))\r
+\r
+(define (analyze-form expr)\r
+ (if (null? expr)\r
+ (error-msg 'non-atomic expr)\r
+ (case (car expr)\r
+ [(def) (analyze-def expr)]\r
+ [(fn) (analyze-fn expr)]\r
+ [(if) (validate-and-analyze 'if = 4 expr)]\r
+ [(do) (validate-and-analyze 'do >= 1 expr)]\r
+ [(quote) (validate-and-analyze 'quote = 2 expr)]\r
+ [else (map analyze expr)])))\r
+\r
+(define (analyze-def expr)\r
+ (validate-form 'def = 3 expr)\r
+ (validate-signature (cadr expr))\r
+ expr)\r
+\r
+(define (analyze-fn expr)\r
+ (if (and (form-structure-valid? 'fn >= 3 expr)\r
+ (arg-list-valid? (cadr expr)))\r
+ (append (list 'fn (cadr expr))\r
+ (map analyze (cddr expr)))\r
+ (error-msg 'invalid-fn expr)))\r
+\r
+(define (validate-and-analyze type cmpop nargs expr)\r
+ (validate-form type cmpop nargs expr)\r
+ (map analyze expr))\r
+\r
+(define (validate-form type cmpop nargs expr)\r
+ (cond [(not (pair? expr)) (error-msg 'not-an-sexp expr)]\r
+ [(not (eqv? type (car expr))) (error-msg 'wrong-form-type expr)]\r
+ [(not (cmpop (length expr) nargs)) (error-msg 'num-args expr)]))\r
+\r
+(define (validate-signature sig)\r
+ (cond [(not (list? sig)) (error-msg 'sig-not-list sig)]\r
+ [(not (= 2 (length sig))) (error-msg 'sig-num-entries sig)]\r
+ [(not (variable? (car sig))) (error-msg 'sig-variable sig)]\r
+ ;[(not (type? (cadr sig))) (error-msg 'expect-type sig)]))\r
+ ))\r
+\r
+; Type Checking Phase\r
+;------------------------------------------------------------------------------\r
+; This phase is responsible for performing type reconstruction and verifying\r
+; that the expression is well-typed before being passed to the optimization and\r
+; compilation phases\r
+\r
+(define (check-type expr env)\r
+ expr)\r
+\r
+; CPS-Conversion Phase\r
+;------------------------------------------------------------------------------\r
+; This phase translates the fully macro-expanded, desugared, and analyzed\r
+; program into continuation-passing style so various optimizations can be\r
+; performed before code is generated.\r
+\r
+(define (cps-convert expr)\r
+ expr)\r
+\r
+; SCLPL to Scheme Phase\r
+;------------------------------------------------------------------------------\r
+\r
+(define (sclpl->scheme expr)\r
+ expr)\r
+\r
+; Error Messages\r
+;------------------------------------------------------------------------------\r
+(define (error-msg type expr . args)\r
+ (let [(handler (assoc type error-handlers))]\r
+ (if handler (apply (cdr handler) args) (apply unknown-error args))\r
+ (log-msg (with-output-to-string (lambda () (pretty-print expr))))\r
+ (fail expr)))\r
+\r
+(define (non-atomic-expr)\r
+ (log-msg "Error: Illegal non-atomic object"))\r
+\r
+(define (invalid-fn)\r
+ (log-msg "Error: Invalid function form"))\r
+\r
+(define (not-an-sexpr)\r
+ (log-msg "Error: Not an s-expression"))\r
+\r
+(define (wrong-form-type)\r
+ (log-msg "Error: Incorrect form type"))\r
+\r
+(define (wrong-num-args)\r
+ (log-msg "Error: Incorrect number of args for form"))\r
+\r
+(define (sig-is-not-a-list)\r
+ (log-msg "Error: Function signature is not a list"))\r
+\r
+(define (wrong-num-sig-parts)\r
+ (log-msg "Error: Function signature has incorrect number of parts"))\r
+\r
+(define (sig-name-not-var)\r
+ (log-msg "Error: Name part of function signature is not a variable"))\r
+\r
+(define (expected-:)\r
+ (log-msg "Error: Expected a :"))\r
+\r
+(define (unknown-error . args)\r
+ (log-msg "Error: Unknown error occurred in the following expression"))\r
+\r
+(define error-handlers\r
+ `((non-atomic . ,non-atomic-expr)\r
+ (invalid-fn . ,invalid-fn)\r
+ (not-an-sexp . ,not-an-sexpr)\r
+ (wrong-form-type . ,wrong-form-type)\r
+ (num-args . ,wrong-num-args)\r
+ (sig-not-list . ,sig-is-not-a-list)\r
+ (sig-num-entries . ,wrong-num-sig-parts)\r
+ (sig-variable . ,sig-name-not-var)\r
+ (expect-: . ,expected-:)))\r
+\r
+; Helper Predicates\r
+;------------------------------------------------------------------------------\r
+; This collection of predicate functions is used to assist the earlier phases\r
+; when dealing with similar data-structures.\r
+\r
+(define (form-structure-valid? type cmpop nargs expr)\r
+ (and (pair? expr)\r
+ (eqv? type (car expr))\r
+ (cmpop (length expr) nargs)))\r
+\r
+(define (arg-list-valid? arglst)\r
+ (or (variable? arglst)\r
+ (and (or (list? arglst) (pair? arglst))\r
+ (list-of? variable? arglst))))\r
+\r
+(define (list-of? type lst)\r
+ (if (null? lst) #t\r
+ (if (type (car lst))\r
+ (if (type (cdr lst)) #t (list-of? type (cdr lst)))\r
+ #f)))\r
+\r
+(define (variable? sym)\r
+ (and (symbol? sym)\r
+ (not (type-name? sym))\r
+ (not (type-var? sym))))\r
+\r
+(define (atomic-base-type? type)\r
+ (if (member type '(Any Number Symbol String Char Bool)) #t #f))\r
+\r
+(define (type? expr)\r
+ (cond [(null? expr) #f]\r
+ [(member '-> expr) (fn-type? expr)]\r
+ [(list? expr) (and (> (length expr) 1)\r
+ (apply list-and? (map type? expr)))]\r
+ [else (or (type-name? expr) (type-var? expr))]))\r
+\r
+(define (type-name? sym)\r
+ (and (symbol? sym)\r
+ (let [(ch (string-ref (symbol->string sym) 0))]\r
+ (and (char>=? ch #\A) (char<=? ch #\Z)))))\r
+\r
+(define (type-var? sym)\r
+ (and (symbol? sym)\r
+ (let [(ch (string-ref (symbol->string sym) 0))]\r
+ (char=? ch #\?))))\r
+\r
+(define (fn-type? expr)\r
+ (define (is-fn-type? prev expr)\r
+ (if (null? expr) #t\r
+ (case (car expr)\r
+ [(...) (and (type? prev)\r
+ (>= (length (cdr expr)) 1)\r
+ (equal? '-> (cadr expr))\r
+ (is-fn-type? #f (cdr expr)))]\r
+ [(->) (and (= 2 (length expr))\r
+ (is-fn-type? (car expr) (cdr expr)))]\r
+ [else (and (type? (car expr))\r
+ (is-fn-type? (car expr) (cdr expr)))])))\r
+ (is-fn-type? #f expr))\r
+\r
+(define (list-and? . args)\r
+ (if (null? args) #t (and (car args) (apply list-and? (cdr args)))))\r
+\r
+; Main\r
+;------------------------------------------------------------------------------\r
+\r
+(define fail error)\r
+\r
+(define log-msg (lambda args '()))\r
+\r
+;(define (print-data . args)\r
+; (apply print\r
+; (map (lambda (e)\r
+; (if (string? e)\r
+; e\r
+; (with-output-to-string (lambda () (pretty-print e)))))\r
+; args)))\r
+\r
+;(define (interpret port)\r
+; (call/cc (lambda (k)\r
+; (set! fail k)\r
+; (set! log-msg print)\r
+; (display (string-append ":" (sexp-count) "> "))\r
+; ; Read and type and analyze all expressions from input\r
+; (define expr (sclpl-read port))\r
+; (print-data "Read Phase: \n" expr)\r
+; (set! expr (expand-macros expr))\r
+; (print-data "Macro Expansion Phase: \n" expr)\r
+; (set! expr (desugar expr))\r
+; (print-data "Desugar Phase: \n" expr)\r
+; (set! expr (analyze expr))\r
+; (print-data "Analysis Phase: \n" expr)))\r
+; (interpret port))\r
+;(interpret (current-input-port))\r
+;(exit)\r
+\r
+(define (read-program port)\r
+ (define expr (sclpl-read port))\r
+ (if (eof-object? expr)\r
+ '()\r
+ (cons (analyze (desugar (expand-macros expr)))\r
+ (read-program port))))\r
+\r
+(print (read-program (current-input-port)))\r
+\r
+\r
-(declare (uses library server))
-
-(define slpkg-usage
-"Package manager for SCLPL (Simple Concurrent List Processing Language).
-
-Usage:
- slpkg [COMMAND] [OPTIONS]
-
-Commands:
- help Show help documentation for a specific command or subcommand.
- install Install one or more packages from the configured sources.
- publish Publish a package to a specified repository.
- remove Remove one or more packages from this machine.
- search Search the repositories for packages matching a pattern.
- server Start a package server to host packages.
- show Show detailed information about a specific package or packages.
- source Manage the sources from which packages will be retrieved.
- update Update the package lists for all configured sources.
- upgrade Upgrade a given package or packages.
-")
-
-;------------------------------------------------------------------------------
-
-(define (help-cmd args)
- (print args))
-
-;------------------------------------------------------------------------------
-(define install-cmd help-cmd)
-;------------------------------------------------------------------------------
-(define publish-cmd help-cmd)
-;------------------------------------------------------------------------------
-(define remove-cmd help-cmd)
-;------------------------------------------------------------------------------
-(define search-cmd help-cmd)
-;------------------------------------------------------------------------------
-
-(define (server-cmd args)
- (start-pkg-server (cadr args) (caddr args)))
-
-;------------------------------------------------------------------------------
-(define show-cmd help-cmd)
-;------------------------------------------------------------------------------
-(define source-cmd help-cmd)
-;------------------------------------------------------------------------------
-(define update-cmd help-cmd)
-;------------------------------------------------------------------------------
-(define upgrade-cmd help-cmd)
-;------------------------------------------------------------------------------
-
-(define slpkg-commands
- `(("help" . ,help-cmd)
- ("install" . ,install-cmd)
- ("publish" . ,publish-cmd)
- ("remove" . ,remove-cmd)
- ("search" . ,search-cmd)
- ("server" . ,server-cmd)
- ("show" . ,show-cmd)
- ("source" . ,source-cmd)
- ("update" . ,update-cmd)
- ("upgrade" . ,upgrade-cmd)))
-
-;------------------------------------------------------------------------------
-
-(define (cmd-dispatch cmd-map usage args)
- (define sub-cmd (if (pair? args) (assoc (car args) cmd-map) '()))
- (cond [(pair? sub-cmd) ((cdr sub-cmd) (cdr args))]
- [else (print usage)]))
-
-;------------------------------------------------------------------------------
-
-(cmd-dispatch slpkg-commands slpkg-usage (command-line-arguments))
-
+(declare (uses library server))\r
+\r
+(define slpkg-usage\r
+"Package manager for SCLPL (Simple Concurrent List Processing Language).\r
+\r
+Usage:\r
+ slpkg [COMMAND] [OPTIONS]\r
+\r
+Commands:\r
+ help Show help documentation for a specific command or subcommand.\r
+ install Install one or more packages from the configured sources.\r
+ publish Publish a package to a specified repository.\r
+ remove Remove one or more packages from this machine.\r
+ search Search the repositories for packages matching a pattern.\r
+ server Start a package server to host packages.\r
+ show Show detailed information about a specific package or packages.\r
+ source Manage the sources from which packages will be retrieved.\r
+ update Update the package lists for all configured sources.\r
+ upgrade Upgrade a given package or packages.\r
+")\r
+\r
+;------------------------------------------------------------------------------\r
+\r
+(define (help-cmd args)\r
+ (print args))\r
+\r
+;------------------------------------------------------------------------------\r
+(define install-cmd help-cmd)\r
+;------------------------------------------------------------------------------\r
+(define publish-cmd help-cmd)\r
+;------------------------------------------------------------------------------\r
+(define remove-cmd help-cmd)\r
+;------------------------------------------------------------------------------\r
+(define search-cmd help-cmd)\r
+;------------------------------------------------------------------------------\r
+\r
+(define (server-cmd args)\r
+ (start-pkg-server (cadr args) (caddr args)))\r
+\r
+;------------------------------------------------------------------------------\r
+(define show-cmd help-cmd)\r
+;------------------------------------------------------------------------------\r
+(define source-cmd help-cmd)\r
+;------------------------------------------------------------------------------\r
+(define update-cmd help-cmd)\r
+;------------------------------------------------------------------------------\r
+(define upgrade-cmd help-cmd)\r
+;------------------------------------------------------------------------------\r
+\r
+(define slpkg-commands\r
+ `(("help" . ,help-cmd)\r
+ ("install" . ,install-cmd)\r
+ ("publish" . ,publish-cmd)\r
+ ("remove" . ,remove-cmd)\r
+ ("search" . ,search-cmd)\r
+ ("server" . ,server-cmd)\r
+ ("show" . ,show-cmd)\r
+ ("source" . ,source-cmd)\r
+ ("update" . ,update-cmd)\r
+ ("upgrade" . ,upgrade-cmd)))\r
+\r
+;------------------------------------------------------------------------------\r
+\r
+(define (cmd-dispatch cmd-map usage args)\r
+ (define sub-cmd (if (pair? args) (assoc (car args) cmd-map) '()))\r
+ (cond [(pair? sub-cmd) ((cdr sub-cmd) (cdr args))]\r
+ [else (print usage)]))\r
+\r
+;------------------------------------------------------------------------------\r
+\r
+(cmd-dispatch slpkg-commands slpkg-usage (command-line-arguments))\r
+\r
-(declare (unit server) (uses eval));(uses spiffy intarweb posix))
-(require-extension spiffy)
-
-(define index-template
-"<!DOCTYPE html PUBLIC
- \"-//W3C//DTD XHTML 1.0 Strict//EN\"
- \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">
-<html lang=\"en\">
- <head>
- <title>Index of ~a</title>
- </head>
- <body>
- <div>~a</div>
- </body>
-</html>")
-
-(define entry-template "<a href=\"~a\">~a</a><br/>\n")
-
-(define (html-response html)
- (with-headers `((content-type text/html)
- (content-length ,(string-length html)))
- (lambda ()
- (write-logged-response)
- (display html (response-port (current-response))))))
-
-(define (generate-index path)
- (define curr_root (string-append (root-path) path))
- (define entries (glob (string-append curr_root "/*")))
- (apply string-append
- (map (lambda (e)
- (define pth (if (equal? "/" path) path (string-append path "/" e)))
- (sprintf entry-template pth e))
- (map (lambda (e) (car (reverse (string-split e "/"))))
- entries))))
-
-(define (index-handler path)
- (html-response (sprintf index-template path (generate-index path))))
-
-(define (start-pkg-server port root)
- (server-port port)
- (root-path root)
- (handle-directory index-handler)
- (start-server))
-
+(declare (unit server) (uses eval));(uses spiffy intarweb posix))\r
+(require-extension spiffy)\r
+\r
+(define index-template\r
+"<!DOCTYPE html PUBLIC\r
+ \"-//W3C//DTD XHTML 1.0 Strict//EN\"\r
+ \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\r
+<html lang=\"en\">\r
+ <head>\r
+ <title>Index of ~a</title>\r
+ </head>\r
+ <body>\r
+ <div>~a</div>\r
+ </body>\r
+</html>")\r
+\r
+(define entry-template "<a href=\"~a\">~a</a><br/>\n")\r
+\r
+(define (html-response html)\r
+ (with-headers `((content-type text/html)\r
+ (content-length ,(string-length html)))\r
+ (lambda ()\r
+ (write-logged-response)\r
+ (display html (response-port (current-response))))))\r
+\r
+(define (generate-index path)\r
+ (define curr_root (string-append (root-path) path))\r
+ (define entries (glob (string-append curr_root "/*")))\r
+ (apply string-append\r
+ (map (lambda (e)\r
+ (define pth (if (equal? "/" path) path (string-append path "/" e)))\r
+ (sprintf entry-template pth e))\r
+ (map (lambda (e) (car (reverse (string-split e "/"))))\r
+ entries))))\r
+\r
+(define (index-handler path)\r
+ (html-response (sprintf index-template path (generate-index path))))\r
+\r
+(define (start-pkg-server port root)\r
+ (server-port port)\r
+ (root-path root)\r
+ (handle-directory index-handler)\r
+ (start-server))\r
+\r
-/**
- @file parser.h
- @brief TODO: Describe this file
- $Revision$
- $HeadURL$
- */
-#ifndef PARSER_H
-#define PARSER_H
-
-#include "slvm.h"
-#include <stdio.h>
-#include <stdbool.h>
-
-typedef enum {
- ERROR = 0,
- WORD,
- STRING,
- CHAR,
- INTEGER,
- FLOAT,
-} TokenType_T;
-
-char* fetch_token(void);
-
-TokenType_T parse_token(char* str, val_t* p_val);
-
-#endif /* PARSER_H */
+/**\r
+ @file parser.h\r
+ @brief TODO: Describe this file\r
+ $Revision$\r
+ $HeadURL$\r
+ */\r
+#ifndef PARSER_H\r
+#define PARSER_H\r
+\r
+#include "slvm.h"\r
+#include <stdio.h>\r
+#include <stdbool.h>\r
+\r
+typedef enum {\r
+ ERROR = 0,\r
+ WORD,\r
+ STRING,\r
+ CHAR,\r
+ INTEGER,\r
+ FLOAT,\r
+} TokenType_T;\r
+\r
+char* fetch_token(void);\r
+\r
+TokenType_T parse_token(char* str, val_t* p_val);\r
+\r
+#endif /* PARSER_H */\r
-#include "slvm.h"
-#include "parser.h"
-#include "pal.h"
-
-/*
- Wish List:
-
- * Dynamic Loading and Unloading of Dictionaries (File, Object, or Dynamic Lib)
- * Rework w* words to allow gettign and setting attributes of a word
- * Add optional debugging words
- * Add optional floating point / fixed point words
- * Add optional runtime integrity checks
- * Add optional static heap replacement for malloc, realloc, free
- * Add optional support for embedded systems (No dependence on stdlib)
- * Run through profiler and optimize execution speed where possible.
- * Add optional support for temporaries
- * Add optional code optimizer for compiled words
- * Add ability to compile to simple object file
- * Add ability to compile to shared library
- * Add ability to compile to standalone executable
- * Add support for multi-tasking
- * Add support for multi-tasking with multiple cores/threads
-
-*/
-
-/* Inner Interpreter
- *****************************************************************************/
-void docolon(val_t* code) {
- word_t* word;
- /* We may have previously been executing a word so we should save off our
- * previous position */
- val_t* prev_code = CodePtr;
- /* Set the next instruction to execute */
- CodePtr = code;
- /* Loop through until "ret" sets the code pointer to null */
- while(CodePtr)
- {
- word = (word_t*)*CodePtr;
- /* Increment the instruction pointer */
- CodePtr++;
- /* Execute the byte code instruction */
- word->codeword(CodePtr);
- }
- /* Execution finished lets put things back the way they were */
- CodePtr = prev_code;
-}
-
-/* Built-in Constants
- *****************************************************************************/
-defconst("VERSION", version, 0, NULL, 1)
-defconst("EXECDEF", execdef, 0, &version, (val_t)&docolon)
-defconst("WORDSZ", wordsz, 0, &execdef, sizeof(val_t))
-
-/* Built-in Variables
- *****************************************************************************/
-defvar("state", state, 0, &wordsz, 0)
-defvar("latest", latest, 0, &state, 0)
-
-/* Word Words
- *****************************************************************************/
-defcode("wlink", wlink, 0, &latest){
- *(ArgStack) = (val_t)(((word_t*)*(ArgStack))->link);
-}
-
-defcode("wsize", wflags, 0, &wlink){
- *(ArgStack) = (val_t)(((word_t*)*(ArgStack))->flags.attr.codesize);
-}
-
-defcode("wname", wname, 0, &wflags){
- *(ArgStack) = (val_t)(((word_t*)*(ArgStack))->name);
-}
-
-defcode("wfunc", wfunc, 0, &wname){
- *(ArgStack) = (val_t)(((word_t*)*(ArgStack))->codeword);
-}
-
-defcode("wcode", wcode, 0, &wfunc){
- *(ArgStack) = (val_t)(((word_t*)*(ArgStack))->code);
-}
-
-defcode("here", here, 0, &wcode){
- ArgStack++;
- *(ArgStack) = (val_t)((((word_t*)latest_val)->flags.attr.codesize) - 1);
-}
-
-/* Interpreter Words
- *****************************************************************************/
-defcode("exec", exec, 0, &here){
- word_t* word = (word_t*)(*ArgStack);
- ArgStack--;
- EXEC( *(word) );
-}
-
-defcode("find", find, 0, &exec){
- word_t const* curr = (word_t const*)latest_val;
- char* name = (char*)*(ArgStack);
- while(curr)
- {
- if (!(curr->flags.attr.hidden) && (0 == pal_strcmp(curr->name,name)))
- {
- break;
- }
- curr = curr->link;
- }
- *(ArgStack) = (val_t)curr;
-}
-
-defcode("fetchtok", fetchtok, 0, &find){
- ArgStack++;
- *(ArgStack) = (val_t)fetch_token();
-}
-
-defcode("parsetok", parsetok, 0, &fetchtok){
- char* p_str = (char*)*(ArgStack);
- ArgStack++;
- *(ArgStack) = (val_t)parse_token( p_str, ArgStack-1 );
- /* If the parsed token no longer needs the original string */
- if (*(ArgStack) > STRING)
- {
- /* Free the mem */
- pal_free(p_str);
- }
-}
-
-/* Branching and Literal Words
- *****************************************************************************/
-defcode("lit", lit, 0, &parsetok){
- ArgStack++;
- *(ArgStack) = *CodePtr;
- CodePtr++;
-}
-
-defcode("br", br, 0, &lit){
- CodePtr = (val_t*)(((val_t)CodePtr) + (*(CodePtr) * sizeof(val_t)));
-}
-
-defcode("0br", zbr, 0, &br){
- if (*ArgStack == 0)
- {
- CodePtr = (val_t*)(((val_t)CodePtr) + (*(CodePtr) * sizeof(val_t)));
- }
- else
- {
- CodePtr++;
- }
- ArgStack--;
-}
-
-/* Compiler Words
- *****************************************************************************/
-defcode("ret", ret, 0, &zbr){
- CodePtr = 0;
-}
-
-defcode("[", lbrack, 0, &ret){
- state_val = 0;
-}
-
-defcode("]", rbrack, 1, &lbrack){
- state_val = 1;
-}
-
-defcode("create", create, 0, &rbrack){
- /* Copy the name string */
- char* name = 0u;
- if (*(ArgStack))
- {
- size_t namesz = pal_strlen((char*)*(ArgStack));
- name = (char*)pal_allocate( namesz );
- pal_strcpy(name, (char*)*(ArgStack));
- }
- /* Create the word entry */
- word_t* word = (word_t*)pal_allocate(sizeof(word_t));
- word->link = (word_t*)latest_val;
- /* Initialize the flags (hidden and non-immediate by default) */
- word->flags.attr.immed = 0;
- word->flags.attr.hidden = 1;
- word->flags.attr.codesize = 1;
- /* Initialize the name, codeword, and bytecode */
- word->name = name;
- word->codeword = &docolon;
- word->code = (val_t*)pal_allocate(sizeof(val_t));
- word->code[0] = (val_t)&ret;
- /* Update Latest and Return the new word */
- latest_val = (val_t)word;
- *(ArgStack) = (val_t)word;
-}
-
-defcode(",", comma, 0, &create){
- /* Get the word we are currently compiling */
- word_t* word = (word_t*)latest_val;
- /* Put the next instruction in place of the terminating 'ret' that "here"
- * points too */
- word->code[word->flags.attr.codesize-1] = *(ArgStack);
- ArgStack--;
- /* Resize the code section and relocate if necessary */
- word->flags.attr.codesize++;
- word->code = (val_t*)pal_reallocate(word->code, word->flags.attr.codesize * sizeof(val_t));
- /* Update "here" and terminate the code section */
- word->code[word->flags.attr.codesize-1] = (val_t)&ret;
-}
-
-defcode("hidden", hidden, 1, &comma){
- ((word_t*)*(ArgStack))->flags.attr.hidden ^= 1;
-}
-
-defcode("immediate", immediate, 1, &hidden){
- ((word_t*)*(ArgStack))->flags.attr.immed ^= 1;
-}
-
-defcode(":", colon, 0, &immediate){
- EXEC(fetchtok);
- EXEC(parsetok);
- ArgStack--;
- EXEC(create);
- EXEC(rbrack);
-}
-
-defcode(";", semicolon, 1, &colon){
- EXEC(lbrack);
- EXEC(hidden);
- ArgStack--;
-}
-
-defcode("'", tick, 1, &semicolon){
- EXEC(fetchtok);
- EXEC(parsetok);
- ArgStack--;
- EXEC(find);
-}
-
-defcode("interp", interp, 0, &parsetok){
- char* p_str = NULL;
- EXEC(fetchtok);
- EXEC(parsetok);
- /* If what we parsed was a word */
- if(*ArgStack == WORD)
- {
- /* Consume the type token and save off the string pointer */
- ArgStack--;
- p_str = (char*)*ArgStack;
- /* Search for the word in the dictionary */
- EXEC(find);
- /* If we found a definition */
- if(*ArgStack)
- {
- /* And the definition is marked immediate or we're in immediate mode */
- if((state_val == 0) || (((word_t*)*ArgStack)->flags.attr.immed))
- {
- /* Execute it */
- EXEC(exec);
- }
- /* Otherwise, compile it! */
- else
- {
- EXEC(comma);
- }
- }
- /* We didn't find a definition */
- else
- {
- /* Ask the user what gives */
- pal_unknown_word(p_str);
- /* Consume the token */
- ArgStack--;
- }
- }
- /* What we parsed is a literal and we're in compile mode */
- else if (state_val == 1)
- {
- *(ArgStack) = (val_t)&lit;
- EXEC(comma);
- EXEC(comma);
- }
- else
- {
- ArgStack--;
- }
-
- /* If we saved off a pointer, we're done with it so free the memory */
- if(p_str) pal_free(p_str);
-}
-
-defcode("quit", quit, 0, &interp){
- while(1)
- {
- pal_prompt();
- EXEC(interp);
- }
-}
-
-/* Stack Manipulation Words
- *****************************************************************************/
-defcode("drop", drop, 0, &tick){
- ArgStack--;
-}
-
-defcode("swap", swap, 0, &drop){
- val_t temp = *(ArgStack);
- *(ArgStack) = *(ArgStack-1);
- *(ArgStack-1) = temp;
-}
-
-defcode("dup", dup, 0, &swap){
- ArgStack++;
- *(ArgStack) = *(ArgStack-1);
-}
-
-defcode("over", over, 0, &dup){
- ArgStack++;
- *(ArgStack) = *(ArgStack-2);
-}
-
-defcode("rot", rot, 0, &over){
- val_t temp = *(ArgStack);
- *(ArgStack) = *(ArgStack-1);
- *(ArgStack-1) = *(ArgStack-2);
- *(ArgStack-2) = temp;
-}
-
-defcode("-rot", nrot, 0, &rot){
- val_t temp = *(ArgStack-2);
- *(ArgStack-2) = *(ArgStack-1);
- *(ArgStack-1) = *(ArgStack);
- *(ArgStack) = temp;
-}
-
-/* Arithmetic Words
- *****************************************************************************/
-defcode("+", add, 0, &nrot){
- *(ArgStack-1) += *(ArgStack);
- ArgStack--;
-}
-
-defcode("-", sub, 0, &add){
- *(ArgStack-1) -= *(ArgStack);
- ArgStack--;
-}
-
-defcode("*", mul, 0, &sub){
- *(ArgStack-1) *= *(ArgStack);
- ArgStack--;
-}
-
-defcode("/", div, 0, &mul){
- *(ArgStack-1) /= *(ArgStack);
- ArgStack--;
-}
-
-defcode("%", mod, 0, &div){
- *(ArgStack-1) %= *(ArgStack);
- ArgStack--;
-}
-
-/* Boolean Conditional Words
- *****************************************************************************/
-defcode("=", equal, 0, &mod){
- *(ArgStack-1) = *(ArgStack-1) == *(ArgStack);
- ArgStack--;
-}
-
-defcode("!=", notequal, 0, &equal){
- *(ArgStack-1) = *(ArgStack-1) != *(ArgStack);
- ArgStack--;
-}
-
-defcode("<", lessthan, 0, ¬equal){
- *(ArgStack-1) = *(ArgStack-1) < *(ArgStack);
- ArgStack--;
-}
-
-defcode(">", greaterthan, 0, &lessthan){
- *(ArgStack-1) = *(ArgStack-1) > *(ArgStack);
- ArgStack--;
-}
-
-defcode("<=", lessthaneq, 0, &greaterthan){
- *(ArgStack-1) = *(ArgStack-1) <= *(ArgStack);
- ArgStack--;
-}
-
-defcode(">=", greaterthaneq, 0, &lessthaneq){
- *(ArgStack-1) = *(ArgStack-1) >= *(ArgStack);
- ArgStack--;
-}
-
-defcode("and", and, 0, &greaterthaneq){
- *(ArgStack-1) = *(ArgStack-1) && *(ArgStack);
- ArgStack--;
-}
-
-defcode("or", or, 0, &and){
- *(ArgStack-1) = *(ArgStack-1) || *(ArgStack);
- ArgStack--;
-}
-
-defcode("not", not, 0, &or){
- *(ArgStack) = !(*(ArgStack));
-}
-
-/* Bitwise Words
- *****************************************************************************/
-defcode("band", band, 0, ¬){
- *(ArgStack-1) = *(ArgStack-1) & *(ArgStack);
- ArgStack--;
-}
-
-defcode("bor", bor, 0, &band){
- *(ArgStack-1) = *(ArgStack-1) | *(ArgStack);
- ArgStack--;
-}
-
-defcode("bxor", bxor, 0, &bor){
- *(ArgStack-1) = *(ArgStack-1) ^ *(ArgStack);
- ArgStack--;
-}
-
-defcode("bnot", bnot, 0, &bxor){
- *(ArgStack) = ~(*(ArgStack));
-}
-
-/* Memory Manipulation Words
- *****************************************************************************/
-defcode("!", store, 0, &bnot){
- *((val_t*)*(ArgStack)) = *(ArgStack-1);
- ArgStack -= 2;
-}
-
-defcode("@", fetch, 0, &store){
- *(ArgStack) = *((val_t*)*(ArgStack));
-}
-
-defcode("+!", addstore, 0, &fetch){
- *((val_t*)*(ArgStack)) += *(ArgStack-1);
- ArgStack -= 2;
-}
-
-defcode("-!", substore, 0, &addstore){
- *((val_t*)*(ArgStack)) -= *(ArgStack-1);
- ArgStack -= 2;
-}
-
-defcode("b!", bytestore, 0, &substore){
- *((char*)*(ArgStack)) = (char)*(ArgStack-1);
- ArgStack -= 2;
-}
-
-defcode("b@", bytefetch, 0, &bytestore){
- *(ArgStack) = *((char*)*(ArgStack));
-}
-
-defcode("b@b!", bytecopy, 0, &bytefetch){
-}
-
-defcode("bmove", bytemove, 0, &bytecopy){
-}
-
-int main(int argc, char** argv)
-{
- (void)argc;
- (void)argv;
- /* Compile-time Assertions */
- CT_ASSERT(sizeof(val_t) == sizeof(val_t*));
- CT_ASSERT(sizeof(val_t) == sizeof(flags_t));
-
- /* Platform specific initialization */
- latest_val = (val_t)&bytemove;
-
- /* Start the interpreter */
- EXEC(quit);
- return 0;
-}
-
-/* Debugging Words
- *****************************************************************************/
-#if 0
-defcode("printw", printw, 0, &mem_free){
- word_t* word = (word_t*)*(ArgStack);
- val_t* bytecode = word->code;
- ArgStack--;
-
- printf("Name: %s\n", word->name);
- //printf("Flags: 0x%lX\n", word->flags);
- if (word->codeword == &docolon)
- {
- puts("CodeFn: docolon");
- puts("Bytecode:");
- while(bytecode)
- {
- if (*bytecode == (val_t)&literal)
- {
- bytecode++;
- printf("\tlit %ld\n", *bytecode);
- }
- else if (*bytecode == (val_t)&zbranch)
- {
- bytecode++;
- printf("\t0br %ld\n", *bytecode);
- }
- else if (*bytecode == (val_t)&branch)
- {
- bytecode++;
- printf("\tbr %ld\n", *bytecode);
- }
- else
- {
- printf("\t%s\n", ((word_t*) *bytecode)->name);
- }
-
- if (*bytecode == (val_t)&ret)
- {
- bytecode = 0;
- break;
- }
- else
- {
- bytecode++;
- }
- }
- }
- else
- {
- printf("CodeFn: 0x%lX\n",(val_t)word->codeword);
- printf("Bytecode: (native)\n");
- }
-}
-
-defcode("printallw", printallw, 0, &printw){
- const word_t* word = (word_t*)latest_val;
- while(word)
- {
- puts(word->name);
- word = word->link;
- }
-}
-
-defcode("printdefw", printdefw, 0, &printallw){
- const word_t* word = (word_t*)latest_val;
- while(word != &printdefw)
- {
- printf("%s\t%ld %ld",
- word->name,
- word->flags.attr.immed,
- word->flags.attr.hidden);
- word = word->link;
- }
-}
-#endif
-
+#include "slvm.h"\r
+#include "parser.h"\r
+#include "pal.h"\r
+\r
+/*\r
+ Wish List:\r
+\r
+ * Dynamic Loading and Unloading of Dictionaries (File, Object, or Dynamic Lib)\r
+ * Rework w* words to allow gettign and setting attributes of a word\r
+ * Add optional debugging words\r
+ * Add optional floating point / fixed point words\r
+ * Add optional runtime integrity checks\r
+ * Add optional static heap replacement for malloc, realloc, free\r
+ * Add optional support for embedded systems (No dependence on stdlib)\r
+ * Run through profiler and optimize execution speed where possible.\r
+ * Add optional support for temporaries\r
+ * Add optional code optimizer for compiled words\r
+ * Add ability to compile to simple object file\r
+ * Add ability to compile to shared library\r
+ * Add ability to compile to standalone executable\r
+ * Add support for multi-tasking\r
+ * Add support for multi-tasking with multiple cores/threads\r
+\r
+*/\r
+\r
+/* Inner Interpreter\r
+ *****************************************************************************/\r
+void docolon(val_t* code) {\r
+ word_t* word;\r
+ /* We may have previously been executing a word so we should save off our\r
+ * previous position */\r
+ val_t* prev_code = CodePtr;\r
+ /* Set the next instruction to execute */\r
+ CodePtr = code;\r
+ /* Loop through until "ret" sets the code pointer to null */\r
+ while(CodePtr)\r
+ {\r
+ word = (word_t*)*CodePtr;\r
+ /* Increment the instruction pointer */\r
+ CodePtr++;\r
+ /* Execute the byte code instruction */\r
+ word->codeword(CodePtr);\r
+ }\r
+ /* Execution finished lets put things back the way they were */\r
+ CodePtr = prev_code;\r
+}\r
+\r
+/* Built-in Constants\r
+ *****************************************************************************/\r
+defconst("VERSION", version, 0, NULL, 1)\r
+defconst("EXECDEF", execdef, 0, &version, (val_t)&docolon)\r
+defconst("WORDSZ", wordsz, 0, &execdef, sizeof(val_t))\r
+\r
+/* Built-in Variables\r
+ *****************************************************************************/\r
+defvar("state", state, 0, &wordsz, 0)\r
+defvar("latest", latest, 0, &state, 0)\r
+\r
+/* Word Words\r
+ *****************************************************************************/\r
+defcode("wlink", wlink, 0, &latest){\r
+ *(ArgStack) = (val_t)(((word_t*)*(ArgStack))->link);\r
+}\r
+\r
+defcode("wsize", wflags, 0, &wlink){\r
+ *(ArgStack) = (val_t)(((word_t*)*(ArgStack))->flags.attr.codesize);\r
+}\r
+\r
+defcode("wname", wname, 0, &wflags){\r
+ *(ArgStack) = (val_t)(((word_t*)*(ArgStack))->name);\r
+}\r
+\r
+defcode("wfunc", wfunc, 0, &wname){\r
+ *(ArgStack) = (val_t)(((word_t*)*(ArgStack))->codeword);\r
+}\r
+\r
+defcode("wcode", wcode, 0, &wfunc){\r
+ *(ArgStack) = (val_t)(((word_t*)*(ArgStack))->code);\r
+}\r
+\r
+defcode("here", here, 0, &wcode){\r
+ ArgStack++;\r
+ *(ArgStack) = (val_t)((((word_t*)latest_val)->flags.attr.codesize) - 1);\r
+}\r
+\r
+/* Interpreter Words\r
+ *****************************************************************************/\r
+defcode("exec", exec, 0, &here){\r
+ word_t* word = (word_t*)(*ArgStack);\r
+ ArgStack--;\r
+ EXEC( *(word) );\r
+}\r
+\r
+defcode("find", find, 0, &exec){\r
+ word_t const* curr = (word_t const*)latest_val;\r
+ char* name = (char*)*(ArgStack);\r
+ while(curr)\r
+ {\r
+ if (!(curr->flags.attr.hidden) && (0 == pal_strcmp(curr->name,name)))\r
+ {\r
+ break;\r
+ }\r
+ curr = curr->link;\r
+ }\r
+ *(ArgStack) = (val_t)curr;\r
+}\r
+\r
+defcode("fetchtok", fetchtok, 0, &find){\r
+ ArgStack++;\r
+ *(ArgStack) = (val_t)fetch_token();\r
+}\r
+\r
+defcode("parsetok", parsetok, 0, &fetchtok){\r
+ char* p_str = (char*)*(ArgStack);\r
+ ArgStack++;\r
+ *(ArgStack) = (val_t)parse_token( p_str, ArgStack-1 );\r
+ /* If the parsed token no longer needs the original string */\r
+ if (*(ArgStack) > STRING)\r
+ {\r
+ /* Free the mem */\r
+ pal_free(p_str);\r
+ }\r
+}\r
+\r
+/* Branching and Literal Words\r
+ *****************************************************************************/\r
+defcode("lit", lit, 0, &parsetok){\r
+ ArgStack++;\r
+ *(ArgStack) = *CodePtr;\r
+ CodePtr++;\r
+}\r
+\r
+defcode("br", br, 0, &lit){\r
+ CodePtr = (val_t*)(((val_t)CodePtr) + (*(CodePtr) * sizeof(val_t)));\r
+}\r
+\r
+defcode("0br", zbr, 0, &br){\r
+ if (*ArgStack == 0)\r
+ {\r
+ CodePtr = (val_t*)(((val_t)CodePtr) + (*(CodePtr) * sizeof(val_t)));\r
+ }\r
+ else\r
+ {\r
+ CodePtr++;\r
+ }\r
+ ArgStack--;\r
+}\r
+\r
+/* Compiler Words\r
+ *****************************************************************************/\r
+defcode("ret", ret, 0, &zbr){\r
+ CodePtr = 0;\r
+}\r
+\r
+defcode("[", lbrack, 0, &ret){\r
+ state_val = 0;\r
+}\r
+\r
+defcode("]", rbrack, 1, &lbrack){\r
+ state_val = 1;\r
+}\r
+\r
+defcode("create", create, 0, &rbrack){\r
+ /* Copy the name string */\r
+ char* name = 0u;\r
+ if (*(ArgStack))\r
+ {\r
+ size_t namesz = pal_strlen((char*)*(ArgStack));\r
+ name = (char*)pal_allocate( namesz );\r
+ pal_strcpy(name, (char*)*(ArgStack));\r
+ }\r
+ /* Create the word entry */\r
+ word_t* word = (word_t*)pal_allocate(sizeof(word_t));\r
+ word->link = (word_t*)latest_val;\r
+ /* Initialize the flags (hidden and non-immediate by default) */\r
+ word->flags.attr.immed = 0;\r
+ word->flags.attr.hidden = 1;\r
+ word->flags.attr.codesize = 1;\r
+ /* Initialize the name, codeword, and bytecode */\r
+ word->name = name;\r
+ word->codeword = &docolon;\r
+ word->code = (val_t*)pal_allocate(sizeof(val_t));\r
+ word->code[0] = (val_t)&ret;\r
+ /* Update Latest and Return the new word */\r
+ latest_val = (val_t)word;\r
+ *(ArgStack) = (val_t)word;\r
+}\r
+\r
+defcode(",", comma, 0, &create){\r
+ /* Get the word we are currently compiling */\r
+ word_t* word = (word_t*)latest_val;\r
+ /* Put the next instruction in place of the terminating 'ret' that "here"\r
+ * points too */\r
+ word->code[word->flags.attr.codesize-1] = *(ArgStack);\r
+ ArgStack--;\r
+ /* Resize the code section and relocate if necessary */\r
+ word->flags.attr.codesize++;\r
+ word->code = (val_t*)pal_reallocate(word->code, word->flags.attr.codesize * sizeof(val_t));\r
+ /* Update "here" and terminate the code section */\r
+ word->code[word->flags.attr.codesize-1] = (val_t)&ret;\r
+}\r
+\r
+defcode("hidden", hidden, 1, &comma){\r
+ ((word_t*)*(ArgStack))->flags.attr.hidden ^= 1;\r
+}\r
+\r
+defcode("immediate", immediate, 1, &hidden){\r
+ ((word_t*)*(ArgStack))->flags.attr.immed ^= 1;\r
+}\r
+\r
+defcode(":", colon, 0, &immediate){\r
+ EXEC(fetchtok);\r
+ EXEC(parsetok);\r
+ ArgStack--;\r
+ EXEC(create);\r
+ EXEC(rbrack);\r
+}\r
+\r
+defcode(";", semicolon, 1, &colon){\r
+ EXEC(lbrack);\r
+ EXEC(hidden);\r
+ ArgStack--;\r
+}\r
+\r
+defcode("'", tick, 1, &semicolon){\r
+ EXEC(fetchtok);\r
+ EXEC(parsetok);\r
+ ArgStack--;\r
+ EXEC(find);\r
+}\r
+\r
+defcode("interp", interp, 0, &parsetok){\r
+ char* p_str = NULL;\r
+ EXEC(fetchtok);\r
+ EXEC(parsetok);\r
+ /* If what we parsed was a word */\r
+ if(*ArgStack == WORD)\r
+ {\r
+ /* Consume the type token and save off the string pointer */\r
+ ArgStack--;\r
+ p_str = (char*)*ArgStack;\r
+ /* Search for the word in the dictionary */\r
+ EXEC(find);\r
+ /* If we found a definition */\r
+ if(*ArgStack)\r
+ {\r
+ /* And the definition is marked immediate or we're in immediate mode */\r
+ if((state_val == 0) || (((word_t*)*ArgStack)->flags.attr.immed))\r
+ {\r
+ /* Execute it */\r
+ EXEC(exec);\r
+ }\r
+ /* Otherwise, compile it! */\r
+ else\r
+ {\r
+ EXEC(comma);\r
+ }\r
+ }\r
+ /* We didn't find a definition */\r
+ else\r
+ {\r
+ /* Ask the user what gives */\r
+ pal_unknown_word(p_str);\r
+ /* Consume the token */\r
+ ArgStack--;\r
+ }\r
+ }\r
+ /* What we parsed is a literal and we're in compile mode */\r
+ else if (state_val == 1)\r
+ {\r
+ *(ArgStack) = (val_t)&lit;\r
+ EXEC(comma);\r
+ EXEC(comma);\r
+ }\r
+ else\r
+ {\r
+ ArgStack--;\r
+ }\r
+\r
+ /* If we saved off a pointer, we're done with it so free the memory */\r
+ if(p_str) pal_free(p_str);\r
+}\r
+\r
+defcode("quit", quit, 0, &interp){\r
+ while(1)\r
+ {\r
+ pal_prompt();\r
+ EXEC(interp);\r
+ }\r
+}\r
+\r
+/* Stack Manipulation Words\r
+ *****************************************************************************/\r
+defcode("drop", drop, 0, &tick){\r
+ ArgStack--;\r
+}\r
+\r
+defcode("swap", swap, 0, &drop){\r
+ val_t temp = *(ArgStack);\r
+ *(ArgStack) = *(ArgStack-1);\r
+ *(ArgStack-1) = temp;\r
+}\r
+\r
+defcode("dup", dup, 0, &swap){\r
+ ArgStack++;\r
+ *(ArgStack) = *(ArgStack-1);\r
+}\r
+\r
+defcode("over", over, 0, &dup){\r
+ ArgStack++;\r
+ *(ArgStack) = *(ArgStack-2);\r
+}\r
+\r
+defcode("rot", rot, 0, &over){\r
+ val_t temp = *(ArgStack);\r
+ *(ArgStack) = *(ArgStack-1);\r
+ *(ArgStack-1) = *(ArgStack-2);\r
+ *(ArgStack-2) = temp;\r
+}\r
+\r
+defcode("-rot", nrot, 0, &rot){\r
+ val_t temp = *(ArgStack-2);\r
+ *(ArgStack-2) = *(ArgStack-1);\r
+ *(ArgStack-1) = *(ArgStack);\r
+ *(ArgStack) = temp;\r
+}\r
+\r
+/* Arithmetic Words\r
+ *****************************************************************************/\r
+defcode("+", add, 0, &nrot){\r
+ *(ArgStack-1) += *(ArgStack);\r
+ ArgStack--;\r
+}\r
+\r
+defcode("-", sub, 0, &add){\r
+ *(ArgStack-1) -= *(ArgStack);\r
+ ArgStack--;\r
+}\r
+\r
+defcode("*", mul, 0, &sub){\r
+ *(ArgStack-1) *= *(ArgStack);\r
+ ArgStack--;\r
+}\r
+\r
+defcode("/", div, 0, &mul){\r
+ *(ArgStack-1) /= *(ArgStack);\r
+ ArgStack--;\r
+}\r
+\r
+defcode("%", mod, 0, &div){\r
+ *(ArgStack-1) %= *(ArgStack);\r
+ ArgStack--;\r
+}\r
+\r
+/* Boolean Conditional Words\r
+ *****************************************************************************/\r
+defcode("=", equal, 0, &mod){\r
+ *(ArgStack-1) = *(ArgStack-1) == *(ArgStack);\r
+ ArgStack--;\r
+}\r
+\r
+defcode("!=", notequal, 0, &equal){\r
+ *(ArgStack-1) = *(ArgStack-1) != *(ArgStack);\r
+ ArgStack--;\r
+}\r
+\r
+defcode("<", lessthan, 0, ¬equal){\r
+ *(ArgStack-1) = *(ArgStack-1) < *(ArgStack);\r
+ ArgStack--;\r
+}\r
+\r
+defcode(">", greaterthan, 0, &lessthan){\r
+ *(ArgStack-1) = *(ArgStack-1) > *(ArgStack);\r
+ ArgStack--;\r
+}\r
+\r
+defcode("<=", lessthaneq, 0, &greaterthan){\r
+ *(ArgStack-1) = *(ArgStack-1) <= *(ArgStack);\r
+ ArgStack--;\r
+}\r
+\r
+defcode(">=", greaterthaneq, 0, &lessthaneq){\r
+ *(ArgStack-1) = *(ArgStack-1) >= *(ArgStack);\r
+ ArgStack--;\r
+}\r
+\r
+defcode("and", and, 0, &greaterthaneq){\r
+ *(ArgStack-1) = *(ArgStack-1) && *(ArgStack);\r
+ ArgStack--;\r
+}\r
+\r
+defcode("or", or, 0, &and){\r
+ *(ArgStack-1) = *(ArgStack-1) || *(ArgStack);\r
+ ArgStack--;\r
+}\r
+\r
+defcode("not", not, 0, &or){\r
+ *(ArgStack) = !(*(ArgStack));\r
+}\r
+\r
+/* Bitwise Words\r
+ *****************************************************************************/\r
+defcode("band", band, 0, ¬){\r
+ *(ArgStack-1) = *(ArgStack-1) & *(ArgStack);\r
+ ArgStack--;\r
+}\r
+\r
+defcode("bor", bor, 0, &band){\r
+ *(ArgStack-1) = *(ArgStack-1) | *(ArgStack);\r
+ ArgStack--;\r
+}\r
+\r
+defcode("bxor", bxor, 0, &bor){\r
+ *(ArgStack-1) = *(ArgStack-1) ^ *(ArgStack);\r
+ ArgStack--;\r
+}\r
+\r
+defcode("bnot", bnot, 0, &bxor){\r
+ *(ArgStack) = ~(*(ArgStack));\r
+}\r
+\r
+/* Memory Manipulation Words\r
+ *****************************************************************************/\r
+defcode("!", store, 0, &bnot){\r
+ *((val_t*)*(ArgStack)) = *(ArgStack-1);\r
+ ArgStack -= 2;\r
+}\r
+\r
+defcode("@", fetch, 0, &store){\r
+ *(ArgStack) = *((val_t*)*(ArgStack));\r
+}\r
+\r
+defcode("+!", addstore, 0, &fetch){\r
+ *((val_t*)*(ArgStack)) += *(ArgStack-1);\r
+ ArgStack -= 2;\r
+}\r
+\r
+defcode("-!", substore, 0, &addstore){\r
+ *((val_t*)*(ArgStack)) -= *(ArgStack-1);\r
+ ArgStack -= 2;\r
+}\r
+\r
+defcode("b!", bytestore, 0, &substore){\r
+ *((char*)*(ArgStack)) = (char)*(ArgStack-1);\r
+ ArgStack -= 2;\r
+}\r
+\r
+defcode("b@", bytefetch, 0, &bytestore){\r
+ *(ArgStack) = *((char*)*(ArgStack));\r
+}\r
+\r
+defcode("b@b!", bytecopy, 0, &bytefetch){\r
+}\r
+\r
+defcode("bmove", bytemove, 0, &bytecopy){\r
+}\r
+\r
+int main(int argc, char** argv)\r
+{\r
+ (void)argc;\r
+ (void)argv;\r
+ /* Compile-time Assertions */\r
+ CT_ASSERT(sizeof(val_t) == sizeof(val_t*));\r
+ CT_ASSERT(sizeof(val_t) == sizeof(flags_t));\r
+\r
+ /* Platform specific initialization */\r
+ latest_val = (val_t)&bytemove;\r
+\r
+ /* Start the interpreter */\r
+ EXEC(quit);\r
+ return 0;\r
+}\r
+\r
+/* Debugging Words\r
+ *****************************************************************************/\r
+#if 0\r
+defcode("printw", printw, 0, &mem_free){\r
+ word_t* word = (word_t*)*(ArgStack);\r
+ val_t* bytecode = word->code;\r
+ ArgStack--;\r
+\r
+ printf("Name: %s\n", word->name);\r
+ //printf("Flags: 0x%lX\n", word->flags);\r
+ if (word->codeword == &docolon)\r
+ {\r
+ puts("CodeFn: docolon");\r
+ puts("Bytecode:");\r
+ while(bytecode)\r
+ {\r
+ if (*bytecode == (val_t)&literal)\r
+ {\r
+ bytecode++;\r
+ printf("\tlit %ld\n", *bytecode);\r
+ }\r
+ else if (*bytecode == (val_t)&zbranch)\r
+ {\r
+ bytecode++;\r
+ printf("\t0br %ld\n", *bytecode);\r
+ }\r
+ else if (*bytecode == (val_t)&branch)\r
+ {\r
+ bytecode++;\r
+ printf("\tbr %ld\n", *bytecode);\r
+ }\r
+ else\r
+ {\r
+ printf("\t%s\n", ((word_t*) *bytecode)->name);\r
+ }\r
+\r
+ if (*bytecode == (val_t)&ret)\r
+ {\r
+ bytecode = 0;\r
+ break;\r
+ }\r
+ else\r
+ {\r
+ bytecode++;\r
+ }\r
+ }\r
+ }\r
+ else\r
+ {\r
+ printf("CodeFn: 0x%lX\n",(val_t)word->codeword);\r
+ printf("Bytecode: (native)\n");\r
+ }\r
+}\r
+\r
+defcode("printallw", printallw, 0, &printw){\r
+ const word_t* word = (word_t*)latest_val;\r
+ while(word)\r
+ {\r
+ puts(word->name);\r
+ word = word->link;\r
+ }\r
+}\r
+\r
+defcode("printdefw", printdefw, 0, &printallw){\r
+ const word_t* word = (word_t*)latest_val;\r
+ while(word != &printdefw)\r
+ {\r
+ printf("%s\t%ld %ld",\r
+ word->name,\r
+ word->flags.attr.immed,\r
+ word->flags.attr.hidden);\r
+ word = word->link;\r
+ }\r
+}\r
+#endif\r
+\r
projects / proto / sclpl.git / commitdiff