aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-xbuild-setup.sh1
-rw-r--r--src/ChangeLog20
-rw-r--r--src/boot/Makefile.in191
-rw-r--r--src/boot/Makefile.pamphlet1630
-rw-r--r--src/boot/ast.boot1087
-rw-r--r--src/boot/includer.boot390
-rw-r--r--src/boot/includer.boot.pamphlet1226
-rw-r--r--src/boot/initial-env.lisp (renamed from src/boot/initial-env.lisp.pamphlet)174
-rw-r--r--src/boot/parser.boot1041
-rw-r--r--src/boot/pile.boot143
-rw-r--r--src/boot/scanner.boot514
-rw-r--r--src/boot/strap/ast.clisp (renamed from src/boot/ast.boot.pamphlet)1517
-rw-r--r--src/boot/strap/includer.clisp553
-rw-r--r--src/boot/strap/parser.clisp (renamed from src/boot/parser.boot.pamphlet)1161
-rw-r--r--src/boot/strap/pile.clisp (renamed from src/boot/pile.boot.pamphlet)171
-rw-r--r--src/boot/strap/scanner.clisp (renamed from src/boot/scanner.boot.pamphlet)537
-rw-r--r--src/boot/strap/tokens.clisp352
-rw-r--r--src/boot/strap/translator.clisp (renamed from src/boot/translator.boot.pamphlet)861
-rw-r--r--src/boot/tokens.boot411
-rw-r--r--src/boot/tokens.boot.pamphlet897
-rw-r--r--src/boot/translator.boot751
21 files changed, 5719 insertions, 7909 deletions
diff --git a/build-setup.sh b/build-setup.sh
index 295b8064..b177598e 100755
--- a/build-setup.sh
+++ b/build-setup.sh
@@ -17,7 +17,6 @@ autoconf || error "could not re-generate configure"
## subdirectories that contain Makefile pamphlets of interest
SUBDIRS=" . \
src \
- src/boot \
src/interp \
src/algebra \
src/input \
diff --git a/src/ChangeLog b/src/ChangeLog
index c52458b5..5bdbf5f8 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,25 @@
2008-01-27 Gabriel Dos Reis <gdr@cs.tamu.edu>
+ * boot/Makefile.pamphlet: Remove.
+ * boot/translator.boot: New.
+ * boot/translator.boot: Remove.
+ * boot/tokens.boot: New.
+ * boot/tokens.boot.pamphlet: Remove.
+ * boot/scanner.boot: New.
+ * boot/scanner.boot.pamphlet: Remove.
+ * boot/pile.boot: New.
+ * boot/pile.boot.pamphlet: Remove.
+ * boot/parser.boot: New.
+ * boot/parser.boot.pamphlet: New.
+ * boot/initial-env.lisp: New.
+ * boot/initial-env.lisp.pamphlet: Remove.
+ * boot/includer.boot: New.
+ * boot/includer.boot.pamphlet: Remove.
+ * boot/ast.boot: New.
+ * boot/ast.boot.pamphlet: Remove.
+
+2008-01-27 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
Fix SF/1872551
* interp/c-util.boot (dollarIfRepHack): New.
(RepIfRepHack): Likewise.
diff --git a/src/boot/Makefile.in b/src/boot/Makefile.in
index 94d98c33..c438d385 100644
--- a/src/boot/Makefile.in
+++ b/src/boot/Makefile.in
@@ -1,9 +1,68 @@
+## Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
+## All rights reserved.
+## Copyright (C) 2007-2008, Gabriel Dos Reis.
+## 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.
+##
+## - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+## names of its contributors may be used to endorse or promote products
+## derived from this software without specific prior written permission.
+##
+## 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 OWNER
+## 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.
+##
+
+##
+## Abstract:
+## OpenAxiom is built in layers. The first layer is contructed into
+## an image called `bootsys'. The `bootsys' image is used
+## to translate Boot code to Common Lisp code. Since a Boot coded
+## interpreter is needed to translate the code for the Boot coded
+## interpreter we have a ``boot-strapping'' problem. In order to get
+## the whole process to start we need certain files kept in
+## common lisp form. This directory contains those files.
+##
+
+## We start with a Lisp image created in a previous build step (src/lisp).
+## That image is used to build Boot translator executable through the
+## entire bootstrap process.
+
AXIOM_LOCAL_LISP_sources = initial-env.lisp
AXIOM_LOCAL_LISP = ../lisp/lisp$(EXEEXT)
-PROCLAIMS=(load "$(srcdir)/boot-proclaims.lisp")
+
+## FASLs that comprises `bootsys'
+boot_SOURCES = initial-env.lisp $(boot_sources)
+boot_sources = tokens.boot includer.boot scanner.boot \
+ pile.boot ast.boot parser.boot translator.boot
+boot_clisp = $(boot_sources:.boot=.clisp)
boot_objects = initial-env.$(FASLEXT) $(boot_sources:.boot=.$(FASLEXT))
+# Garbage produced by GCL during compilation
+boot_data = $(boot_sources:.boot=.data)
+boot_fn = $(boot_sources:.boot=.fn)
+
+##
## ECL's program construction model is not based on image-dumping. It is
## closer to `traditional C' application building. Therefore, since
## bootsys is an augmentation of base-lisp, we need to have the objects
@@ -12,28 +71,10 @@ ifeq (@axiom_lisp_flavor@,ecl)
boot_objects_extra = ../lisp/core.$(FASLEXT)
endif
-boot_SOURCES = \
- initial-env.lisp.pamphlet \
- $(addsuffix .pamphlet, $(boot_sources))
-
-pamphlets = Makefile.pamphlet $(boot_SOURCES)
-boot_sources = tokens.boot includer.boot scanner.boot \
- pile.boot ast.boot parser.boot translator.boot
-
-boot_clisp = $(boot_sources:.boot=.clisp)
-boot_data = $(boot_sources:.boot=.data)
-boot_fn = $(boot_sources:.boot=.fn)
-boot_cached_clisp = $(boot_sources:.boot=.clisp)
-
-COMPILE_LISP = \
- $(axiom_build_document) --tag=lisp --mode=compile --output=$@
-
-BOOT_TO_LISP = \
- $(axiom_build_document) --tag=boot --mode=translate \
- --use=./prev-stage/bootsys $<
-
+# reference to this directory from toplevel
subdir = src/boot/
+## Make rule toplevel entry points.
.PHONY: all-ax all-boot
all: all-ax all-boot
@@ -43,119 +84,139 @@ stamp: $(axiom_build_bindir)/bootsys$(EXEEXT)
@rm -f stamp
$(STAMP) $@
+## The final `bootsys' image.
$(axiom_build_bindir)/bootsys$(EXEEXT): stage2/bootsys$(EXEEXT)
$(mkinstalldirs) $(axiom_build_bindir)
$(INSTALL_PROGRAM) stage2/bootsys$(EXEEXT) $(axiom_build_bindir)
-.PRECIOUS: stage0/%.clisp
-.PRECIOUS: stage0/%.$(FASLEXT)
+.PRECIOUS: strap/%.$(FASLEXT)
+
+##
+## The bootstrapping `bootsys' image.
+##
-stage0_boot_clisp = $(addprefix stage0/, $(boot_clisp))
+# The bootstrapping Lisp code is cached in the subdirectory strap/.
+# It is built first, followed by stage 1, and stage 2 `bootsys' images.
+strap_boot_clisp = $(addprefix strap/, $(boot_clisp))
-stage0_boot_objects = $(addprefix stage0/, $(boot_objects))
+strap_boot_objects = \
+ $(addprefix strap/, $(boot_objects))
-stage0/stamp: stage0/bootsys$(EXEEXT)
+strap/stamp: strap/bootsys$(EXEEXT)
@rm -f $@
@$(STAMP) $@
-stage0/bootsys$(EXEEXT): $(stage0_boot_objects)
+strap/bootsys$(EXEEXT): $(strap_boot_objects)
$(AXIOM_LOCAL_LISP) -- --make --main="|AxiomCore|::|topLevel|"\
- --output=$@ --load-directory=stage0 \
- $(boot_objects_extra) $(stage0_boot_objects)
+ --output=$@ --load-directory=strap \
+ $(boot_objects_extra) $(strap_boot_objects)
-.PRECIOUS: %/.started
-%/.started:
- $(mkinstalldirs) $*
- $(STAMP) $@
-
-$(stage0_boot_objects): $(AXIOM_LOCAL_LISP)
-
-stage0/%.clisp: $(srcdir)/%.boot.pamphlet stage0/.started
- $(axiom_build_document) --tangle=$*.clisp --output=$@ $<
+$(strap_boot_objects): $(AXIOM_LOCAL_LISP)
-%/initial-env.$(FASLEXT): initial-env.lisp %/.started
- $(AXIOM_LOCAL_LISP) -- --compile --output=$@ $<
+##
+## Stage 1 `bootsys' image.
+##
.PRECIOUS: stage1/%.$(FASLEXT)
.PRECIOUS: stage1/%.clisp
+stage1_boot_clisp = $(addprefix stage1/, $(boot_clisp))
+
+stage1_boot_objects = \
+ $(addprefix stage1/, $(boot_objects))
+
stage1/stamp: stage1/bootsys$(EXEEXT)
rm -f $@
$(STAMP) $@
-stage1/bootsys$(EXEEXT): $(addprefix stage1/, $(boot_objects))
+stage1/bootsys$(EXEEXT): $(stage1_boot_objects)
$(AXIOM_LOCAL_LISP) -- --make --main="|AxiomCore|::|topLevel|" \
--output=$@ --load-directory=stage1 \
- $(boot_objects_extra) $(addprefix stage1/, $(boot_objects))
+ $(boot_objects_extra) $(stage1_boot_objects)
+
+stage1/%.clisp: %.boot strap/stamp stage1/.started
+ strap/bootsys -- --translate --output=$@ $<
+
-stage1/%.clisp: %.boot stage0/stamp stage1/.started
- stage0/bootsys -- --translate --output=$@ $<
+##
+## Stage 2 `bootsys' image.
+##
.PRECIOUS: stage2/%.$(FASLEXT)
.PRECIOUS: stage2/%.clisp
+stage2_boot_clisp = $(addprefix stage2/, $(boot_clisp))
+
+stage2_boot_objects = \
+ $(addprefix stage2/, $(boot_objects))
+
stage2/stamp: stage2/bootsys$(EXEEXT)
@echo Building stage 2
$(STAMP) $@
-stage2/bootsys$(EXEEXT): $(addprefix stage2/, $(boot_objects))
+stage2/bootsys$(EXEEXT): $(stage2_boot_objects)
$(AXIOM_LOCAL_LISP) -- --make --main="|AxiomCore|::|topLevel|" \
--output=$@ --load-directory=stage2 \
- $(boot_objects_extra) $(addprefix stage2/, $(boot_objects))
+ $(boot_objects_extra) $(stage2_boot_objects)
stage2/%.clisp: %.boot stage1/stamp stage2/.started
stage1/bootsys -- --translate --output=$@ $<
+##
+## Generic rules for compiling FASLs
+##
+
+.PRECIOUS: %/.started
+%/.started:
+ $(mkinstalldirs) $*
+ $(STAMP) $@
+
## Dependency for various modules.
## FIXME: This should be automatically extracted from the
## Boot source file at packaging time.
+%/initial-env.$(FASLEXT): initial-env.lisp %/.started
+ $(AXIOM_LOCAL_LISP) -- --compile --output=$@ $<
+
%/tokens.$(FASLEXT): %/tokens.clisp %/initial-env.$(FASLEXT)
- $(AXIOM_LOCAL_LISP) -- --compile --load-directory=$* $<
+ $(AXIOM_LOCAL_LISP) -- --output=$@ --compile --load-directory=$* $<
%/includer.$(FASLEXT): %/includer.clisp %/tokens.$(FASLEXT)
- $(AXIOM_LOCAL_LISP) -- --compile --load-directory=$* $<
+ $(AXIOM_LOCAL_LISP) -- --output=$@ --compile --load-directory=$* $<
%/scanner.$(FASLEXT): %/scanner.clisp %/tokens.$(FASLEXT) %/includer.$(FASLEXT)
- $(AXIOM_LOCAL_LISP) -- --compile --load-directory=$* $<
+ $(AXIOM_LOCAL_LISP) -- --output=$@ --compile --load-directory=$* $<
%/pile.$(FASLEXT): %/pile.clisp %/scanner.$(FASLEXT) %/includer.$(FASLEXT)
- $(AXIOM_LOCAL_LISP) -- --compile --load-directory=$* $<
+ $(AXIOM_LOCAL_LISP) -- --output=$@ --compile --load-directory=$* $<
%/ast.$(FASLEXT): %/ast.clisp %/includer.$(FASLEXT)
- $(AXIOM_LOCAL_LISP) -- --compile --load-directory=$* $<
+ $(AXIOM_LOCAL_LISP) -- --output=$@ --compile --load-directory=$* $<
%/parser.$(FASLEXT): %/parser.clisp %/ast.$(FASLEXT) %/scanner.$(FASLEXT) \
%/includer.$(FASLEXT)
- $(AXIOM_LOCAL_LISP) -- --compile --load-directory=$* $<
+ $(AXIOM_LOCAL_LISP) -- --output=$@ --compile --load-directory=$* $<
%/translator.$(FASLEXT): %/translator.clisp %/parser.$(FASLEXT) \
%/ast.$(FASLEXT) %/pile.$(FASLEXT) %/scanner.$(FASLEXT) \
%/includer.$(FASLEXT)
- $(AXIOM_LOCAL_LISP) -- --compile --load-directory=$* $<
-
-.PRECIOUS: %.boot
-%.boot: $(srcdir)/%.boot.pamphlet
- $(axiom_build_document) --tangle $<
-.PRECIOUS: %.boot
+ $(AXIOM_LOCAL_LISP) -- --output=$@ --compile --load-directory=$* $<
-%.boot: $(srcdir)/%.boot.pamphlet
- $(axiom_build_document) --tangle $<
-.PRECIOUS: %.lisp
-initial-env.lisp: initial-env.lisp.pamphlet
- $(axiom_build_document) --tangle $<
+##
+## Cleaning mess
+##
mostlyclean-local:
@rm -f $(axiom_build_bindir)/bootsys$(EXEEXT)
@rm -rf prev-stage
- @rm -rf stage0 stage1 stage2
+ @rm -rf strap stage1 stage2
@rm -f *.data *.fn
@rm -f stamp
clean-local: mostlyclean-local
@rm -f $(boot_sources)
- @rm -f *.clisp *.lisp
+ @rm -f *.clisp
distclean-local: clean-local
diff --git a/src/boot/Makefile.pamphlet b/src/boot/Makefile.pamphlet
deleted file mode 100644
index 6ce07945..00000000
--- a/src/boot/Makefile.pamphlet
+++ /dev/null
@@ -1,1630 +0,0 @@
-%% Oh Emacs, this is a -*- Makefile -*-, so give me tabs.
-\documentclass{article}
-\usepackage{axiom}
-
-\title{\File{src/boot/Makefile} Pamphlet}
-\author{Timothy Daly \and Gabriel Dos~Reis}
-
-\begin{document}
-\maketitle
-
-\begin{abstract}
- \Tool{OpenAxiom} is built in layers. The first layer is contructed into
- an image called {\bf bootsys}. The \Tool{bootsys} image is used
- to translate Boot code to Common Lisp code. Since a Boot coded
- interpreter is needed to translate the code for the Boot coded
- interpreter we have a ``boot-strapping'' problem. In order to get
- the whole process to start we need certain files kept in
- common lisp form. This directory contains those files.
-\end{abstract}
-\eject
-
-\tableofcontents
-\eject
-
-\section{Introduction}
-\label{sec:intro}
-
-The Scratchpad language is implemented by using a mixture of Lisp and
-a more convenient language for writing Lisp called \emph{Boot}.
-This document contains a description of the Boot language, and some
-details of the resulting Lisp programs.
-The description of the translation
-functions available are at the end of this file.
-
-The main difference between Lisp and Boot is in the syntax for
-the application of a function to its argument.
-The Lisp format [[(F X Y Z)]], means, when [[F]] is a function,
-the application of [[F]] to its arguments [[X]], [[Y]], and [[Z]],
-is written in Boot as [[F(X,Y,Z)]].
-When [[F]] is a special Lisp word it will be written
-in Boot by using some other syntactic construction, such as spelling
-in CAPITAL LETTERS.
-
-Boot contains an easy method of writing expressions that denote lists,
-and provides an analogous method of writing patterns containing variables
-and constants which denote a particular class of lists. The pattern
-is matched against a particular list at run time,
-and if the list belongs to the class then its variables will
-take on the values of components of the list. Similarly, Boot provides
-an easy way of writting discriminated unions or algebraic types, and
-pattern matching as found in ML.
-
- A second convenient feature provided by Boot is a method of
-writing programs that iterate over the elements of one or more lists
-and which either transform the state of the machine, or
-produce some object from the list or lists.
-
-
-\section{Boot To Common Lisp Translaters}
-\label{sec:boot-to-cl}
-
-The Boot to Common Lisp translation is organized in several
-separate logical phases. At the moment, those phases are not
-really separate; but from a logical point of view, it is better
-to think of them that way.
-
-
-\subsection{The Boot Includer}
-\label{sec:boot-to-cl:includer}
-
-The Boot Includer is the module that reads Boot codes from source files.
-The details of the Includer, as well as the grammar of the include
-files are to be found in \File{includer.boot}
-
-
-\subsection{The Scanner}
-\label{sec:boot-to-cl:scanner}
-
-The tokenization process is implemented in \File{scanner.boot}. Further
-details about keywords and reserved identifiers are available in
-\File{tokens.boot}.
-
-
-\subsection{Piling}
-\label{sec:boot-to-cl:piling}
-
-The Boot language uses layout to delimit blocks of expressions. After
-the scanner pass, and before the parser pass is another pass called
-\emph{piling}. The piling pass inserts tokens to unambiguously delimit
-the boundaries of piles. This is implemented in
-\File{pile.boot}
-
-
-\subsection{The Parser}
-\label{sec:boot-to-cl:piling}
-
-The Boot parser is implemented in \File{parser.boot}. It is a hand-written
-recursive descent parser
-based on \emph{parser combinators} methodology. Thoe files also
-implicitly defines the grammar of the Boot language.
-
-
-\subsection{The Transformer}
-\label{sec:boot-to-cl:transfo}
-
-As observed earlier, the Boot language was originally defined as a syntactic
-sugar over Common Lisp. Consequently, it semantics is defined by
-tranformation to Lisp. The transformers are defined in
-\File{ast.boot}.
-
-\subsection{Utils}
-\label{sec:boot-to-cl:utils}
-
-Finally, the file \File{translator.boot} is a pot-pourri of many utility
-functions. It also contains the entry points to the Boot translater.
-
-
-\section{Boot}
-\label{sec:boot}
-
-\subsection{Lines and Commands}
-
-If the first character of a line is a closing parenthesis the line
-is treated as a command which controls the lines that will be
-passed to the translater rather than being passed itself.
-The command [[)include filename]] filemodifier will for example
-be replaced by the lines in the file [[filename filemodifier]].
-
-If a line starts with a closing parenthesis it will be called a command
-line, otherwise it will be called a plain line.
-The command lines are
-\begin{verbatim}
-name as written
-
-Include )include filename filemodifier
-IncludeLisp )includelisp filename filemodifier
-If )if bootexpression
-Else )else
-ElseIf )elseif bootexpression
-EndIf )endif
-Fin )fin
-Say )say string
-Eval )eval bootexpression
-EvalStrings )evalstrings bootexpression
-Package )package packagename
-
-SimpleLine::= PlainLine | Include | IncludeLisp |Say | Eval | EvalStrings
- | Package
-\end{verbatim}
-
-A [[PlainLine]] is delivered to the translater as is.
-
-An [[Include]] delivers the lines in the file filename.filemodifier,
-treated as boot lines.
-
-An [[IncludeLisp]] delivers the lines in the specified file, treated as Lisp
-lines. The only comments allowed in lisp files that are included in
-this way require that the semicolon is at the beginning of the line.
-
-A [[Say]] outputs the remainder of the line to the console,
- delivering nothing to the translater.
-
-An [[Eval]] translates the reminder of the line, assumed to be
- written in Boot, to Lisp, and evaluates it, delivering nothing to
- the translater.
-
-An [[EvalStrings]] also translates and evaluates the rest of the line
- but this time assumes that the Boot expression denotes a list
- of strings which are then delivered to the translater
- instead of the EvalString line. The strings are treated as Boot lines.
-
-It is also possible to include or exclude lines based upon some
-condition which is the result of translating and evaluating
-the boot expression that follows an )if or )elseif command.
-This construction will be called a Conditional. A file will be
-composed from SimpleLines and Conditionals. A file is either
-terminated by the end of file or by a Fin line.
-\begin{verbatim}
-Components ::=(SimpleLine | Conditional)*
-
-File ::= Components ( Fin | empty)
-
-A conditional is bracketed by an If and an EndIf.
-
-Conditional ::= If Components Elselines EndIf
-\end{verbatim}
-
-If the boot expression following the )if has value true then the
-Components are delivered but not the ElseLines,
-otherwise the Components are ignored ,and the ElseLines
-are delivered to the translater. In any case the lines after
-the EndIf are then processed.
-\begin{verbatim}
-ElseLines ::= Else Components | ElseIf Components ElseLines | empty
-\end{verbatim}
-
-When the Elselines of a Conditional is being included then if an
-"Else Components" phrase is encountered then the following
-Components are included
-otherwise if an "ElseIf Components ElseLines" phrase is encountered then
-the boot expression following the )elseif is evaluated and
-if true the following Components are included, if false the
-following ElseLines is included.
-
-
-\subsection{Boot syntax and semantics}
-
-The semantics of Boot was originally defined by translation to Lisp.
-Ideally, we would like to give it a self-contained semantics,
-without explicitly referring to Lisp, or if we must we should use
-lambda calculus.
-
-\subsubsection{Source character set}
-\label{sec:boot:char-set}
-
-???What is the source character set??? That of Common Lisp?
-
-\subsubsection{Identifiers}
-\label{sec:boot:identifier}
-
-The standard identifiers start with a letter ([[a-z]] or [[A-Z]])
-dollar sign ([[$]]), question mark ([[?]]), or the percent sign
-([[\%]]), and are followed by any number of letters, digits, single
-quotes([[']]), question marks, or percent signs.
-It is possible however, by using the escape character ([[\_]]),
-to construct identifiers that contain any
-characters except the blank or newline character. The rules in this case
-are that an escape character followed by any non-blank character
-will start an identifier with that character. Once an identifier
-has been started either in this way or by a letter, [[$]], or
-[[%]], then it may be continued either with a letter, digit,
-quote , question mark or percent sign, or with
-an escape character followed by any non-blank character.
-Certain words having the form of identifiers are not classified as
-such, but are reserved words. They are listed below.
-
-An identifier ends when a blank or end of line is encountered, or
-an escape character followed by a blank or end of line, or a
-character which is not a letter, digit, quote, question mark
-or percent sign is found. Two identifiers are equal if the
-strings produced by replacing each escape followed by a character
-by that character are equal character by character.
-
-\subsubsection{Numbers}
-\label{sec:boot:number}
-
-Integers start with a digit ([[0-9]]) and are followed by any number
-of digits. The syntax for floating point numbers is
-\begin{verbatim}
-<.I | I. | I.I> <E|e> <+ | - | empty> I
-\end{verbatim}
-where I is an integer.
-
-\subsubsection{Strings}
-\label{sec:boot:string}
-
-Strings of characters are enclosed by double quote signs. They cannot
-span two or more lines and an escape character within a string will
-include the next character regardless of its nature.
-The meaning of a string depends somewhat on the context in which
-it is found, but in general a bare string denotes the interned atom
-making up its body whereas when it is preceded by a single quote (')
-it denotes the string of characters enclosed.
-
-\subsubsection{S-expressions}
-\label{sec:boot:s-expression}
-
-An s-expression is preceded by a single quote and is followed by
-a Lisp s-expression.
-\begin{verbatim}
-sexpression ::=identifier | integer | MINUS integer | float | string
- | QUOTE sexpression | parenthesized sexpression1
-
-sexpression1 ::=sexpression (DOT sexpression | sexpression1)| empty
-\end{verbatim}
-
-There are two ways to quote an iddentifier: either 'name or "name", which
-both give rise to (QUOTE name). However a string that is a
-component of an sexpression will denote the string unless it is the
-sole component of the s-expression in which case it denotes a string
-i.e. '"name" gives rise to "name" in Lisp rather than (QUOTE "name").
-
-
-\subsubsection{Keywords}
-\label{sec:boot:keyword}
-
-The table of key words follows, each is given an upper case
-name for use in the description of the syntax.
-\begin{verbatim}
- as written name
-
- and AND
- by BY
- case CASE
- cross CROSS
- else ELSE
- for FOR
- if IF
- in IN
- is IS
- isnt ISNT
- of OF
- or OR
- repeat REPEAT
- return RETURN
- structure STRUCTURE
- then THEN
- until UNTIL
- where WHERE
- while WHILE
- . DOT
- : COLON
- , COMMA
- ; SEMICOLON
- * TIMES
- ** POWER
- / SLASH
- + PLUS
- - MINUS
- < LT
- > GT
- <= LE
- >= GE
- = SHOEEQ
- ^ NOT
- ^= NE
- .. SEG
- # LENGTH
- => EXIT
- := BEC
- == DEF
- ==> MDEF
- ( OPAREN
- ) CPAREN
- (| OBRACK
- |) CBRACK
- [ OBRACK
- ] CBRACK
- suchthat BAR
- ' QUOTE
- | BAR
-\end{verbatim}
-
-\subsubsection{Primary}
-\label{sec:boot:primar-expr}
-
-\begin{verbatim}
-constant::= integer | string | float | sexpression
-\end{verbatim}
-
-The value of a constant does not depend on the context in which it
-is found.
-\begin{verbatim}
-primary::= name | constant | construct | block | tuple | pile
-\end{verbatim}
-
-The primaries are the simplest constituents of the language and
-either denote some object or perform some transformation of the
-machine state, or both.
-The statements are the largest constituents and enclosing them
-in parentheses converts them into a primary.
-
-An alternative method of grouping uses indentation to indicate the
-parenthetical structure.
-A number of lines whose first non-space characters are in the same
-column will be called a \emph{pile}. The translater first tokenizes the
-lines producing identifier, key word, integer, string or float tokens,
-and then examines the pile structure of a Boot program
-in order to add additional tokens called [[SETTAB]], [[BACKTAB]]
-and [[BACKSET]].
-These tokens may be considered as commands for creating a pile.
-The [[SETTAB]] starts a new line indented from the previous line and
-pushes the resulting column number on to a stack of tab positions.
-The [[BACKTAB]] will start a new line at the column position found
-at the head of the stack and removes it from the stack.
-The [[BACKSET]] has the same effect as a [[BACKTAB]] immediately followed
-by a [[SETTAB]].
-The meaning of a sequence of tokens containing [[SETTAB]],
-[[BACKTAB]], and [[BACKSET]] is the same the sequence in which each
-[[SETTAB]] is replaced by [[OPAREN]] , each [[BACKTAB]] is replaced by
-[[CPAREN]], and each [[BACKSET]] is replaced by [[SEMICOLON]]. By
-construction the [[BACKTABS]] and [[SETTABS]] are properly nested.
-\begin{verbatim}
-listof(p,s)== p | p s ... s p
-
-parenthesized s ::= OPAREN s CPAREN
-piled s ::= SETTAB s BACKTAB
-
-blockof s ::= parenthesized (listof (s,SEMICOLON))
-pileof s ::= piled (listof (s,BACKSET ))
-\end{verbatim}
-
-A pileof s has the same meaning as a blockof s.
-There is however a slight difference because piling is weaker than
-separation by semicolons. In other words the pile items
-may be listof(s,SEMICOLON).
-In other words if statements::= listof(statement,SEMICOLON) then
-we can have a pileof statements which has the same meaning as
-the flattened sequence formed by replacing
-all [[BACKSET]]'s by [[SEMICOLON]]'s.
-
-A blockof statement is translated to a compound statement
-e.g. in the absence of any exits,
-(a;b;c;d) is translated to (PROGN a b c d).
-
-\subsubsection{Selectors}
-\label{sec:boot:selector}
-
-\begin{verbatim}
-selector::= leftassociative(primary, DOT)
-\end{verbatim}
-
-A selector [[a.b]] denotes some component of a structure, and in
-general is translated to [[(ELT a b)]]. There are some special identifiers
-that may be used in the [[b]] position to denote list components, of which
-more later.
-The [[DOT]] has a greater precedence than juxtaposition and is
-left associative, For example
-\begin{verbatim}
-a.b.c is grouped as (a.b).c which is translated to
- (ELT (ELT a b) c)
-
-application ::= selector selector ... selector
-
-\end{verbatim}
-
-Application of function to argument is denoted by juxtaposition.
-
-A sequence of selectors is right associative and so
-[[f g h x]] is grouped as [[f(g(h x))]]. The applications [[f x]] and
-[[f(x)]]
-mean the application of [[f]] to [[x]] and get translated to
-the Lisp [[(f x)]]. The application of a function to the empty list
-is written [[f()]], meaning the Lisp [[(f)]]. [[f(x,y,z)]] gets translated to
-the Lisp [[(f x y z)]].
-Common Lisp does not permit a variable to occur in operator position,
-so that when f is a variable its application has to be
-put in argument position of a [[FUNCALL]] or [[APPLY]].
-[[f(x,y,z)]] has to be replaced by [[FUNCALL(f,x,y)]] which gets translated to
-the Lisp [[(FUNCALL f x y z)]].
-In Common Lisp each symbol might refer
-to two objects a function and a non-function. In order to resolve
-this ambiguity when a function symbol appears in a context other
-than operator position it has to be preceded by the symbol [[FUNCTION]].
-Also it is possible to produce the function type symbol from the
-non-function symbol by applying [[SYMBOL-FUNCTION]] to it.
-
-Certain reserved words called infixed operators namely
-[[POWER]], [[TIMES]], [[SLASH]], [[PLUS]], [[MINUS]], [[IS]],
-[[EQ]], [[NE]] , [[GT]], [[GE]], [[LT]], [[LE]], [[IN]], [[AND]],
-[[OR]], indicate application by being placed between their 2 arguments.
-
-Infixed application may be either right- or left-associative.
-\begin{verbatim}
-rightassociative(p,o)::= p o p o p o ... o p
- == p o (p o (p o ... o p)))
-
-leftassociative(p,o)::= p o p o p o ... o p
- == (((p o p) o p) o ...) o p
-
-
-exponent ::= rightassociative(application,POWER)
-
-reduction ::= (infixedoperator |string | thetaname) SLASH application
-\end{verbatim}
-
-In a reduction the application denotes a list of items and
-operator [[SLASH]] application accumulates the list elements from the
-left using the operator
-\begin{verbatim}
-e.g. +/[a,b,c] means (((0+a)+b)+c)
-\end{verbatim}
-
-Only certain operators are provided with values when the list is empty
-they are [[and]], [[or]], [[+]], [[*]], [[max]], [[min]], [[append]],
-[[union]]. However any function can be used as an operator by enclosing it
-in double quotes. In this case the reduction is not applicable to an
-empty list.
-\begin{verbatim}
-multiplication ::= rightassociative(exponent,TIMES|SLASH) | reduction
-
-minus ::= MINUS multiplication | multiplication
-
-arith ::= leftasscociative(minus,PLUS | MINUS)
-
-is ::= arith | arith (IS | ISNT) pattern
-
-comparison ::= is (EQ | NE | GT | GE | LT | LE | IN) is | is
-
-and ::= leftassociative (comparison,AND)
-
-return ::= and | RETURN and
-
-expression ::= leftassociative(return,OR)
-\end{verbatim}
-
-The infixed operators denote application of the function to its
-two arguments. To summarize,
-the infixed operators are, in order of decreasing precedence
-strengths.
-\begin{verbatim}
- .
- juxtaposition
- **
- * /
- + -
- is
- = ^= > >= < <= in
- and
- or
-\end{verbatim}
-
-\subsubsection{Conditionals}
-\label{sec:boot:conditional}
-
-\begin{verbatim}
-conditional ::= IF where THEN where |
- IF where THEN where ELSE where
-
-IF a THEN b is translated to (COND (a b)) and
-IF a THEN b else c is translated to (COND (a b) (T c))
-
-statement::= conditional | loop | expression
-\end{verbatim}
-
-\subsubsection{Loops}
-\label{sec:boot:iteration}
-
-\begin{verbatim}
-loop ::= crossproduct REPEAT statement | REPEAT statement
-
-iterator ::= forin | suchthat | until | while
-
-iterators ::= iterator iterator ... iterator
-
-crossproduct ::=rightassociative(iterators,CROSS)
-
-suchthat ::= BAR where
-
-while ::= WHILE expression
-
-until ::= UNTIL expression
-
-forin ::= for variable IN segment |
- for variable IN segment BY arith
-
-segment::= arith | arith SEG arith | arith SEG
-\end{verbatim}
-
-A loop performs an iterated transformation of the state which is
-specified by its statement component and its iterators.
-The forin construction introduces a new variable which is assigned
-the elements of the list which is the value of the segment in the order
-in which they appear in the list .
-
-A segment of the form [[arith]] denotes a list,
-and segments of the form [[arith SEG arith]] and
-[[arith SEG]] denote terminating and non-terminating
-arithmetic progressions.
-The [[BY arith]] option is the step size, if omitted the step is [[1]].
-
-Two or more [[forin]]'s may control a loop.
-The associated lists are scanned in parallel and
-a variable of one [[forin]] may not appear in the segment expression that
-denotes the list in a second [[forin]].
-Such a variable may however occur in the conditions for filtering or
-introduced by a [[suchthat]], or for termination introduced by a
-while iterator, and in the statement of the loop.
-The [[forin]] variables are local to the statement, the conditions
-that follow a [[while]] or [[suchthat]] in the same list of iterators and
-have no meaning outside them.
-The loop will be terminated when one of its [[forin]] lists is null, or
-if the condition in a [[while]] is not satisfied. The list
-elements are filtered by all the [[suchthat]] conditions.
-The ordering of the iterators is irrelevant to the meaning, so it is
-best to avoid side effects within the conditions for filtering and
-termination.
-
-It is possible to control a loop by using a \emph{cross-product} of iterators.
-The iteration in the case [[iterators1 CROSS iterators2]] is over
-all pairs of list items one from the list denoted by
-iterators1 and the other from the list denoted by iterators2.
-In this case the variables introduced [[forin]] statements in
-[[iterators1]] may be used in [[iterators2]].
-
-\subsubsection{Lists}
-\label{sec:boot:list}
-
-Boot contains a simple way of specifying lists that are constructed
-by [[CONS]] and [[APPEND]], or by transforming one list to another in a
-systematic manner.
-\begin{verbatim}
-construct ::= OBRACK construction CBRACK
-
-construction ::= comma | comma iteratortail
-
-iteratortail ::= REPEAT iterators | iterators
-\end{verbatim}
-
-A construct expression denotes a list and may also have a list
-of controlling iterators having the same syntax as a loop. In this
-case the expression is enclosed in brackets and the iterators follow
-the expression they qualify, rather than preceding it.
-
-In the case that there are no iterators the construct expression
-denotes a list by listing its components separated by commas, or by
-a comma followed by a colon. In the simple case in which there are no
-colons the Boot expression [a,b,c,d] translates to the Lisp
-[[(LIST a b c d)]] or [[(CONS a (CONS b (CONS c (CONS d NIL))))]].
-
-When elements are separated by comma colon, however, the expression
-that follows will be assumed to denote a list which will be appended
-to the following list, rather than consed. An exception to this rule
-is that a colon preceding the last expression is translated to
-the expression itself. If it immediately preceded by a CONS
-then it need not denote a list.
-
-For example:
-\begin{verbatim}
-[] is translated to the empty list NIL
-[a] is translated to the 1-list (LIST a) or (CONS a NIL)
-[:a] is translated to a
-[a,b] is translated to the 2-list (LIST a b) or (CONS a (CONS b NIL))
-[:a,b] is translated to (APPEND a (CONS b NIL))
-[a,:b] is translated to (CONS a b)
-[:a,:b] is translated to (APPEND a b)
-[:a,b,c] is translated to (APPEND a (CONS b (CONS c NIL)))
-[a,:b,c] is translated to (CONS a (APPEND b (CONS c NIL)))
-[a,b,:c] is translated to (CONS a (CONS b c))
-\end{verbatim}
-
-If the construct expression has iterators that control the production
-of the list the resulting list depends on the form of the comma
-expression.
-i.e.
-\begin{verbatim}
-construction ::= comma iteratortail
-\end{verbatim}
-
-If the comma expression is recognised as denoting a list
-by either preceding it by a colon, or having commas at top level
-as above, then the successive values are appended. If not then
-the successive values are consed.
-e.g.
-\begin{verbatim}
-[f i for i in x] denotes the list formed by applying f to each
- member of the list x.
-
-[:f i for i in 0..n] denotes the list formed by appending the
- lists f i for each i in 0..n.
-\end{verbatim}
-
-\subsubsection{Patterns}
-\label{sec:boot:pattern}
-
-\begin{verbatim}
-is ::= arith | arith IS pattern
-\end{verbatim}
-
-The pattern in the proposition [[arith IS pattern]] has the same form
-as the construct phrase without iterators. In this case, however it
-denotes a class of lists rather than a list, and is composed
-from identifiers rather than expressions. The proposition
-is translated into a program that tests whether the arith expression
-denotes a list that belongs to the class. If it does then the value
-of the is expression is true and the identifiers in
-the pattern are assigned the values of the corresponding
-components of the list. If the list does not match the pattern
-the value of the is expression is false and the values of the
-identifier might be changed in some unknown way that reflects the
-partial success of the matching.
-Because of this uncertainty,
-it is advisable to use the variables in a pattern
-as new definitions rather than assigning to variables that are
-defined elsewhere.
-\begin{verbatim}
-pattern::= identifier | constant | [ patternlist ]
-\end{verbatim}
-
-The value of [[arith IS identifier]] is [[true]] and the value of
-[[arith]] is assigned to the [[identifier]].
-[[(PROGN (SETQ identifier arith) T)]]
-The expression [[arith IS constant]] is translated to
-[[(EQUAL constant arith)]].
-The expression arith [[IS [ pattenlist ] ]]
-produces a program which tests whether arith denotes a list
-of the right length and that each patternitem matches the corresponding
-list component.
-
-\begin{verbatim}
-patternitem ::= EQ application | DOT | pattern | name := pattern
-\end{verbatim}
-
-If the [[patternitem]] is [[EQ application]] then the value is true if
-the component is [[EQUAL]] to the value of the application expression.
-If the [[patternitem]] is [[DOT]] then the value is [[true]] regardless of the
-nature of the component. It is used as a place-holder to test
-whether the component exists.
-If the patternitem is pattern then the component is matched against
-the pattern as above.
-If the [[patternitem]] is [[name:=pattern]] then the component is
-matched against
-the pattern as above, and if the value is [[true]] the component is assigned
-to the name. This last provision enables both a component and
-its components to be given names.
-\begin{verbatim}
-patternlist ::= listof(patternitem,COMMA)|
- listof(patternitem,COMMA) COMMA patterntail
- patterntail
-
-patterncolon ::= COLON patternitem
-
-patterntail ::= patterncolon |
- patterncolon COMMA listof(patternitem,COMMA)
-\end{verbatim}
-
-The [[patternlist]] may contain one colon to indicate that the following
-patternitem can match a list of any length. In this case
-the matching rule is to construct the expression
-with [[CONS]] and [[APPEND]] from the pattern as shown above and then test
-whether the list can be constructed in this way, and if so
-deduce the components and assign them to identifiers.
-
-The effect of a pattern that occurs as a variable in a for iterator
-is to filter the list by the pattern.
-\begin{verbatim}
-forin ::= for pattern IN segment
-\end{verbatim}
-
-is translated to two iterators
-\begin{verbatim}
- for g IN segment | g IS pattern
-\end{verbatim}
-where [[g]] is an invented identifier.
-\begin{verbatim}
-forin ::= for (name:=pattern) IN segment
-\end{verbatim}
-
-is translated to two iterators
-\begin{verbatim}
- for name IN segment BAR name IS pattern
-\end{verbatim}
-
-in order to both filter the list elements, and name both elements and
-their components.
-
-\subsubsection{Assignments}
-\label{sec:boot:assignment}
-
-A pattern may also occur on the left hand side of an assignment
-statement, and has a slightly different meaning.
-The purpose in this case is to give names to the components
-of the list which is the value of the right hand side.
-In this case no checking
-is done that the list matches the pattern precisely and the only
-effect is to construct the selectors that correspond to
-the identifiers in the pattern, apply them to the value of the
-right hand side and assign the selected components
-to the corresponding identifiers.
-The effect of applying [[CAR]] or [[CDR]] to arguments to which they are not
-applicable will depend on the underlying Lisp system.
-\begin{verbatim}
-assignment::= assignvariable BECOMES assignment| statement
-
-assignvariable := OBRACK patternlist CBRACK | assignlhs
-\end{verbatim}
-
-The assignment having a pattern as its left hand side is reduced
-as explained above to one or more assignments having an identifier
-on the left hand side.
-The meaning of the assignment depends on whether the identifier
-starts with a dollar sign or not, if it is and whether it is followed by
-[[:local]] or [[:fluid]].
-If the identifier does not start with a dollar sign it
-is treated as local to the body of the function in which it
-occurs, and
-if it is not already an argument of the function,
-a declaration to that effect is added to the Lisp code
-by adding a [[PROG]] construction at top level within the body of the
-function definition. Note also the all local variables and fluid variables
-are treated this way, resulting in initialization to [[nil]] before
-execution of the body of the function. Consequently care must be
-exercised when assigning to Lisp special global variables. If you
-do not want that implicitly initialization to [[nil]], then use the
-explicit [[SETQ]] Lisp special form in an application syntax.
-
-If such an identifier assignment does not occur in the body
-of a function but in a top level expression then
-it is also treated as a local. The sole exception to this rule
-is when the top level expression is an assignment to an identifier
-in which case it is treated as global.
-
-If the left hand side of an assignment is an identifier that starts with
-a dollar sign it will not be classified as a local but will
-be treated as non-local. If it is also followed by [[:local]] then it
-will be treated as a declaration of a [[FLUID]] (VMLisp) or [[SPECIAL]]
-variable (Common Lisp) which will be given an initial value which is the
-value of the right hand side of the assignment statement.
-The [[FLUID]] or [[SPECIAL]] variables may be referred to or assigned to
-by functions that are applied in the body of the declaration.
-
-If the left hand side of an assignment statement is
-an identifier that does not start with a dollar sign followed
-by [[:local]] then it will also be treated as a [[FLUID]] or [[SPECIAL]]
-declaration, however it may only be assigned to in the body
-of the function in which the assignment it occurs.
-\begin{verbatim}
-assignment::= assignvariable BECOMES assignment | statement
-
-assignvariable := OBRACK patternlist CBRACK | assignlhs
-
-assignlhs::= name | name COLON local |
- name DOT primary DOT ... DOT primary
-\end{verbatim}
-
-If the left hand side of an assignment has the form
-\begin{verbatim}
- name DOT primary DOT ... DOT primary
-\end{verbatim}
-the assignment statement will denote an updating of some component
-of the value of name. In general [[name DOT primary := statement]]
-will get translated to [[(SETELT name primary statement)]] or
-[[(SETF (ELT name primary) statement)]]
-There are however certain identifiers that denote components of
-a list which will get translated to statements that update that
-component (see appendix) e.g.
-\begin{verbatim}
-a.car:=b is translated to (SETF (CAR a) b) in Common Lisp.
-\end{verbatim}
-The iterated [[DOT]] is used to update components of components
-and e.g
-
-\begin{verbatim}
-a.b.c:=d is translated to (SETF (ELT (ELT a b)c) d)
-
-exit::= assignment | assignment EXIT where
-\end{verbatim}
-
-The exit format [[assignment EXIT where]] is used to give a value to
-a blockof or pileof statements in which it occurs at top level.
-
-The expression
-\begin{verbatim}
- (a =>b;c) will be translated to if a then b else c or
- (COND (a b) (T c))
-\end{verbatim}
-
-If the exit is not a component of a blockof or pileof statements
-then
-\begin{verbatim}
-a=>b will be translated to (COND (a b))
-\end{verbatim}
-
-\subsubsection{Definitions}
-
-Functions may be defined using the syntax
-\begin{verbatim}
-functiondefinition::= name DEF where | name variable DEF where
-
-
-variable ::= parenthesized variablelist | pattern
-
-variableitem ::=
- name| pattern | name BECOMES pattern | name IS pattern
-
-variablelist ::= variableitem | COLON name |
- variableitem COMMA variablelist
-\end{verbatim}
-
-Function definitions may only occur at top level or after a [[where]].
-The [[name]] is the name of the function being defined, and the
-most frequently used form of the [[variable]] is either a single name
-or a parenthesized list of names separated by commas.
-In this case the translation to Lisp is straightforward, for example:
-\begin{verbatim}
-f x == E or f(x)==E is translated to (DEFUN f (x) TE)
-f (x,y,z)==E is translated to (DEFUN f (x y z) TE)
-f ()==E is translated to (DEFUN f () TE)
-\end{verbatim}
-
-where [[TE]] is the translation of [[E]].
-At top level
-\begin{verbatim}
-f==E is translated to (DEFUN f () TE)
-\end{verbatim}
-
-The function being defined is that which when applied to its arguments
-produces the value of the body as result where the variables
-in the body take on the values of its arguments.
-
-A pattern may also occur in the variable of a definition of a function
-and serves the purpose, similar to the left hand side of assignments,
-of naming the list components.
-The phrase
-\begin{verbatim}
- name pattern DEF where
-is translated to
- name g DEF (pattern:=g;where)
-\end{verbatim}
-
-similarly
-\begin{verbatim}
- name1 name2 := pattern DEF where or name1 name2 is pattern DEF where
-
-are both translated to
- name1 name2 DEF (pattern:=name2;where)
-\end{verbatim}
-
-similarly for patterns that occur as components of a list of
-variables. order
-\begin{verbatim}
-variablelist ::=
- variableitem | COLON name | variableitem COMMA variablelist
-\end{verbatim}
-
-The parenthesized [[variablelist]] that occurs as a variable of a function
-definition can contain variables separated by commas but can also
-have a comma colon as its last separator.
-
-This means that the function is applicable to lists of different
-sizes and that only the first few elements corresponding to the
-variables separated by commas are named, and
-the last name after the colon denotes the rest of the list.
-
-Macros may be defined only at top level, and must always have a variable
-\begin{verbatim}
-macrodefinition::= name variable MDEF where
-\end{verbatim}
-
-The effect of a [[macrodefinition]] is to produce a Lisp macro
-which is applied to arguments that are treated as expressions, rather
-than their values, and whose result if formed by first substituting
-the expressions for occurrences of the variables within the body
-and then evaluating the resulting expression.
-
-\subsubsection{Where Clauses}
-\label{sec:boot:where-clause}
-
-Expressions may be qualified by one or more function definitions
-using the syntax
-\begin{verbatim}
-where ::= exit | exit WHERE qualifier
-
-qualifier ::= functiondefinition |
- pileof (functiondefinition) | blockof functiondefinition
-\end{verbatim}
-
-The functions may only be used within the expression that is qualified.
-This feature has to be used with some care, however, because
-a where clause may only occur within a function body, and
-the component functions are extruded, so to speak, from their contexts
-renamed, and made into top level function definitions.
-As a result the variables of the outer function cannot be referred to
-within the inner function.
-If a qualifying function has the format [[name DEF where]] then
-the [[where]] phrase is substituted for all occurences of the name
-within the expression qualified.
-If an expression is qualified by a phrase that is not a
-function definition then the result will be a compound statement
-in which the qualifying phrase is followed by the qualified phrase.
-
-\subsubsection{Tuples}
-\label{sec:boot:tuples}
-
-Although a tuple may appear syntactically
-in any position occupied by a primary
-it will only be given meaning when it is the argument to a function.
-To denote a list it has to be enclosed in brackets rather than
-parentheses. A tuple at top level is treated as if its components
-appeared at top level in the order of the list.
-\begin{verbatim}
-tuple::= parenthesized (listof (where,COMMA))
-\end{verbatim}
-
-\subsubsection{Blocks and Piles}
-\label{sec:boot:block}
-
-\begin{verbatim}
-block::= parenthesized (listof (where,SEMICOLON))
-pile::= piled (listof (listof(where,SEMICOLON),BACKSET))
-A block or a pile get translated to a compound statement or PROGN
-\end{verbatim}
-
-\subsubsection{Top Level}
-\label{sec:boot:top-level}
-
-\begin{verbatim}
-toplevel ::= functiondefinition | macrodefinition | primary
-\end{verbatim}
-
-\subsubsection{Translation Functions}
-\label{sec:boot:translation}
-
-\begin{verbatim}
-(boottocl "filename")
-translates the file "filename.boot" to
-the common lisp file "filename.clisp"
-\end{verbatim}
-
-\begin{verbatim}
-(bootclam "filename")
-translates the file "filename.boot" to
-the common lisp file "filename.clisp"
-\end{verbatim}
-
-producing, for each function a
-hash table to store previously computed values indexed by argument
-list. The function first looks in the hash table for the result
-if there returns it, if not computes the result and stores it in the
-table.
-
-\begin{verbatim}
-(boottoclc "filename")
-translates the file "filename.boot" to
-the common lisp file "filename.clisp"
-with the original boot code as comments
-\end{verbatim}
-
-\begin{verbatim}
-(boot "filename")
-translates the file "filename.boot" to
-the common lisp file "filename.clisp",
-compiles it to the file "filename.bbin"
-and loads the bbin file.
-\end{verbatim}
-
-\begin{verbatim}
-(bo "filename")
-translates the file "filename.boot"
-and prints the result at the console
-\end{verbatim}
-
-\begin{verbatim}
-(stout "string") translates the string "string"
-and prints the result at the console
-\end{verbatim}
-
-\begin{verbatim}
-(sttomc "string") translates the string "string"
-to common lisp, and compiles the result.
-\end{verbatim}
-
-\begin{verbatim}
-(fc "functionname" "filename")
-attempts to find the boot function
-functionname in the file filename,
-if found it translates it to common
-lisp, compiles and loads it.
-\end{verbatim}
-
-\begin{verbatim}
-BOOT_-COMPILE_-DEFINITION_-FROM_-FILE(fn,symbol)
- is similar to fc, fn is the file name but symbol is the symbol
- of the function name rather than the string.
-(fn,symbol)
-\end{verbatim}
-
-\begin{verbatim}
-BOOT_-EVAL_-DEFINITION_-FROM_-FILE(fn,symbol)
-attempts to find the definition of symbol in file fn, but this time
-translation is followed by EVAL rather than COMPILE
-\end{verbatim}
-
-\begin{verbatim}
-(defuse "filename")
-Translates the file filename, and writes a report of the
-functions defined and not used, and used and not defined in the
-file filename.defuse
-\end{verbatim}
-
-\begin{verbatim}
-(xref "filename")
-Translates the file filename, and writes a report of the
-names used, and where used to the file filename.xref
-\end{verbatim}
-
-\subsection{Reserved identifiers}
-\label{sec:boot:reserved-identifiers}
-
-The following identifiers are reserved by Boot.
-\begin{verbatim}
- and append apply atom car cdr cons copy
- croak drop exit false first function genvar IN
- is isnt lastNode LAST list member mkpf nconc
- nil not NOT nreverse null or otherwise PAIRP
- removeDuplicates rest reverse setDifference
- setIntersection setPart setUnion size strconc substitute
- take true PLUS MINUS TIMES POWER SLASH LT
- GT LE GE SHOEEQ NE T
-\end{verbatim}
-
-The following identifiers designate special accessor functions in Boot.
-\begin{verbatim}
- setName setLabel setLevel setType setVar setLeaf
- setLeaf setDef aGeneral aMode aTree aValue
- attributes cacheCount cacheName cacheReset cacheType env
- expr CAR mmCondition mmDC mmImplementation
- mmSignature mmTarget mode op opcode opSig
- CDR sig source streamCode streamDef streamName
- target
-\end{verbatim}
-
-
-\section{The Makefile}
-\label{sec:Makefile}
-
-When all of the native object files are produced we construct a
-lisp image that contains the boot translator, called [[bootsys]], which
-lives in the [[$(axiom_target_bindir)]] directory. This [[bootsys]] image
-is critical for the rest of the makefiles to succeed.
-
-There are two halves of this file. the first half compiles the .lisp files
-that live in the src/boot directory. the second half compiles the .clisp
-files (which are generated from the .boot files). It is important that
-the .clisp files are kept in the src/boot directory for the boot translator
-as they cannot be recreated without a boot translator (a bootstrap problem).
-
-An important subtlety is that files in the boot translator depend on the
-file npextras. there are 3 macros in npextras that must be in the lisp
-workspace (\verb$|shoeOpenInputFile| |shoeOpenOutputFile| memq$).
-
-\subsection{Environment}
-\label{sec:Makefile:env}
-
-\subsubsection{Lisp Images}
-\label{sec:Makefile:env:lisp-images}
-
-We will use create and use several lisp images during the build
-process. We name them here for convenience.
-
-\paragraph{[[AXIOM_LOCAL_LISP]].} We start with a Lisp image
-created in a previous build step (src/lisp). That image is used
-to build Boot translator executable through the entire bootstrap process.
-<<environment>>=
-AXIOM_LOCAL_LISP_sources = initial-env.lisp
-AXIOM_LOCAL_LISP = ../lisp/lisp$(EXEEXT)
-@
-
-
-\section{Proclaim optimization}
-\label{sec:proclaim}
-
-GCL, and possibly other common lisps, can generate much better
-code if the function argument types and return values are proclaimed.
-
-In theory what we should do is scan all of the functions in the system
-and create a file of proclaim definitions. These proclaim definitions
-should be loaded into the image before we do any compiles so they can
-allow the compiler to optimize function calling.
-
-GCL has an approximation to this scanning which we use here.
-
-The first step is to build a version of GCL that includes gcl\_collectfn.
-This file contains code that enhances the lisp compiler and creates a
-hash table of structs. Each struct in the hash table describes information
-that about the types of the function being compiled and the types of its
-arguments. At the end of the compile-file this hash table is written out
-to a ".fn" file.
-
-The second step is to build axiom images (depsys, interpsys, AXIOMsys)
-which contain the gcl\_collectfn code.
-
-The third step is to build the system. This generates a .fn file for
-each lisp file that gets compiled.
-
-The fourth step is to build the proclaims.lisp files. There is one
-proclaims.lisp file for
-boot (boot-proclaims.lisp),
-interp (interp-proclaims.lisp), and
-algebra (algebra-proclaims.lisp).
-
-To build the proclaims file (e.g. for interp) we:
-\begin{verbatim}
-(a) cd to obj/linux/interp
-(b) (yourpath)/axiom/obj/linux/bin/lisp
-(c) (load "sys-pkg.lsp")
-(d) (mapcar #'load (directory "*.fn"))
-(e) (with-open-file (out "interp-proclaims.lisp" :direction :output)
- (compiler::make-proclaims out))
-\end{verbatim}
-Note that step (c) is only used for interp, not for boot.
-
-The fifth step is to copy the newly constructed proclaims file back
-into the src/interp diretory (or boot, algebra).
-
-In order for this information to be used during compiles we define
-<<environment>>=
-PROCLAIMS=(load "$(srcdir)/boot-proclaims.lisp")
-
-@
-
-\section{Special Commands}
-\label{sec:special-commands}
-
-We are working in a build environment that combines Makefile
-technology with Lisp technology. Instead of invoking a command
-like {\bf gcc} and giving it arguments we will be creating
-Lisp S-expressions and piping them into a Lisp image. The
-Lisp image starts, reads the S-expression from standard input,
-evaluates it, and finding an end-of-stream on standard input, exits.
-
-
-\section{The Boot Compiler}
-\label{sec:boot-compiler}
-
-This section describes the set of object files that make the Boot compiler.
-
-\subsection{The Bootstrap files}
-\label{sec:boot-compiler:bootstrap}
-
-This is a list of all of the files that must be loaded to construct the
-boot translator image.
-<<environment>>=
-boot_objects = initial-env.$(FASLEXT) $(boot_sources:.boot=.$(FASLEXT))
-
-## ECL's program construction model is not based on image-dumping. It is
-## closer to `traditional C' application building. Therefore, since
-## bootsys is an augmentation of base-lisp, we need to have the objects
-## that made up base-lisp too.
-ifeq (@axiom_lisp_flavor@,ecl)
-boot_objects_extra = ../lisp/core.$(FASLEXT)
-endif
-
-boot_SOURCES = \
- initial-env.lisp.pamphlet \
- $(addsuffix .pamphlet, $(boot_sources))
-
-pamphlets = Makefile.pamphlet $(boot_SOURCES)
-@
-
-[[$(boot_sources)]] is a list of the boot file targets. If you modify a
-boot file you'll have to explicitly build the clisp files and
-merge the generated code back into the pamphlet by hand. The
-assumption is that if you know enough to change the fundamental
-bootstrap files you know how to migrate the changes back.
-This process, by design, does not occur automatically (though it
-could).
-
-The Boot compiler, [[bootsys]], is built from a set of source files
-written in Boot. Note that the order is
-important as earlier files will contain code needed by later files.
-<<environment>>=
-boot_sources = tokens.boot includer.boot scanner.boot \
- pile.boot ast.boot parser.boot translator.boot
-
-boot_clisp = $(boot_sources:.boot=.clisp)
-boot_data = $(boot_sources:.boot=.data)
-boot_fn = $(boot_sources:.boot=.fn)
-@
-These source files use macros defined in the first set, and they be compiled
-in an environment where those macros are present.
-
-
-
-The Boot source file for [[bootsys]] are automatically extracted ---
-only during bootstrap --- from the pamphlets into the current build
-directory. When bootstrapping, they are the inputs to the stage0, stage1
- [[bootsys]] compilers.
-
-<<boot from pamphlet>>=
-.PRECIOUS: %.boot
-%.boot: $(srcdir)/%.boot.pamphlet
- $(axiom_build_document) --tangle $<
-@
-
-Since the Boot language is defined as a syntactic sugar over Lisp
-(a reasonably tasty sugar), the
-the second set of source files (written in Boot) is first translated
-to Lisp, and the result of that translation is subsequently compiled to
-native object files.
-
-Partly for bootstrapping reasons, and partly because OpenAxiom (therefore
-Boot) is not yet widespread, the pamphlets for the source files written
-in Boot currently keep a cache of their translated versions. Hopefully
-the maintainance of that cache will be unnecessary as the build machinery
-becomes more and more improved, and OpenAxiom gets in widespread use.
-<<environment>>=
-boot_cached_clisp = $(boot_sources:.boot=.clisp)
-@
-
-\section{Bootstrapping Boot}
-\label{sec:bootstrapping}
-
-When the system is configured for bootstrap, we build the Boot compiler ---
-[[bootsys]] --- in three steps:
-\begin{enumerate}
-\item a stage-0 Boot compiler, built from the cached (Lisp) source files;
-
-\item a stage-1 Boot compiler, built the original Boot source files using the
- stage-0 Boot compiler;
-
-\item and a stage-2 Boot compiler, built from original Boot source files
- using the stage-2 Boot compiler.
-\end{enumerate}
-Notice that in last two steps, the source file written in Boot are first
-translated to Lisp using the freshly built Boot compiler, and the resulting
-Lisp files subsequently compiled to natve object files.
-
-Ideally, we should also compare the intermediate Lisp source files from
-stage 1 and 2 to detect possible miscompilation. We don't do that
-for the moment.
-
-\subsection{Compiling the Boot source files}
-\label{sec:bootstrapping:source-files}
-
-We compile the Boot compiler source files written in Boot only
-at stage 1 and 2 (when bootstrapping). As explained earlier, the
-compilation of these files proceeds in two steps:
-\begin{enumerate}
-\item Translate the Boot source files to Lisp code,
-\item compile the resulting Lisp source files to native object code.
-\end{enumerate}
-
-<<compile Boot files from pamphlets>>=
-## Dependency for various modules.
-## FIXME: This should be automatically extracted from the
-## Boot source file at packaging time.
-
-%/tokens.$(FASLEXT): %/tokens.clisp %/initial-env.$(FASLEXT)
- $(AXIOM_LOCAL_LISP) -- --compile --load-directory=$* $<
-
-%/includer.$(FASLEXT): %/includer.clisp %/tokens.$(FASLEXT)
- $(AXIOM_LOCAL_LISP) -- --compile --load-directory=$* $<
-
-%/scanner.$(FASLEXT): %/scanner.clisp %/tokens.$(FASLEXT) %/includer.$(FASLEXT)
- $(AXIOM_LOCAL_LISP) -- --compile --load-directory=$* $<
-
-%/pile.$(FASLEXT): %/pile.clisp %/scanner.$(FASLEXT) %/includer.$(FASLEXT)
- $(AXIOM_LOCAL_LISP) -- --compile --load-directory=$* $<
-
-%/ast.$(FASLEXT): %/ast.clisp %/includer.$(FASLEXT)
- $(AXIOM_LOCAL_LISP) -- --compile --load-directory=$* $<
-
-%/parser.$(FASLEXT): %/parser.clisp %/ast.$(FASLEXT) %/scanner.$(FASLEXT) \
- %/includer.$(FASLEXT)
- $(AXIOM_LOCAL_LISP) -- --compile --load-directory=$* $<
-
-%/translator.$(FASLEXT): %/translator.clisp %/parser.$(FASLEXT) \
- %/ast.$(FASLEXT) %/pile.$(FASLEXT) %/scanner.$(FASLEXT) \
- %/includer.$(FASLEXT)
- $(AXIOM_LOCAL_LISP) -- --compile --load-directory=$* $<
-
-<<boot from pamphlet>>
-@
-
-\subsection{Building [[bootsys]]}
-\label{sec:bootstrapping:build-bootsys}
-
-\subsection{The various bootstrapping stages}
-\label{sec:bootstrapping:stages}
-
-The bootstrapping phase is carried out in three stages:
-\begin{itemize}
-\item[Stage 0] we compile the cached Lisp translations of the Boot codes.
- Currently, these translations are functionally equivalent
- to the final \Tool{bootsys} we get out of the bootstrap. Ideally,
- this should just be powerfull enough to translate the \Tool{bootsys}
- Boot codes. The compilation of thee Lisp code is done with the
- Lisp image [[$(AXIOM_LOCAL_LISP)]].
-
-\item[Stage 1] Using the \Tool{bootsys} built from the previous
- stage (\eg{} from
- cached Lisp translations), we build a new \Tool{bootsys} from the
- Boot codes proper.
-\label{sec:bootstrapping:stages}
-
-\item[Stage 2] Finally, we build another (and final) \Tool{bootsys} image
- using the \Tool{bootsys} from Stage 1. This is the \Tool{bootsys}
- image that is used to build the rest of the OpenAxiom system.
-\end{itemize}
-
-Stage 1 and Stage 2 are structurally identical. Ideally, we should be
-doing a bootstrap compare.
-
-Although all the \Tool{bootsys} images are powerful enough to
-compile Boot codes directly, we don't use them for compilation.
-Instead, we the fresh, clean, [[$(AXIOM_LOCAL_LISP)]] image.
-The reason is that the process of compiling a Boot source file
-may have the side effect of loading a module in the compiler (as
-by-product of resolving module dependencies). But such module
-will contain objects already present in the compiler and being
-used. Consequently, we must use a fresh image to guarantee
-clean and reproductible build and semantics. Notice that only
-the compilation of \Tool{bootsys} itself needs that care.
-The rest of the OpenAxiom system should use \Tool{bootsys} to
-compile Boot codes, instead of manually going through the
-Lisp translation phase.
-
-
-\subsubsection{Stage 0}
-\label{sec:bootstrapping:stages:stage-0}
-
-We build the stage-0 Boot compiler from the cached Lisp souces code.
-<<stage 0 boot compiler>>=
-.PRECIOUS: stage0/%.clisp
-.PRECIOUS: stage0/%.$(FASLEXT)
-
-stage0_boot_clisp = $(addprefix stage0/, $(boot_clisp))
-
-stage0_boot_objects = $(addprefix stage0/, $(boot_objects))
-
-stage0/stamp: stage0/bootsys$(EXEEXT)
- @rm -f $@
- @$(STAMP) $@
-
-stage0/bootsys$(EXEEXT): $(stage0_boot_objects)
- $(AXIOM_LOCAL_LISP) -- --make --main="|AxiomCore|::|topLevel|"\
- --output=$@ --load-directory=stage0 \
- $(boot_objects_extra) $(stage0_boot_objects)
-
-
-.PRECIOUS: %/.started
-%/.started:
- $(mkinstalldirs) $*
- $(STAMP) $@
-
-$(stage0_boot_objects): $(AXIOM_LOCAL_LISP)
-
-stage0/%.clisp: $(srcdir)/%.boot.pamphlet stage0/.started
- $(axiom_build_document) --tangle=$*.clisp --output=$@ $<
-
-%/initial-env.$(FASLEXT): initial-env.lisp %/.started
- $(AXIOM_LOCAL_LISP) -- --compile --output=$@ $<
-@
-
-\subsubsection{Stage 1}
-\label{sec:bootstrapping:stages:stage-1}
-
-<<stage 1 boot compiler>>=
-.PRECIOUS: stage1/%.$(FASLEXT)
-.PRECIOUS: stage1/%.clisp
-
-stage1/stamp: stage1/bootsys$(EXEEXT)
- rm -f $@
- $(STAMP) $@
-
-stage1/bootsys$(EXEEXT): $(addprefix stage1/, $(boot_objects))
- $(AXIOM_LOCAL_LISP) -- --make --main="|AxiomCore|::|topLevel|" \
- --output=$@ --load-directory=stage1 \
- $(boot_objects_extra) $(addprefix stage1/, $(boot_objects))
-
-stage1/%.clisp: %.boot stage0/stamp stage1/.started
- stage0/bootsys -- --translate --output=$@ $<
-@
-
-\subsubsection{Stage 2}
-\label{sec:bootstrapping:stages:stage-2}
-
-<<stage 2 boot compiler>>=
-.PRECIOUS: stage2/%.$(FASLEXT)
-.PRECIOUS: stage2/%.clisp
-
-stage2/stamp: stage2/bootsys$(EXEEXT)
- @echo Building stage 2
- $(STAMP) $@
-
-stage2/bootsys$(EXEEXT): $(addprefix stage2/, $(boot_objects))
- $(AXIOM_LOCAL_LISP) -- --make --main="|AxiomCore|::|topLevel|" \
- --output=$@ --load-directory=stage2 \
- $(boot_objects_extra) $(addprefix stage2/, $(boot_objects))
-
-stage2/%.clisp: %.boot stage1/stamp stage2/.started
- stage1/bootsys -- --translate --output=$@ $<
-@
-
-<<bootstrap>>=
-<<stage 0 boot compiler>>
-
-<<stage 1 boot compiler>>
-
-<<stage 2 boot compiler>>
-@
-
-
-\section{Making the documentation}
-\label{sec:doc}
-
-\subsection{Compiling Lisp files without deps from pamphlets}
-<<initial-env.lisp>>=
-.PRECIOUS: %.lisp
-
-initial-env.lisp: initial-env.lisp.pamphlet
- $(axiom_build_document) --tangle $<
-@
-
-\subsection{boot from pamphlet}
-<<boot from pamphlet>>=
-.PRECIOUS: %.boot
-
-%.boot: $(srcdir)/%.boot.pamphlet
- $(axiom_build_document) --tangle $<
-@
-
-
-\section{Making the documentation}
-<<environment>>=
-
-COMPILE_LISP = \
- $(axiom_build_document) --tag=lisp --mode=compile --output=$@
-
-BOOT_TO_LISP = \
- $(axiom_build_document) --tag=boot --mode=translate \
- --use=./prev-stage/bootsys $<
-@
-
-\section{Cleanup}
-<<cleanup>>=
-mostlyclean-local:
- @rm -f $(axiom_build_bindir)/bootsys$(EXEEXT)
- @rm -rf prev-stage
- @rm -rf stage0 stage1 stage2
- @rm -f *.data *.fn
- @rm -f stamp
-
-clean-local: mostlyclean-local
- @rm -f $(boot_sources)
- @rm -f *.clisp *.lisp
-
-distclean-local: clean-local
-@
-
-
-\section{Global variables}
-
-The Boot implementation uses a number of global variables
-for communication between several routines. Some of them follow
-the syntactic convention of starting their names with [[$]]. Some
-don't.
-
-\subsection{[[$linepos]]}
-
-\subsection{[[$f]]}
-
-\subsection{[[$r]]}
-
-\subsection{[[$ln]]}
-
-\subsection{[[$sz]]}
-
-\subsection{[[$n]]}
-
-\subsection{[[$floatok]]}
-
-\subsection{[[$bfClamming]]}
-
-\subsection{[[$GenVarCounter]]}
-
-\subsection{[[$inputstream]]}
-
-\subsection{[[$stack]]}
-
-\subsection{[[$stok]]}
-
-\subsection{[[$ttok]]}
-
-\subsection{[[$op]]}
-
-\subsection{[[$wheredefs]]}
-
-\subsection{[[$typings]]}
-
-\subsection{[[$returns]]}
-
-\subsection{[[$bpCount]]}
-
-\subsection{[[$bpParentCount]]}
-
-\subsection{[[$lispWordTable]]}
-
-\subsection{[[$bootUsed]]}
-
-\subsection{[[$bootDefinedTwice]]}
-
-\subsection{[[$used]]}
-
-\subsection{[[$letGenVarCounter]]}
-
-\subsection{[[$isGenVarCounter]]}
-
-\subsection{[[$inDefIS]]}
-
-\subsection{[[$fluidVars]]}
-
-\subsection{[[$locVars]]}
-
-\subsection{[[$dollarVars]]}
-
-
-
-
-\section{The Makefile}
-<<*>>=
-<<environment>>
-
-subdir = src/boot/
-
-.PHONY: all-ax all-boot
-all: all-ax all-boot
-
-all-ax all-boot: stamp
-
-stamp: $(axiom_build_bindir)/bootsys$(EXEEXT)
- @rm -f stamp
- $(STAMP) $@
-
-$(axiom_build_bindir)/bootsys$(EXEEXT): stage2/bootsys$(EXEEXT)
- $(mkinstalldirs) $(axiom_build_bindir)
- $(INSTALL_PROGRAM) stage2/bootsys$(EXEEXT) $(axiom_build_bindir)
-
-<<bootstrap>>
-
-<<compile Boot files from pamphlets>>
-<<initial-env.lisp>>
-
-<<cleanup>>
-@
-
-\eject
-\begin{thebibliography}{99}
-\bibitem{1} src/boot/boothdr.lisp.pamphlet
-\bibitem{2} src/boot/includer.boot.pamphlet
-\bibitem{3} src/boot/pile.boot.pamphlet
-\bibitem{4} src/boot/scanner.boot.pamphlet
-\bibitem{5} src/boot/exports.lisp.pamphlet
-\bibitem{7} src/boot/translator.boot.pamphlet
-\bibitem{8} src/boot/parser.boot.pamphlet
-\bibitem{9} src/boot/tokens.boot.pamphlet
-\bibitem{10} src/boot/ast.boot.pamphlet
-\end{thebibliography}
-\end{document}
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
new file mode 100644
index 00000000..4c0c02d4
--- /dev/null
+++ b/src/boot/ast.boot
@@ -0,0 +1,1087 @@
+-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
+-- All rights reserved.
+-- Copyright (C) 2007-2008, Gabriel Dos Reis.
+-- 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.
+--
+-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+-- names of its contributors may be used to endorse or promote products
+-- derived from this software without specific prior written permission.
+--
+-- 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 OWNER
+-- 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.
+--
+
+--
+-- Abstract:
+-- This file defines the AST data structure and helper functions
+-- for representing Boot programs.
+--
+
+module '"boot-ast"
+import '"includer"
+
+)package "BOOTTRAN"
+
+++ True means that Boot functions should be translated to use
+++ hash tables to remember values. By default, functions are
+++ translated with the obvious semantics, e.g. no caching.
+$bfClamming := false
+
+++ A Boot string is no different from a Lisp string. Same holds
+++ for symbols and sequences. In an ideal world, these would be
+++ built-in/library data types.
+String <=> STRING
+Symbol <=> SYMBOL
+Sequence <=> SEQUENCE
+
+++ Ideally, we would like to say that a List T if either nil or a
+++ cons of a T and List of T. However, we don't support parameterized
+++ alias definitions yet.
+List <=> nil or cons
+
+++ Currently, the Boot processor uses Lisp symbol datatype for names.
+++ That causes the BOOTTRAN package to contain more symbols than we would
+++ like. In the future, we want want to intern `on demand'. How that
+++ interacts with renaming is to be worked out.
+structure Name == Name(Symbol)
+
+structure Ast ==
+ Command(String) -- includer command
+ Module(String) -- module declaration
+ Import(String) -- import module
+ ImportSignature(Name, Signature) -- import function declaration
+ TypeAlias(Name, List, List) -- type alias definition
+ Signature(Name, Mapping) -- op: S -> T
+ Mapping(Ast, List) -- (S1, S2) -> T
+ SuffixDot(Ast) -- x .
+ Quote(Ast) -- 'x
+ EqualName(Name) -- =x -- patterns
+ Colon(Name) -- :x
+ QualifiedName(Name, Name) -- m::x
+ Bracket(Ast) -- [x, y]
+ UnboundedSegment(Ast) -- 3..
+ BoundedSgement(Ast, Ast) -- 2..4
+ Tuple(List) -- comma-separated expression sequence
+ ColonAppend(Ast, Ast) -- [:y] or [x, :y]
+ Is(Ast, Ast) -- e is p -- patterns
+ Isnt(Ast, Ast) -- e isnt p -- patterns
+ Reduce(Ast, Ast) -- +/[...]
+ PrefixExpr(Name, Ast) -- #v
+ Call(Ast, Sequence) -- f(x, y , z)
+ InfixExpr(Name, Ast, Ast) -- x + y
+ ConstantDefinition(Name, Ast) -- x == y
+ Definition(Name, List, Ast, Ast) -- f x == y
+ Macro(Name, List, Ast) -- m x ==> y
+ SuchThat(Ast) -- | p
+ Assignment(Ast, Ast) -- x := y
+ While(Ast) -- while p -- iterator
+ Until(Ast) -- until p -- iterator
+ For(Ast, Ast, Ast) -- for x in e by k -- iterator
+ Exit(Ast, Ast) -- p => x
+ Iterators(List) -- list of iterators
+ Cross(List) -- iterator cross product
+ Repeat(Sequence, Ast) -- while p repeat s
+ Pile(Sequence) -- pile of expression sequence
+ Append(Sequence) -- concatenate lists
+ Case(Ast, Sequence) -- case x of ...
+ Return(Ast) -- return x
+ Where(Ast, Sequence) -- e where f x == y
+ Structure(Ast, Sequence) -- structure Foo == ...
+
+-- TRUE if we are currently building the syntax tree for an 'is'
+-- expression.
+$inDefIS := false
+
+bfGenSymbol()==
+ $GenVarCounter:=$GenVarCounter+1
+ INTERN(CONCAT ('"bfVar#",STRINGIMAGE $GenVarCounter))
+
+bfListOf x==x
+
+bfColon x== ["COLON",x]
+
+bfColonColon(package, name) ==
+ INTERN(SYMBOL_-NAME name, package)
+
+bfSymbol x==
+ STRINGP x=> x
+ ['QUOTE,x]
+
+bfDot()== "DOT"
+
+bfSuffixDot x==[x,"DOT"]
+
+bfEqual(name)== ["EQUAL",name]
+
+bfBracket(part) == part
+
+bfPile(part) == part
+
+bfAppend x== APPLY(function APPEND,x)
+
+bfColonAppend (x,y) ==
+ if null x
+ then
+ if y is ["BVQUOTE",:a]
+ then ["&REST",["QUOTE",:a]]
+ else ["&REST",y]
+ else cons(CAR x,bfColonAppend(CDR x,y))
+
+bfDefinition(bflhsitems, bfrhs,body) ==
+ ['DEF,bflhsitems,bfrhs,body]
+
+bfMDefinition(bflhsitems, bfrhs,body) ==
+ bfMDef('MDEF,bflhsitems,bfrhs,body)
+
+bfCompDef x ==
+ case x of
+ ConstantDefinition(n, e) => x
+ otherwise =>
+ x is [def, op, args, body] =>
+ bfDef(def,op,args,body)
+ coreError '"invalid AST"
+
+bfBeginsDollar x== EQL('"$".0,(PNAME x).0)
+
+compFluid id== ["FLUID",id]
+
+compFluidize x==
+ IDENTP x and bfBeginsDollar x=>compFluid x
+ ATOM x =>x
+ EQCAR(x,"QUOTE")=>x
+ cons(compFluidize(CAR x),compFluidize(CDR x))
+
+bfTuple x== ["TUPLE",:x]
+
+bfTupleP x==EQCAR(x,"TUPLE")
+
+bfTupleIf x==
+ if bfTupleP x
+ then x
+ else bfTuple x
+
+bfTupleConstruct b ==
+ a:= if bfTupleP b
+ then cdr b
+ else [b]
+ or/[x is ["COLON",.] for x in a] => bfMakeCons a
+ ["LIST",:a]
+
+bfConstruct b ==
+ a:= if bfTupleP b
+ then cdr b
+ else [b]
+ bfMakeCons a
+
+bfMakeCons l ==
+ null l => NIL
+ l is [["COLON",a],:l1] =>
+ l1 => ['APPEND,a,bfMakeCons l1]
+ a
+ ['CONS,first l,bfMakeCons rest l]
+
+bfFor(bflhs,U,step) ==
+ if EQCAR (U,'tails)
+ then bfForTree('ON, bflhs, CADR U)
+ else
+ if EQCAR(U,"SEGMENT")
+ then bfSTEP(bflhs,CADR U,step,CADDR U)
+ else bfForTree('IN, bflhs, U)
+
+bfForTree(OP,lhs,whole)==
+ whole:=if bfTupleP whole then bfMakeCons cdr whole else whole
+ ATOM lhs =>bfINON [OP,lhs,whole]
+ lhs:=if bfTupleP lhs then CADR lhs else lhs
+ EQCAR(lhs,"L%T") =>
+ G:=CADR lhs
+ [:bfINON [OP,G,whole],:bfSuchthat bfIS(G,CADDR lhs)]
+ G:=bfGenSymbol()
+ [:bfINON [OP,G,whole],:bfSuchthat bfIS(G,lhs)]
+
+
+bfSTEP(id,fst,step,lst)==
+ initvar:=[id]
+ initval:=[fst]
+ inc:=if ATOM step
+ then step
+ else
+ g1:=bfGenSymbol()
+ initvar:=cons(g1,initvar)
+ initval:=cons(step,initval)
+ g1
+ final:=if ATOM lst
+ then lst
+ else
+ g2:=bfGenSymbol()
+ initvar:=cons(g2,initvar)
+ initval:=cons(lst,initval)
+ g2
+ ex:=
+ null lst=> []
+ INTEGERP inc =>
+ pred:=if MINUSP inc then "<" else ">"
+ [[pred,id,final]]
+ [['COND,[['MINUSP,inc],
+ ["<",id,final]],['T,[">",id,final]]]]
+ suc:=[['SETQ,id,["+",id,inc]]]
+ [[initvar,initval,suc,[],ex,[]]]
+
+
+bfINON x==
+ [op,id,whole]:=x
+ if EQ(op,"ON")
+ then bfON(id,whole)
+ else bfIN(id,whole)
+
+bfIN(x,E)==
+ g:=bfGenSymbol()
+ [[[g,x],[E,nil],[['SETQ,g,['CDR, g]]],[],
+ [['OR,['ATOM,g],['PROGN,['SETQ,x,['CAR,g]] ,'NIL]]],[]]]
+
+bfON(x,E)==
+ [[[x],[E],[['SETQ,x,['CDR, x]]],[],
+ [['ATOM,x]],[]]]
+
+bfSuchthat p== [[[],[],[],[p],[],[]]]
+
+bfWhile p== [[[],[],[],[],[bfNOT p],[]]]
+
+bfUntil p==
+ g:=bfGenSymbol()
+ [[[g],[nil],[['SETQ,g,p]],[],[g],[]]]
+
+bfIterators x==["ITERATORS",:x]
+
+bfCross x== ["CROSS",:x]
+
+bfLp(iters,body)==
+ EQCAR (iters,"ITERATORS")=>bfLp1(CDR iters,body)
+ bfLpCross(CDR iters,body)
+
+bfLpCross(iters,body)==
+ if null cdr iters
+ then bfLp(car iters,body)
+ else bfLp(car iters,bfLpCross(cdr iters,body))
+
+bfSep(iters)==
+ if null iters
+ then [[],[],[],[],[],[]]
+ else
+ f:=first iters
+ r:=bfSep rest iters
+ [append(i,j) for i in f for j in r]
+
+bfReduce(op,y)==
+ a:=if EQCAR(op,"QUOTE") then CADR op else op
+ op:=bfReName a
+ init:=GET(op,"SHOETHETA")
+ g:=bfGenSymbol()
+ g1:=bfGenSymbol()
+ body:=['SETQ,g,[op,g,g1]]
+ if null init
+ then
+ g2:=bfGenSymbol()
+ init:=['CAR,g2]
+ ny:=['CDR,g2]
+ it:= ["ITERATORS",:[[[[g],[init],[],[],[],[g]]],bfIN(g1,ny)]]
+ bfMKPROGN [['L%T,g2,y],bfLp(it,body)]
+ else
+ init:=car init
+ it:= ["ITERATORS",:[[[[g],[init],[],[],[],[g]]],bfIN(g1,y)]]
+ bfLp(it,body)
+
+bfReduceCollect(op,y)==
+ if EQCAR (y,"COLLECT")
+ then
+ body:=y.1
+ itl:=y.2
+ a:=if EQCAR(op,"QUOTE") then CADR op else op
+ op:=bfReName a
+ init:=GET(op,"SHOETHETA")
+ bfOpReduce(op,init,body,itl)
+ else
+ a:=bfTupleConstruct (y.1)
+ bfReduce(op,a)
+
+-- delayed collect
+
+bfDCollect(y,itl)== ["COLLECT",y,itl]
+
+bfDTuple x== ["DTUPLE",x]
+
+bfCollect(y,itl) ==
+ y is ["COLON",a] => bf0APPEND(a,itl)
+ y is ["TUPLE",:.] =>
+ newBody:=bfConstruct y
+ bf0APPEND(newBody,itl)
+ bf0COLLECT(y,itl)
+
+bf0COLLECT(y,itl)==bfListReduce('CONS,y,itl)
+
+
+bf0APPEND(y,itl)==
+ g:=bfGenSymbol()
+ body:=['SETQ,g,['APPEND,['REVERSE,y],g]]
+ extrait:= [[[g],[nil],[],[],[],[['NREVERSE,g]]]]
+ bfLp2(extrait,itl,body)
+
+bfListReduce(op,y,itl)==
+ g:=bfGenSymbol()
+ body:=['SETQ,g,[op,y,g]]
+ extrait:= [[[g],[nil],[],[],[],[['NREVERSE,g]]]]
+ bfLp2(extrait,itl,body)
+
+bfLp1(iters,body)==
+ [vars,inits,sucs,filters,exits,value]:=bfSep bfAppend iters
+ nbody:=if null filters then body else bfAND [:filters,body]
+ value:=if null value then "NIL" else car value
+ exits:= ["COND",[bfOR exits,["RETURN",value]],
+ ['(QUOTE T),nbody]]
+ loop := ["LOOP",exits,:sucs]
+ if vars then loop :=
+ ["LET",[[v, i] for v in vars for i in inits], loop]
+ loop
+
+bfLp2(extrait,itl,body)==
+ EQCAR (itl,"ITERATORS")=>bfLp1(cons(extrait,CDR itl),body)
+ iters:=cdr itl
+ bfLpCross
+ ([["ITERATORS",extrait,:CDAR iters],:CDR iters],body)
+
+bfOpReduce(op,init,y,itl)==
+ g:=bfGenSymbol()
+ body:=
+ EQ(op,"AND")=>
+ bfMKPROGN [["SETQ",g,y],
+ ['COND, [['NOT,g],['RETURN,'NIL]]]]
+ EQ(op,"OR") =>
+ bfMKPROGN [["SETQ",g,y],
+ ['COND, [g,['RETURN,g]]]]
+ ['SETQ,g,[op,g,y]]
+ if null init
+ then
+ g1:=bfGenSymbol()
+ init:=['CAR,g1]
+ y:=['CDR,g1]
+ extrait:= [[[g],[init],[],[],[],[g]]]
+ bfMKPROGN [['L%T,g1,y],bfLp2(extrait,itl,body)]
+ else
+ init:=car init
+ extrait:= [[[g],[init],[],[],[],[g]]]
+ bfLp2(extrait,itl,body)
+
+bfLoop1 body == bfLp (bfIterators nil,body)
+
+bfSegment1(lo)== ["SEGMENT",lo,nil]
+
+bfSegment2(lo,hi)== ["SEGMENT",lo,hi]
+
+bfForInBy(variable,collection,step)==
+ bfFor(variable,collection,step)
+
+bfForin(lhs,U)==bfFor(lhs,U,1)
+
+bfLocal(a,b)==
+ EQ(b,"FLUID")=> compFluid a
+ EQ(b,"fluid")=> compFluid a
+ EQ(b,"local") => compFluid a
+ -- $typings:=cons(["TYPE",b,a],$typings)
+ a
+
+bfTake(n,x)==
+ null x=>x
+ n=0 => nil
+ cons(car x,bfTake(n-1,cdr x))
+
+bfDrop(n,x)==
+ null x or n=0 =>x
+ bfDrop(n-1,cdr x)
+
+bfDefSequence l == ['SEQ,: l]
+
+bfReturnNoName a ==
+ ["RETURN",a]
+
+bfSUBLIS(p,e)==
+ ATOM e=>bfSUBLIS1(p,e)
+ EQCAR(e,"QUOTE")=>e
+ cons(bfSUBLIS(p,car e),bfSUBLIS(p,cdr e))
+
++++ Returns e/p, where e is an atom. We assume that the
++++ DEFs form a system admitting a fix point; otherwise we may
++++ loop forever. That can happen only if nullary goats
++++ are recursive -- which they are not supposed to be.
++++ We don't enforce that restriction though.
+bfSUBLIS1(p,e)==
+ null p =>e
+ f:=CAR p
+ EQ(CAR f,e)=> bfSUBLIS(p, CDR f)
+ bfSUBLIS1(cdr p,e)
+
+defSheepAndGoats(x)==
+ EQCAR (x,"DEF") =>
+ [def,op,args,body]:=x
+ argl:=if bfTupleP args
+ then cdr args
+ else [args]
+ if null argl
+ then
+ opassoc:=[[op,:body]]
+ [opassoc,[],[]]
+ else
+ op1:=INTERN CONCAT(PNAME $op,'",",PNAME op)
+ opassoc:=[[op,:op1]]
+ defstack:=[["DEF",op1,args,body]]
+ [opassoc,defstack,[]]
+ EQCAR (x,"SEQ") => defSheepAndGoatsList(cdr x)
+ [[],[],[x]]
+
+defSheepAndGoatsList(x)==
+ if null x
+ then [[],[],[]]
+ else
+ [opassoc,defs,nondefs] := defSheepAndGoats car x
+ [opassoc1,defs1,nondefs1] := defSheepAndGoatsList cdr x
+ [append(opassoc,opassoc1),append(defs,defs1),
+ append(nondefs,nondefs1)]
+--% LET
+
+bfLetForm(lhs,rhs) == ['L%T,lhs,rhs]
+
+bfLET1(lhs,rhs) ==
+ IDENTP lhs => bfLetForm(lhs,rhs)
+ lhs is ['FLUID,.] => bfLetForm(lhs,rhs)
+ IDENTP rhs and not bfCONTAINED(rhs,lhs) =>
+ rhs1 := bfLET2(lhs,rhs)
+ EQCAR(rhs1,'L%T) => bfMKPROGN [rhs1,rhs]
+ EQCAR(rhs1,'PROGN) => APPEND(rhs1,[rhs])
+ if IDENTP CAR rhs1 then rhs1 := CONS(rhs1,NIL)
+ bfMKPROGN [:rhs1,rhs]
+ CONSP(rhs) and EQCAR(rhs,'L%T) and IDENTP(name := CADR rhs) =>
+ -- handle things like [a] := x := foo
+ l1 := bfLET1(name,CADDR rhs)
+ l2 := bfLET1(lhs,name)
+ EQCAR(l2,'PROGN) => bfMKPROGN [l1,:CDR l2]
+ if IDENTP CAR l2 then l2 := cons(l2,nil)
+ bfMKPROGN [l1,:l2,name]
+ g := INTERN CONCAT('"LETTMP#",STRINGIMAGE $letGenVarCounter)
+ $letGenVarCounter := $letGenVarCounter + 1
+ rhs1 := ['L%T,g,rhs]
+ let1 := bfLET1(lhs,g)
+ EQCAR(let1,'PROGN) => bfMKPROGN [rhs1,:CDR let1]
+ if IDENTP CAR let1 then let1 := CONS(let1,NIL)
+ bfMKPROGN [rhs1,:let1,g]
+
+bfCONTAINED(x,y)==
+ EQ(x,y) => true
+ ATOM y=> false
+ bfCONTAINED(x,car y) or bfCONTAINED(x,cdr y)
+
+bfLET2(lhs,rhs) ==
+ IDENTP lhs => bfLetForm(lhs,rhs)
+ NULL lhs => NIL
+ lhs is ['FLUID,.] => bfLetForm(lhs,rhs)
+ lhs is ['L%T,a,b] =>
+ a := bfLET2(a,rhs)
+ null (b := bfLET2(b,rhs)) => a
+ ATOM b => [a,b]
+ CONSP CAR b => CONS(a,b)
+ [a,b]
+ lhs is ['CONS,var1,var2] =>
+ var1 = "DOT" or (CONSP(var1) and EQCAR(var1,'QUOTE)) =>
+ bfLET2(var2,addCARorCDR('CDR,rhs))
+ l1 := bfLET2(var1,addCARorCDR('CAR,rhs))
+ null var2 or EQ(var2,"DOT") =>l1
+ if CONSP l1 and ATOM CAR l1 then l1 := cons(l1,nil)
+ IDENTP var2 =>
+ [:l1,bfLetForm(var2,addCARorCDR('CDR,rhs))]
+ l2 := bfLET2(var2,addCARorCDR('CDR,rhs))
+ if CONSP l2 and ATOM CAR l2 then l2 := cons(l2,nil)
+ APPEND(l1,l2)
+ lhs is ['APPEND,var1,var2] =>
+ patrev := bfISReverse(var2,var1)
+ rev := ['REVERSE,rhs]
+ g := INTERN CONCAT('"LETTMP#", STRINGIMAGE $letGenVarCounter)
+ $letGenVarCounter := $letGenVarCounter + 1
+ l2 := bfLET2(patrev,g)
+ if CONSP l2 and ATOM CAR l2 then l2 := cons(l2,nil)
+ var1 = "DOT" => [['L%T,g,rev],:l2]
+ last l2 is ['L%T, =var1, val1] =>
+ [['L%T,g,rev],:REVERSE CDR REVERSE l2,
+ bfLetForm(var1,['NREVERSE,val1])]
+ [['L%T,g,rev],:l2,bfLetForm(var1,['NREVERSE,var1])]
+ lhs is ["EQUAL",var1] =>
+ ['COND,[["EQUAL",var1,rhs],var1]]
+ -- The original expression may be one that involves literals as
+ -- sub-patterns, e.g.
+ -- ['SEQ, :l, ['exit, 1, x]] := item
+ -- We continue the processing as if that expression had been written
+ -- item is ['SEQ, :l, ['exit, 1, x]]
+ -- and generate appropriate codes.
+ -- -- gdr/2007-04-02.
+ isPred :=
+ $inDefIS => bfIS1(rhs,lhs)
+ bfIS(rhs,lhs)
+ ['COND,[isPred,rhs]]
+
+
+bfLET(lhs,rhs) ==
+ $letGenVarCounter : local := 1
+-- $inbfLet : local := true
+ bfLET1(lhs,rhs)
+
+addCARorCDR(acc,expr) ==
+ NULL CONSP expr => [acc,expr]
+ acc = 'CAR and EQCAR(expr,'REVERSE) =>
+ ["CAR",["LAST",:CDR expr]]
+ -- cons('last,CDR expr)
+ funs := '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR
+ CDAAR CDDAR CDADR CDDDR)
+ p := bfPosition(CAR expr,funs)
+ p = -1 => [acc,expr]
+ funsA := '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR CAAADR
+ CAADDR CADAAR CADDAR CADADR CADDDR)
+ funsR := '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR CDAADR
+ CDADDR CDDAAR CDDDAR CDDADR CDDDDR)
+ if acc = 'CAR then CONS(funsA.p,CDR expr)
+ else CONS(funsR.p,CDR expr)
+
+bfPosition(x,l) == bfPosn(x,l,0)
+bfPosn(x,l,n) ==
+ null l => -1
+ x=first l => n
+ bfPosn(x,rest l,n+1)
+
+--% IS
+
+bfISApplication(op,left,right)==
+ EQ(op ,"IS") => bfIS(left,right)
+ EQ(op ,"ISNT") => bfNOT bfIS(left,right)
+ [op ,left,right]
+
+bfIS(left,right)==
+ $isGenVarCounter:local :=1
+ $inDefIS :local :=true
+ bfIS1(left,right)
+
+bfISReverse(x,a) ==
+ x is ['CONS,:.] =>
+ NULL CADDR x => ['CONS,CADR x, a]
+ y := bfISReverse(CADDR x, NIL)
+ RPLACA(CDDR y,['CONS,CADR x,a])
+ y
+ bpSpecificErrorHere '"Error in bfISReverse"
+ bpTrap()
+
+bfIS1(lhs,rhs) ==
+ NULL rhs =>
+ ['NULL,lhs]
+ STRINGP rhs =>
+ ['EQ,lhs,['QUOTE,INTERN rhs]]
+ NUMBERP rhs =>
+ ["EQUAL",lhs,rhs]
+ ATOM rhs =>
+ ['PROGN,bfLetForm(rhs,lhs),''T]
+ rhs is ['QUOTE,a] =>
+ IDENTP a => ['EQ,lhs,rhs]
+ ["EQUAL",lhs,rhs]
+ rhs is ['L%T,c,d] =>
+ l :=
+ bfLET(c,lhs)
+-- $inbfLet => bfLET1(c,lhs)
+-- bfLET(c,lhs)
+ bfAND [bfIS1(lhs,d),bfMKPROGN [l,''T]]
+ rhs is ["EQUAL",a] =>
+ ["EQUAL",lhs,a]
+ CONSP lhs =>
+ g := INTERN CONCAT('"ISTMP#",STRINGIMAGE $isGenVarCounter)
+ $isGenVarCounter := $isGenVarCounter + 1
+ bfMKPROGN [['L%T,g,lhs],bfIS1(g,rhs)]
+ rhs is ['CONS,a,b] =>
+ a = "DOT" =>
+ NULL b =>
+ bfAND [['CONSP,lhs],
+ ['EQ,['CDR,lhs],'NIL]]
+ bfAND [['CONSP,lhs],
+ bfIS1(['CDR,lhs],b)]
+ NULL b =>
+ bfAND [['CONSP,lhs],
+ ['EQ,['CDR,lhs],'NIL],_
+ bfIS1(['CAR,lhs],a)]
+ b = "DOT" =>
+ bfAND [['CONSP,lhs],bfIS1(['CAR,lhs],a)]
+ a1 := bfIS1(['CAR,lhs],a)
+ b1 := bfIS1(['CDR,lhs],b)
+ a1 is ['PROGN,c,''T] and b1 is ['PROGN,:cls] =>
+ bfAND [['CONSP,lhs],bfMKPROGN [c,:cls]]
+ bfAND [['CONSP,lhs],a1,b1]
+ rhs is ['APPEND,a,b] =>
+ patrev := bfISReverse(b,a)
+ g := INTERN CONCAT('"ISTMP#",STRINGIMAGE $isGenVarCounter)
+ $isGenVarCounter := $isGenVarCounter + 1
+ rev := bfAND [['CONSP,lhs],['PROGN,['L%T,g,['REVERSE,lhs]],''T]]
+ l2 := bfIS1(g,patrev)
+ if CONSP l2 and ATOM CAR l2 then l2 := cons(l2,nil)
+ a = "DOT" => bfAND [rev,:l2]
+ bfAND [rev,:l2,['PROGN,bfLetForm(a,['NREVERSE,a]),''T]]
+ bpSpecificErrorHere '"bad IS code is generated"
+ bpTrap()
+
+bfApplication(bfop, bfarg) ==
+ if bfTupleP bfarg
+ then cons(bfop,CDR bfarg)
+ else cons(bfop,[bfarg])
+
+
+++ Token renaming. New Boot and Old Boot differs in the set of
+++ tokens they rename. When converting code written in Old Boot
+++ to New Boot, it is helpful to have some noise about potential
+++ divergence in semantics. So, when compiling with --boot=old,
+++ we compute the renaming in both Old Boot and New Boot and compare
+++ the results. If they differ, we prefer the old meaning, with some
+++ warnings. Notice that the task is compounded by the fact the
+++ tokens in both language do not always agreee.
+++ However, to minimize the flood of false positive, we
+++ keep a list of symbols which apparently differ in meanings, but
+++ which have been verified to agree.
+++ This is a valuable automated tool during the transition period.
+
+-- return the meaning of the x in Old Boot.
+bfGetOldBootName x ==
+ a := GET(x, "OLD-BOOT") => car a
+ x
+
+-- returns true if x has same meaning in both Old Boot and New Boot.
+bfSameMeaning x ==
+ GET(x, 'RENAME_-OK)
+
+-- returns the meaning of x in the appropriate Boot dialect.
+bfReName x==
+ newName :=
+ a := GET(x,"SHOERENAME") => car a
+ x
+ $translatingOldBoot and not bfSameMeaning x =>
+ oldName := bfGetOldBootName x
+ if newName ^= oldName then
+ warn [PNAME x, '" as `", PNAME newName, _
+ '"_' differs from Old Boot `", PNAME oldName, '"_'"]
+ oldName
+ newName
+
+
+bfInfApplication(op,left,right)==
+ EQ(op,"EQUAL") => bfQ(left,right)
+ EQ(op,"/=") => bfNOT bfQ(left,right)
+ EQ(op,">") => bfLessp(right,left)
+ EQ(op,"<") => bfLessp(left,right)
+ EQ(op,"<=") => bfNOT bfLessp(right,left)
+ EQ(op,">=") => bfNOT bfLessp(left,right)
+ EQ(op,"OR") => bfOR [left,right]
+ EQ(op,"AND") => bfAND [left,right]
+ [op,left,right]
+
+bfNOT x==
+ x is ["NOT",a]=> a
+ x is ["NULL",a]=> a
+ ["NOT",x]
+
+bfFlatten(op, x) ==
+ EQCAR(x,op) => CDR x
+ [x]
+
+bfOR l ==
+ null l => NIL
+ null cdr l => CAR l
+ ["OR",:[:bfFlatten("OR",c) for c in l]]
+
+bfAND l ==
+ null l=> 'T
+ null cdr l => CAR l
+ ["AND",:[:bfFlatten("AND",c) for c in l]]
+
+
+defQuoteId x== EQCAR(x,"QUOTE") and IDENTP CADR x
+
+bfSmintable x==
+ INTEGERP x or CONSP x and
+ MEMQ(CAR x, '(SIZE LENGTH))
+
+bfQ(l,r)==
+ if bfSmintable l or bfSmintable r
+ then ["EQL",l,r]
+ else if defQuoteId l or defQuoteId r
+ then ["EQ",l,r]
+ else
+ if null l
+ then ["NULL",r]
+ else if null r
+ then ["NULL",l]
+ else ["EQUAL",l,r]
+
+bfLessp(l,r)==
+ if r=0
+ then ["MINUSP", l]
+ else ["<",l,r]
+
+bfMDef (defOp,op,args,body) ==
+ argl:=if bfTupleP args then cdr args else [args]
+ [gargl,sgargl,nargl,largl]:=bfGargl argl
+ sb:=[cons(i,j) for i in nargl for j in sgargl]
+ body:= SUBLIS(sb,body)
+ sb2 := [["CONS",["QUOTE",i],j] for i in sgargl for j in largl]
+ body := ["SUBLIS",["LIST",:sb2],["QUOTE",body]]
+ lamex:= ["MLAMBDA",gargl,body]
+ def:= [op,lamex]
+ bfTuple
+ cons(shoeComp def,[:shoeComps bfDef1 d for d in $wheredefs])
+
+bfGargl argl==
+ if null argl
+ then [[],[],[],[]]
+ else
+ [a,b,c,d]:=bfGargl cdr argl
+ if car argl="&REST"
+ then [cons(car argl,b),b,c,
+ cons(["CONS",["QUOTE","LIST"],car d],cdr d)]
+ else
+ f:=bfGenSymbol()
+ [cons(f,a),cons(f,b),cons(car argl,c),cons(f,d)]
+
+bfDef1 [defOp,op,args,body] ==
+ argl:=if bfTupleP args then cdr args else [args]
+ [quotes,control,arglp,body]:=bfInsertLet (argl,body)
+ quotes=>shoeLAM(op,arglp,control,body)
+ [[op,["LAMBDA",arglp,body]]]
+
+shoeLAM (op,args,control,body)==
+ margs :=bfGenSymbol()
+ innerfunc:=INTERN(CONCAT(PNAME op,",LAM"))
+ [[innerfunc,["LAMBDA",args,body]],
+ [op,["MLAMBDA",["&REST",margs],["CONS",["QUOTE", innerfunc],
+ ["WRAP",margs, ["QUOTE", control]]]]]]
+
+bfDef(defOp,op,args,body) ==
+ $bfClamming =>
+ [.,op1,arg1,:body1]:=shoeComp first bfDef1 [defOp,op,args,body]
+ bfCompHash(op1,arg1,body1)
+ bfTuple
+ [:shoeComps bfDef1 d for d in cons([defOp,op,args,body],$wheredefs)]
+
+shoeComps x==[shoeComp def for def in x]
+shoeComp x==
+ a:=shoeCompTran CADR x
+ if EQCAR(a,"LAMBDA")
+ then ["DEFUN",CAR x,CADR a,:CDDR a]
+ else ["DEFMACRO",CAR x,CADR a,:CDDR a]
+
+bfInsertLet(x,body)==
+ if null x
+ then [false,nil,x,body]
+ else
+ if x is ["&REST",a]
+ then if a is ["QUOTE",b]
+ then [true,"QUOTE",["&REST",b],body]
+ else [false,nil,x,body]
+ else
+ [b,norq,name1,body1]:= bfInsertLet1 (car x,body)
+ [b1,norq1,name2,body2]:= bfInsertLet (cdr x,body1)
+ [b or b1,cons(norq,norq1),cons(name1,name2),body2]
+
+bfInsertLet1(y,body)==
+ if y is ["L%T",l,r]
+ then [false,nil,l,bfMKPROGN [bfLET(r,l),body]]
+ else if IDENTP y
+ then [false,nil,y,body]
+ else
+ if y is ["BVQUOTE",b]
+ then [true,"QUOTE",b,body]
+ else
+ g:=bfGenSymbol()
+ ATOM y => [false,nil,g,body]
+ [false,nil,g,bfMKPROGN [bfLET(compFluidize y,g),body]]
+
+shoeCompTran x==
+ lamtype:=CAR x
+ args :=CADR x
+ body :=CDDR x
+ $fluidVars:local:=nil
+ $locVars:local:=nil
+ $dollarVars:local:=nil
+ shoeCompTran1 body
+ $locVars:=SETDIFFERENCE(SETDIFFERENCE($locVars,
+ $fluidVars),shoeATOMs args)
+ body:=
+ if $fluidVars or $locVars or $dollarVars or $typings
+ then
+ lvars:=append($fluidVars,$locVars)
+ $fluidVars:=UNION($fluidVars,$dollarVars)
+ if null $fluidVars
+ then
+ null $typings=> shoePROG(lvars,body)
+ shoePROG(lvars,[["DECLARE",:$typings],:body])
+ else
+ fvars:=["DECLARE",["SPECIAL",:$fluidVars]]
+ null $typings => shoePROG(lvars,[fvars,:body])
+ shoePROG(lvars,[fvars,["DECLARE",:$typings],:body])
+ else shoePROG([], body)
+ fl:=shoeFluids args
+ body:=if fl
+ then
+ fvs:=["DECLARE",["SPECIAL",:fl]]
+ cons(fvs,body)
+ else body
+ [lamtype,args, :body]
+
+shoePROG(v,b)==
+ null b => [["PROG", v]]
+ [:blist,blast] := b
+ [["PROG",v,:blist,["RETURN", blast]]]
+
+shoeFluids x==
+ if null x
+ then nil
+ else if IDENTP x and bfBeginsDollar x
+ then [x]
+ else
+ if EQCAR(x,"QUOTE")
+ then []
+ else
+ if ATOM x
+ then nil
+ else append(shoeFluids car x,shoeFluids cdr x)
+shoeATOMs x==
+ if null x
+ then nil
+ else if ATOM x
+ then [x]
+ else append(shoeATOMs car x,shoeATOMs cdr x)
+
+shoeCompTran1 x==
+ ATOM x=>
+ IDENTP x and bfBeginsDollar x=>
+ $dollarVars:=
+ MEMQ(x,$dollarVars)=>$dollarVars
+ cons(x,$dollarVars)
+ nil
+ U:=car x
+ EQ(U,"QUOTE")=>nil
+ x is ["L%T",l,r]=>
+ RPLACA (x,"SETQ")
+ shoeCompTran1 r
+ IDENTP l =>
+ not bfBeginsDollar l=>
+ $locVars:=
+ MEMQ(l,$locVars)=>$locVars
+ cons(l,$locVars)
+ $dollarVars:=
+ MEMQ(l,$dollarVars)=>$dollarVars
+ cons(l,$dollarVars)
+ EQCAR(l,"FLUID")=>
+ $fluidVars:=
+ MEMQ(CADR l,$fluidVars)=>$fluidVars
+ cons(CADR l,$fluidVars)
+ RPLACA (CDR x,CADR l)
+ MEMQ(U,'(PROG LAMBDA))=>
+ newbindings:=nil
+ for y in CADR x repeat
+ not MEMQ(y,$locVars)=>
+ $locVars:=cons(y,$locVars)
+ newbindings:=cons(y,newbindings)
+ res:=shoeCompTran1 CDDR x
+ $locVars:=[y for y in $locVars | not MEMQ(y,newbindings)]
+ shoeCompTran1 car x
+ shoeCompTran1 cdr x
+
+bfTagged(a,b)==
+ IDENTP a =>
+ EQ(b,"FLUID") => bfLET(compFluid a,NIL)
+ EQ(b,"fluid") => bfLET(compFluid a,NIL)
+ EQ(b,"local") => bfLET(compFluid a,NIL)
+ $typings:=cons(["TYPE",b,a],$typings)
+ a
+ ["THE",b,a]
+
+bfAssign(l,r)==
+ if bfTupleP l then bfSetelt(CADR l,CDDR l ,r) else bfLET(l,r)
+
+bfSetelt(e,l,r)==
+ if null cdr l
+ then defSETELT(e,car l,r)
+ else bfSetelt(bfElt(e,car l),cdr l,r)
+
+bfElt(expr,sel)==
+ y:=SYMBOLP sel and GET(sel,"SHOESELFUNCTION")
+ y=>
+ INTEGERP y => ["ELT",expr,y]
+ [y,expr]
+ ["ELT",expr,sel]
+
+defSETELT(var,sel,expr)==
+ y:=SYMBOLP sel and GET(sel,"SHOESELFUNCTION")
+ y=>
+ INTEGERP y => ["SETF",["ELT",var,y],expr]
+ ["SETF",[y,var],expr]
+ ["SETF",["ELT",var,sel],expr]
+
+bfIfThenOnly(a,b)==
+ b1:=if EQCAR (b,"PROGN") then CDR b else [b]
+ ["COND",[a,:b1]]
+
+bfIf(a,b,c)==
+ b1:=if EQCAR (b,"PROGN") then CDR b else [b]
+ EQCAR (c,"COND") => ["COND",[a,:b1],:CDR c]
+ c1:=if EQCAR (c,"PROGN") then CDR c else [c]
+ ["COND",[a,:b1],['(QUOTE T),:c1]]
+
+bfExit(a,b)== ["COND",[a,["IDENTITY",b]]]
+
+bfMKPROGN l==
+ a:=[:bfFlattenSeq c for c in tails l]
+ null a=> nil
+ null CDR a=> CAR a
+ ["PROGN",:a]
+
+bfFlattenSeq x ==
+ null x=>NIL
+ f:=CAR x
+ ATOM f =>if CDR x then nil else [f]
+ EQCAR(f,"PROGN") =>
+ CDR x=> [i for i in CDR f| not ATOM i]
+ CDR f
+ [f]
+
+bfSequence l ==
+ null l=> NIL
+ transform:= [[a,b] for x in l while
+ x is ["COND",[a,["IDENTITY",b]]]]
+ no:=#transform
+ before:= bfTake(no,l)
+ aft := bfDrop(no,l)
+ null before =>
+ null rest l =>
+ f:=first l
+ if EQCAR(f,"PROGN")
+ then bfSequence CDR f
+ else f
+ bfMKPROGN [first l,bfSequence rest l]
+ null aft => ["COND",:transform]
+ ["COND",:transform,['(QUOTE T),bfSequence aft]]
+
+bfWhere (context,expr)==
+ [opassoc,defs,nondefs] := defSheepAndGoats context
+ a:=[[def,op,args,bfSUBLIS(opassoc,body)]
+ for d in defs |d is [def,op,args,body]]
+ $wheredefs:=append(a,$wheredefs)
+ bfMKPROGN bfSUBLIS(opassoc,NCONC(nondefs,[expr]))
+
+--shoeReadLispString(s,n)==
+-- n>= # s => nil
+-- [exp,ind]:=shoeReadLisp(s,n)
+-- null exp => nil
+-- cons(exp,shoeReadLispString(s,ind))
+
+bfReadLisp string==bfTuple shoeReadLispString (string,0)
+
+bfCompHash(op,argl,body) ==
+ auxfn:= INTERN CONCAT (PNAME op,'";")
+ computeFunction:= ["DEFUN",auxfn,argl,:body]
+ bfTuple [computeFunction,:bfMain(auxfn,op)]
+
+shoeCompileTimeEvaluation x ==
+ ["EVAL-WHEN", [KEYWORD::COMPILE_-TOPLEVEL], x]
+
+shoeEVALANDFILEACTQ x==
+ ["EVAL-WHEN", [KEYWORD::EXECUTE, KEYWORD::LOAD_-TOPLEVEL], x]
+
+bfMain(auxfn,op)==
+ g1:= bfGenSymbol()
+ arg:=["&REST",g1]
+ computeValue := ['APPLY,["FUNCTION",auxfn],g1]
+ cacheName:= INTERN CONCAT (PNAME op,'";AL")
+ g2:= bfGenSymbol()
+ getCode:= ['GETHASH,g1,cacheName]
+ secondPredPair:= [['SETQ,g2,getCode],g2]
+ putCode:= ['SETF ,getCode,computeValue]
+ thirdPredPair:= ['(QUOTE T),putCode]
+ codeBody:= ['PROG,[g2],
+ ['RETURN,['COND,secondPredPair,thirdPredPair]]]
+ mainFunction:= ["DEFUN",op,arg,codeBody]
+
+ cacheType:= 'hash_-table
+ cacheResetCode:= ['SETQ,cacheName,['MAKE_-HASHTABLE,
+ ["QUOTE","UEQUAL"]]]
+ cacheCountCode:= ['hashCount,cacheName]
+ cacheVector:=
+ [op,cacheName,cacheType,cacheResetCode,cacheCountCode]
+ [mainFunction,
+ shoeEVALANDFILEACTQ
+ ["SETF",["GET",
+ ["QUOTE", op],["QUOTE",'cacheInfo]],["QUOTE", cacheVector]],
+ shoeEVALANDFILEACTQ cacheResetCode ]
+
+bfNameOnly x==
+ if x="t"
+ then ["T"]
+ else [x]
+
+bfNameArgs (x,y)==
+ y:=if EQCAR(y,"TUPLE") then CDR y else [y]
+ cons(x,y)
+
+bfStruct(name,arglist)==
+ bfTuple [bfCreateDef i for i in arglist]
+
+bfCreateDef x==
+ if null cdr x
+ then
+ f:=car x
+ ["SETQ",f,["LIST",["QUOTE",f]]]
+ else
+ a:=[bfGenSymbol() for i in cdr x]
+ ["DEFUN",car x,a,["CONS",["QUOTE",car x],["LIST",:a]]]
+
+bfCaseItem(x,y)==[x,y]
+
+bfCase(x,y)==
+ g:=bfGenSymbol()
+ g1:=bfGenSymbol()
+ a:=bfLET(g,x)
+ b:=bfLET(g1,["CDR",g])
+ c:=bfCaseItems (g1,y)
+ bfMKPROGN [a,b,["CASE",["CAR", g],:c]]
+
+bfCaseItems(g,x)== [bfCI(g,i,j) for [i,j] in x]
+
+bfCI(g,x,y)==
+ a:=cdr x
+ if null a
+ then [car x,y]
+ else
+ b:=[[i,bfCARCDR(j,g)] for i in a for j in 0..]
+ [car x,["LET",b,y]]
+
+bfCARCDR (n,g)==[INTERN CONCAT ('"CA",bfDs n,'"R"),g]
+
+bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
+
diff --git a/src/boot/includer.boot b/src/boot/includer.boot
new file mode 100644
index 00000000..2f81c55a
--- /dev/null
+++ b/src/boot/includer.boot
@@ -0,0 +1,390 @@
+-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+-- All rights reserved.
+-- Copyright (C) 2007-2008, Gabriel Dos Reis.
+-- 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.
+--
+-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+-- names of its contributors may be used to endorse or promote products
+-- derived from this software without specific prior written permission.
+--
+-- 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 OWNER
+-- 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.
+--
+
+--
+-- Abstract:
+-- This file defines the includer (or preprocessor) of Boot programs.
+--
+
+module '"boot-includer"
+import '"tokens"
+
+)package "BOOTTRAN"
+-- BOOT INCLUDER
+
+-- Line syntax is
+--
+-- Include ::= (SimpleLine | If )* | ( )fin | empty)
+--
+-- SimpleLine::=
+-- PlainLine | includes the line
+-- )say line | outputs line to console
+-- )eval line | evaluates the boot line
+-- nothing included
+-- )line line | line is reproduced as is in lisp output
+-- )lisp line | line is read by lisp READ
+-- )package line | produces (IN-PACKAGE line) in lisp
+-- output
+-- )include filename | includes the file as boot code
+-- )includelisp filename | includes the file as lisp code
+-- read by lisp READ
+-- )includelines filename | includes the file as is
+-- in lisp output
+--
+-- If ::= )if SimpleLine* ElseLines )endif
+--
+-- ElseLines ::= )else SimpleLine* | )elseif SimpleLine* ElseLines | empty
+
+-- returns a printable representation of X, when it is a symbol
+-- or a character, as string. Otherwise, returns nil.
+PNAME x ==
+ SYMBOLP x => SYMBOL_-NAME x
+ CHARACTERP x => STRING x
+ nil
+
+-- converts X, a 1-length string, to a character.
+char x ==
+ CHAR(PNAME x, 0)
+
+EQCAR(x,y)== CONSP x and EQ(CAR x,y)
+
+-- returns the string representation of object X.
+STRINGIMAGE x ==
+ WRITE_-TO_-STRING x
+
+-- close STREAM.
+shoeCLOSE stream ==
+ CLOSE stream
+
+-- error out if file is not found.
+shoeNotFound fn ==
+ coreError [fn, '" not found"]
+ nil
+
+
+shoeReadLispString(s,n) ==
+ l:=# s
+ n >= l => nil
+ READ_-FROM_-STRING CONCAT ( "(", SUBSTRING(s,n,l-n) ,")")
+
+-- read a line from stream
+shoeReadLine stream ==
+ READ_-LINE(stream, nil, nil)
+
+-- write LINE to standard terminal I/O.
+shoeConsole line ==
+ WRITE_-LINE(line, _*TERMINAL_-IO_*)
+
+shoeSpaces n == MAKE_-FULL_-CVEC(n, '".")
+
+SoftShoeError(posn,key)==
+ coreError ['"in line ", STRINGIMAGE lineNo posn]
+ shoeConsole lineString posn
+ shoeConsole CONCAT(shoeSpaces lineCharacter posn,'"|")
+ shoeConsole key
+
+bpSpecificErrorAtToken(tok, key) ==
+ a:=shoeTokPosn tok
+ SoftShoeError(a,key)
+
+bpSpecificErrorHere(key) == bpSpecificErrorAtToken($stok, key)
+
+bpGeneralErrorHere() == bpSpecificErrorHere('"syntax error")
+
+bpIgnoredFromTo(pos1, pos2) ==
+ shoeConsole CONCAT('"ignored from line ", STRINGIMAGE lineNo pos1)
+ shoeConsole lineString pos1
+ shoeConsole CONCAT(shoeSpaces lineCharacter pos1,'"|")
+ shoeConsole CONCAT('"ignored through line ", STRINGIMAGE lineNo pos2)
+ shoeConsole lineString pos2
+ shoeConsole CONCAT(shoeSpaces lineCharacter pos2,'"|")
+
+-- Line inclusion support.
+
+lineNo p==CDAAR p
+lineString p==CAAAR p
+lineCharacter p==CDR p
+
+shoePackageStartsAt (lines,sz,name,stream)==
+ bStreamNull stream => [[],['nullstream]]
+ a:=CAAR stream
+ if #a >= 8 and SUBSTRING(a,0,8)='")package"
+ then shoePackageStartsAt(cons(CAAR stream,lines),sz,name,CDR stream)
+ else
+ if #a<sz
+ then shoePackageStartsAt(lines, sz,name,CDR stream)
+ else if SUBSTRING(a,0,sz)=name and (#a>sz and not shoeIdChar(a.sz))
+ then [lines,stream]
+ else shoePackageStartsAt(lines,sz,name,CDR stream)
+
+shoeFindLines(fn,name,a)==
+ if null a
+ then
+ shoeNotFound fn
+ []
+ else
+ [lines,b]:=shoePackageStartsAt([],#name,name, shoeInclude
+ bAddLineNumber(bRgen a,bIgen 0))
+ b:=shoeTransform2 b
+ if bStreamNull b
+ then
+ shoeConsole CONCAT (name,'" not found in ",fn)
+ []
+ else
+ if null lines
+ then shoeConsole '")package not found"
+ append(reverse lines,car b)
+
+-- Lazy inclusion support.
+
+$bStreamNil:=["nullstream"]
+
+bStreamNull x==
+ null x or EQCAR (x,"nullstream") => true
+ while EQCAR(x,"nonnullstream") repeat
+ st:=APPLY(CADR x,CDDR x)
+ RPLACA(x,CAR st)
+ RPLACD(x,CDR st)
+ EQCAR(x,"nullstream")
+
+bMap(f,x)==bDelay(function bMap1, [f,x])
+
+bMap1(:z)==
+ [f,x]:=z
+ if bStreamNull x
+ then $bStreamNil
+ else cons(FUNCALL(f,car x),bMap(f,cdr x))
+
+shoeFileMap(f, fn)==
+ a:=shoeInputFile fn
+ null a =>
+ shoeConsole CONCAT(fn,'" NOT FOUND")
+ $bStreamNil
+ shoeConsole CONCAT('"READING ",fn)
+ shoeInclude bAddLineNumber(bMap(f,bRgen a),bIgen 0)
+
+
+bDelay(f,x)==cons("nonnullstream",[f,:x])
+
+bAppend(x,y)==bDelay(function bAppend1,[x,y])
+
+bAppend1(:z)==
+ if bStreamNull car z
+ then if bStreamNull CADR z
+ then ["nullstream"]
+ else CADR z
+ else cons(CAAR z,bAppend(CDAR z,CADR z))
+
+bNext(f,s)==bDelay(function bNext1,[f,s])
+
+bNext1(f,s)==
+ bStreamNull s=> ["nullstream"]
+ h:= APPLY(f, [s])
+ bAppend(car h,bNext(f,cdr h))
+
+bRgen s==bDelay(function bRgen1,[s])
+
+bRgen1(:s) ==
+ a:=shoeReadLine car s
+ if shoePLACEP a
+ then
+-- shoeCLOSE car s
+ ["nullstream"]
+ else cons(a,bRgen car s)
+
+bIgen n==bDelay(function bIgen1,[n])
+
+bIgen1(:n)==
+ n:=car n+1
+ cons(n,bIgen n)
+
+bAddLineNumber(f1,f2)==bDelay(function bAddLineNumber1,[f1,f2])
+
+bAddLineNumber1(:f)==
+ [f1,f2] := f
+ bStreamNull f1 => ["nullstream"]
+ bStreamNull f2 => ["nullstream"]
+ cons(cons(CAR f1,CAR f2),bAddLineNumber(CDR f1,CDR f2))
+
+
+
+shoeFileInput fn==shoeFileMap(function IDENTITY,fn)
+
+shoePrefixLisp x== CONCAT('")lisp",x)
+shoeLispFileInput fn== shoeFileMap(function shoePrefixLisp,fn)
+
+shoePrefixLine x== CONCAT('")line",x)
+shoeLineFileInput fn== shoeFileMap(function shoePrefixLine,fn)
+
+shoePrefix?(prefix,whole) ==
+ #prefix > #whole => false
+ good:=true
+ for i in 0..#prefix-1 for j in 0.. while good repeat
+ good:= prefix.i = whole.j
+ if good then SUBSTRING(whole,#prefix,nil) else good
+
+shoePlainLine?(s) ==
+ #s = 0 => true
+ s.0 ^= char ")"
+
+shoeSay? s == shoePrefix?('")say", s)
+shoeEval? s == shoePrefix?('")eval", s)
+shoeInclude? s == shoePrefix?('")include", s)
+shoeFin? s == shoePrefix?('")fin", s)
+shoeIf? s == shoePrefix?('")if", s)
+shoeEndIf? s == shoePrefix?('")endif", s)
+shoeElse? s == shoePrefix?('")else", s)
+shoeElseIf? s == shoePrefix?('")elseif", s)
+shoePackage? s == shoePrefix?('")package", s)
+shoeLisp? s == shoePrefix?('")lisp", s)
+shoeIncludeLisp? s == shoePrefix?('")includelisp" ,s)
+shoeLine? s == shoePrefix?('")line", s)
+shoeIncludeLines? s == shoePrefix?('")includelines",s)
+shoeIncludeFunction? s == shoePrefix?('")includefunction",s)
+
+shoeBiteOff x==
+ n:=STRPOSL('" ",x,0,true)
+ null n => false
+ n1:=STRPOSL ('" ",x,n,nil)
+ null n1 => [SUBSTRING(x,n,nil),'""]
+ [SUBSTRING(x,n,n1-n),SUBSTRING(x,n1,nil)]
+
+shoeFileName x==
+ a:=shoeBiteOff x
+ null a => '""
+ c:=shoeBiteOff CADR a
+ null c => CAR a
+ CONCAT(CAR a,'".",CAR c)
+
+shoeFnFileName x==
+ a:=shoeBiteOff x
+ null a => ['"",'""]
+ c:=shoeFileName CADR a
+ null c => [CAR a,'""]
+ [CAR a, c]
+
+shoeFunctionFileInput [fun,fn]==
+ shoeOpenInputFile (a,fn,
+ shoeInclude bAddLineNumber( shoeFindLines(fn,fun,a),bIgen 0))
+
+shoeInclude s== bDelay(function shoeInclude1,[s])
+shoeInclude1 s==
+ bStreamNull s=> s
+ [h,:t] :=s
+ string :=CAR h
+ command :=shoeFin? string => $bStreamNil
+ command :=shoeIf? string => shoeThen([true],[STTOMC command],t)
+ bAppend(shoeSimpleLine h,shoeInclude t)
+
+shoeSimpleLine(h) ==
+ string :=CAR h
+ shoePlainLine? string=> [h]
+ command:=shoeLisp? string => [h]
+ command:=shoeIncludeLisp? string =>
+ shoeLispFileInput shoeFileName command
+ command:=shoeIncludeFunction? string =>
+ shoeFunctionFileInput shoeFnFileName command
+ command:=shoeLine? string => [h]
+ command:=shoeIncludeLines? string =>
+ shoeLineFileInput shoeFileName command
+ command:=shoeInclude? string => shoeFileInput shoeFileName command
+ command:=shoePackage? string => [h]
+ command:=shoeSay? string =>
+ shoeConsole command
+ nil
+ command:=shoeEval? string =>
+ STTOMC command
+ nil
+ shoeLineSyntaxError(h)
+ nil
+
+shoeThen(keep,b,s)== bDelay(function shoeThen1,[keep,b,s])
+shoeThen1(keep,b,s)==
+ bPremStreamNull s=> s
+ [h,:t] :=s
+ string :=CAR h
+ command :=shoeFin? string => bPremStreamNil(h)
+ keep1:= car keep
+ b1 := car b
+ command :=shoeIf? string =>
+ keep1 and b1=> shoeThen(cons(true,keep),cons(STTOMC command,b),t)
+ shoeThen(cons(false,keep),cons(false,b),t)
+ command :=shoeElseIf? string=>
+ keep1 and not b1=>
+ shoeThen(cons(true,rest keep),cons(STTOMC command,rest b),t)
+ shoeThen(cons(false,rest keep),cons(false,rest b),t)
+ command :=shoeElse? string =>
+ keep1 and not b1=>shoeElse(cons(true,rest keep),cons(true,rest b),t)
+ shoeElse(cons(false,rest keep),cons(false,rest b),t)
+ command :=shoeEndIf? string=>
+ null cdr b=> shoeInclude t
+ shoeThen(rest keep,rest b,t)
+ keep1 and b1 => bAppend(shoeSimpleLine h,shoeThen(keep,b,t))
+ shoeThen(keep,b,t)
+
+shoeElse(keep,b,s)== bDelay(function shoeElse1,[keep,b,s])
+shoeElse1(keep,b,s)==
+ bPremStreamNull s=> s
+ [h,:t] :=s
+ string :=CAR h
+ command :=shoeFin? string => bPremStreamNil(h)
+ b1:=car b
+ keep1:=car keep
+ command :=shoeIf? string=>
+ keep1 and b1=> shoeThen(cons(true,keep),cons(STTOMC command,b),t)
+ shoeThen(cons(false,keep),cons(false,b),t)
+ command :=shoeEndIf? string =>
+ null cdr b=> shoeInclude t
+ shoeThen(rest keep,rest b,t)
+ keep1 and b1 => bAppend(shoeSimpleLine h,shoeElse(keep,b,t))
+ shoeElse(keep,b,t)
+
+shoeLineSyntaxError(h)==
+ shoeConsole CONCAT('"INCLUSION SYNTAX ERROR IN LINE ",
+ STRINGIMAGE CDR h)
+ shoeConsole car h
+ shoeConsole '"LINE IGNORED"
+
+bPremStreamNil(h)==
+ shoeConsole CONCAT('"UNEXPECTED )fin IN LINE ",STRINGIMAGE CDR h)
+ shoeConsole car h
+ shoeConsole '"REST OF FILE IGNORED"
+ $bStreamNil
+
+bPremStreamNull(s)==
+ if bStreamNull s
+ then
+ shoeConsole '"FILE TERMINATED BEFORE )endif"
+ true
+ else false
diff --git a/src/boot/includer.boot.pamphlet b/src/boot/includer.boot.pamphlet
deleted file mode 100644
index 9775aeb1..00000000
--- a/src/boot/includer.boot.pamphlet
+++ /dev/null
@@ -1,1226 +0,0 @@
-\documentclass{article}
-\usepackage{axiom}
-
-\title{\File{src/boot/includer.boot} Pamphlet}
-\author{The Axiom Team}
-
-\begin{document}
-\maketitle
-
-\begin{abstract}
-\end{abstract}
-
-\eject
-\tableofcontents
-\eject
-
-\section{License}
-
-<<license>>=
--- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
--- 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.
---
--- - Neither the name of The Numerical ALgorithms Group Ltd. nor the
--- names of its contributors may be used to endorse or promote products
--- derived from this software without specific prior written permission.
---
--- 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 OWNER
--- 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.
-@
-
-\section{Call graphs}
-
-The followng sections give summarize symbols referenced by each
-function defined in this pamphlet.
-
-\subsection{[[shoeFileMap]]}
-\begin{itemize}
-\item \Code{shoeInputFile} --- \File{initial-env.lisp}
-\item \Code{\$bStreamNil} --- this file
-\item \Code{shoeConsole} --- \File{initial-env.lisp}
-\item \Code{CONCAT} --- \File{initial-env.lisp}
-\item \Code{shoeInclude} --- this file
-\item \Code{bAddLineNumber} --- \File{ptyout.boot}
-\item \Code{bMap} --- \File{pytout.boot}
-\item \Code{bRgen} --- \File{pytout.boot}
-\item \Code{bIgen} --- \File{pytout.boot}
-\end{itemize}
-
-\subsection{[[shoeFileInput]]}
-\begin{itemize}
-\item \Code{shoeFileMap} --- this file
-\end{itemize}
-
-\subsection{[[shoePrefixLisp]]}
-\begin{itemize}
-\item \Code{CONCAT} --- \File{npextras.lisp}
-\end{itemize}
-
-\subsection{[[shoeLispFileInput]]}
-\begin{itemize}
-\item \Code{shoeFileMap} --- this file
-\item \Code{shoePrefixLisp} --- this file
-\end{itemize}
-
-\subsection{[[shoePrefixLine]]}
-\begin{itemize}
-\item \Code{CONCAT} --- \File{initial-env.lisp}
-\end{itemize}
-
-\subsection{[[shoeLineFileInput]]}
-\begin{itemize}
-\item \Code{shoeFileMap} -- this file
-\item \Code{shoePrefixLine} -- this file
-\end{itemize}
-
-
-\subsection{[[shoePrefix?]]}
-\begin{itemize}
-\item \Code{SUBSTRING} --- \File{initial-env.lisp}
-\end{itemize}
-
-\subsection{[[shoePlainLine?]]}
-\begin{itemize}
-\item \Code{char}
-\end{itemize}
-
-\subsection{[[shoeSay?]]}
-\begin{itemize}
-\item \Code{shoePrefix?}
-\end{itemize}
-
-\subsection{[[shoeEval?]]}
-\begin{itemize}
-\item \Code{shoePrefix?}
-\end{itemize}
-
-\subsection{[[shoeInclude?]]}
-\begin{itemize}
-\item \Code{shoePrefix?}
-\end{itemize}
-
-\subsection{[[shoeFin?]]}
-\begin{itemize}
-\item \Code{shoePrefix?}
-\end{itemize}
-
-\subsection{[[shoeIf?]]}
-\begin{itemize}
-\item \Code{shoePrefix?}
-\end{itemize}
-
-\subsection{[[shoeEndIf?]]}
-\begin{itemize}
-\item \Code{shoePrefix?}
-\end{itemize}
-
-\subsection{[[shoeElse?]]}
-\begin{itemize}
-\item \Code{shoePrefix?}
-\end{itemize}
-
-\subsection{[[shoeElseIf?]]}
-\begin{itemize}
-\item \Code{shoePrefix?}
-\end{itemize}
-
-\subsection{[[shoePackage?]]}
-\begin{itemize}
-\item \Code{shoePrefix?}
-\end{itemize}
-
-\subsection{[[shoeLisp?]]}
-\begin{itemize}
-\item \Code{shoePrefix?}
-\end{itemize}
-
-\subsection{[[shoeIncludeLisp?]]}
-\begin{itemize}
-\item \Code{shoePrefix?}
-\end{itemize}
-
-\subsection{[[shoeLine?]]}
-\begin{itemize}
-\item \Code{shoePrefix?}
-\end{itemize}
-
-\subsection{[[shoeIncludeLines?]]}
-\begin{itemize}
-\item \Code{shoePrefix?}
-\end{itemize}
-
-\subsection{[[shoeIncludeFunction?]]}
-\begin{itemize}
-\item \Code{shoePrefix?}
-\end{itemize}
-
-\subsection{[[shoeBiteOff]]}
-\begin{itemize}
-\item \Code{STRPOSL} --- \File{initial-env.lisp}
-\item \Code{SUBSTRING} --- \File{initial-env.lisp}
-\end{itemize}
-
-\subsection{[[shoeFileName]]}
-\begin{itemize}
-\item \Code{shoeBiteOff} --- this file
-\item \Code{CONCAT} --- \File{initial-env.lisp}
-\end{itemize}
-
-\subsection{[[shoeFnFileName]]}
-\begin{itemize}
-\item \Code{shoeBiteOff} --- this file
-\item \Code{CONCAT} --- \File{initial-env.lisp}
-\end{itemize}
-
-\subsection{[[shoeFunctionFileInput]]}
-\begin{itemize}
-\item \Code{shoeOpenInputFile} --- \File{initial-env.lisp}
-\item \Code{shoeInclude} --- this file
-\item \Code{bAddLineNumber} --- \File{ptyout.boot}
-\item \Code{shoeFindLines} --- \File{ptyout.boot}
-\item \Code{bIgen} --- \File{ptyout.boot}
-\end{itemize}
-
-\subsection{[[shoeInclude]]}
-\begin{itemize}
-\item \Code{bDelay} --- \File{ptyout.boot}
-\item \Code{shoeInclude1} --- this file
-\end{itemize}
-
-\subsection{[[shoeInclude1]]}
-\begin{itemize}
-\item \Code{bStreamNull} --- \File{ptyout.boot}
-\item \Code{shoeFin?} --- this file
-\item \Code{\$bStreamNil} --- tis file
-\item \Code{shoeIf?} --- this file
-\item \Code{shoeThen} --- this file
-\item \Code{STTOMC} --- this file
-\item \Code{bAppend} --- \File{ptyout.boot}
-\item \Code{shoeSimpleLine} --- this file
-\item \Code{shoeInclude} --- this file
-\end{itemize}
-
-\subsection{[[shoeSimpleLine]]}
-\begin{itemize}
-\item \Code{shoePlainLine?} --- this file
-\item \Code{shoeLisp?} --- this file
-\item \Code{shoeIncludeLisp?} --- this file
-\item \Code{shoeLispFileInput} --- this file
-\item \Code{shoeFileName} --- this file
-\item \Code{shoeIncludeFunction?} --- this file
-\item \Code{shoeFunctionFileInput} --- this file
-\item \Code{shoeFnFileName} --- this file
-\item \Code{shoeLine?} --- this file
-\item \Code{shoeIncludeLines?} --- this file
-\item \Code{shoeInclude?} --- this file
-\item \Code{shoeFileInput} --- this file
-\item \Code{shoePackage?} --- this file
-\item \Code{shoeSay?} --- this file
-\item \Code{shoeConsole} --- this file
-\item \Code{shoeEval?} --- this file
-\item \Code{STTOMC} --- \File{ptyout.boot}
-\item \Code{shoeLineSyntaxError} --- this file
-\end{itemize}
-
-\subsection{[[shoeThen]]}
-\begin{itemize}
-\item \Code{bDelay} --- \File{ptyout.boot}
-\item \Code{shoeThen1} --- this file
-\end{itemize}
-
-\subsection{[[shoeThen1]]}
-\begin{itemize}
-\item \Code{bPremStreamNull} --- this file
-\item \Code{shoeFin?} --- this file
-\item \Code{bPremStreamNil} --- this file
-\item \Code{shoeIf?} --- this file
-\item \Code{shoeThen} --- this file
-\item \Code{STTOMC} --- \File{ptyout.boot}
-\item \Code{shoeThen} --- this file
-\item \Code{shoeElseIf?} --- this file
-\item \Code{shoeElse?} --- this file
-\item \Code{shoeElse} --- this file
-\item \Code{shoeEndIf?} --- this file
-\item \Code{shoeInclude} --- this file
-\item \Code{bAppend} --- \File{ptyout.boot}
-\item \Code{shoeSimpleLine} --- this file
-\end{itemize}
-
-\subsection{[[shoeElse]]}
-\begin{itemize}
-\item \Code{bDelay} --- \File{ptyout.boot}
-\item \Code{shoeElse1} --- this file
-\item \Code{bPremStreamNull} --- this file
-\item \Code{shoeFin?} --- this file
-\item \Code{bPremStreamNil} --- this file
-\item \Code{shoeIf?} --- this file
-\item \Code{shoeThen} --- this file
-\item \Code{STTOMC} --- \File{ptyout.boot}
-\item \Code{shoeEndIf?} --- this file
-\item \Code{bAppend} --- \File{ptyout.boot}
-\item \Code{shoeSimpleLine} --- this file
-\item \Code{shoeElse} --- this file
-\end{itemize}
-
-\subsection{[[shoeLineSyntaxError]]}
-\begin{itemize}
-\item \Code{shoeConsole} --- \File{ptyout.boot}
-\item \Code{CONCAT} --- \File{initial-env.lisp}
-\item \Code{STRINGIMAGE} --- \File{initial-env.lisp}
-\end{itemize}
-
-\subsection{[[bPremStreamNil]]}
-\begin{itemize}
-\item \Code{shoeConsole} --- \File{initial-env.lisp}
-\item \Code{CONCAT} --- \File{initial-env.lisp}
-\item \Code{STRINGIMAGE} --- \File{initial-env.lisp}
-\item \Code{\$bStreamNil} --- this file
-\end{itemize}
-
-\subsection{[[bPremStreamNull]]}
-\begin{itemize}
-\item \Code{bStreamNull} --- \File{ptyout.boot}
-\item \Code{shoeConsole} --- \File{initial-env.lisp}
-\end{itemize}
-
-
-\section{The Boot code}
-
-<<*>>=
-<<license>>
-
-module '"boot-includer"
-import '"tokens"
-
-)package "BOOTTRAN"
--- BOOT INCLUDER
-
--- Line syntax is
---
--- Include ::= (SimpleLine | If )* | ( )fin | empty)
---
--- SimpleLine::=
--- PlainLine | includes the line
--- )say line | outputs line to console
--- )eval line | evaluates the boot line
--- nothing included
--- )line line | line is reproduced as is in lisp output
--- )lisp line | line is read by lisp READ
--- )package line | produces (IN-PACKAGE line) in lisp
--- output
--- )include filename | includes the file as boot code
--- )includelisp filename | includes the file as lisp code
--- read by lisp READ
--- )includelines filename | includes the file as is
--- in lisp output
---
--- If ::= )if SimpleLine* ElseLines )endif
---
--- ElseLines ::= )else SimpleLine* | )elseif SimpleLine* ElseLines | empty
-
--- returns a printable representation of X, when it is a symbol
--- or a character, as string. Otherwise, returns nil.
-PNAME x ==
- SYMBOLP x => SYMBOL_-NAME x
- CHARACTERP x => STRING x
- nil
-
--- converts X, a 1-length string, to a character.
-char x ==
- CHAR(PNAME x, 0)
-
-EQCAR(x,y)== CONSP x and EQ(CAR x,y)
-
--- returns the string representation of object X.
-STRINGIMAGE x ==
- WRITE_-TO_-STRING x
-
--- close STREAM.
-shoeCLOSE stream ==
- CLOSE stream
-
--- error out if file is not found.
-shoeNotFound fn ==
- coreError [fn, '" not found"]
- nil
-
-
-shoeReadLispString(s,n) ==
- l:=# s
- n >= l => nil
- READ_-FROM_-STRING CONCAT ( "(", SUBSTRING(s,n,l-n) ,")")
-
--- read a line from stream
-shoeReadLine stream ==
- READ_-LINE(stream, nil, nil)
-
--- write LINE to standard terminal I/O.
-shoeConsole line ==
- WRITE_-LINE(line, _*TERMINAL_-IO_*)
-
-shoeSpaces n == MAKE_-FULL_-CVEC(n, '".")
-
-SoftShoeError(posn,key)==
- coreError ['"in line ", STRINGIMAGE lineNo posn]
- shoeConsole lineString posn
- shoeConsole CONCAT(shoeSpaces lineCharacter posn,'"|")
- shoeConsole key
-
-bpSpecificErrorAtToken(tok, key) ==
- a:=shoeTokPosn tok
- SoftShoeError(a,key)
-
-bpSpecificErrorHere(key) == bpSpecificErrorAtToken($stok, key)
-
-bpGeneralErrorHere() == bpSpecificErrorHere('"syntax error")
-
-bpIgnoredFromTo(pos1, pos2) ==
- shoeConsole CONCAT('"ignored from line ", STRINGIMAGE lineNo pos1)
- shoeConsole lineString pos1
- shoeConsole CONCAT(shoeSpaces lineCharacter pos1,'"|")
- shoeConsole CONCAT('"ignored through line ", STRINGIMAGE lineNo pos2)
- shoeConsole lineString pos2
- shoeConsole CONCAT(shoeSpaces lineCharacter pos2,'"|")
-
--- Line inclusion support.
-
-lineNo p==CDAAR p
-lineString p==CAAAR p
-lineCharacter p==CDR p
-
-shoePackageStartsAt (lines,sz,name,stream)==
- bStreamNull stream => [[],['nullstream]]
- a:=CAAR stream
- if #a >= 8 and SUBSTRING(a,0,8)='")package"
- then shoePackageStartsAt(cons(CAAR stream,lines),sz,name,CDR stream)
- else
- if #a<sz
- then shoePackageStartsAt(lines, sz,name,CDR stream)
- else if SUBSTRING(a,0,sz)=name and (#a>sz and not shoeIdChar(a.sz))
- then [lines,stream]
- else shoePackageStartsAt(lines,sz,name,CDR stream)
-
-shoeFindLines(fn,name,a)==
- if null a
- then
- shoeNotFound fn
- []
- else
- [lines,b]:=shoePackageStartsAt([],#name,name, shoeInclude
- bAddLineNumber(bRgen a,bIgen 0))
- b:=shoeTransform2 b
- if bStreamNull b
- then
- shoeConsole CONCAT (name,'" not found in ",fn)
- []
- else
- if null lines
- then shoeConsole '")package not found"
- append(reverse lines,car b)
-
--- Lazy inclusion support.
-
-$bStreamNil:=["nullstream"]
-
-bStreamNull x==
- null x or EQCAR (x,"nullstream") => true
- while EQCAR(x,"nonnullstream") repeat
- st:=APPLY(CADR x,CDDR x)
- RPLACA(x,CAR st)
- RPLACD(x,CDR st)
- EQCAR(x,"nullstream")
-
-bMap(f,x)==bDelay(function bMap1, [f,x])
-
-bMap1(:z)==
- [f,x]:=z
- if bStreamNull x
- then $bStreamNil
- else cons(FUNCALL(f,car x),bMap(f,cdr x))
-
-shoeFileMap(f, fn)==
- a:=shoeInputFile fn
- null a =>
- shoeConsole CONCAT(fn,'" NOT FOUND")
- $bStreamNil
- shoeConsole CONCAT('"READING ",fn)
- shoeInclude bAddLineNumber(bMap(f,bRgen a),bIgen 0)
-
-
-bDelay(f,x)==cons("nonnullstream",[f,:x])
-
-bAppend(x,y)==bDelay(function bAppend1,[x,y])
-
-bAppend1(:z)==
- if bStreamNull car z
- then if bStreamNull CADR z
- then ["nullstream"]
- else CADR z
- else cons(CAAR z,bAppend(CDAR z,CADR z))
-
-bNext(f,s)==bDelay(function bNext1,[f,s])
-
-bNext1(f,s)==
- bStreamNull s=> ["nullstream"]
- h:= APPLY(f, [s])
- bAppend(car h,bNext(f,cdr h))
-
-bRgen s==bDelay(function bRgen1,[s])
-
-bRgen1(:s) ==
- a:=shoeReadLine car s
- if shoePLACEP a
- then
--- shoeCLOSE car s
- ["nullstream"]
- else cons(a,bRgen car s)
-
-bIgen n==bDelay(function bIgen1,[n])
-
-bIgen1(:n)==
- n:=car n+1
- cons(n,bIgen n)
-
-bAddLineNumber(f1,f2)==bDelay(function bAddLineNumber1,[f1,f2])
-
-bAddLineNumber1(:f)==
- [f1,f2] := f
- bStreamNull f1 => ["nullstream"]
- bStreamNull f2 => ["nullstream"]
- cons(cons(CAR f1,CAR f2),bAddLineNumber(CDR f1,CDR f2))
-
-
-
-shoeFileInput fn==shoeFileMap(function IDENTITY,fn)
-
-shoePrefixLisp x== CONCAT('")lisp",x)
-shoeLispFileInput fn== shoeFileMap(function shoePrefixLisp,fn)
-
-shoePrefixLine x== CONCAT('")line",x)
-shoeLineFileInput fn== shoeFileMap(function shoePrefixLine,fn)
-
-shoePrefix?(prefix,whole) ==
- #prefix > #whole => false
- good:=true
- for i in 0..#prefix-1 for j in 0.. while good repeat
- good:= prefix.i = whole.j
- if good then SUBSTRING(whole,#prefix,nil) else good
-
-shoePlainLine?(s) ==
- #s = 0 => true
- s.0 ^= char ")"
-
-shoeSay? s == shoePrefix?('")say", s)
-shoeEval? s == shoePrefix?('")eval", s)
-shoeInclude? s == shoePrefix?('")include", s)
-shoeFin? s == shoePrefix?('")fin", s)
-shoeIf? s == shoePrefix?('")if", s)
-shoeEndIf? s == shoePrefix?('")endif", s)
-shoeElse? s == shoePrefix?('")else", s)
-shoeElseIf? s == shoePrefix?('")elseif", s)
-shoePackage? s == shoePrefix?('")package", s)
-shoeLisp? s == shoePrefix?('")lisp", s)
-shoeIncludeLisp? s == shoePrefix?('")includelisp" ,s)
-shoeLine? s == shoePrefix?('")line", s)
-shoeIncludeLines? s == shoePrefix?('")includelines",s)
-shoeIncludeFunction? s == shoePrefix?('")includefunction",s)
-
-shoeBiteOff x==
- n:=STRPOSL('" ",x,0,true)
- null n => false
- n1:=STRPOSL ('" ",x,n,nil)
- null n1 => [SUBSTRING(x,n,nil),'""]
- [SUBSTRING(x,n,n1-n),SUBSTRING(x,n1,nil)]
-
-shoeFileName x==
- a:=shoeBiteOff x
- null a => '""
- c:=shoeBiteOff CADR a
- null c => CAR a
- CONCAT(CAR a,'".",CAR c)
-
-shoeFnFileName x==
- a:=shoeBiteOff x
- null a => ['"",'""]
- c:=shoeFileName CADR a
- null c => [CAR a,'""]
- [CAR a, c]
-
-shoeFunctionFileInput [fun,fn]==
- shoeOpenInputFile (a,fn,
- shoeInclude bAddLineNumber( shoeFindLines(fn,fun,a),bIgen 0))
-
-shoeInclude s== bDelay(function shoeInclude1,[s])
-shoeInclude1 s==
- bStreamNull s=> s
- [h,:t] :=s
- string :=CAR h
- command :=shoeFin? string => $bStreamNil
- command :=shoeIf? string => shoeThen([true],[STTOMC command],t)
- bAppend(shoeSimpleLine h,shoeInclude t)
-
-shoeSimpleLine(h) ==
- string :=CAR h
- shoePlainLine? string=> [h]
- command:=shoeLisp? string => [h]
- command:=shoeIncludeLisp? string =>
- shoeLispFileInput shoeFileName command
- command:=shoeIncludeFunction? string =>
- shoeFunctionFileInput shoeFnFileName command
- command:=shoeLine? string => [h]
- command:=shoeIncludeLines? string =>
- shoeLineFileInput shoeFileName command
- command:=shoeInclude? string => shoeFileInput shoeFileName command
- command:=shoePackage? string => [h]
- command:=shoeSay? string =>
- shoeConsole command
- nil
- command:=shoeEval? string =>
- STTOMC command
- nil
- shoeLineSyntaxError(h)
- nil
-
-shoeThen(keep,b,s)== bDelay(function shoeThen1,[keep,b,s])
-shoeThen1(keep,b,s)==
- bPremStreamNull s=> s
- [h,:t] :=s
- string :=CAR h
- command :=shoeFin? string => bPremStreamNil(h)
- keep1:= car keep
- b1 := car b
- command :=shoeIf? string =>
- keep1 and b1=> shoeThen(cons(true,keep),cons(STTOMC command,b),t)
- shoeThen(cons(false,keep),cons(false,b),t)
- command :=shoeElseIf? string=>
- keep1 and not b1=>
- shoeThen(cons(true,rest keep),cons(STTOMC command,rest b),t)
- shoeThen(cons(false,rest keep),cons(false,rest b),t)
- command :=shoeElse? string =>
- keep1 and not b1=>shoeElse(cons(true,rest keep),cons(true,rest b),t)
- shoeElse(cons(false,rest keep),cons(false,rest b),t)
- command :=shoeEndIf? string=>
- null cdr b=> shoeInclude t
- shoeThen(rest keep,rest b,t)
- keep1 and b1 => bAppend(shoeSimpleLine h,shoeThen(keep,b,t))
- shoeThen(keep,b,t)
-
-shoeElse(keep,b,s)== bDelay(function shoeElse1,[keep,b,s])
-shoeElse1(keep,b,s)==
- bPremStreamNull s=> s
- [h,:t] :=s
- string :=CAR h
- command :=shoeFin? string => bPremStreamNil(h)
- b1:=car b
- keep1:=car keep
- command :=shoeIf? string=>
- keep1 and b1=> shoeThen(cons(true,keep),cons(STTOMC command,b),t)
- shoeThen(cons(false,keep),cons(false,b),t)
- command :=shoeEndIf? string =>
- null cdr b=> shoeInclude t
- shoeThen(rest keep,rest b,t)
- keep1 and b1 => bAppend(shoeSimpleLine h,shoeElse(keep,b,t))
- shoeElse(keep,b,t)
-
-shoeLineSyntaxError(h)==
- shoeConsole CONCAT('"INCLUSION SYNTAX ERROR IN LINE ",
- STRINGIMAGE CDR h)
- shoeConsole car h
- shoeConsole '"LINE IGNORED"
-
-bPremStreamNil(h)==
- shoeConsole CONCAT('"UNEXPECTED )fin IN LINE ",STRINGIMAGE CDR h)
- shoeConsole car h
- shoeConsole '"REST OF FILE IGNORED"
- $bStreamNil
-
-bPremStreamNull(s)==
- if bStreamNull s
- then
- shoeConsole '"FILE TERMINATED BEFORE )endif"
- true
- else false
-@
-
-
-\section{Translated Lisp code}
-
-<<includer.clisp>>=
-(EVAL-WHEN (:COMPILE-TOPLEVEL) (PROVIDE "boot-includer"))
-
-(IMPORT-MODULE "tokens")
-
-(IN-PACKAGE "BOOTTRAN")
-
-(DEFUN PNAME (|x|)
- (PROG ()
- (RETURN
- (COND
- ((SYMBOLP |x|) (SYMBOL-NAME |x|))
- ((CHARACTERP |x|) (STRING |x|))
- ('T NIL)))))
-
-(DEFUN |char| (|x|) (PROG () (RETURN (CHAR (PNAME |x|) 0))))
-
-(DEFUN EQCAR (|x| |y|)
- (PROG () (RETURN (AND (CONSP |x|) (EQ (CAR |x|) |y|)))))
-
-(DEFUN STRINGIMAGE (|x|) (PROG () (RETURN (WRITE-TO-STRING |x|))))
-
-(DEFUN |shoeCLOSE| (|stream|) (PROG () (RETURN (CLOSE |stream|))))
-
-(DEFUN |shoeNotFound| (|fn|)
- (PROG ()
- (RETURN (PROGN (|coreError| (LIST |fn| " not found")) NIL))))
-
-(DEFUN |shoeReadLispString| (|s| |n|)
- (PROG (|l|)
- (RETURN
- (PROGN
- (SETQ |l| (LENGTH |s|))
- (COND
- ((NOT (< |n| |l|)) NIL)
- ('T
- (READ-FROM-STRING
- (CONCAT '|(| (SUBSTRING |s| |n| (- |l| |n|)) '|)|))))))))
-
-(DEFUN |shoeReadLine| (|stream|)
- (PROG () (RETURN (READ-LINE |stream| NIL NIL))))
-
-(DEFUN |shoeConsole| (|line|)
- (PROG () (RETURN (WRITE-LINE |line| *TERMINAL-IO*))))
-
-(DEFUN |shoeSpaces| (|n|) (PROG () (RETURN (MAKE-FULL-CVEC |n| "."))))
-
-(DEFUN |SoftShoeError| (|posn| |key|)
- (PROG ()
- (RETURN
- (PROGN
- (|coreError| (LIST "in line " (STRINGIMAGE (|lineNo| |posn|))))
- (|shoeConsole| (|lineString| |posn|))
- (|shoeConsole|
- (CONCAT (|shoeSpaces| (|lineCharacter| |posn|)) "|"))
- (|shoeConsole| |key|)))))
-
-(DEFUN |bpSpecificErrorAtToken| (|tok| |key|)
- (PROG (|a|)
- (RETURN
- (PROGN
- (SETQ |a| (|shoeTokPosn| |tok|))
- (|SoftShoeError| |a| |key|)))))
-
-(DEFUN |bpSpecificErrorHere| (|key|)
- (PROG ()
- (DECLARE (SPECIAL |$stok|))
- (RETURN (|bpSpecificErrorAtToken| |$stok| |key|))))
-
-(DEFUN |bpGeneralErrorHere| ()
- (PROG () (RETURN (|bpSpecificErrorHere| "syntax error"))))
-
-(DEFUN |bpIgnoredFromTo| (|pos1| |pos2|)
- (PROG ()
- (RETURN
- (PROGN
- (|shoeConsole|
- (CONCAT "ignored from line "
- (STRINGIMAGE (|lineNo| |pos1|))))
- (|shoeConsole| (|lineString| |pos1|))
- (|shoeConsole|
- (CONCAT (|shoeSpaces| (|lineCharacter| |pos1|)) "|"))
- (|shoeConsole|
- (CONCAT "ignored through line "
- (STRINGIMAGE (|lineNo| |pos2|))))
- (|shoeConsole| (|lineString| |pos2|))
- (|shoeConsole|
- (CONCAT (|shoeSpaces| (|lineCharacter| |pos2|)) "|"))))))
-
-(DEFUN |lineNo| (|p|) (PROG () (RETURN (CDAAR |p|))))
-
-(DEFUN |lineString| (|p|) (PROG () (RETURN (CAAAR |p|))))
-
-(DEFUN |lineCharacter| (|p|) (PROG () (RETURN (CDR |p|))))
-
-(DEFUN |shoePackageStartsAt| (|lines| |sz| |name| |stream|)
- (PROG (|a|)
- (RETURN
- (COND
- ((|bStreamNull| |stream|) (LIST NIL (LIST '|nullstream|)))
- ('T
- (PROGN
- (SETQ |a| (CAAR |stream|))
- (COND
- ((AND (NOT (< (LENGTH |a|) 8))
- (EQUAL (SUBSTRING |a| 0 8) ")package"))
- (|shoePackageStartsAt| (CONS (CAAR |stream|) |lines|)
- |sz| |name| (CDR |stream|)))
- ((< (LENGTH |a|) |sz|)
- (|shoePackageStartsAt| |lines| |sz| |name|
- (CDR |stream|)))
- ((AND (EQUAL (SUBSTRING |a| 0 |sz|) |name|)
- (< |sz| (LENGTH |a|))
- (NULL (|shoeIdChar| (ELT |a| |sz|))))
- (LIST |lines| |stream|))
- ('T
- (|shoePackageStartsAt| |lines| |sz| |name|
- (CDR |stream|))))))))))
-
-(DEFUN |shoeFindLines| (|fn| |name| |a|)
- (PROG (|b| |lines| |LETTMP#1|)
- (RETURN
- (COND
- ((NULL |a|) (|shoeNotFound| |fn|) NIL)
- (#0='T
- (SETQ |LETTMP#1|
- (|shoePackageStartsAt| NIL (LENGTH |name|) |name|
- (|shoeInclude|
- (|bAddLineNumber| (|bRgen| |a|) (|bIgen| 0)))))
- (SETQ |lines| (CAR |LETTMP#1|)) (SETQ |b| (CADR |LETTMP#1|))
- (SETQ |b| (|shoeTransform2| |b|))
- (COND
- ((|bStreamNull| |b|)
- (|shoeConsole| (CONCAT |name| " not found in " |fn|)) NIL)
- (#0#
- (COND
- ((NULL |lines|) (|shoeConsole| ")package not found")))
- (APPEND (REVERSE |lines|) (CAR |b|)))))))))
-
-(DEFPARAMETER |$bStreamNil| (LIST '|nullstream|))
-
-(DEFUN |bStreamNull| (|x|)
- (PROG (|st|)
- (RETURN
- (COND
- ((OR (NULL |x|) (EQCAR |x| '|nullstream|)) T)
- ('T
- (PROGN
- (LOOP
- (COND
- ((NOT (EQCAR |x| '|nonnullstream|)) (RETURN NIL))
- ('T
- (PROGN
- (SETQ |st| (APPLY (CADR |x|) (CDDR |x|)))
- (RPLACA |x| (CAR |st|))
- (RPLACD |x| (CDR |st|))))))
- (EQCAR |x| '|nullstream|)))))))
-
-(DEFUN |bMap| (|f| |x|)
- (PROG () (RETURN (|bDelay| #'|bMap1| (LIST |f| |x|)))))
-
-(DEFUN |bMap1| (&REST |z|)
- (PROG (|x| |f|)
- (DECLARE (SPECIAL |$bStreamNil|))
- (RETURN
- (PROGN
- (SETQ |f| (CAR |z|))
- (SETQ |x| (CADR |z|))
- (COND
- ((|bStreamNull| |x|) |$bStreamNil|)
- ('T (CONS (FUNCALL |f| (CAR |x|)) (|bMap| |f| (CDR |x|)))))))))
-
-(DEFUN |shoeFileMap| (|f| |fn|)
- (PROG (|a|)
- (DECLARE (SPECIAL |$bStreamNil|))
- (RETURN
- (PROGN
- (SETQ |a| (|shoeInputFile| |fn|))
- (COND
- ((NULL |a|)
- (PROGN
- (|shoeConsole| (CONCAT |fn| " NOT FOUND"))
- |$bStreamNil|))
- ('T
- (PROGN
- (|shoeConsole| (CONCAT "READING " |fn|))
- (|shoeInclude|
- (|bAddLineNumber| (|bMap| |f| (|bRgen| |a|))
- (|bIgen| 0))))))))))
-
-(DEFUN |bDelay| (|f| |x|)
- (PROG () (RETURN (CONS '|nonnullstream| (CONS |f| |x|)))))
-
-(DEFUN |bAppend| (|x| |y|)
- (PROG () (RETURN (|bDelay| #'|bAppend1| (LIST |x| |y|)))))
-
-(DEFUN |bAppend1| (&REST |z|)
- (PROG ()
- (RETURN
- (COND
- ((|bStreamNull| (CAR |z|))
- (COND
- ((|bStreamNull| (CADR |z|)) (LIST '|nullstream|))
- (#0='T (CADR |z|))))
- (#0# (CONS (CAAR |z|) (|bAppend| (CDAR |z|) (CADR |z|))))))))
-
-(DEFUN |bNext| (|f| |s|)
- (PROG () (RETURN (|bDelay| #'|bNext1| (LIST |f| |s|)))))
-
-(DEFUN |bNext1| (|f| |s|)
- (PROG (|h|)
- (RETURN
- (COND
- ((|bStreamNull| |s|) (LIST '|nullstream|))
- ('T
- (PROGN
- (SETQ |h| (APPLY |f| (LIST |s|)))
- (|bAppend| (CAR |h|) (|bNext| |f| (CDR |h|)))))))))
-
-(DEFUN |bRgen| (|s|)
- (PROG () (RETURN (|bDelay| #'|bRgen1| (LIST |s|)))))
-
-(DEFUN |bRgen1| (&REST |s|)
- (PROG (|a|)
- (RETURN
- (PROGN
- (SETQ |a| (|shoeReadLine| (CAR |s|)))
- (COND
- ((|shoePLACEP| |a|) (LIST '|nullstream|))
- ('T (CONS |a| (|bRgen| (CAR |s|)))))))))
-
-(DEFUN |bIgen| (|n|)
- (PROG () (RETURN (|bDelay| #'|bIgen1| (LIST |n|)))))
-
-(DEFUN |bIgen1| (&REST |n|)
- (PROG ()
- (RETURN
- (PROGN (SETQ |n| (+ (CAR |n|) 1)) (CONS |n| (|bIgen| |n|))))))
-
-(DEFUN |bAddLineNumber| (|f1| |f2|)
- (PROG () (RETURN (|bDelay| #'|bAddLineNumber1| (LIST |f1| |f2|)))))
-
-(DEFUN |bAddLineNumber1| (&REST |f|)
- (PROG (|f2| |f1|)
- (RETURN
- (PROGN
- (SETQ |f1| (CAR |f|))
- (SETQ |f2| (CADR |f|))
- (COND
- ((|bStreamNull| |f1|) (LIST '|nullstream|))
- ((|bStreamNull| |f2|) (LIST '|nullstream|))
- ('T
- (CONS (CONS (CAR |f1|) (CAR |f2|))
- (|bAddLineNumber| (CDR |f1|) (CDR |f2|)))))))))
-
-(DEFUN |shoeFileInput| (|fn|)
- (PROG () (RETURN (|shoeFileMap| #'IDENTITY |fn|))))
-
-(DEFUN |shoePrefixLisp| (|x|) (PROG () (RETURN (CONCAT ")lisp" |x|))))
-
-(DEFUN |shoeLispFileInput| (|fn|)
- (PROG () (RETURN (|shoeFileMap| #'|shoePrefixLisp| |fn|))))
-
-(DEFUN |shoePrefixLine| (|x|) (PROG () (RETURN (CONCAT ")line" |x|))))
-
-(DEFUN |shoeLineFileInput| (|fn|)
- (PROG () (RETURN (|shoeFileMap| #'|shoePrefixLine| |fn|))))
-
-(DEFUN |shoePrefix?| (|prefix| |whole|)
- (PROG (|good|)
- (RETURN
- (COND
- ((< (LENGTH |whole|) (LENGTH |prefix|)) NIL)
- ('T
- (PROGN
- (SETQ |good| T)
- (LET ((|bfVar#1| (- (LENGTH |prefix|) 1)) (|i| 0) (|j| 0))
- (LOOP
- (COND
- ((OR (> |i| |bfVar#1|) (NOT |good|)) (RETURN NIL))
- ('T
- (SETQ |good|
- (EQUAL (ELT |prefix| |i|) (ELT |whole| |j|)))))
- (SETQ |i| (+ |i| 1))
- (SETQ |j| (+ |j| 1))))
- (COND
- (|good| (SUBSTRING |whole| (LENGTH |prefix|) NIL))
- ('T |good|))))))))
-
-(DEFUN |shoePlainLine?| (|s|)
- (PROG ()
- (RETURN
- (COND
- ((EQL (LENGTH |s|) 0) T)
- ('T (NOT (EQUAL (ELT |s| 0) (|char| '|)|))))))))
-
-(DEFUN |shoeSay?| (|s|) (PROG () (RETURN (|shoePrefix?| ")say" |s|))))
-
-(DEFUN |shoeEval?| (|s|)
- (PROG () (RETURN (|shoePrefix?| ")eval" |s|))))
-
-(DEFUN |shoeInclude?| (|s|)
- (PROG () (RETURN (|shoePrefix?| ")include" |s|))))
-
-(DEFUN |shoeFin?| (|s|) (PROG () (RETURN (|shoePrefix?| ")fin" |s|))))
-
-(DEFUN |shoeIf?| (|s|) (PROG () (RETURN (|shoePrefix?| ")if" |s|))))
-
-(DEFUN |shoeEndIf?| (|s|)
- (PROG () (RETURN (|shoePrefix?| ")endif" |s|))))
-
-(DEFUN |shoeElse?| (|s|)
- (PROG () (RETURN (|shoePrefix?| ")else" |s|))))
-
-(DEFUN |shoeElseIf?| (|s|)
- (PROG () (RETURN (|shoePrefix?| ")elseif" |s|))))
-
-(DEFUN |shoePackage?| (|s|)
- (PROG () (RETURN (|shoePrefix?| ")package" |s|))))
-
-(DEFUN |shoeLisp?| (|s|)
- (PROG () (RETURN (|shoePrefix?| ")lisp" |s|))))
-
-(DEFUN |shoeIncludeLisp?| (|s|)
- (PROG () (RETURN (|shoePrefix?| ")includelisp" |s|))))
-
-(DEFUN |shoeLine?| (|s|)
- (PROG () (RETURN (|shoePrefix?| ")line" |s|))))
-
-(DEFUN |shoeIncludeLines?| (|s|)
- (PROG () (RETURN (|shoePrefix?| ")includelines" |s|))))
-
-(DEFUN |shoeIncludeFunction?| (|s|)
- (PROG () (RETURN (|shoePrefix?| ")includefunction" |s|))))
-
-(DEFUN |shoeBiteOff| (|x|)
- (PROG (|n1| |n|)
- (RETURN
- (PROGN
- (SETQ |n| (STRPOSL " " |x| 0 T))
- (COND
- ((NULL |n|) NIL)
- (#0='T
- (PROGN
- (SETQ |n1| (STRPOSL " " |x| |n| NIL))
- (COND
- ((NULL |n1|) (LIST (SUBSTRING |x| |n| NIL) ""))
- (#0#
- (LIST (SUBSTRING |x| |n| (- |n1| |n|))
- (SUBSTRING |x| |n1| NIL)))))))))))
-
-(DEFUN |shoeFileName| (|x|)
- (PROG (|c| |a|)
- (RETURN
- (PROGN
- (SETQ |a| (|shoeBiteOff| |x|))
- (COND
- ((NULL |a|) "")
- (#0='T
- (PROGN
- (SETQ |c| (|shoeBiteOff| (CADR |a|)))
- (COND
- ((NULL |c|) (CAR |a|))
- (#0# (CONCAT (CAR |a|) "." (CAR |c|)))))))))))
-
-(DEFUN |shoeFnFileName| (|x|)
- (PROG (|c| |a|)
- (RETURN
- (PROGN
- (SETQ |a| (|shoeBiteOff| |x|))
- (COND
- ((NULL |a|) (LIST "" ""))
- (#0='T
- (PROGN
- (SETQ |c| (|shoeFileName| (CADR |a|)))
- (COND
- ((NULL |c|) (LIST (CAR |a|) ""))
- (#0# (LIST (CAR |a|) |c|))))))))))
-
-(DEFUN |shoeFunctionFileInput| (|bfVar#2|)
- (PROG (|fn| |fun|)
- (RETURN
- (PROGN
- (SETQ |fun| (CAR |bfVar#2|))
- (SETQ |fn| (CADR |bfVar#2|))
- (|shoeOpenInputFile| |a| |fn|
- (|shoeInclude|
- (|bAddLineNumber| (|shoeFindLines| |fn| |fun| |a|)
- (|bIgen| 0))))))))
-
-(DEFUN |shoeInclude| (|s|)
- (PROG () (RETURN (|bDelay| #'|shoeInclude1| (LIST |s|)))))
-
-(DEFUN |shoeInclude1| (|s|)
- (PROG (|command| |string| |t| |h|)
- (DECLARE (SPECIAL |$bStreamNil|))
- (RETURN
- (COND
- ((|bStreamNull| |s|) |s|)
- (#0='T
- (PROGN
- (SETQ |h| (CAR |s|))
- (SETQ |t| (CDR |s|))
- (SETQ |string| (CAR |h|))
- (COND
- ((SETQ |command| (|shoeFin?| |string|)) |$bStreamNil|)
- ((SETQ |command| (|shoeIf?| |string|))
- (|shoeThen| (LIST T) (LIST (STTOMC |command|)) |t|))
- (#0#
- (|bAppend| (|shoeSimpleLine| |h|) (|shoeInclude| |t|))))))))))
-
-(DEFUN |shoeSimpleLine| (|h|)
- (PROG (|command| |string|)
- (RETURN
- (PROGN
- (SETQ |string| (CAR |h|))
- (COND
- ((|shoePlainLine?| |string|) (LIST |h|))
- ((SETQ |command| (|shoeLisp?| |string|)) (LIST |h|))
- ((SETQ |command| (|shoeIncludeLisp?| |string|))
- (|shoeLispFileInput| (|shoeFileName| |command|)))
- ((SETQ |command| (|shoeIncludeFunction?| |string|))
- (|shoeFunctionFileInput| (|shoeFnFileName| |command|)))
- ((SETQ |command| (|shoeLine?| |string|)) (LIST |h|))
- ((SETQ |command| (|shoeIncludeLines?| |string|))
- (|shoeLineFileInput| (|shoeFileName| |command|)))
- ((SETQ |command| (|shoeInclude?| |string|))
- (|shoeFileInput| (|shoeFileName| |command|)))
- ((SETQ |command| (|shoePackage?| |string|)) (LIST |h|))
- ((SETQ |command| (|shoeSay?| |string|))
- (PROGN (|shoeConsole| |command|) NIL))
- ((SETQ |command| (|shoeEval?| |string|))
- (PROGN (STTOMC |command|) NIL))
- ('T (PROGN (|shoeLineSyntaxError| |h|) NIL)))))))
-
-(DEFUN |shoeThen| (|keep| |b| |s|)
- (PROG () (RETURN (|bDelay| #'|shoeThen1| (LIST |keep| |b| |s|)))))
-
-(DEFUN |shoeThen1| (|keep| |b| |s|)
- (PROG (|b1| |keep1| |command| |string| |t| |h|)
- (RETURN
- (COND
- ((|bPremStreamNull| |s|) |s|)
- (#0='T
- (PROGN
- (SETQ |h| (CAR |s|))
- (SETQ |t| (CDR |s|))
- (SETQ |string| (CAR |h|))
- (COND
- ((SETQ |command| (|shoeFin?| |string|))
- (|bPremStreamNil| |h|))
- (#0#
- (PROGN
- (SETQ |keep1| (CAR |keep|))
- (SETQ |b1| (CAR |b|))
- (COND
- ((SETQ |command| (|shoeIf?| |string|))
- (COND
- ((AND |keep1| |b1|)
- (|shoeThen| (CONS T |keep|)
- (CONS (STTOMC |command|) |b|) |t|))
- (#0#
- (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|))))
- ((SETQ |command| (|shoeElseIf?| |string|))
- (COND
- ((AND |keep1| (NULL |b1|))
- (|shoeThen| (CONS T (CDR |keep|))
- (CONS (STTOMC |command|) (CDR |b|)) |t|))
- (#0#
- (|shoeThen| (CONS NIL (CDR |keep|))
- (CONS NIL (CDR |b|)) |t|))))
- ((SETQ |command| (|shoeElse?| |string|))
- (COND
- ((AND |keep1| (NULL |b1|))
- (|shoeElse| (CONS T (CDR |keep|))
- (CONS T (CDR |b|)) |t|))
- (#0#
- (|shoeElse| (CONS NIL (CDR |keep|))
- (CONS NIL (CDR |b|)) |t|))))
- ((SETQ |command| (|shoeEndIf?| |string|))
- (COND
- ((NULL (CDR |b|)) (|shoeInclude| |t|))
- (#0# (|shoeThen| (CDR |keep|) (CDR |b|) |t|))))
- ((AND |keep1| |b1|)
- (|bAppend| (|shoeSimpleLine| |h|)
- (|shoeThen| |keep| |b| |t|)))
- (#0# (|shoeThen| |keep| |b| |t|))))))))))))
-
-(DEFUN |shoeElse| (|keep| |b| |s|)
- (PROG () (RETURN (|bDelay| #'|shoeElse1| (LIST |keep| |b| |s|)))))
-
-(DEFUN |shoeElse1| (|keep| |b| |s|)
- (PROG (|keep1| |b1| |command| |string| |t| |h|)
- (RETURN
- (COND
- ((|bPremStreamNull| |s|) |s|)
- (#0='T
- (PROGN
- (SETQ |h| (CAR |s|))
- (SETQ |t| (CDR |s|))
- (SETQ |string| (CAR |h|))
- (COND
- ((SETQ |command| (|shoeFin?| |string|))
- (|bPremStreamNil| |h|))
- (#0#
- (PROGN
- (SETQ |b1| (CAR |b|))
- (SETQ |keep1| (CAR |keep|))
- (COND
- ((SETQ |command| (|shoeIf?| |string|))
- (COND
- ((AND |keep1| |b1|)
- (|shoeThen| (CONS T |keep|)
- (CONS (STTOMC |command|) |b|) |t|))
- (#0#
- (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|))))
- ((SETQ |command| (|shoeEndIf?| |string|))
- (COND
- ((NULL (CDR |b|)) (|shoeInclude| |t|))
- (#0# (|shoeThen| (CDR |keep|) (CDR |b|) |t|))))
- ((AND |keep1| |b1|)
- (|bAppend| (|shoeSimpleLine| |h|)
- (|shoeElse| |keep| |b| |t|)))
- (#0# (|shoeElse| |keep| |b| |t|))))))))))))
-
-(DEFUN |shoeLineSyntaxError| (|h|)
- (PROG ()
- (RETURN
- (PROGN
- (|shoeConsole|
- (CONCAT "INCLUSION SYNTAX ERROR IN LINE "
- (STRINGIMAGE (CDR |h|))))
- (|shoeConsole| (CAR |h|))
- (|shoeConsole| "LINE IGNORED")))))
-
-(DEFUN |bPremStreamNil| (|h|)
- (PROG ()
- (DECLARE (SPECIAL |$bStreamNil|))
- (RETURN
- (PROGN
- (|shoeConsole|
- (CONCAT "UNEXPECTED )fin IN LINE " (STRINGIMAGE (CDR |h|))))
- (|shoeConsole| (CAR |h|))
- (|shoeConsole| "REST OF FILE IGNORED")
- |$bStreamNil|))))
-
-(DEFUN |bPremStreamNull| (|s|)
- (PROG ()
- (RETURN
- (COND
- ((|bStreamNull| |s|)
- (|shoeConsole| "FILE TERMINATED BEFORE )endif") T)
- ('T NIL)))))
-
-@
-
-
-\end{document}
diff --git a/src/boot/initial-env.lisp.pamphlet b/src/boot/initial-env.lisp
index d3242458..d256e7c4 100644
--- a/src/boot/initial-env.lisp.pamphlet
+++ b/src/boot/initial-env.lisp
@@ -1,29 +1,7 @@
-%% Oh Emacs, this is a -*- Lisp -*- file despite apperance.
-\documentclass{article}
-\usepackage{axiom}
-
-\title{\File{src/boot/initial-env.lisp} Pamphlet}
-\author{Gabriel Dos~Reis \and Timothy Daly}
-
-\begin{document}
-\maketitle
-
-\begin{abstract}
- This pamphlet defines the base initial environment for building
- a Boot translator image. It essentially etablishes a namespace
- (package \Code{Boot}) for the Boot translator, and defines
- some macros that need to be present during translation of Boot
- source files.
-\end{abstract}
-
-\tableofcontents
-\eject
-
-\section{License}
-
-<<license>>=
;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
;; All rights reserved.
+;; Copyright (C) 2007-2008, Gabriel Dos Reis.
+;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
@@ -52,60 +30,23 @@
;; 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.
+;;
-@
-\section{The \code{BOOTTRAN} package}
+;;
+;; Abstract:
+;; This file defines the base initial environment for building
+;; a Boot translator image. It essentially etablishes a namespace
+;; (package BOOTTRAN) for the Boot translator, and defines
+;; some macros that need to be present during translation of Boot
+;; source files.
+;;
-All Boot translator functions are defined in the package
-\code{BOOTTRAN}. It is expected that the translator interfaces
-with the rest of the system only through the functions explicitly exported
-by \code{BOOTTRAN}:
-<<boot-translator>>=
(defpackage "BOOTTRAN"
(:use "AxiomCore")
#+:common-lisp (:use "COMMON-LISP")
#-:common-lisp (:use "LISP"))
-@
-
-\section{I/O macros}
-
-The Boot translator source codes make uses of some
-higher order functions. For various reasons, including efficiency,
-they are defined as Lisp macros and must therefore be available in each
-source file that uses them.
-
-\subsection{[[shoeInputFile]]}
-
-<<with-input-file>>=
-(defmacro |shoeOpenInputFile|
- (stream fn prog)
- `(with-open-file (,stream ,fn :direction :input
- :if-does-not-exist nil) ,prog))
-@
-
-This macro creates a input stream object from a file name [[fn]], and
-processes it with [[prog]]. If the file name designates a non-existent
-file, the standard input is used instead.
-
-\subsection{[[shoeOpenOutputFile]]}
-<<with-output-file>>=
-(defmacro |shoeOpenOutputFile|
- (stream fn prog)
- `(with-open-file (,stream ,fn :direction :output
- :if-exists :supersede) ,prog))
-@
-
-This macro creates an output stream object from a file name [[fn]], and
-processes it with [[prog]]. The output file is overwritten if it exists.
-
-\section{Putting it together}
-
-<<*>>=
-<<license>>
-
-<<boot-translator>>
(in-package "BOOTTRAN")
@@ -113,12 +54,22 @@ processes it with [[prog]]. The output file is overwritten if it exists.
#+:ieee-floating-point (defparameter $ieee t)
#-:ieee-floating-point (defparameter $ieee nil)
-(defmacro memq (a b) `(member ,a ,b :test #'eq))
+(defmacro memq (a b)
+ `(member ,a ,b :test #'eq))
+
(defvar *lisp-bin-filetype* "o")
+
(defvar *lisp-source-filetype* "lisp")
-(defun setdifference (x y) (set-difference x y))
-(defun make-cvec (sint) (make-string sint))
-(defun MAKE-VEC (n) (make-array n))
+
+(defun setdifference (x y)
+ (set-difference x y))
+
+(defun make-cvec (sint)
+ (make-string sint))
+
+(defun MAKE-VEC (n)
+ (make-array n))
+
(defun concat (&rest l)
(progn
(setq l (mapcar #'string l))
@@ -127,16 +78,22 @@ processes it with [[prog]]. The output file is overwritten if it exists.
(defun |shoeInputFile| (filespec )
(open filespec :direction :input :if-does-not-exist nil))
-<<with-input-file>>
+(defmacro |shoeOpenInputFile|
+ (stream fn prog)
+ `(with-open-file (,stream ,fn :direction :input
+ :if-does-not-exist nil) ,prog))
-<<with-output-file>>
+(defmacro |shoeOpenOutputFile|
+ (stream fn prog)
+ `(with-open-file (,stream ,fn :direction :output
+ :if-exists :supersede) ,prog))
(defun shoeprettyprin1 (x &optional (stream *standard-output*))
(let ((*print-pretty* t)
- (*print-array* t)
- (*print-circle* t)
- (*print-level* nil)
- (*print-length* nil))
+ (*print-array* t)
+ (*print-circle* t)
+ (*print-level* nil)
+ (*print-length* nil))
(prin1 x stream)))
(defun reallyprettyprint (x &optional (stream *terminal-io*))
@@ -144,14 +101,15 @@ processes it with [[prog]]. The output file is overwritten if it exists.
(defun shoeprettyprin0 (x &optional (stream *standard-output*))
(let ((*print-pretty* nil)
- (*print-array* t)
- (*print-circle* t)
- (*print-level* nil)
- (*print-length* nil))
+ (*print-array* t)
+ (*print-circle* t)
+ (*print-level* nil)
+ (*print-length* nil))
(prin1 x stream)))
(defun shoenotprettyprint (x &optional (stream *terminal-io*))
- (shoeprettyprin0 x stream) (terpri stream))
+ (shoeprettyprin0 x stream)
+ (terpri stream))
(defun make-full-cvec (sint &optional (char #\space))
(make-string sint :initial-element (character char)))
@@ -160,22 +118,23 @@ processes it with [[prog]]. The output file is overwritten if it exists.
(eq item nil))
(defun substring (cvec start length)
- (if length (subseq cvec start (+ start length))
+ (if length
+ (subseq cvec start (+ start length))
(subseq cvec start)))
(defun MAKE-HASHTABLE (id1)
(let ((test (case id1
- ((EQ ID) #'eq)
- (CVEC #'equal)
- ((UEQUAL EQUAL) #'equal)
- (otherwise (error "bad arg to make-hashtable")))))
+ ((EQ ID) #'eq)
+ (CVEC #'equal)
+ ((UEQUAL EQUAL) #'equal)
+ (otherwise (error "bad arg to make-hashtable")))))
(make-hash-table :test test)))
(defun HKEYS (table)
(let (keys)
(maphash #'(lambda (key val)
- (declare (ignore val))
- (push key keys)) table)
+ (declare (ignore val))
+ (push key keys)) table)
keys))
@@ -198,25 +157,32 @@ processes it with [[prog]]. The output file is overwritten if it exists.
(defun strpos (what in start dontcare)
(setq what (string what) in (string in))
- (if dontcare (progn (setq dontcare (character dontcare))
- (search what in :start2 start
- :test #'(lambda (x y) (or (eql x dontcare)
- (eql x y)))))
+ (if dontcare
+ (progn
+ (setq dontcare (character dontcare))
+ (search what in :start2 start
+ :test #'(lambda (x y) (or (eql x dontcare)
+ (eql x y)))))
(search what in :start2 start)))
(defun strposl (table cvec sint item)
(setq cvec (string cvec))
(if (not item)
- (position table cvec :test #'(lambda (x y) (position y x)) :start sint)
- (position table cvec :test-not #'(lambda (x y) (position y x))
- :start sint )))
+ (position table cvec
+ :test #'(lambda (x y) (position y x))
+ :start sint)
+ (position table cvec
+ :test-not #'(lambda (x y) (position y x))
+ :start sint)))
(defun VEC-SETELT (vec ind val)
(setf (elt vec ind) val))
(defun bvec-make-full (n x)
- (make-array (list n) :element-type 'bit :initial-element x))
+ (make-array (list n)
+ :element-type 'bit
+ :initial-element x))
(defun make-bvec (n)
(bvec-make-full n 0))
@@ -226,8 +192,8 @@ processes it with [[prog]]. The output file is overwritten if it exists.
(defun size (l)
(cond ((vectorp l) (length l))
- ((consp l) (list-length l))
- (t 0)))
+ ((consp l) (list-length l))
+ (t 0)))
(defun identp (a)
(and (symbolp a) a))
@@ -237,7 +203,3 @@ processes it with [[prog]]. The output file is overwritten if it exists.
(defun |last| (x)
(car (last x)))
-@
-
-
-\end{document}
diff --git a/src/boot/parser.boot b/src/boot/parser.boot
new file mode 100644
index 00000000..9908a68a
--- /dev/null
+++ b/src/boot/parser.boot
@@ -0,0 +1,1041 @@
+-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+-- All rights reserved.
+-- Copyright (C) 2007-2008, Gabriel Dos Reis.
+-- 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.
+--
+-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+-- names of its contributors may be used to endorse or promote products
+-- derived from this software without specific prior written permission.
+--
+-- 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 OWNER
+-- 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.
+--
+
+--
+-- Abstract:
+-- This file defines the Boot grammar and parser. The parser
+-- is hand-written based on `parser combinators' technology.
+--
+
+
+module '"boot-parser"
+import '"includer"
+import '"scanner"
+import '"ast"
+
+)package "BOOTTRAN"
+
+
+++ true when the current function definition has its parameters
+++ written round parenthesis.
+$sawParenthesizedHead := false
+
+++ true if the current function definition has a return statement.
+$bodyHasReturn := false
+
+
+bpFirstToken()==
+ $stok:=
+ if null $inputStream
+ then shoeTokConstruct("ERROR","NOMORE",shoeTokPosn $stok)
+ else CAR $inputStream
+ $ttok:=shoeTokPart $stok
+ true
+
+bpFirstTok()==
+ $stok:=
+ if null $inputStream
+ then shoeTokConstruct("ERROR","NOMORE",shoeTokPosn $stok)
+ else CAR $inputStream
+ $ttok:=shoeTokPart $stok
+ $bpParenCount>0 and EQCAR($stok,"KEY") =>
+ EQ($ttok,"SETTAB")=>
+ $bpCount:=$bpCount+1
+ bpNext()
+ EQ($ttok,"BACKTAB")=>
+ $bpCount:=$bpCount-1
+ bpNext()
+ EQ($ttok,"BACKSET")=>
+ bpNext()
+ true
+ true
+
+bpNext() ==
+ $inputStream := CDR($inputStream)
+ bpFirstTok()
+
+bpNextToken() ==
+ $inputStream := CDR($inputStream)
+ bpFirstToken()
+
+bpState()== [$inputStream,$stack,$bpParenCount,$bpCount]
+--cons($inputStream,$stack)
+
+bpRestore(x)==
+ $inputStream:=CAR x
+ bpFirstToken()
+ $stack:=CADR x
+ $bpParenCount:=CADDR x
+ $bpCount:=CADDDR x
+ true
+
+bpPush x==$stack:=CONS(x,$stack)
+
+bpPushId()==
+ $stack:=CONS(bfReName $ttok,$stack)
+
+bpPop1()==
+ a:=CAR $stack
+ $stack:=CDR $stack
+ a
+
+bpPop2()==
+ a:=CADR $stack
+ RPLACD($stack,CDDR $stack)
+ a
+
+bpPop3()==
+ a:=CADDR $stack
+ RPLACD(CDR $stack,CDDDR $stack)
+ a
+
+bpIndentParenthesized f==
+ $bpCount:local:=0
+ a:=$stok
+ if bpEqPeek "OPAREN"
+ then
+ $bpParenCount:=$bpParenCount+1
+ bpNext()
+ if APPLY(f,nil) and bpFirstTok() and
+ (bpEqPeek "CPAREN" or bpParenTrap(a))
+ then
+ $bpParenCount:=$bpParenCount-1
+ bpNextToken()
+ $bpCount=0 => true
+ $inputStream:=append( bpAddTokens $bpCount,$inputStream)
+ bpFirstToken()
+ $bpParenCount=0 =>
+ bpCancel()
+ true
+ true
+ else if bpEqPeek "CPAREN"
+ then
+ bpPush bfTuple []
+ $bpParenCount:=$bpParenCount-1
+ bpNextToken()
+ true
+ else bpParenTrap(a)
+ else false
+
+bpParenthesized f==
+ a:=$stok
+ if bpEqKey "OPAREN"
+ then
+ if APPLY(f,nil) and (bpEqKey "CPAREN" or bpParenTrap(a))
+ then true
+ else if bpEqKey "CPAREN"
+ then
+ bpPush bfTuple []
+ true
+ else bpParenTrap(a)
+ else false
+
+bpBracket f==
+ a:=$stok
+ if bpEqKey "OBRACK"
+ then
+ if APPLY(f,nil) and (bpEqKey "CBRACK" or bpBrackTrap(a))
+ then bpPush bfBracket bpPop1 ()
+ else if bpEqKey "CBRACK"
+ then bpPush []
+ else bpBrackTrap(a)
+ else false
+
+bpPileBracketed f==
+ if bpEqKey "SETTAB"
+ then if bpEqKey "BACKTAB"
+ then true
+ else if APPLY(f,nil) and
+ (bpEqKey "BACKTAB" or bpPileTrap())
+ then bpPush bfPile bpPop1()
+ else false
+ else false
+
+bpListof(f,str1,g)==
+ if APPLY(f,nil)
+ then
+ if bpEqKey str1 and (APPLY(f,nil) or bpTrap())
+ then
+ a:=$stack
+ $stack:=nil
+ while bpEqKey str1 and (APPLY(f,nil) or bpTrap()) repeat 0
+ $stack:=cons(NREVERSE $stack,a)
+ bpPush FUNCALL(g, [bpPop3(),bpPop2(),:bpPop1()])
+ else
+ true
+ else false
+
+
+-- to do ,<backset>
+bpListofFun(f,h,g)==
+ if APPLY(f,nil)
+ then
+ if APPLY(h,nil) and (APPLY(f,nil) or bpTrap())
+ then
+ a:=$stack
+ $stack:=nil
+ while APPLY(h,nil) and (APPLY(f,nil) or bpTrap()) repeat 0
+ $stack:=cons(NREVERSE $stack,a)
+ bpPush FUNCALL(g, bfListOf [bpPop3(),bpPop2(),:bpPop1()])
+ else
+ true
+ else false
+
+bpList(f,str1,g)==
+ if APPLY(f,nil)
+ then
+ if bpEqKey str1 and (APPLY(f,nil) or bpTrap())
+ then
+ a:=$stack
+ $stack:=nil
+ while bpEqKey str1 and (APPLY(f,nil) or bpTrap()) repeat 0
+ $stack:=cons(NREVERSE $stack,a)
+ bpPush FUNCALL(g, [bpPop3(),bpPop2(),:bpPop1()])
+ else
+ bpPush FUNCALL(g, [bpPop1()])
+ else bpPush FUNCALL(g, [])
+
+bpOneOrMore f==
+ APPLY(f,nil)=>
+ a:=$stack
+ $stack:=nil
+ while APPLY(f,nil) repeat 0
+ $stack:=cons(NREVERSE $stack,a)
+ bpPush cons(bpPop2(),bpPop1())
+ false
+
+
+-- s must transform the head of the stack
+bpAnyNo s==
+ while APPLY(s,nil) repeat 0
+ true
+
+
+-- AndOr(k,p,f)= k p
+bpAndOr(keyword,p,f)==
+ bpEqKey keyword and (APPLY(p,nil) or bpTrap())
+ and bpPush FUNCALL(f, bpPop1())
+
+bpConditional f==
+ if bpEqKey "IF" and (bpWhere() or bpTrap()) and
+ (bpEqKey "BACKSET" or true)
+ then
+ if bpEqKey "SETTAB"
+ then if bpEqKey "THEN"
+ then (APPLY(f,nil) or bpTrap()) and bpElse(f) and bpEqKey "BACKTAB"
+ else bpMissing "THEN"
+ else if bpEqKey "THEN"
+ then (APPLY(f,nil) or bpTrap()) and bpElse(f)
+ else bpMissing "then"
+ else false
+
+bpElse(f)==
+ a:=bpState()
+ if bpBacksetElse()
+ then (APPLY(f,nil) or bpTrap()) and
+ bpPush bfIf(bpPop3(),bpPop2(),bpPop1())
+ else
+ bpRestore a
+ bpPush bfIfThenOnly(bpPop2(),bpPop1())
+
+bpBacksetElse()==
+ if bpEqKey "BACKSET"
+ then bpEqKey "ELSE"
+ else bpEqKey "ELSE"
+
+bpEqPeek s == EQCAR($stok,"KEY") and EQ(s,$ttok)
+
+bpEqKey s == EQCAR($stok,"KEY") and EQ(s,$ttok) and bpNext()
+bpEqKeyNextTok s == EQCAR($stok,"KEY") and EQ(s,$ttok) and
+ bpNextToken()
+
+bpPileTrap() == bpMissing "BACKTAB"
+bpBrackTrap(x) == bpMissingMate("]",x)
+bpParenTrap(x) == bpMissingMate(")",x)
+
+bpMissingMate(close,open)==
+ bpSpecificErrorAtToken(open, '"possibly missing mate")
+ bpMissing close
+
+bpMissing s==
+ bpSpecificErrorHere(CONCAT(PNAME s,'" possibly missing"))
+ THROW("TRAPPOINT","TRAPPED")
+
+bpCompMissing s == bpEqKey s or bpMissing s
+
+bpTrap()==
+ bpGeneralErrorHere()
+ THROW("TRAPPOINT","TRAPPED")
+
+bpRecoverTrap()==
+ bpFirstToken()
+ pos1 := shoeTokPosn $stok
+ bpMoveTo 0
+ pos2 := shoeTokPosn $stok
+ bpIgnoredFromTo(pos1, pos2)
+ bpPush [['"pile syntax error"]]
+
+bpListAndRecover(f)==
+ a:=$stack
+ b:=nil
+ $stack:=nil
+ done:=false
+ c:=$inputStream
+ while not done repeat
+-- $trapped:local:=false
+ found:=CATCH("TRAPPOINT",APPLY(f,nil))
+ if found="TRAPPED"
+ then
+ $inputStream:=c
+ bpRecoverTrap()
+ else if not found
+ then
+ $inputStream:=c
+ bpGeneralErrorHere()
+ bpRecoverTrap()
+ if bpEqKey "BACKSET"
+ then
+ c:=$inputStream
+ else if bpEqPeek "BACKTAB" or null $inputStream
+ then
+ done:=true
+ else
+ $inputStream:=c
+ bpGeneralErrorHere()
+ bpRecoverTrap()
+ if bpEqPeek "BACKTAB" or null $inputStream
+ then done:=true
+ else
+ bpNext()
+ c:=$inputStream
+ b:=cons(bpPop1(),b)
+ $stack:=a
+ bpPush NREVERSE b
+
+bpMoveTo n==
+ null $inputStream => true
+ bpEqPeek "BACKTAB" =>
+ n=0 => true
+ bpNextToken()
+ $bpCount:=$bpCount-1
+ bpMoveTo(n-1)
+ bpEqPeek "BACKSET" =>
+ n=0 => true
+ bpNextToken()
+ bpMoveTo n
+ bpEqPeek "SETTAB" =>
+ bpNextToken()
+ bpMoveTo(n+1)
+ bpEqPeek "OPAREN" =>
+ bpNextToken()
+ $bpParenCount:=$bpParenCount+1
+ bpMoveTo n
+ bpEqPeek "CPAREN" =>
+ bpNextToken()
+ $bpParenCount:=$bpParenCount-1
+ bpMoveTo n
+ bpNextToken()
+ bpMoveTo n
+
+-- A fully qualified name could be interpreted as a left reduction
+-- of an '::' infix operator. At the moment, we don't use
+-- that general interpretation.
+
+-- When this routine is called, a symbol is already pushed on the
+-- stack. When this routine finished execution, we have either
+-- reduced a '::' and a name, or nothing. In either case, a
+-- symbol is present on the stack.
+bpQualifiedName() ==
+ bpEqPeek "COLON-COLON" =>
+ bpNext()
+ EQCAR($stok, "ID") and bpPushId() and bpNext()
+ and bpPush bfColonColon(bpPop2(), bpPop1())
+ false
+
+++ Name:
+++ ID
+++ Name :: ID
+bpName() ==
+ EQCAR( $stok,"ID") =>
+ bpPushId()
+ bpNext()
+ bpAnyNo function bpQualifiedName
+ false
+
+
+++ Constant:
+++ INTEGER
+++ FLOAT
+++ LISP
+++ LISPEXPR
+++ LINE
+++ QUOTE S-Expression
+++ STRING
+bpConstTok() ==
+ MEMQ(shoeTokType $stok, '(INTEGER FLOAT)) =>
+ bpPush $ttok
+ bpNext()
+ EQCAR($stok,"LISP")=> bpPush bfReadLisp $ttok and bpNext()
+ EQCAR($stok,"LISPEXP")=> bpPush $ttok and bpNext()
+ EQCAR($stok,"LINE")=> bpPush ["+LINE", $ttok] and bpNext()
+ bpEqPeek "QUOTE" =>
+ bpNext()
+ (bpSexp() or bpTrap()) and
+ bpPush bfSymbol bpPop1()
+ bpString()
+
+++ Parse a module definitoin
+++ Module:
+++ MODULE QUOTE String
+bpModule() ==
+ bpEqKey "MODULE" =>
+ -- we really want to check that the next token is indeed
+ -- a string. For the moment, we delay the type checking
+ -- to the Lisp compiler/interpreter. That is likely to
+ -- cause cryptic diagnostics. To be fixed.
+ bpConstTok() and bpPush Module bpPop1()
+ false
+
+++ Parse a module import, or a import declaration for a foreign entity.
+++ Import:
+++ IMPORT Name for Signature
+++ IMPORT QUOTE String
+bpImport() ==
+ bpEqKey "IMPORT" =>
+ (bpName() and (bpEqKey "FOR" or bpTrap()) and bpSignature()
+ and bpPush ImportSignature(bpPop2(), bpPop1()))
+ or
+ -- we really want to check that the next token is indeed
+ -- a string. For the moment, we delay the type checking
+ -- to the Lisp compiler/interpreter. That is likely to
+ -- cause cryptic diagnostics. To be fixed.
+ (bpConstTok() and bpPush Import bpPop1())
+ false
+
+-- Parse a type alias defnition:
+-- type-alias-definition:
+-- identifier <=> logical-expression
+bpTypeAliasDefition() ==
+ (bpName() or bpTrap()) and
+ bpEqKey "TDEF" and bpLogical() and
+ bpPush TypeAlias(bpPop2(), nil, bpPop1())
+
+++ Parse a signature declaration
+++ Signature:
+++ Name COLON Mapping
+bpSignature() ==
+ bpName() and bpEqKey "COLON" and bpMapping()
+ and bpPush Signature(bpPop2(), bpPop1())
+
+++ Parse a mapping expression
+++ Mapping:
+++ (Name | IdList) -> Name
+bpMapping() ==
+ (bpName() or bpIdList()) and bpEqKey "ARROW" and bpName()
+ and bpPush Mapping(bpPop1(), bpPop1())
+
+bpCancel()==
+ a:=bpState()
+ if bpEqKeyNextTok "SETTAB"
+ then if bpCancel()
+ then if bpEqKeyNextTok "BACKTAB"
+ then true
+ else
+ bpRestore a
+ false
+ else
+ if bpEqKeyNextTok "BACKTAB"
+ then true
+ else
+ bpRestore a
+ false
+ else false
+bpAddTokens n==
+ n=0 => nil
+ n>0=> cons(shoeTokConstruct("KEY","SETTAB",shoeTokPosn $stok),bpAddTokens(n-1))
+ cons(shoeTokConstruct("KEY","BACKTAB",shoeTokPosn $stok),bpAddTokens(n+1))
+
+bpExceptions()==
+ bpEqPeek "DOT" or bpEqPeek "QUOTE" or
+ bpEqPeek "OPAREN" or bpEqPeek "CPAREN" or
+ bpEqPeek "SETTAB" or bpEqPeek "BACKTAB"
+ or bpEqPeek "BACKSET"
+
+
+bpSexpKey()==
+ EQCAR( $stok,"KEY") and not bpExceptions()=>
+ a:=GET($ttok,"SHOEINF")
+ null a=> bpPush $ttok and bpNext()
+ bpPush a and bpNext()
+ false
+
+bpAnyId()==
+ bpEqKey "MINUS" and (EQCAR($stok,"INTEGER") or bpTrap()) and
+ bpPush MINUS $ttok and bpNext() or
+ bpSexpKey() or
+ MEMQ(shoeTokType $stok, '(ID INTEGER STRING FLOAT))
+ and bpPush $ttok and bpNext()
+
+bpSexp()==
+ bpAnyId() or
+ bpEqKey "QUOTE" and (bpSexp() or bpTrap())
+ and bpPush bfSymbol bpPop1() or
+ bpIndentParenthesized function bpSexp1
+
+bpSexp1()== bpFirstTok() and
+ bpSexp() and
+ (bpEqKey "DOT" and bpSexp() and bpPush CONS (bpPop2(),bpPop1())or
+ bpSexp1() and bpPush CONS (bpPop2(),bpPop1())) or
+ bpPush nil
+
+bpPrimary1() ==
+ bpName() or
+ bpDot() or
+ bpConstTok() or
+ bpConstruct() or
+ bpCase() or
+ bpStruct() or
+ bpPDefinition() or
+ bpBPileDefinition()
+
+bpPrimary()== bpFirstTok() and (bpPrimary1() or bpPrefixOperator())
+
+bpDot()== bpEqKey "DOT" and bpPush bfDot ()
+
+bpPrefixOperator()==
+ EQCAR( $stok,"KEY") and
+ GET($ttok,"SHOEPRE") and bpPushId() and bpNext()
+
+bpInfixOperator()==
+ EQCAR( $stok,"KEY") and
+ GET($ttok,"SHOEINF") and bpPushId() and bpNext()
+
+bpSelector()==
+ bpEqKey "DOT" and (bpPrimary()
+ and bpPush(bfElt(bpPop2(),bpPop1()))
+ or bpPush bfSuffixDot bpPop1() )
+
+bpOperator()== bpPrimary() and bpAnyNo function bpSelector
+
+bpApplication()==
+ bpPrimary() and bpAnyNo function bpSelector and
+ (bpApplication() and
+ bpPush(bfApplication(bpPop2(),bpPop1())) or true)
+
+bpTagged()==
+ bpApplication() and
+ (bpEqKey "COLON" and (bpApplication() or bpTrap()) and
+ bpPush bfTagged(bpPop2(),bpPop1()) or true)
+
+bpExpt()== bpRightAssoc('(POWER),function bpTagged)
+
+bpInfKey s==
+ EQCAR( $stok,"KEY") and
+ MEMBER($ttok,s) and bpPushId() and bpNext()
+
+bpInfGeneric s== bpInfKey s and (bpEqKey "BACKSET" or true)
+
+bpRightAssoc(o,p)==
+ a:=bpState()
+ if APPLY(p,nil)
+ then
+ while bpInfGeneric o and (bpRightAssoc(o,p) or bpTrap()) repeat
+ bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1())
+ true
+ else
+ bpRestore a
+ false
+
+bpLeftAssoc(operations,parser)==
+ if APPLY(parser,nil)
+ then
+ while bpInfGeneric(operations) and
+ (APPLY(parser,nil) or bpTrap())
+ repeat
+ bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1())
+ true
+ else false
+
+bpString()==
+ EQ(shoeTokType $stok,"STRING") and
+ bpPush(["QUOTE",INTERN $ttok]) and bpNext()
+
+bpThetaName() ==
+ if EQCAR( $stok,"ID") and GET($ttok,"SHOETHETA")
+ then
+ bpPushId()
+ bpNext()
+ else false
+
+bpReduceOperator()==
+ bpInfixOperator() or bpString()
+ or bpThetaName()
+
+bpReduce()==
+ a:=bpState()
+ if bpReduceOperator() and bpEqKey "SLASH"
+ then
+ bpEqPeek "OBRACK" => (bpDConstruct() or bpTrap()) and
+ bpPush bfReduceCollect(bpPop2(),bpPop1())
+ (bpApplication() or bpTrap()) and
+ bpPush bfReduce(bpPop2(),bpPop1())
+ else
+ bpRestore a
+ false
+
+bpTimes()==
+ bpReduce() or bpLeftAssoc('(TIMES SLASH),function bpExpt)
+
+bpMinus()==
+ bpInfGeneric '(MINUS) and (bpTimes() or bpTrap())
+ and bpPush(bfApplication(bpPop2(),bpPop1()))
+ or bpTimes()
+
+bpArith()==bpLeftAssoc('(PLUS MINUS),function bpMinus)
+
+bpIs()==
+ bpArith() and (bpInfKey '(IS ISNT) and (bpPattern() or bpTrap())
+ and bpPush bfISApplication(bpPop2(),bpPop2(),bpPop1())
+ or true)
+
+bpBracketConstruct(f)==
+ bpBracket f and bpPush bfConstruct bpPop1 ()
+
+bpCompare()==
+ bpIs() and (bpInfKey '(SHOEEQ SHOENE LT LE GT GE IN)
+ and (bpIs() or bpTrap())
+ and bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1())
+ or true)
+
+bpAnd()== bpLeftAssoc('(AND),function bpCompare)
+
+
+++ Note the fact that a return statement is used in the body
+++ of current function definition.
+bpNoteReturnStmt() ==
+ $bodyHasReturn := true
+ true
+
+bpReturn()==
+ (bpEqKey "RETURN" and bpNoteReturnStmt() and
+ (bpAnd() or bpTrap()) and
+ bpPush bfReturnNoName bpPop1()) or bpAnd()
+
+
+bpLogical()== bpLeftAssoc('(OR),function bpReturn)
+
+bpExpression()==
+ bpEqKey "COLON" and (bpLogical() and
+ bpPush bfApplication ("COLON",bpPop1())
+ or bpTrap()) or bpLogical()
+
+bpStatement()==
+ bpConditional function bpWhere or bpLoop() or bpExpression()
+
+bpLoop()==
+ bpIterators() and
+ (bpCompMissing "REPEAT" and
+ (bpWhere() or bpTrap()) and
+ bpPush bfLp(bpPop2(),bpPop1()))
+ or
+ bpEqKey "REPEAT" and (bpLogical() or bpTrap()) and
+ bpPush bfLoop1 bpPop1 ()
+
+bpSuchThat()==bpAndOr("BAR",function bpWhere,function bfSuchthat)
+
+bpWhile()==bpAndOr ("WHILE",function bpLogical,function bfWhile)
+
+bpUntil()==bpAndOr ("UNTIL",function bpLogical,function bfUntil)
+
+bpForIn()==
+ bpEqKey "FOR" and (bpVariable() or bpTrap()) and (bpCompMissing "IN")
+ and ((bpSeg() or bpTrap()) and
+ (bpEqKey "BY" and (bpArith() or bpTrap()) and
+ bpPush bfForInBy(bpPop3(),bpPop2(),bpPop1())) or
+ bpPush bfForin(bpPop2(),bpPop1()))
+
+bpSeg()==
+ bpArith() and
+ (bpEqKey "SEG" and
+ (bpArith() and bpPush(bfSegment2(bpPop2(),bpPop1()))
+ or bpPush(bfSegment1(bpPop1()))) or true)
+
+bpIterator()==
+ bpForIn() or bpSuchThat() or bpWhile() or bpUntil()
+
+bpIteratorList()==bpOneOrMore function bpIterator
+ and bpPush bfIterators bpPop1 ()
+
+bpCrossBackSet()== bpEqKey "CROSS" and (bpEqKey "BACKSET" or true)
+
+bpIterators()==
+ bpListofFun(function bpIteratorList,
+ function bpCrossBackSet,function bfCross)
+
+bpAssign()==
+ a:=bpState()
+ if bpStatement()
+ then
+ if bpEqPeek "BEC"
+ then
+ bpRestore a
+ bpAssignment() or bpTrap()
+ else true
+ else
+ bpRestore a
+ false
+
+bpAssignment()==
+ bpAssignVariable() and
+ bpEqKey "BEC" and
+ (bpAssign() or bpTrap()) and
+ bpPush bfAssign (bpPop2(),bpPop1())
+
+-- should only be allowed in sequences
+bpExit()==
+ bpAssign() and (bpEqKey "EXIT" and
+ ((bpWhere() or bpTrap()) and
+ bpPush bfExit (bpPop2(),bpPop1()))
+ or true)
+
+++ returns true if the next token introduces a definition.
+bpBeginDefinition() ==
+ bpEqPeek "DEF" or
+ $sawParenthesizedHead and bpEqPeek "COLON"
+
+bpDefinition()==
+ a:=bpState()
+ bpExit() =>
+ bpBeginDefinition() =>
+ bpRestore a
+ bpDef()
+ bpEqPeek "TDEF" =>
+ bpRestore a
+ bpTypeAliasDefition()
+ bpEqPeek "MDEF" =>
+ bpRestore a
+ bpMdef()
+ true
+ bpRestore a
+ false
+
+bpStoreName()==
+ $op := car $stack
+ $wheredefs := nil
+ $typings := nil
+ $returnType := true -- assume we may return anything
+ $bodyHasReturn := false
+ true
+
+bpReturnType() ==
+ -- a return type is acceptable for a function definition only
+ -- if its parameters are written in round parenthesis.
+ -- In particular, we reject the situation `foo x:Integer == ...'
+ $sawParenthesizedHead and bpEqKey "COLON" =>
+ bpApplication() or bpTrap()
+ $returnType := bpPop1()
+ true
+ true
+
+bpDef() ==
+ bpName() and bpStoreName() and
+ bpDefTail() and bpPush bfCompDef bpPop1 ()
+
+bpDDef() == bpName() and bpDefTail()
+
+++ Parse the remaining of a simple definition.
+bpSimpleDefinitionTail() ==
+ bpEqKey "DEF" and
+ (bpWhere() or bpTrap())
+ and bpPush ConstantDefinition(bpPop2(), bpPop1())
+
+++ Parse the remaining of a compound definition.
+bpCompoundDefinitionTail() ==
+ bpVariable() and bpReturnType() and
+ bpEqKey "DEF" and (bpWhere() or bpTrap())
+ and bpPush bfDefinition(bpPop3(),bpPop2(),bpPop1())
+
+
+++ Parse the remainding of a definition. When we reach this point
+++ we know we must parse a definition and we have already parsed
+++ the name of the main operator in the definition.
+bpDefTail() ==
+ bpSimpleDefinitionTail()
+ or bpCompoundDefinitionTail()
+
+
+bpMDefTail()==
+ -- bpEqKey "MDEF" and
+ -- (bpWhere() or bpTrap())
+ -- and bpPush bfMDefinition1(bpPop2(),bpPop1())
+ -- or
+ (bpVariable() or bpTrap()) and
+ bpEqKey "MDEF" and (bpWhere() or bpTrap())
+ and bpPush bfMDefinition(bpPop3(),bpPop2(),bpPop1())
+
+bpMdef()== bpName() and bpStoreName() and bpMDefTail()
+
+bpWhere()==
+ bpDefinition() and
+ (bpEqKey "WHERE" and (bpDefinitionItem() or bpTrap())
+ and bpPush bfWhere(bpPop1(),bpPop1()) or true)
+
+bpDefinitionItem()==
+ a:=bpState()
+ if bpDDef()
+ then true
+ else
+ bpRestore a
+ if bpBDefinitionPileItems()
+ then true
+ else
+ bpRestore a
+ if bpPDefinitionItems()
+ then true
+ else
+ bpRestore a
+ bpWhere()
+
+bpDefinitionPileItems()==
+ bpListAndRecover function bpDefinitionItem
+ and bpPush bfDefSequence bpPop1()
+
+bpBDefinitionPileItems()== bpPileBracketed function bpDefinitionPileItems
+
+bpSemiColonDefinition()==bpSemiListing
+ (function bpDefinitionItem,function bfDefSequence)
+
+bpPDefinitionItems()==bpParenthesized function bpSemiColonDefinition
+
+bpComma()==
+ bpModule() or bpImport() or
+ bpTuple function bpWhere
+
+bpTuple(p)==bpListofFun(p,function bpCommaBackSet,function bfTuple)
+
+bpCommaBackSet()== bpEqKey "COMMA" and (bpEqKey "BACKSET" or true)
+
+bpSemiColon()==bpSemiListing (function bpComma,function bfSequence)
+
+bpSemiListing(p,f)==bpListofFun(p,function bpSemiBackSet,f)
+
+bpSemiBackSet()== bpEqKey "SEMICOLON" and (bpEqKey "BACKSET" or true)
+
+bpPDefinition()== bpIndentParenthesized function bpSemiColon
+
+bpPileItems()==
+ bpListAndRecover function bpSemiColon and bpPush bfSequence bpPop1()
+
+bpBPileDefinition()== bpPileBracketed function bpPileItems
+
+bpIteratorTail()==
+ (bpEqKey "REPEAT" or true) and bpIterators()
+
+--bpExpression()== bpLogical()
+
+bpConstruct()==bpBracket function bpConstruction
+
+bpConstruction()==
+ bpComma() and
+ (bpIteratorTail() and
+ bpPush bfCollect (bpPop2(),bpPop1()) or
+ bpPush bfTupleConstruct bpPop1())
+
+bpDConstruct()==bpBracket function bpDConstruction
+
+bpDConstruction()==
+ bpComma() and
+ (bpIteratorTail() and
+ bpPush bfDCollect (bpPop2(),bpPop1()) or
+ bpPush bfDTuple bpPop1())
+
+
+
+--PATTERN
+
+--bpNameOrDot() == bpName() or bpDot() or bpEqual()
+
+bpPattern()== bpBracketConstruct function bpPatternL
+ or bpName() or bpConstTok()
+
+bpEqual()==
+ bpEqKey "SHOEEQ" and (bpApplication() or bpConstTok() or
+ bpTrap()) and bpPush bfEqual bpPop1()
+
+bpRegularPatternItem() ==
+ bpEqual() or
+ bpConstTok() or bpDot() or
+ bpName() and
+ ((bpEqKey "BEC" and (bpPattern() or bpTrap())
+ and bpPush bfAssign(bpPop2(),bpPop1())) or true)
+ or bpBracketConstruct function bpPatternL
+
+bpRegularPatternItemL()==
+ bpRegularPatternItem() and bpPush [bpPop1()]
+
+bpRegularList()==
+ bpListof(function bpRegularPatternItemL,"COMMA",function bfAppend)
+
+bpPatternColon()==
+ bpEqKey "COLON" and (bpRegularPatternItem() or bpTrap())
+ and bpPush [bfColon bpPop1()]
+
+
+-- only one colon
+bpPatternL() == bpPatternList() and bpPush bfTuple bpPop1()
+
+bpPatternList()==
+ if bpRegularPatternItemL()
+ then
+ while (bpEqKey "COMMA" and (bpRegularPatternItemL() or
+ (bpPatternTail()
+ and bpPush append(bpPop2(),bpPop1())
+ or bpTrap();false) )) repeat
+ bpPush append(bpPop2(),bpPop1())
+ true
+ else bpPatternTail()
+
+bpPatternTail()==
+ bpPatternColon() and
+ (bpEqKey "COMMA" and (bpRegularList() or bpTrap())
+ and bpPush append (bpPop2(),bpPop1()) or true)
+
+-- BOUND VARIABLE
+bpRegularBVItem() ==
+ bpBVString() or
+ bpConstTok() or
+ (bpName() and
+ (bpEqKey "COLON" and (bpApplication() or bpTrap())
+ and bpPush bfTagged(bpPop2(), bpPop1()) or
+ bpEqKey "BEC" and (bpPattern() or bpTrap())
+ and bpPush bfAssign(bpPop2(),bpPop1()) or
+ (bpEqKey "IS" and (bpPattern() or bpTrap())
+ and bpPush bfAssign(bpPop2(),bpPop1())) or true))
+ or bpBracketConstruct function bpPatternL
+
+bpBVString()==
+ EQ(shoeTokType $stok,"STRING") and
+ bpPush(["BVQUOTE",INTERN $ttok]) and bpNext()
+
+bpRegularBVItemL() ==
+ bpRegularBVItem() and bpPush [bpPop1()]
+
+bpColonName()==
+ bpEqKey "COLON" and (bpName() or bpBVString() or bpTrap())
+
+
+-- at most one colon at end
+bpBoundVariablelist()==
+ if bpRegularBVItemL()
+ then
+ while (bpEqKey "COMMA" and (bpRegularBVItemL() or
+ (bpColonName()
+ and bpPush bfColonAppend(bpPop2(),bpPop1())
+ or bpTrap();false) )) repeat
+ bpPush append(bpPop2(),bpPop1())
+ true
+ else bpColonName() and bpPush bfColonAppend(nil,bpPop1())
+
+
+++ Mark the start of parameter list enclosed in round parenthesis
+bpBeginParameterList() ==
+ $sawParenthesizedHead := false
+ true
+
+++ Mark the end of parameter list enclosed in round parenthesis
+bpEndParameterList() ==
+ $sawParenthesizedHead := true
+
+bpVariable()==
+ bpBeginParameterList() and
+ bpParenthesized function bpBoundVariablelist and
+ bpPush bfTupleIf bpPop1() and bpEndParameterList()
+ or bpBracketConstruct function bpPatternL
+ or bpName() or bpConstTok()
+
+bpAssignVariable()==
+ bpBracketConstruct function bpPatternL or bpAssignLHS()
+
+bpAssignLHS()==
+ bpName() and (bpEqKey "COLON" and (bpApplication() or bpTrap())
+ and bpPush bfLocal(bpPop2(),bpPop1())
+ or bpEqKey "DOT" and bpList(function bpPrimary,"DOT",
+ function bfListOf)
+ and bpChecknull() and
+ bpPush bfTuple(cons(bpPop2(),bpPop1()))
+ or true)
+bpChecknull()==
+ a:=bpPop1()
+ if null a
+ then bpTrap()
+ else bpPush a
+
+bpStruct()==
+ bpEqKey "STRUCTURE" and
+ (bpName() or bpTrap()) and
+ (bpEqKey "DEF" or bpTrap()) and
+ bpTypeList() and bpPush bfStruct(bpPop2(),bpPop1())
+
+bpTypeList() == bpPileBracketed function bpTypeItemList
+ or bpTerm() and bpPush [bpPop1()]
+
+bpTypeItemList() == bpListAndRecover function bpTerm
+
+bpTerm() ==
+ (bpName() or bpTrap()) and
+ ((bpParenthesized function bpIdList and
+ bpPush bfNameArgs (bpPop2(),bpPop1()))
+ or bpName() and bpPush bfNameArgs(bpPop2(),bpPop1()))
+ or bpPush(bfNameOnly bpPop1())
+
+bpIdList()== bpTuple function bpName
+
+bpCase()==
+ bpEqKey "CASE" and
+ (bpWhere() or bpTrap()) and
+ (bpEqKey "OF" or bpMissing "OF") and
+ bpPiledCaseItems()
+
+bpPiledCaseItems()==
+ bpPileBracketed function bpCaseItemList and
+ bpPush bfCase(bpPop2(),bpPop1())
+bpCaseItemList()==
+ bpListAndRecover function bpCaseItem
+
+bpCaseItem()==
+ (bpTerm() or bpTrap()) and
+ (bpEqKey "EXIT" or bpTrap()) and
+ (bpWhere() or bpTrap()) and
+ bpPush bfCaseItem (bpPop2(),bpPop1())
+
diff --git a/src/boot/pile.boot b/src/boot/pile.boot
new file mode 100644
index 00000000..0b8b1651
--- /dev/null
+++ b/src/boot/pile.boot
@@ -0,0 +1,143 @@
+-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+-- 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.
+--
+-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+-- names of its contributors may be used to endorse or promote products
+-- derived from this software without specific prior written permission.
+--
+-- 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 OWNER
+-- 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.
+
+
+module '"boot-pile"
+import '"includer"
+import '"scanner"
+
+)package "BOOTTRAN"
+shoeFirstTokPosn t== shoeTokPosn CAAR t
+shoeLastTokPosn t== shoeTokPosn CADR t
+shoePileColumn t==CDR shoeTokPosn CAAR t
+
+-- s is a token-dq-stream
+
+shoePileInsert (s)==
+ if bStreamNull s
+ then cons([],s)
+ else
+ toktype:=shoeTokType CAAAR s
+ if toktype ="LISP" or toktype = "LINE"
+ then cons([car s],cdr s)
+ else
+ a:=shoePileTree(-1,s)
+ cons([a.2],a.3)
+
+shoePileTree(n,s)==
+ if bStreamNull s
+ then [false,n,[],s]
+ else
+ [h,t]:=[car s,cdr s]
+ hh:=shoePileColumn h
+ if hh > n
+ then shoePileForests(h,hh,t)
+ else [false,n,[],s]
+
+eqshoePileTree(n,s)==
+ if bStreamNull s
+ then [false,n,[],s]
+ else
+ [h,t]:=[car s,cdr s]
+ hh:=shoePileColumn h
+ if hh = n
+ then shoePileForests(h,hh,t)
+ else [false,n,[],s]
+
+shoePileForest(n,s)==
+ [b,hh,h,t]:= shoePileTree(n,s)
+ if b
+ then
+ [h1,t1]:=shoePileForest1(hh,t)
+ [cons(h,h1),t1]
+ else [[],s]
+
+shoePileForest1(n,s)==
+ [b,n1,h,t]:= eqshoePileTree(n,s)
+ if b
+ then
+ [h1,t1]:=shoePileForest1(n,t)
+ [cons(h,h1),t1]
+ else [[],s]
+
+shoePileForests(h,n,s)==
+ [h1,t1]:=shoePileForest(n,s)
+ if bStreamNull h1
+ then [true,n,h,s]
+ else shoePileForests(shoePileCtree(h,h1),n,t1)
+
+shoePileCtree(x,y)==dqAppend(x,shoePileCforest y)
+
+-- only enshoePiles forests with >=2 trees
+
+shoePileCforest x==
+ if null x
+ then []
+ else if null cdr x
+ then car x
+ else
+ a:=car x
+ b:=shoePileCoagulate(a,rest x)
+ if null cdr b
+ then car b
+ else shoeEnPile shoeSeparatePiles b
+
+shoePileCoagulate(a,b)==
+ if null b
+ then [a]
+ else
+ c:=car b
+ if EQ(shoeTokPart CAAR c,"THEN") or EQ(shoeTokPart CAAR c,"ELSE")
+ then shoePileCoagulate (dqAppend(a,c),cdr b)
+ else
+ d:=CADR a
+ e:=shoeTokPart d
+ if EQCAR(d,"KEY") and
+ (GET(e,"SHOEINF") or EQ(e,"COMMA") or EQ(e,"SEMICOLON"))
+ then shoePileCoagulate(dqAppend(a,c),cdr b)
+ else cons(a,shoePileCoagulate(c,rest b))
+
+shoeSeparatePiles x==
+ if null x
+ then []
+ else if null cdr x
+ then car x
+ else
+ a:=car x
+ semicolon:=dqUnit
+ shoeTokConstruct("KEY", "BACKSET",shoeLastTokPosn a)
+ dqConcat [a,semicolon,shoeSeparatePiles cdr x]
+
+shoeEnPile x==
+ dqConcat [dqUnit shoeTokConstruct("KEY","SETTAB",shoeFirstTokPosn x),
+ x, _
+ dqUnit shoeTokConstruct("KEY","BACKTAB",shoeLastTokPosn x)]
+
diff --git a/src/boot/scanner.boot b/src/boot/scanner.boot
new file mode 100644
index 00000000..cd127781
--- /dev/null
+++ b/src/boot/scanner.boot
@@ -0,0 +1,514 @@
+-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+-- All rights reserved.
+-- Copyright (C) 2007-2008, Gabriel Dos Reis.
+-- 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.
+--
+-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+-- names of its contributors may be used to endorse or promote products
+-- derived from this software without specific prior written permission.
+--
+-- 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 OWNER
+-- 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.
+--
+
+
+module '"boot-lexer"
+import '"tokens"
+import '"includer"
+
+)package "BOOTTRAN"
+
+-- converts X to double-float.
+double x ==
+ FLOAT(x, 1.0)
+
+dqUnit s==(a:=[s];CONS(a,a))
+
+dqAppend(x,y)==
+ if null x
+ then y
+ else if null y
+ then x
+ else
+ RPLACD (CDR x,CAR y)
+ RPLACD (x, CDR y)
+ x
+
+dqConcat ld==
+ if null ld
+ then nil
+ else if null rest ld
+ then first ld
+ else dqAppend(first ld,dqConcat rest ld)
+
+dqToList s==if null s then nil else CAR s
+
+shoeConstructToken(ln,lp,b,n)==[b.0,b.1,:cons(lp,n)]
+shoeTokType x== CAR x
+shoeTokPart x== CADR x
+shoeTokPosn x== CDDR x
+shoeTokConstruct(x,y,z)==[x,y,:z]
+
+shoeNextLine(s)==
+ if bStreamNull s
+ then false
+ else
+ $linepos:=s
+ $f:= CAR s
+ $r:= CDR s
+ $ln:=CAR $f
+ $n:=STRPOSL('" ",$ln,0,true)
+ $sz :=# $ln
+ null $n => true
+ QENUM($ln,$n)=shoeTAB =>
+ a:=MAKE_-FULL_-CVEC (7-REM($n,8) ,'" ")
+ $ln.$n:='" ".0
+ $ln:=CONCAT(a,$ln)
+ s1:=cons(cons($ln,CDR $f),$r)
+ shoeNextLine s1
+ true
+
+shoeLineToks(s)==
+ $f: local:=nil
+ $r:local :=nil
+ $ln:local :=nil
+ $n:local:=nil
+ $sz:local := nil
+ $floatok:local:=true
+ $linepos:local:=s
+ not shoeNextLine s => CONS(nil,nil)
+ null $n => shoeLineToks $r
+ fst:=QENUM($ln,0)
+ EQL(fst,shoeCLOSEPAREN)=>
+ command:=shoeLine? $ln=>
+ dq:=dqUnit shoeConstructToken
+ ($ln,$linepos,shoeLeafLine command,0)
+ cons([dq],$r)
+ command:=shoeLisp? $ln=> shoeLispToken($r,command)
+ command:=shoePackage? $ln=>
+ -- z:=car shoeBiteOff command
+ a:=CONCAT('"(IN-PACKAGE ",command,'")")
+ dq:=dqUnit shoeConstructToken
+ ($ln,$linepos,shoeLeafLisp a,0)
+ cons([dq],$r)
+ shoeLineToks $r
+ toks:=[]
+ while $n<$sz repeat toks:=dqAppend(toks,shoeToken())
+ null toks => shoeLineToks $r
+ cons([toks],$r)
+
+shoeLispToken(s,string)==
+ string:=
+ # string=0 or EQL(QENUM(string,0),QENUM('";",0))=> '""
+ string
+ ln:=$ln
+ linepos:=$linepos
+ [r,:st]:=shoeAccumulateLines(s,string)
+ dq:=dqUnit shoeConstructToken(ln,linepos,shoeLeafLisp st,0)
+ cons([dq],r)
+
+shoeAccumulateLines(s,string)==
+ not shoeNextLine s => CONS(s,string)
+ null $n => shoeAccumulateLines($r,string)
+ # $ln=0 => shoeAccumulateLines($r,string)
+ fst:=QENUM($ln,0)
+ EQL(fst,shoeCLOSEPAREN)=>
+ command:=shoeLisp? $ln
+ command and #command>0 =>
+ EQL(QENUM(command,0),QENUM('";",0))=>
+ shoeAccumulateLines($r,string)
+ a:=STRPOS('";",command,0,nil)
+ a=>
+ shoeAccumulateLines($r,
+ CONCAT(string,SUBSTRING(command,0,a-1)))
+ shoeAccumulateLines($r,CONCAT(string,command))
+ shoeAccumulateLines($r,string)
+ CONS(s,string)
+
+-- returns true if token t is closing `parenthesis'.
+shoeCloser t ==
+ MEMQ(shoeKeyWord t, '(CPAREN CBRACK))
+
+shoeToken () ==
+ ln:=$ln
+ c:=QENUM($ln,$n)
+ linepos:=$linepos
+ n:=$n
+ ch:=$ln.$n
+ b:=
+ shoeStartsComment() =>
+ shoeComment()
+ []
+ shoeStartsNegComment() =>
+ shoeNegComment()
+ []
+ c=shoeLispESCAPE =>
+ shoeLispEscape()
+ shoePunctuation c => shoePunct ()
+ shoeStartsId ch => shoeWord (false)
+ c=shoeSPACE =>
+ shoeSpace ()
+ []
+ c = shoeSTRING_CHAR => shoeString ()
+ shoeDigit ch => shoeNumber ()
+ c=shoeESCAPE => shoeEscape()
+ c=shoeTAB =>
+ $n:=$n+1
+ []
+ shoeError ()
+ null b => nil
+ dqUnit shoeConstructToken(ln,linepos,b,n)
+
+-- to pair badge and badgee
+shoeLeafId x== ["ID",INTERN x]
+
+shoeLeafKey x==["KEY",shoeKeyWord x]
+
+shoeLeafInteger x==["INTEGER",shoeIntValue x]
+
+shoeLeafFloat(a,w,e)==
+ b:=shoeIntValue CONCAT(a,w)
+ c:= double b * EXPT(double 10, e-#w)
+ ["FLOAT",c]
+
+shoeLeafString x == ["STRING",x]
+
+shoeLeafLisp x == ["LISP",x]
+shoeLeafLispExp x == ["LISPEXP",x]
+
+shoeLeafLine x == ["LINE",x]
+
+shoeLeafComment x == ["COMMENT", x]
+
+shoeLeafNegComment x== ["NEGCOMMENT", x]
+
+shoeLeafError x == ["ERROR",x]
+
+shoeLeafSpaces x == ["SPACES",x]
+
+shoeLispEscape()==
+ $n:=$n+1
+ if $n>=$sz
+ then
+ SoftShoeError(cons($linepos,$n),'"lisp escape error")
+ shoeLeafError ($ln.$n)
+ else
+ a:=shoeReadLispString($ln,$n)
+ null a =>
+ SoftShoeError(cons($linepos,$n),'"lisp escape error")
+ shoeLeafError ($ln.$n)
+ [exp,n]:=a
+ null n =>
+ $n:= $sz
+ shoeLeafLispExp exp
+ $n:=n
+ shoeLeafLispExp exp
+shoeEscape()==
+ $n:=$n+1
+ a:=shoeEsc()
+ if a then shoeWord true else nil
+
+shoeEsc()==
+ if $n>=$sz
+ then if shoeNextLine($r)
+ then
+ while null $n repeat shoeNextLine($r)
+ shoeEsc()
+ false
+ else false
+ else
+ n1:=STRPOSL('" ",$ln,$n,true)
+ if null n1
+ then
+ shoeNextLine($r)
+ while null $n repeat shoeNextLine($r)
+ shoeEsc()
+ false
+ else true
+
+shoeStartsComment()==
+ if $n<$sz
+ then
+ if QENUM($ln,$n)=shoePLUSCOMMENT
+ then
+ www:=$n+1
+ if www>=$sz
+ then false
+ else QENUM($ln,www) = shoePLUSCOMMENT
+ else false
+ else false
+
+shoeStartsNegComment()==
+ if $n< $sz
+ then
+ if QENUM($ln,$n)=shoeMINUSCOMMENT
+ then
+ www:=$n+1
+ if www>=$sz
+ then false
+ else QENUM($ln,www) = shoeMINUSCOMMENT
+ else false
+ else false
+
+shoeNegComment()==
+ n:=$n
+ $n:=$sz
+ shoeLeafNegComment SUBSTRING($ln,n,nil)
+
+shoeComment()==
+ n:=$n
+ $n:=$sz
+ shoeLeafComment SUBSTRING($ln,n,nil)
+
+shoePunct()==
+ sss:=shoeMatch($ln,$n)
+ $n:=$n+#sss
+ shoeKeyTr sss
+
+shoeKeyTr w==
+ if EQ(shoeKeyWord w,"DOT")
+ then if $floatok
+ then shoePossFloat(w)
+ else shoeLeafKey w
+ else
+ $floatok:=not shoeCloser w
+ shoeLeafKey w
+
+shoePossFloat (w)==
+ if $n>=$sz or not shoeDigit $ln.$n
+ then shoeLeafKey w
+ else
+ w:=shoeInteger()
+ shoeExponent('"0",w)
+
+
+shoeSpace()==
+ n:=$n
+ $n:=STRPOSL('" ",$ln,$n,true)
+ $floatok:=true
+ if null $n
+ then
+ shoeLeafSpaces 0
+ $n:= # $ln
+ else shoeLeafSpaces ($n-n)
+
+shoeString()==
+ $n:=$n+1
+ $floatok:=false
+ shoeLeafString shoeS ()
+
+shoeS()==
+ if $n>=$sz
+ then
+ SoftShoeError(cons($linepos,$n),'"quote added")
+ '""
+ else
+ n:=$n
+ strsym :=STRPOS ('"_"",$ln,$n,nil) or $sz
+ escsym:=STRPOS ('"__"
+ ,$ln,$n,nil) or $sz
+ mn:=MIN(strsym,escsym)
+ if mn=$sz
+ then
+ $n:=$sz
+ SoftShoeError(cons($linepos,$n),'"quote added")
+ SUBSTRING($ln,n,nil)
+ else if mn=strsym
+ then
+ $n:=mn+1
+ SUBSTRING($ln,n,mn-n)
+ else
+ str:=SUBSTRING($ln,n,mn-n)
+ $n:=mn+1
+ a:=shoeEsc()
+ b:=if a
+ then
+ str:=CONCAT(str,$ln.$n)
+ $n:=$n+1
+ shoeS()
+ else shoeS()
+ CONCAT(str,b)
+
+
+
+
+shoeIdEnd(line,n)==
+ while n<#line and shoeIdChar line.n repeat n:=n+1
+ n
+
+
+shoeDigit x== DIGIT_-CHAR_-P x
+
+shoeW(b)==
+ n1:=$n
+ $n:=$n+1
+ l:=$sz
+ endid:=shoeIdEnd($ln,$n)
+ if endid=l or QENUM($ln,endid)^=shoeESCAPE
+ then
+ $n:=endid
+ [b,SUBSTRING($ln,n1,endid-n1)]
+ else
+ str:=SUBSTRING($ln,n1,endid-n1)
+ $n:=endid+1
+ a:=shoeEsc()
+ bb:=if a
+ then shoeW(true)
+ else [b,'""] -- escape finds space or newline
+ [bb.0 or b,CONCAT(str,bb.1)]
+
+shoeWord(esp) ==
+ aaa:=shoeW(false)
+ w:=aaa.1
+ $floatok:=false
+ if esp or aaa.0
+ then shoeLeafId w
+ else if shoeKeyWordP w
+ then
+ $floatok:=true
+ shoeLeafKey w
+ else shoeLeafId w
+
+shoeInteger()==shoeInteger1(false)
+
+shoeInteger1(zro) ==
+ n:=$n
+ l:= $sz
+ while $n<l and shoeDigit($ln.$n) repeat $n:=$n+1
+ if $n=l or QENUM($ln,$n)^=shoeESCAPE
+ then if n=$n and zro
+ then '"0"
+ else SUBSTRING($ln,n,$n-n)
+ else
+ str:=SUBSTRING($ln,n,$n-n)
+ $n:=$n+1
+ a:=shoeEsc()
+ bb:=shoeInteger1(zro)
+ CONCAT(str,bb)
+
+shoeIntValue(s) ==
+ ns := #s
+ ival := 0
+ for i in 0..ns-1 repeat
+ d := shoeOrdToNum ELT(s,i)
+ ival := 10*ival + d
+ ival
+
+shoeNumber() ==
+ a := shoeInteger()
+ if $n>=$sz
+ then shoeLeafInteger a
+ else
+ if $floatok and QENUM($ln,$n)=shoeDOT
+ then
+ n:=$n
+ $n:=$n+1
+ if $n<$sz and QENUM($ln,$n)=shoeDOT
+ then
+ $n:=n
+ shoeLeafInteger a
+ else
+ w:=shoeInteger1(true)
+ shoeExponent(a,w)
+ else shoeLeafInteger a
+
+shoeExponent(a,w)==
+ if $n>=$sz
+ then shoeLeafFloat(a,w,0)
+ else
+ n:=$n
+ c:=QENUM($ln,$n)
+ if c=shoeEXPONENT1 or c=shoeEXPONENT2
+ then
+ $n:=$n+1
+ if $n>=$sz
+ then
+ $n:=n
+ shoeLeafFloat(a,w,0)
+ else if shoeDigit($ln.$n)
+ then
+ e:=shoeInteger()
+ e:=shoeIntValue e
+ shoeLeafFloat(a,w,e)
+ else
+ c1:=QENUM($ln,$n)
+ if c1=shoePLUSCOMMENT or c1=shoeMINUSCOMMENT
+ then
+ $n:=$n+1
+ if $n>=$sz
+ then
+ $n:=n
+ shoeLeafFloat(a,w,0)
+ else
+ if shoeDigit($ln.$n)
+ then
+ e:=shoeInteger()
+ e:=shoeIntValue e
+ shoeLeafFloat(a,w,
+ (if c1=shoeMINUSCOMMENT then MINUS e else e))
+ else
+ $n:=n
+ shoeLeafFloat(a,w,0)
+ else shoeLeafFloat(a,w,0)
+
+shoeError()==
+ n:=$n
+ $n:=$n+1
+ SoftShoeError(cons($linepos,n),
+ CONCAT( '"The character whose number is ",
+ STRINGIMAGE QENUM($ln,n),'" is not a Boot character"))
+ shoeLeafError ($ln.n)
+
+shoeOrdToNum x== DIGIT_-CHAR_-P x
+
+shoeKeyWord st == GETHASH(st,shoeKeyTable)
+
+shoeKeyWordP st == not null GETHASH(st,shoeKeyTable)
+
+shoeMatch(l,i)==shoeSubStringMatch(l,shoeDict,i)
+
+shoeSubStringMatch (l,d,i)==
+ h:= QENUM(l, i)
+ u:=ELT(d,h)
+ ll:=SIZE l
+ done:=false
+ s1:='""
+ for j in 0.. SIZE u - 1 while not done repeat
+ s:=ELT(u,j)
+ ls:=SIZE s
+ done:=if ls+i > ll
+ then false
+ else
+ eql:= true
+ for k in 1..ls-1 while eql repeat
+ eql:= EQL(QENUM(s,k),QENUM(l,k+i))
+ if eql
+ then
+ s1:=s
+ true
+ else false
+ s1
+
+shoePunctuation c== shoePun.c =1
+
diff --git a/src/boot/ast.boot.pamphlet b/src/boot/strap/ast.clisp
index b0c2f483..591bd9bf 100644
--- a/src/boot/ast.boot.pamphlet
+++ b/src/boot/strap/ast.clisp
@@ -1,1118 +1,3 @@
-\documentclass{article}
-\usepackage{axiom}
-
-\title{\File{src/boot/ast.boot} Pamphlet}
-\author{The Axiom Team}
-
-\begin{document}
-\maketitle
-\begin{abstract}
-\end{abstract}
-
-\tableofcontents
-\eject
-
-Note that shoeReadLispString has a duplicate definition in this file.
-I don't know why. I've commented out the first definition since it
-gets overwritten.
-
-\section{License}
-
-<<license>>=
--- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
--- 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.
---
--- - Neither the name of The Numerical ALgorithms Group Ltd. nor the
--- names of its contributors may be used to endorse or promote products
--- derived from this software without specific prior written permission.
---
--- 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 OWNER
--- 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.
-
-@
-
-\section{Abstract syntax tree}
-
-<<abstract syntax tree>>=
-++ A Boot string is no different from a Lisp string. Same holds
-++ for symbols and sequences. In an ideal world, these would be
-++ built-in/library data types.
-String <=> STRING
-Symbol <=> SYMBOL
-Sequence <=> SEQUENCE
-
-++ Ideally, we would like to say that a List T if either nil or a
-++ cons of a T and List of T. However, we don't support parameterized
-++ alias definitions yet.
-List <=> nil or cons
-
-++ Currently, the Boot processor uses Lisp symbol datatype for names.
-++ That causes the BOOTTRAN package to contain more symbols than we would
-++ like. In the future, we want want to intern `on demand'. How that
-++ interacts with renaming is to be worked out.
-structure Name == Name(Symbol)
-
-structure Ast ==
- Command(String) -- includer command
- Module(String) -- module declaration
- Import(String) -- import module
- ImportSignature(Name, Signature) -- import function declaration
- TypeAlias(Name, List, List) -- type alias definition
- Signature(Name, Mapping) -- op: S -> T
- Mapping(Ast, List) -- (S1, S2) -> T
- SuffixDot(Ast) -- x .
- Quote(Ast) -- 'x
- EqualName(Name) -- =x -- patterns
- Colon(Name) -- :x
- QualifiedName(Name, Name) -- m::x
- Bracket(Ast) -- [x, y]
- UnboundedSegment(Ast) -- 3..
- BoundedSgement(Ast, Ast) -- 2..4
- Tuple(List) -- comma-separated expression sequence
- ColonAppend(Ast, Ast) -- [:y] or [x, :y]
- Is(Ast, Ast) -- e is p -- patterns
- Isnt(Ast, Ast) -- e isnt p -- patterns
- Reduce(Ast, Ast) -- +/[...]
- PrefixExpr(Name, Ast) -- #v
- Call(Ast, Sequence) -- f(x, y , z)
- InfixExpr(Name, Ast, Ast) -- x + y
- ConstantDefinition(Name, Ast) -- x == y
- Definition(Name, List, Ast, Ast) -- f x == y
- Macro(Name, List, Ast) -- m x ==> y
- SuchThat(Ast) -- | p
- Assignment(Ast, Ast) -- x := y
- While(Ast) -- while p -- iterator
- Until(Ast) -- until p -- iterator
- For(Ast, Ast, Ast) -- for x in e by k -- iterator
- Exit(Ast, Ast) -- p => x
- Iterators(List) -- list of iterators
- Cross(List) -- iterator cross product
- Repeat(Sequence, Ast) -- while p repeat s
- Pile(Sequence) -- pile of expression sequence
- Append(Sequence) -- concatenate lists
- Case(Ast, Sequence) -- case x of ...
- Return(Ast) -- return x
- Where(Ast, Sequence) -- e where f x == y
- Structure(Ast, Sequence) -- structure Foo == ...
-@
-
-
-\section{Putting it all together}
-<<*>>=
-<<license>>
-
-module '"boot-ast"
-import '"includer"
-
-)package "BOOTTRAN"
-
-++ True means that Boot functions should be translated to use
-++ hash tables to remember values. By default, functions are
-++ translated with the obvious semantics, e.g. no caching.
-$bfClamming := false
-
-<<abstract syntax tree>>
-
--- TRUE if we are currently building the syntax tree for an 'is'
--- expression.
-$inDefIS := false
-
-bfGenSymbol()==
- $GenVarCounter:=$GenVarCounter+1
- INTERN(CONCAT ('"bfVar#",STRINGIMAGE $GenVarCounter))
-
-bfListOf x==x
-
-bfColon x== ["COLON",x]
-
-bfColonColon(package, name) ==
- INTERN(SYMBOL_-NAME name, package)
-
-bfSymbol x==
- STRINGP x=> x
- ['QUOTE,x]
-
-bfDot()== "DOT"
-
-bfSuffixDot x==[x,"DOT"]
-
-bfEqual(name)== ["EQUAL",name]
-
-bfBracket(part) == part
-
-bfPile(part) == part
-
-bfAppend x== APPLY(function APPEND,x)
-
-bfColonAppend (x,y) ==
- if null x
- then
- if y is ["BVQUOTE",:a]
- then ["&REST",["QUOTE",:a]]
- else ["&REST",y]
- else cons(CAR x,bfColonAppend(CDR x,y))
-
-bfDefinition(bflhsitems, bfrhs,body) ==
- ['DEF,bflhsitems,bfrhs,body]
-
-bfMDefinition(bflhsitems, bfrhs,body) ==
- bfMDef('MDEF,bflhsitems,bfrhs,body)
-
-bfCompDef x ==
- case x of
- ConstantDefinition(n, e) => x
- otherwise =>
- x is [def, op, args, body] =>
- bfDef(def,op,args,body)
- coreError '"invalid AST"
-
-bfBeginsDollar x== EQL('"$".0,(PNAME x).0)
-
-compFluid id== ["FLUID",id]
-
-compFluidize x==
- IDENTP x and bfBeginsDollar x=>compFluid x
- ATOM x =>x
- EQCAR(x,"QUOTE")=>x
- cons(compFluidize(CAR x),compFluidize(CDR x))
-
-bfTuple x== ["TUPLE",:x]
-
-bfTupleP x==EQCAR(x,"TUPLE")
-
-bfTupleIf x==
- if bfTupleP x
- then x
- else bfTuple x
-
-bfTupleConstruct b ==
- a:= if bfTupleP b
- then cdr b
- else [b]
- or/[x is ["COLON",.] for x in a] => bfMakeCons a
- ["LIST",:a]
-
-bfConstruct b ==
- a:= if bfTupleP b
- then cdr b
- else [b]
- bfMakeCons a
-
-bfMakeCons l ==
- null l => NIL
- l is [["COLON",a],:l1] =>
- l1 => ['APPEND,a,bfMakeCons l1]
- a
- ['CONS,first l,bfMakeCons rest l]
-
-bfFor(bflhs,U,step) ==
- if EQCAR (U,'tails)
- then bfForTree('ON, bflhs, CADR U)
- else
- if EQCAR(U,"SEGMENT")
- then bfSTEP(bflhs,CADR U,step,CADDR U)
- else bfForTree('IN, bflhs, U)
-
-bfForTree(OP,lhs,whole)==
- whole:=if bfTupleP whole then bfMakeCons cdr whole else whole
- ATOM lhs =>bfINON [OP,lhs,whole]
- lhs:=if bfTupleP lhs then CADR lhs else lhs
- EQCAR(lhs,"L%T") =>
- G:=CADR lhs
- [:bfINON [OP,G,whole],:bfSuchthat bfIS(G,CADDR lhs)]
- G:=bfGenSymbol()
- [:bfINON [OP,G,whole],:bfSuchthat bfIS(G,lhs)]
-
-
-bfSTEP(id,fst,step,lst)==
- initvar:=[id]
- initval:=[fst]
- inc:=if ATOM step
- then step
- else
- g1:=bfGenSymbol()
- initvar:=cons(g1,initvar)
- initval:=cons(step,initval)
- g1
- final:=if ATOM lst
- then lst
- else
- g2:=bfGenSymbol()
- initvar:=cons(g2,initvar)
- initval:=cons(lst,initval)
- g2
- ex:=
- null lst=> []
- INTEGERP inc =>
- pred:=if MINUSP inc then "<" else ">"
- [[pred,id,final]]
- [['COND,[['MINUSP,inc],
- ["<",id,final]],['T,[">",id,final]]]]
- suc:=[['SETQ,id,["+",id,inc]]]
- [[initvar,initval,suc,[],ex,[]]]
-
-
-bfINON x==
- [op,id,whole]:=x
- if EQ(op,"ON")
- then bfON(id,whole)
- else bfIN(id,whole)
-
-bfIN(x,E)==
- g:=bfGenSymbol()
- [[[g,x],[E,nil],[['SETQ,g,['CDR, g]]],[],
- [['OR,['ATOM,g],['PROGN,['SETQ,x,['CAR,g]] ,'NIL]]],[]]]
-
-bfON(x,E)==
- [[[x],[E],[['SETQ,x,['CDR, x]]],[],
- [['ATOM,x]],[]]]
-
-bfSuchthat p== [[[],[],[],[p],[],[]]]
-
-bfWhile p== [[[],[],[],[],[bfNOT p],[]]]
-
-bfUntil p==
- g:=bfGenSymbol()
- [[[g],[nil],[['SETQ,g,p]],[],[g],[]]]
-
-bfIterators x==["ITERATORS",:x]
-
-bfCross x== ["CROSS",:x]
-
-bfLp(iters,body)==
- EQCAR (iters,"ITERATORS")=>bfLp1(CDR iters,body)
- bfLpCross(CDR iters,body)
-
-bfLpCross(iters,body)==
- if null cdr iters
- then bfLp(car iters,body)
- else bfLp(car iters,bfLpCross(cdr iters,body))
-
-bfSep(iters)==
- if null iters
- then [[],[],[],[],[],[]]
- else
- f:=first iters
- r:=bfSep rest iters
- [append(i,j) for i in f for j in r]
-
-bfReduce(op,y)==
- a:=if EQCAR(op,"QUOTE") then CADR op else op
- op:=bfReName a
- init:=GET(op,"SHOETHETA")
- g:=bfGenSymbol()
- g1:=bfGenSymbol()
- body:=['SETQ,g,[op,g,g1]]
- if null init
- then
- g2:=bfGenSymbol()
- init:=['CAR,g2]
- ny:=['CDR,g2]
- it:= ["ITERATORS",:[[[[g],[init],[],[],[],[g]]],bfIN(g1,ny)]]
- bfMKPROGN [['L%T,g2,y],bfLp(it,body)]
- else
- init:=car init
- it:= ["ITERATORS",:[[[[g],[init],[],[],[],[g]]],bfIN(g1,y)]]
- bfLp(it,body)
-
-bfReduceCollect(op,y)==
- if EQCAR (y,"COLLECT")
- then
- body:=y.1
- itl:=y.2
- a:=if EQCAR(op,"QUOTE") then CADR op else op
- op:=bfReName a
- init:=GET(op,"SHOETHETA")
- bfOpReduce(op,init,body,itl)
- else
- a:=bfTupleConstruct (y.1)
- bfReduce(op,a)
-
--- delayed collect
-
-bfDCollect(y,itl)== ["COLLECT",y,itl]
-
-bfDTuple x== ["DTUPLE",x]
-
-bfCollect(y,itl) ==
- y is ["COLON",a] => bf0APPEND(a,itl)
- y is ["TUPLE",:.] =>
- newBody:=bfConstruct y
- bf0APPEND(newBody,itl)
- bf0COLLECT(y,itl)
-
-bf0COLLECT(y,itl)==bfListReduce('CONS,y,itl)
-
-
-bf0APPEND(y,itl)==
- g:=bfGenSymbol()
- body:=['SETQ,g,['APPEND,['REVERSE,y],g]]
- extrait:= [[[g],[nil],[],[],[],[['NREVERSE,g]]]]
- bfLp2(extrait,itl,body)
-
-bfListReduce(op,y,itl)==
- g:=bfGenSymbol()
- body:=['SETQ,g,[op,y,g]]
- extrait:= [[[g],[nil],[],[],[],[['NREVERSE,g]]]]
- bfLp2(extrait,itl,body)
-
-bfLp1(iters,body)==
- [vars,inits,sucs,filters,exits,value]:=bfSep bfAppend iters
- nbody:=if null filters then body else bfAND [:filters,body]
- value:=if null value then "NIL" else car value
- exits:= ["COND",[bfOR exits,["RETURN",value]],
- ['(QUOTE T),nbody]]
- loop := ["LOOP",exits,:sucs]
- if vars then loop :=
- ["LET",[[v, i] for v in vars for i in inits], loop]
- loop
-
-bfLp2(extrait,itl,body)==
- EQCAR (itl,"ITERATORS")=>bfLp1(cons(extrait,CDR itl),body)
- iters:=cdr itl
- bfLpCross
- ([["ITERATORS",extrait,:CDAR iters],:CDR iters],body)
-
-bfOpReduce(op,init,y,itl)==
- g:=bfGenSymbol()
- body:=
- EQ(op,"AND")=>
- bfMKPROGN [["SETQ",g,y],
- ['COND, [['NOT,g],['RETURN,'NIL]]]]
- EQ(op,"OR") =>
- bfMKPROGN [["SETQ",g,y],
- ['COND, [g,['RETURN,g]]]]
- ['SETQ,g,[op,g,y]]
- if null init
- then
- g1:=bfGenSymbol()
- init:=['CAR,g1]
- y:=['CDR,g1]
- extrait:= [[[g],[init],[],[],[],[g]]]
- bfMKPROGN [['L%T,g1,y],bfLp2(extrait,itl,body)]
- else
- init:=car init
- extrait:= [[[g],[init],[],[],[],[g]]]
- bfLp2(extrait,itl,body)
-
-bfLoop1 body == bfLp (bfIterators nil,body)
-
-bfSegment1(lo)== ["SEGMENT",lo,nil]
-
-bfSegment2(lo,hi)== ["SEGMENT",lo,hi]
-
-bfForInBy(variable,collection,step)==
- bfFor(variable,collection,step)
-
-bfForin(lhs,U)==bfFor(lhs,U,1)
-
-bfLocal(a,b)==
- EQ(b,"FLUID")=> compFluid a
- EQ(b,"fluid")=> compFluid a
- EQ(b,"local") => compFluid a
- -- $typings:=cons(["TYPE",b,a],$typings)
- a
-
-bfTake(n,x)==
- null x=>x
- n=0 => nil
- cons(car x,bfTake(n-1,cdr x))
-
-bfDrop(n,x)==
- null x or n=0 =>x
- bfDrop(n-1,cdr x)
-
-bfDefSequence l == ['SEQ,: l]
-
-bfReturnNoName a ==
- ["RETURN",a]
-
-bfSUBLIS(p,e)==
- ATOM e=>bfSUBLIS1(p,e)
- EQCAR(e,"QUOTE")=>e
- cons(bfSUBLIS(p,car e),bfSUBLIS(p,cdr e))
-
-+++ Returns e/p, where e is an atom. We assume that the
-+++ DEFs form a system admitting a fix point; otherwise we may
-+++ loop forever. That can happen only if nullary goats
-+++ are recursive -- which they are not supposed to be.
-+++ We don't enforce that restriction though.
-bfSUBLIS1(p,e)==
- null p =>e
- f:=CAR p
- EQ(CAR f,e)=> bfSUBLIS(p, CDR f)
- bfSUBLIS1(cdr p,e)
-
-defSheepAndGoats(x)==
- EQCAR (x,"DEF") =>
- [def,op,args,body]:=x
- argl:=if bfTupleP args
- then cdr args
- else [args]
- if null argl
- then
- opassoc:=[[op,:body]]
- [opassoc,[],[]]
- else
- op1:=INTERN CONCAT(PNAME $op,'",",PNAME op)
- opassoc:=[[op,:op1]]
- defstack:=[["DEF",op1,args,body]]
- [opassoc,defstack,[]]
- EQCAR (x,"SEQ") => defSheepAndGoatsList(cdr x)
- [[],[],[x]]
-
-defSheepAndGoatsList(x)==
- if null x
- then [[],[],[]]
- else
- [opassoc,defs,nondefs] := defSheepAndGoats car x
- [opassoc1,defs1,nondefs1] := defSheepAndGoatsList cdr x
- [append(opassoc,opassoc1),append(defs,defs1),
- append(nondefs,nondefs1)]
---% LET
-
-bfLetForm(lhs,rhs) == ['L%T,lhs,rhs]
-
-bfLET1(lhs,rhs) ==
- IDENTP lhs => bfLetForm(lhs,rhs)
- lhs is ['FLUID,.] => bfLetForm(lhs,rhs)
- IDENTP rhs and not bfCONTAINED(rhs,lhs) =>
- rhs1 := bfLET2(lhs,rhs)
- EQCAR(rhs1,'L%T) => bfMKPROGN [rhs1,rhs]
- EQCAR(rhs1,'PROGN) => APPEND(rhs1,[rhs])
- if IDENTP CAR rhs1 then rhs1 := CONS(rhs1,NIL)
- bfMKPROGN [:rhs1,rhs]
- CONSP(rhs) and EQCAR(rhs,'L%T) and IDENTP(name := CADR rhs) =>
- -- handle things like [a] := x := foo
- l1 := bfLET1(name,CADDR rhs)
- l2 := bfLET1(lhs,name)
- EQCAR(l2,'PROGN) => bfMKPROGN [l1,:CDR l2]
- if IDENTP CAR l2 then l2 := cons(l2,nil)
- bfMKPROGN [l1,:l2,name]
- g := INTERN CONCAT('"LETTMP#",STRINGIMAGE $letGenVarCounter)
- $letGenVarCounter := $letGenVarCounter + 1
- rhs1 := ['L%T,g,rhs]
- let1 := bfLET1(lhs,g)
- EQCAR(let1,'PROGN) => bfMKPROGN [rhs1,:CDR let1]
- if IDENTP CAR let1 then let1 := CONS(let1,NIL)
- bfMKPROGN [rhs1,:let1,g]
-
-bfCONTAINED(x,y)==
- EQ(x,y) => true
- ATOM y=> false
- bfCONTAINED(x,car y) or bfCONTAINED(x,cdr y)
-
-bfLET2(lhs,rhs) ==
- IDENTP lhs => bfLetForm(lhs,rhs)
- NULL lhs => NIL
- lhs is ['FLUID,.] => bfLetForm(lhs,rhs)
- lhs is ['L%T,a,b] =>
- a := bfLET2(a,rhs)
- null (b := bfLET2(b,rhs)) => a
- ATOM b => [a,b]
- CONSP CAR b => CONS(a,b)
- [a,b]
- lhs is ['CONS,var1,var2] =>
- var1 = "DOT" or (CONSP(var1) and EQCAR(var1,'QUOTE)) =>
- bfLET2(var2,addCARorCDR('CDR,rhs))
- l1 := bfLET2(var1,addCARorCDR('CAR,rhs))
- null var2 or EQ(var2,"DOT") =>l1
- if CONSP l1 and ATOM CAR l1 then l1 := cons(l1,nil)
- IDENTP var2 =>
- [:l1,bfLetForm(var2,addCARorCDR('CDR,rhs))]
- l2 := bfLET2(var2,addCARorCDR('CDR,rhs))
- if CONSP l2 and ATOM CAR l2 then l2 := cons(l2,nil)
- APPEND(l1,l2)
- lhs is ['APPEND,var1,var2] =>
- patrev := bfISReverse(var2,var1)
- rev := ['REVERSE,rhs]
- g := INTERN CONCAT('"LETTMP#", STRINGIMAGE $letGenVarCounter)
- $letGenVarCounter := $letGenVarCounter + 1
- l2 := bfLET2(patrev,g)
- if CONSP l2 and ATOM CAR l2 then l2 := cons(l2,nil)
- var1 = "DOT" => [['L%T,g,rev],:l2]
- last l2 is ['L%T, =var1, val1] =>
- [['L%T,g,rev],:REVERSE CDR REVERSE l2,
- bfLetForm(var1,['NREVERSE,val1])]
- [['L%T,g,rev],:l2,bfLetForm(var1,['NREVERSE,var1])]
- lhs is ["EQUAL",var1] =>
- ['COND,[["EQUAL",var1,rhs],var1]]
- -- The original expression may be one that involves literals as
- -- sub-patterns, e.g.
- -- ['SEQ, :l, ['exit, 1, x]] := item
- -- We continue the processing as if that expression had been written
- -- item is ['SEQ, :l, ['exit, 1, x]]
- -- and generate appropriate codes.
- -- -- gdr/2007-04-02.
- isPred :=
- $inDefIS => bfIS1(rhs,lhs)
- bfIS(rhs,lhs)
- ['COND,[isPred,rhs]]
-
-
-bfLET(lhs,rhs) ==
- $letGenVarCounter : local := 1
--- $inbfLet : local := true
- bfLET1(lhs,rhs)
-
-addCARorCDR(acc,expr) ==
- NULL CONSP expr => [acc,expr]
- acc = 'CAR and EQCAR(expr,'REVERSE) =>
- ["CAR",["LAST",:CDR expr]]
- -- cons('last,CDR expr)
- funs := '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR
- CDAAR CDDAR CDADR CDDDR)
- p := bfPosition(CAR expr,funs)
- p = -1 => [acc,expr]
- funsA := '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR CAAADR
- CAADDR CADAAR CADDAR CADADR CADDDR)
- funsR := '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR CDAADR
- CDADDR CDDAAR CDDDAR CDDADR CDDDDR)
- if acc = 'CAR then CONS(funsA.p,CDR expr)
- else CONS(funsR.p,CDR expr)
-
-bfPosition(x,l) == bfPosn(x,l,0)
-bfPosn(x,l,n) ==
- null l => -1
- x=first l => n
- bfPosn(x,rest l,n+1)
-
---% IS
-
-bfISApplication(op,left,right)==
- EQ(op ,"IS") => bfIS(left,right)
- EQ(op ,"ISNT") => bfNOT bfIS(left,right)
- [op ,left,right]
-
-bfIS(left,right)==
- $isGenVarCounter:local :=1
- $inDefIS :local :=true
- bfIS1(left,right)
-
-bfISReverse(x,a) ==
- x is ['CONS,:.] =>
- NULL CADDR x => ['CONS,CADR x, a]
- y := bfISReverse(CADDR x, NIL)
- RPLACA(CDDR y,['CONS,CADR x,a])
- y
- bpSpecificErrorHere '"Error in bfISReverse"
- bpTrap()
-
-bfIS1(lhs,rhs) ==
- NULL rhs =>
- ['NULL,lhs]
- STRINGP rhs =>
- ['EQ,lhs,['QUOTE,INTERN rhs]]
- NUMBERP rhs =>
- ["EQUAL",lhs,rhs]
- ATOM rhs =>
- ['PROGN,bfLetForm(rhs,lhs),''T]
- rhs is ['QUOTE,a] =>
- IDENTP a => ['EQ,lhs,rhs]
- ["EQUAL",lhs,rhs]
- rhs is ['L%T,c,d] =>
- l :=
- bfLET(c,lhs)
--- $inbfLet => bfLET1(c,lhs)
--- bfLET(c,lhs)
- bfAND [bfIS1(lhs,d),bfMKPROGN [l,''T]]
- rhs is ["EQUAL",a] =>
- ["EQUAL",lhs,a]
- CONSP lhs =>
- g := INTERN CONCAT('"ISTMP#",STRINGIMAGE $isGenVarCounter)
- $isGenVarCounter := $isGenVarCounter + 1
- bfMKPROGN [['L%T,g,lhs],bfIS1(g,rhs)]
- rhs is ['CONS,a,b] =>
- a = "DOT" =>
- NULL b =>
- bfAND [['CONSP,lhs],
- ['EQ,['CDR,lhs],'NIL]]
- bfAND [['CONSP,lhs],
- bfIS1(['CDR,lhs],b)]
- NULL b =>
- bfAND [['CONSP,lhs],
- ['EQ,['CDR,lhs],'NIL],_
- bfIS1(['CAR,lhs],a)]
- b = "DOT" =>
- bfAND [['CONSP,lhs],bfIS1(['CAR,lhs],a)]
- a1 := bfIS1(['CAR,lhs],a)
- b1 := bfIS1(['CDR,lhs],b)
- a1 is ['PROGN,c,''T] and b1 is ['PROGN,:cls] =>
- bfAND [['CONSP,lhs],bfMKPROGN [c,:cls]]
- bfAND [['CONSP,lhs],a1,b1]
- rhs is ['APPEND,a,b] =>
- patrev := bfISReverse(b,a)
- g := INTERN CONCAT('"ISTMP#",STRINGIMAGE $isGenVarCounter)
- $isGenVarCounter := $isGenVarCounter + 1
- rev := bfAND [['CONSP,lhs],['PROGN,['L%T,g,['REVERSE,lhs]],''T]]
- l2 := bfIS1(g,patrev)
- if CONSP l2 and ATOM CAR l2 then l2 := cons(l2,nil)
- a = "DOT" => bfAND [rev,:l2]
- bfAND [rev,:l2,['PROGN,bfLetForm(a,['NREVERSE,a]),''T]]
- bpSpecificErrorHere '"bad IS code is generated"
- bpTrap()
-
-bfApplication(bfop, bfarg) ==
- if bfTupleP bfarg
- then cons(bfop,CDR bfarg)
- else cons(bfop,[bfarg])
-
-
-++ Token renaming. New Boot and Old Boot differs in the set of
-++ tokens they rename. When converting code written in Old Boot
-++ to New Boot, it is helpful to have some noise about potential
-++ divergence in semantics. So, when compiling with --boot=old,
-++ we compute the renaming in both Old Boot and New Boot and compare
-++ the results. If they differ, we prefer the old meaning, with some
-++ warnings. Notice that the task is compounded by the fact the
-++ tokens in both language do not always agreee.
-++ However, to minimize the flood of false positive, we
-++ keep a list of symbols which apparently differ in meanings, but
-++ which have been verified to agree.
-++ This is a valuable automated tool during the transition period.
-
--- return the meaning of the x in Old Boot.
-bfGetOldBootName x ==
- a := GET(x, "OLD-BOOT") => car a
- x
-
--- returns true if x has same meaning in both Old Boot and New Boot.
-bfSameMeaning x ==
- GET(x, 'RENAME_-OK)
-
--- returns the meaning of x in the appropriate Boot dialect.
-bfReName x==
- newName :=
- a := GET(x,"SHOERENAME") => car a
- x
- $translatingOldBoot and not bfSameMeaning x =>
- oldName := bfGetOldBootName x
- if newName ^= oldName then
- warn [PNAME x, '" as `", PNAME newName, _
- '"_' differs from Old Boot `", PNAME oldName, '"_'"]
- oldName
- newName
-
-
-bfInfApplication(op,left,right)==
- EQ(op,"EQUAL") => bfQ(left,right)
- EQ(op,"/=") => bfNOT bfQ(left,right)
- EQ(op,">") => bfLessp(right,left)
- EQ(op,"<") => bfLessp(left,right)
- EQ(op,"<=") => bfNOT bfLessp(right,left)
- EQ(op,">=") => bfNOT bfLessp(left,right)
- EQ(op,"OR") => bfOR [left,right]
- EQ(op,"AND") => bfAND [left,right]
- [op,left,right]
-
-bfNOT x==
- x is ["NOT",a]=> a
- x is ["NULL",a]=> a
- ["NOT",x]
-
-bfFlatten(op, x) ==
- EQCAR(x,op) => CDR x
- [x]
-
-bfOR l ==
- null l => NIL
- null cdr l => CAR l
- ["OR",:[:bfFlatten("OR",c) for c in l]]
-
-bfAND l ==
- null l=> 'T
- null cdr l => CAR l
- ["AND",:[:bfFlatten("AND",c) for c in l]]
-
-
-defQuoteId x== EQCAR(x,"QUOTE") and IDENTP CADR x
-
-bfSmintable x==
- INTEGERP x or CONSP x and
- MEMQ(CAR x, '(SIZE LENGTH))
-
-bfQ(l,r)==
- if bfSmintable l or bfSmintable r
- then ["EQL",l,r]
- else if defQuoteId l or defQuoteId r
- then ["EQ",l,r]
- else
- if null l
- then ["NULL",r]
- else if null r
- then ["NULL",l]
- else ["EQUAL",l,r]
-
-bfLessp(l,r)==
- if r=0
- then ["MINUSP", l]
- else ["<",l,r]
-
-bfMDef (defOp,op,args,body) ==
- argl:=if bfTupleP args then cdr args else [args]
- [gargl,sgargl,nargl,largl]:=bfGargl argl
- sb:=[cons(i,j) for i in nargl for j in sgargl]
- body:= SUBLIS(sb,body)
- sb2 := [["CONS",["QUOTE",i],j] for i in sgargl for j in largl]
- body := ["SUBLIS",["LIST",:sb2],["QUOTE",body]]
- lamex:= ["MLAMBDA",gargl,body]
- def:= [op,lamex]
- bfTuple
- cons(shoeComp def,[:shoeComps bfDef1 d for d in $wheredefs])
-
-bfGargl argl==
- if null argl
- then [[],[],[],[]]
- else
- [a,b,c,d]:=bfGargl cdr argl
- if car argl="&REST"
- then [cons(car argl,b),b,c,
- cons(["CONS",["QUOTE","LIST"],car d],cdr d)]
- else
- f:=bfGenSymbol()
- [cons(f,a),cons(f,b),cons(car argl,c),cons(f,d)]
-
-bfDef1 [defOp,op,args,body] ==
- argl:=if bfTupleP args then cdr args else [args]
- [quotes,control,arglp,body]:=bfInsertLet (argl,body)
- quotes=>shoeLAM(op,arglp,control,body)
- [[op,["LAMBDA",arglp,body]]]
-
-shoeLAM (op,args,control,body)==
- margs :=bfGenSymbol()
- innerfunc:=INTERN(CONCAT(PNAME op,",LAM"))
- [[innerfunc,["LAMBDA",args,body]],
- [op,["MLAMBDA",["&REST",margs],["CONS",["QUOTE", innerfunc],
- ["WRAP",margs, ["QUOTE", control]]]]]]
-
-bfDef(defOp,op,args,body) ==
- $bfClamming =>
- [.,op1,arg1,:body1]:=shoeComp first bfDef1 [defOp,op,args,body]
- bfCompHash(op1,arg1,body1)
- bfTuple
- [:shoeComps bfDef1 d for d in cons([defOp,op,args,body],$wheredefs)]
-
-shoeComps x==[shoeComp def for def in x]
-shoeComp x==
- a:=shoeCompTran CADR x
- if EQCAR(a,"LAMBDA")
- then ["DEFUN",CAR x,CADR a,:CDDR a]
- else ["DEFMACRO",CAR x,CADR a,:CDDR a]
-
-bfInsertLet(x,body)==
- if null x
- then [false,nil,x,body]
- else
- if x is ["&REST",a]
- then if a is ["QUOTE",b]
- then [true,"QUOTE",["&REST",b],body]
- else [false,nil,x,body]
- else
- [b,norq,name1,body1]:= bfInsertLet1 (car x,body)
- [b1,norq1,name2,body2]:= bfInsertLet (cdr x,body1)
- [b or b1,cons(norq,norq1),cons(name1,name2),body2]
-
-bfInsertLet1(y,body)==
- if y is ["L%T",l,r]
- then [false,nil,l,bfMKPROGN [bfLET(r,l),body]]
- else if IDENTP y
- then [false,nil,y,body]
- else
- if y is ["BVQUOTE",b]
- then [true,"QUOTE",b,body]
- else
- g:=bfGenSymbol()
- ATOM y => [false,nil,g,body]
- [false,nil,g,bfMKPROGN [bfLET(compFluidize y,g),body]]
-
-shoeCompTran x==
- lamtype:=CAR x
- args :=CADR x
- body :=CDDR x
- $fluidVars:local:=nil
- $locVars:local:=nil
- $dollarVars:local:=nil
- shoeCompTran1 body
- $locVars:=SETDIFFERENCE(SETDIFFERENCE($locVars,
- $fluidVars),shoeATOMs args)
- body:=
- if $fluidVars or $locVars or $dollarVars or $typings
- then
- lvars:=append($fluidVars,$locVars)
- $fluidVars:=UNION($fluidVars,$dollarVars)
- if null $fluidVars
- then
- null $typings=> shoePROG(lvars,body)
- shoePROG(lvars,[["DECLARE",:$typings],:body])
- else
- fvars:=["DECLARE",["SPECIAL",:$fluidVars]]
- null $typings => shoePROG(lvars,[fvars,:body])
- shoePROG(lvars,[fvars,["DECLARE",:$typings],:body])
- else shoePROG([], body)
- fl:=shoeFluids args
- body:=if fl
- then
- fvs:=["DECLARE",["SPECIAL",:fl]]
- cons(fvs,body)
- else body
- [lamtype,args, :body]
-
-shoePROG(v,b)==
- null b => [["PROG", v]]
- [:blist,blast] := b
- [["PROG",v,:blist,["RETURN", blast]]]
-
-shoeFluids x==
- if null x
- then nil
- else if IDENTP x and bfBeginsDollar x
- then [x]
- else
- if EQCAR(x,"QUOTE")
- then []
- else
- if ATOM x
- then nil
- else append(shoeFluids car x,shoeFluids cdr x)
-shoeATOMs x==
- if null x
- then nil
- else if ATOM x
- then [x]
- else append(shoeATOMs car x,shoeATOMs cdr x)
-
-shoeCompTran1 x==
- ATOM x=>
- IDENTP x and bfBeginsDollar x=>
- $dollarVars:=
- MEMQ(x,$dollarVars)=>$dollarVars
- cons(x,$dollarVars)
- nil
- U:=car x
- EQ(U,"QUOTE")=>nil
- x is ["L%T",l,r]=>
- RPLACA (x,"SETQ")
- shoeCompTran1 r
- IDENTP l =>
- not bfBeginsDollar l=>
- $locVars:=
- MEMQ(l,$locVars)=>$locVars
- cons(l,$locVars)
- $dollarVars:=
- MEMQ(l,$dollarVars)=>$dollarVars
- cons(l,$dollarVars)
- EQCAR(l,"FLUID")=>
- $fluidVars:=
- MEMQ(CADR l,$fluidVars)=>$fluidVars
- cons(CADR l,$fluidVars)
- RPLACA (CDR x,CADR l)
- MEMQ(U,'(PROG LAMBDA))=>
- newbindings:=nil
- for y in CADR x repeat
- not MEMQ(y,$locVars)=>
- $locVars:=cons(y,$locVars)
- newbindings:=cons(y,newbindings)
- res:=shoeCompTran1 CDDR x
- $locVars:=[y for y in $locVars | not MEMQ(y,newbindings)]
- shoeCompTran1 car x
- shoeCompTran1 cdr x
-
-bfTagged(a,b)==
- IDENTP a =>
- EQ(b,"FLUID") => bfLET(compFluid a,NIL)
- EQ(b,"fluid") => bfLET(compFluid a,NIL)
- EQ(b,"local") => bfLET(compFluid a,NIL)
- $typings:=cons(["TYPE",b,a],$typings)
- a
- ["THE",b,a]
-
-bfAssign(l,r)==
- if bfTupleP l then bfSetelt(CADR l,CDDR l ,r) else bfLET(l,r)
-
-bfSetelt(e,l,r)==
- if null cdr l
- then defSETELT(e,car l,r)
- else bfSetelt(bfElt(e,car l),cdr l,r)
-
-bfElt(expr,sel)==
- y:=SYMBOLP sel and GET(sel,"SHOESELFUNCTION")
- y=>
- INTEGERP y => ["ELT",expr,y]
- [y,expr]
- ["ELT",expr,sel]
-
-defSETELT(var,sel,expr)==
- y:=SYMBOLP sel and GET(sel,"SHOESELFUNCTION")
- y=>
- INTEGERP y => ["SETF",["ELT",var,y],expr]
- ["SETF",[y,var],expr]
- ["SETF",["ELT",var,sel],expr]
-
-bfIfThenOnly(a,b)==
- b1:=if EQCAR (b,"PROGN") then CDR b else [b]
- ["COND",[a,:b1]]
-
-bfIf(a,b,c)==
- b1:=if EQCAR (b,"PROGN") then CDR b else [b]
- EQCAR (c,"COND") => ["COND",[a,:b1],:CDR c]
- c1:=if EQCAR (c,"PROGN") then CDR c else [c]
- ["COND",[a,:b1],['(QUOTE T),:c1]]
-
-bfExit(a,b)== ["COND",[a,["IDENTITY",b]]]
-
-bfMKPROGN l==
- a:=[:bfFlattenSeq c for c in tails l]
- null a=> nil
- null CDR a=> CAR a
- ["PROGN",:a]
-
-bfFlattenSeq x ==
- null x=>NIL
- f:=CAR x
- ATOM f =>if CDR x then nil else [f]
- EQCAR(f,"PROGN") =>
- CDR x=> [i for i in CDR f| not ATOM i]
- CDR f
- [f]
-
-bfSequence l ==
- null l=> NIL
- transform:= [[a,b] for x in l while
- x is ["COND",[a,["IDENTITY",b]]]]
- no:=#transform
- before:= bfTake(no,l)
- aft := bfDrop(no,l)
- null before =>
- null rest l =>
- f:=first l
- if EQCAR(f,"PROGN")
- then bfSequence CDR f
- else f
- bfMKPROGN [first l,bfSequence rest l]
- null aft => ["COND",:transform]
- ["COND",:transform,['(QUOTE T),bfSequence aft]]
-
-bfWhere (context,expr)==
- [opassoc,defs,nondefs] := defSheepAndGoats context
- a:=[[def,op,args,bfSUBLIS(opassoc,body)]
- for d in defs |d is [def,op,args,body]]
- $wheredefs:=append(a,$wheredefs)
- bfMKPROGN bfSUBLIS(opassoc,NCONC(nondefs,[expr]))
-
---shoeReadLispString(s,n)==
--- n>= # s => nil
--- [exp,ind]:=shoeReadLisp(s,n)
--- null exp => nil
--- cons(exp,shoeReadLispString(s,ind))
-
-bfReadLisp string==bfTuple shoeReadLispString (string,0)
-
-bfCompHash(op,argl,body) ==
- auxfn:= INTERN CONCAT (PNAME op,'";")
- computeFunction:= ["DEFUN",auxfn,argl,:body]
- bfTuple [computeFunction,:bfMain(auxfn,op)]
-
-shoeCompileTimeEvaluation x ==
- ["EVAL-WHEN", [KEYWORD::COMPILE_-TOPLEVEL], x]
-
-shoeEVALANDFILEACTQ x==
- ["EVAL-WHEN", [KEYWORD::EXECUTE, KEYWORD::LOAD_-TOPLEVEL], x]
-
-bfMain(auxfn,op)==
- g1:= bfGenSymbol()
- arg:=["&REST",g1]
- computeValue := ['APPLY,["FUNCTION",auxfn],g1]
- cacheName:= INTERN CONCAT (PNAME op,'";AL")
- g2:= bfGenSymbol()
- getCode:= ['GETHASH,g1,cacheName]
- secondPredPair:= [['SETQ,g2,getCode],g2]
- putCode:= ['SETF ,getCode,computeValue]
- thirdPredPair:= ['(QUOTE T),putCode]
- codeBody:= ['PROG,[g2],
- ['RETURN,['COND,secondPredPair,thirdPredPair]]]
- mainFunction:= ["DEFUN",op,arg,codeBody]
-
- cacheType:= 'hash_-table
- cacheResetCode:= ['SETQ,cacheName,['MAKE_-HASHTABLE,
- ["QUOTE","UEQUAL"]]]
- cacheCountCode:= ['hashCount,cacheName]
- cacheVector:=
- [op,cacheName,cacheType,cacheResetCode,cacheCountCode]
- [mainFunction,
- shoeEVALANDFILEACTQ
- ["SETF",["GET",
- ["QUOTE", op],["QUOTE",'cacheInfo]],["QUOTE", cacheVector]],
- shoeEVALANDFILEACTQ cacheResetCode ]
-
-bfNameOnly x==
- if x="t"
- then ["T"]
- else [x]
-
-bfNameArgs (x,y)==
- y:=if EQCAR(y,"TUPLE") then CDR y else [y]
- cons(x,y)
-
-bfStruct(name,arglist)==
- bfTuple [bfCreateDef i for i in arglist]
-
-bfCreateDef x==
- if null cdr x
- then
- f:=car x
- ["SETQ",f,["LIST",["QUOTE",f]]]
- else
- a:=[bfGenSymbol() for i in cdr x]
- ["DEFUN",car x,a,["CONS",["QUOTE",car x],["LIST",:a]]]
-
-bfCaseItem(x,y)==[x,y]
-
-bfCase(x,y)==
- g:=bfGenSymbol()
- g1:=bfGenSymbol()
- a:=bfLET(g,x)
- b:=bfLET(g1,["CDR",g])
- c:=bfCaseItems (g1,y)
- bfMKPROGN [a,b,["CASE",["CAR", g],:c]]
-
-bfCaseItems(g,x)== [bfCI(g,i,j) for [i,j] in x]
-
-bfCI(g,x,y)==
- a:=cdr x
- if null a
- then [car x,y]
- else
- b:=[[i,bfCARCDR(j,g)] for i in a for j in 0..]
- [car x,["LET",b,y]]
-
-bfCARCDR (n,g)==[INTERN CONCAT ('"CA",bfDs n,'"R"),g]
-
-bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
-
-@
-
-<<ast.clisp>>=
(EVAL-WHEN (:COMPILE-TOPLEVEL) (PROVIDE "boot-ast"))
(IMPORT-MODULE "includer")
@@ -1137,90 +22,99 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
(DEFUN |Import| #0=(|bfVar#4|) (CONS '|Import| (LIST . #0#)))
-(DEFUN |TypeAlias| #0=(|bfVar#5| |bfVar#6| |bfVar#7|)
+(DEFUN |ImportSignature| #0=(|bfVar#5| |bfVar#6|)
+ (CONS '|ImportSignature| (LIST . #0#)))
+
+(DEFUN |TypeAlias| #0=(|bfVar#7| |bfVar#8| |bfVar#9|)
(CONS '|TypeAlias| (LIST . #0#)))
-(DEFUN |SuffixDot| #0=(|bfVar#8|) (CONS '|SuffixDot| (LIST . #0#)))
+(DEFUN |Signature| #0=(|bfVar#10| |bfVar#11|)
+ (CONS '|Signature| (LIST . #0#)))
+
+(DEFUN |Mapping| #0=(|bfVar#12| |bfVar#13|)
+ (CONS '|Mapping| (LIST . #0#)))
-(DEFUN |Quote| #0=(|bfVar#9|) (CONS '|Quote| (LIST . #0#)))
+(DEFUN |SuffixDot| #0=(|bfVar#14|) (CONS '|SuffixDot| (LIST . #0#)))
-(DEFUN |EqualName| #0=(|bfVar#10|) (CONS '|EqualName| (LIST . #0#)))
+(DEFUN |Quote| #0=(|bfVar#15|) (CONS '|Quote| (LIST . #0#)))
-(DEFUN |Colon| #0=(|bfVar#11|) (CONS '|Colon| (LIST . #0#)))
+(DEFUN |EqualName| #0=(|bfVar#16|) (CONS '|EqualName| (LIST . #0#)))
-(DEFUN |QualifiedName| #0=(|bfVar#12| |bfVar#13|)
+(DEFUN |Colon| #0=(|bfVar#17|) (CONS '|Colon| (LIST . #0#)))
+
+(DEFUN |QualifiedName| #0=(|bfVar#18| |bfVar#19|)
(CONS '|QualifiedName| (LIST . #0#)))
-(DEFUN |Bracket| #0=(|bfVar#14|) (CONS '|Bracket| (LIST . #0#)))
+(DEFUN |Bracket| #0=(|bfVar#20|) (CONS '|Bracket| (LIST . #0#)))
-(DEFUN |UnboundedSegment| #0=(|bfVar#15|)
+(DEFUN |UnboundedSegment| #0=(|bfVar#21|)
(CONS '|UnboundedSegment| (LIST . #0#)))
-(DEFUN |BoundedSgement| #0=(|bfVar#16| |bfVar#17|)
+(DEFUN |BoundedSgement| #0=(|bfVar#22| |bfVar#23|)
(CONS '|BoundedSgement| (LIST . #0#)))
-(DEFUN |Tuple| #0=(|bfVar#18|) (CONS '|Tuple| (LIST . #0#)))
+(DEFUN |Tuple| #0=(|bfVar#24|) (CONS '|Tuple| (LIST . #0#)))
-(DEFUN |ColonAppend| #0=(|bfVar#19| |bfVar#20|)
+(DEFUN |ColonAppend| #0=(|bfVar#25| |bfVar#26|)
(CONS '|ColonAppend| (LIST . #0#)))
-(DEFUN |Is| #0=(|bfVar#21| |bfVar#22|) (CONS '|Is| (LIST . #0#)))
+(DEFUN |Is| #0=(|bfVar#27| |bfVar#28|) (CONS '|Is| (LIST . #0#)))
-(DEFUN |Isnt| #0=(|bfVar#23| |bfVar#24|) (CONS '|Isnt| (LIST . #0#)))
+(DEFUN |Isnt| #0=(|bfVar#29| |bfVar#30|) (CONS '|Isnt| (LIST . #0#)))
-(DEFUN |Reduce| #0=(|bfVar#25| |bfVar#26|)
+(DEFUN |Reduce| #0=(|bfVar#31| |bfVar#32|)
(CONS '|Reduce| (LIST . #0#)))
-(DEFUN |PrefixExpr| #0=(|bfVar#27| |bfVar#28|)
+(DEFUN |PrefixExpr| #0=(|bfVar#33| |bfVar#34|)
(CONS '|PrefixExpr| (LIST . #0#)))
-(DEFUN |Call| #0=(|bfVar#29| |bfVar#30|) (CONS '|Call| (LIST . #0#)))
+(DEFUN |Call| #0=(|bfVar#35| |bfVar#36|) (CONS '|Call| (LIST . #0#)))
-(DEFUN |InfixExpr| #0=(|bfVar#31| |bfVar#32| |bfVar#33|)
+(DEFUN |InfixExpr| #0=(|bfVar#37| |bfVar#38| |bfVar#39|)
(CONS '|InfixExpr| (LIST . #0#)))
-(DEFUN |ConstantDefinition| #0=(|bfVar#34| |bfVar#35|)
+(DEFUN |ConstantDefinition| #0=(|bfVar#40| |bfVar#41|)
(CONS '|ConstantDefinition| (LIST . #0#)))
-(DEFUN |Definition| #0=(|bfVar#36| |bfVar#37| |bfVar#38| |bfVar#39|)
+(DEFUN |Definition| #0=(|bfVar#42| |bfVar#43| |bfVar#44| |bfVar#45|)
(CONS '|Definition| (LIST . #0#)))
-(DEFUN |Macro| #0=(|bfVar#40| |bfVar#41| |bfVar#42|)
+(DEFUN |Macro| #0=(|bfVar#46| |bfVar#47| |bfVar#48|)
(CONS '|Macro| (LIST . #0#)))
-(DEFUN |SuchThat| #0=(|bfVar#43|) (CONS '|SuchThat| (LIST . #0#)))
+(DEFUN |SuchThat| #0=(|bfVar#49|) (CONS '|SuchThat| (LIST . #0#)))
-(DEFUN |Assignment| #0=(|bfVar#44| |bfVar#45|)
+(DEFUN |Assignment| #0=(|bfVar#50| |bfVar#51|)
(CONS '|Assignment| (LIST . #0#)))
-(DEFUN |While| #0=(|bfVar#46|) (CONS '|While| (LIST . #0#)))
+(DEFUN |While| #0=(|bfVar#52|) (CONS '|While| (LIST . #0#)))
-(DEFUN |Until| #0=(|bfVar#47|) (CONS '|Until| (LIST . #0#)))
+(DEFUN |Until| #0=(|bfVar#53|) (CONS '|Until| (LIST . #0#)))
-(DEFUN |For| #0=(|bfVar#48| |bfVar#49| |bfVar#50|)
+(DEFUN |For| #0=(|bfVar#54| |bfVar#55| |bfVar#56|)
(CONS '|For| (LIST . #0#)))
-(DEFUN |Exit| #0=(|bfVar#51| |bfVar#52|) (CONS '|Exit| (LIST . #0#)))
+(DEFUN |Exit| #0=(|bfVar#57| |bfVar#58|) (CONS '|Exit| (LIST . #0#)))
-(DEFUN |Iterators| #0=(|bfVar#53|) (CONS '|Iterators| (LIST . #0#)))
+(DEFUN |Iterators| #0=(|bfVar#59|) (CONS '|Iterators| (LIST . #0#)))
-(DEFUN |Cross| #0=(|bfVar#54|) (CONS '|Cross| (LIST . #0#)))
+(DEFUN |Cross| #0=(|bfVar#60|) (CONS '|Cross| (LIST . #0#)))
-(DEFUN |Repeat| #0=(|bfVar#55| |bfVar#56|)
+(DEFUN |Repeat| #0=(|bfVar#61| |bfVar#62|)
(CONS '|Repeat| (LIST . #0#)))
-(DEFUN |Pile| #0=(|bfVar#57|) (CONS '|Pile| (LIST . #0#)))
+(DEFUN |Pile| #0=(|bfVar#63|) (CONS '|Pile| (LIST . #0#)))
-(DEFUN |Append| #0=(|bfVar#58|) (CONS '|Append| (LIST . #0#)))
+(DEFUN |Append| #0=(|bfVar#64|) (CONS '|Append| (LIST . #0#)))
-(DEFUN |Case| #0=(|bfVar#59| |bfVar#60|) (CONS '|Case| (LIST . #0#)))
+(DEFUN |Case| #0=(|bfVar#65| |bfVar#66|) (CONS '|Case| (LIST . #0#)))
-(DEFUN |Return| #0=(|bfVar#61|) (CONS '|Return| (LIST . #0#)))
+(DEFUN |Return| #0=(|bfVar#67|) (CONS '|Return| (LIST . #0#)))
-(DEFUN |Where| #0=(|bfVar#62| |bfVar#63|)
+(DEFUN |Where| #0=(|bfVar#68| |bfVar#69|)
(CONS '|Where| (LIST . #0#)))
-(DEFUN |Structure| #0=(|bfVar#64| |bfVar#65|)
+(DEFUN |Structure| #0=(|bfVar#70| |bfVar#71|)
(CONS '|Structure| (LIST . #0#)))
(DEFPARAMETER |$inDefIS| NIL)
@@ -1275,14 +169,14 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
(DEFUN |bfCompDef| (|x|)
(PROG (|body| |ISTMP#3| |args| |ISTMP#2| |op| |ISTMP#1| |def|
- |bfVar#67| |bfVar#66|)
+ |bfVar#73| |bfVar#72|)
(RETURN
(PROGN
- (SETQ |bfVar#66| |x|)
- (SETQ |bfVar#67| (CDR |bfVar#66|))
- (CASE (CAR |bfVar#66|)
+ (SETQ |bfVar#72| |x|)
+ (SETQ |bfVar#73| (CDR |bfVar#72|))
+ (CASE (CAR |bfVar#72|)
(|ConstantDefinition|
- (LET ((|n| (CAR |bfVar#67|)) (|e| (CADR |bfVar#67|)))
+ (LET ((|n| (CAR |bfVar#73|)) (|e| (CADR |bfVar#73|)))
|x|))
(T (COND
((AND (CONSP |x|)
@@ -1334,22 +228,22 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
(PROGN
(SETQ |a| (COND ((|bfTupleP| |b|) (CDR |b|)) ('T (LIST |b|))))
(COND
- ((LET ((|bfVar#69| NIL) (|bfVar#68| |a|) (|x| NIL))
+ ((LET ((|bfVar#75| NIL) (|bfVar#74| |a|) (|x| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#68|)
- (PROGN (SETQ |x| (CAR |bfVar#68|)) NIL))
- (RETURN |bfVar#69|))
+ ((OR (ATOM |bfVar#74|)
+ (PROGN (SETQ |x| (CAR |bfVar#74|)) NIL))
+ (RETURN |bfVar#75|))
('T
(PROGN
- (SETQ |bfVar#69|
+ (SETQ |bfVar#75|
(AND (CONSP |x|) (EQ (CAR |x|) 'COLON)
(PROGN
(SETQ |ISTMP#1| (CDR |x|))
(AND (CONSP |ISTMP#1|)
(EQ (CDR |ISTMP#1|) NIL)))))
- (COND (|bfVar#69| (RETURN |bfVar#69|))))))
- (SETQ |bfVar#68| (CDR |bfVar#68|))))
+ (COND (|bfVar#75| (RETURN |bfVar#75|))))))
+ (SETQ |bfVar#74| (CDR |bfVar#74|))))
(|bfMakeCons| |a|))
('T (CONS 'LIST |a|)))))))
@@ -1519,19 +413,19 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
(COND
((NULL |iters|) (LIST NIL NIL NIL NIL NIL NIL))
('T (SETQ |f| (CAR |iters|)) (SETQ |r| (|bfSep| (CDR |iters|)))
- (LET ((|bfVar#72| NIL) (|bfVar#70| |f|) (|i| NIL)
- (|bfVar#71| |r|) (|j| NIL))
+ (LET ((|bfVar#78| NIL) (|bfVar#76| |f|) (|i| NIL)
+ (|bfVar#77| |r|) (|j| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#70|)
- (PROGN (SETQ |i| (CAR |bfVar#70|)) NIL)
- (ATOM |bfVar#71|)
- (PROGN (SETQ |j| (CAR |bfVar#71|)) NIL))
- (RETURN (NREVERSE |bfVar#72|)))
+ ((OR (ATOM |bfVar#76|)
+ (PROGN (SETQ |i| (CAR |bfVar#76|)) NIL)
+ (ATOM |bfVar#77|)
+ (PROGN (SETQ |j| (CAR |bfVar#77|)) NIL))
+ (RETURN (NREVERSE |bfVar#78|)))
('T
- (SETQ |bfVar#72| (CONS (APPEND |i| |j|) |bfVar#72|))))
- (SETQ |bfVar#70| (CDR |bfVar#70|))
- (SETQ |bfVar#71| (CDR |bfVar#71|)))))))))
+ (SETQ |bfVar#78| (CONS (APPEND |i| |j|) |bfVar#78|))))
+ (SETQ |bfVar#76| (CDR |bfVar#76|))
+ (SETQ |bfVar#77| (CDR |bfVar#77|)))))))))
(DEFUN |bfReduce| (|op| |y|)
(PROG (|it| |ny| |g2| |body| |g1| |g| |init| |a|)
@@ -1543,7 +437,7 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
(SETQ |init| (GET |op| 'SHOETHETA))
(SETQ |g| (|bfGenSymbol|))
(SETQ |g1| (|bfGenSymbol|))
- (SETQ |body| (LIST 'SETQ |g| (LIST |op| |g1| |g|)))
+ (SETQ |body| (LIST 'SETQ |g| (LIST |op| |g| |g1|)))
(COND
((NULL |init|) (SETQ |g2| (|bfGenSymbol|))
(SETQ |init| (LIST 'CAR |g2|)) (SETQ |ny| (LIST 'CDR |g2|))
@@ -1648,25 +542,25 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
(COND
(|vars| (SETQ |loop|
(LIST 'LET
- (LET ((|bfVar#75| NIL)
- (|bfVar#73| |vars|) (|v| NIL)
- (|bfVar#74| |inits|) (|i| NIL))
+ (LET ((|bfVar#81| NIL)
+ (|bfVar#79| |vars|) (|v| NIL)
+ (|bfVar#80| |inits|) (|i| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#73|)
+ ((OR (ATOM |bfVar#79|)
(PROGN
- (SETQ |v| (CAR |bfVar#73|))
+ (SETQ |v| (CAR |bfVar#79|))
NIL)
- (ATOM |bfVar#74|)
+ (ATOM |bfVar#80|)
(PROGN
- (SETQ |i| (CAR |bfVar#74|))
+ (SETQ |i| (CAR |bfVar#80|))
NIL))
- (RETURN (NREVERSE |bfVar#75|)))
+ (RETURN (NREVERSE |bfVar#81|)))
('T
- (SETQ |bfVar#75|
- (CONS (LIST |v| |i|) |bfVar#75|))))
- (SETQ |bfVar#73| (CDR |bfVar#73|))
- (SETQ |bfVar#74| (CDR |bfVar#74|))))
+ (SETQ |bfVar#81|
+ (CONS (LIST |v| |i|) |bfVar#81|))))
+ (SETQ |bfVar#79| (CDR |bfVar#79|))
+ (SETQ |bfVar#80| (CDR |bfVar#80|))))
|loop|))))
|loop|))))
@@ -2308,17 +1202,17 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
((NULL (CDR |l|)) (CAR |l|))
('T
(CONS 'OR
- (LET ((|bfVar#77| NIL) (|bfVar#76| |l|) (|c| NIL))
+ (LET ((|bfVar#83| NIL) (|bfVar#82| |l|) (|c| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#76|)
- (PROGN (SETQ |c| (CAR |bfVar#76|)) NIL))
- (RETURN (NREVERSE |bfVar#77|)))
+ ((OR (ATOM |bfVar#82|)
+ (PROGN (SETQ |c| (CAR |bfVar#82|)) NIL))
+ (RETURN (NREVERSE |bfVar#83|)))
('T
- (SETQ |bfVar#77|
+ (SETQ |bfVar#83|
(APPEND (REVERSE (|bfFlatten| 'OR |c|))
- |bfVar#77|))))
- (SETQ |bfVar#76| (CDR |bfVar#76|))))))))))
+ |bfVar#83|))))
+ (SETQ |bfVar#82| (CDR |bfVar#82|))))))))))
(DEFUN |bfAND| (|l|)
(PROG ()
@@ -2328,17 +1222,17 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
((NULL (CDR |l|)) (CAR |l|))
('T
(CONS 'AND
- (LET ((|bfVar#79| NIL) (|bfVar#78| |l|) (|c| NIL))
+ (LET ((|bfVar#85| NIL) (|bfVar#84| |l|) (|c| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#78|)
- (PROGN (SETQ |c| (CAR |bfVar#78|)) NIL))
- (RETURN (NREVERSE |bfVar#79|)))
+ ((OR (ATOM |bfVar#84|)
+ (PROGN (SETQ |c| (CAR |bfVar#84|)) NIL))
+ (RETURN (NREVERSE |bfVar#85|)))
('T
- (SETQ |bfVar#79|
+ (SETQ |bfVar#85|
(APPEND (REVERSE (|bfFlatten| 'AND |c|))
- |bfVar#79|))))
- (SETQ |bfVar#78| (CDR |bfVar#78|))))))))))
+ |bfVar#85|))))
+ (SETQ |bfVar#84| (CDR |bfVar#84|))))))))))
(DEFUN |defQuoteId| (|x|)
(PROG () (RETURN (AND (EQCAR |x| 'QUOTE) (IDENTP (CADR |x|))))))
@@ -2381,55 +1275,55 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
(SETQ |nargl| (CADDR . #0#))
(SETQ |largl| (CADDDR . #0#))
(SETQ |sb|
- (LET ((|bfVar#82| NIL) (|bfVar#80| |nargl|) (|i| NIL)
- (|bfVar#81| |sgargl|) (|j| NIL))
+ (LET ((|bfVar#88| NIL) (|bfVar#86| |nargl|) (|i| NIL)
+ (|bfVar#87| |sgargl|) (|j| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#80|)
- (PROGN (SETQ |i| (CAR |bfVar#80|)) NIL)
- (ATOM |bfVar#81|)
- (PROGN (SETQ |j| (CAR |bfVar#81|)) NIL))
- (RETURN (NREVERSE |bfVar#82|)))
+ ((OR (ATOM |bfVar#86|)
+ (PROGN (SETQ |i| (CAR |bfVar#86|)) NIL)
+ (ATOM |bfVar#87|)
+ (PROGN (SETQ |j| (CAR |bfVar#87|)) NIL))
+ (RETURN (NREVERSE |bfVar#88|)))
(#1='T
- (SETQ |bfVar#82| (CONS (CONS |i| |j|) |bfVar#82|))))
- (SETQ |bfVar#80| (CDR |bfVar#80|))
- (SETQ |bfVar#81| (CDR |bfVar#81|)))))
+ (SETQ |bfVar#88| (CONS (CONS |i| |j|) |bfVar#88|))))
+ (SETQ |bfVar#86| (CDR |bfVar#86|))
+ (SETQ |bfVar#87| (CDR |bfVar#87|)))))
(SETQ |body| (SUBLIS |sb| |body|))
(SETQ |sb2|
- (LET ((|bfVar#85| NIL) (|bfVar#83| |sgargl|) (|i| NIL)
- (|bfVar#84| |largl|) (|j| NIL))
+ (LET ((|bfVar#91| NIL) (|bfVar#89| |sgargl|) (|i| NIL)
+ (|bfVar#90| |largl|) (|j| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#83|)
- (PROGN (SETQ |i| (CAR |bfVar#83|)) NIL)
- (ATOM |bfVar#84|)
- (PROGN (SETQ |j| (CAR |bfVar#84|)) NIL))
- (RETURN (NREVERSE |bfVar#85|)))
+ ((OR (ATOM |bfVar#89|)
+ (PROGN (SETQ |i| (CAR |bfVar#89|)) NIL)
+ (ATOM |bfVar#90|)
+ (PROGN (SETQ |j| (CAR |bfVar#90|)) NIL))
+ (RETURN (NREVERSE |bfVar#91|)))
(#1#
- (SETQ |bfVar#85|
+ (SETQ |bfVar#91|
(CONS (LIST 'CONS (LIST 'QUOTE |i|) |j|)
- |bfVar#85|))))
- (SETQ |bfVar#83| (CDR |bfVar#83|))
- (SETQ |bfVar#84| (CDR |bfVar#84|)))))
+ |bfVar#91|))))
+ (SETQ |bfVar#89| (CDR |bfVar#89|))
+ (SETQ |bfVar#90| (CDR |bfVar#90|)))))
(SETQ |body|
(LIST 'SUBLIS (CONS 'LIST |sb2|) (LIST 'QUOTE |body|)))
(SETQ |lamex| (LIST 'MLAMBDA |gargl| |body|))
(SETQ |def| (LIST |op| |lamex|))
(|bfTuple|
(CONS (|shoeComp| |def|)
- (LET ((|bfVar#87| NIL) (|bfVar#86| |$wheredefs|)
+ (LET ((|bfVar#93| NIL) (|bfVar#92| |$wheredefs|)
(|d| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#86|)
- (PROGN (SETQ |d| (CAR |bfVar#86|)) NIL))
- (RETURN (NREVERSE |bfVar#87|)))
+ ((OR (ATOM |bfVar#92|)
+ (PROGN (SETQ |d| (CAR |bfVar#92|)) NIL))
+ (RETURN (NREVERSE |bfVar#93|)))
(#1#
- (SETQ |bfVar#87|
+ (SETQ |bfVar#93|
(APPEND (REVERSE
(|shoeComps| (|bfDef1| |d|)))
- |bfVar#87|))))
- (SETQ |bfVar#86| (CDR |bfVar#86|))))))))))
+ |bfVar#93|))))
+ (SETQ |bfVar#92| (CDR |bfVar#92|))))))))))
(DEFUN |bfGargl| (|argl|)
(PROG (|f| |d| |c| |b| |a| |LETTMP#1|)
@@ -2449,13 +1343,13 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
(LIST (CONS |f| |a|) (CONS |f| |b|) (CONS (CAR |argl|) |c|)
(CONS |f| |d|)))))))))
-(DEFUN |bfDef1| (|bfVar#88|)
+(DEFUN |bfDef1| (|bfVar#94|)
(PROG (|arglp| |control| |quotes| |LETTMP#1| |argl| |body| |args|
|op| |defOp|)
(RETURN
(PROGN
- (SETQ |defOp| (CAR |bfVar#88|))
- (SETQ |op| (CADR . #0=(|bfVar#88|)))
+ (SETQ |defOp| (CAR |bfVar#94|))
+ (SETQ |op| (CADR . #0=(|bfVar#94|)))
(SETQ |args| (CADDR . #0#))
(SETQ |body| (CADDDR . #0#))
(SETQ |argl|
@@ -2501,33 +1395,33 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
(|bfCompHash| |op1| |arg1| |body1|)))
('T
(|bfTuple|
- (LET ((|bfVar#90| NIL)
- (|bfVar#89|
+ (LET ((|bfVar#96| NIL)
+ (|bfVar#95|
(CONS (LIST |defOp| |op| |args| |body|)
|$wheredefs|))
(|d| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#89|)
- (PROGN (SETQ |d| (CAR |bfVar#89|)) NIL))
- (RETURN (NREVERSE |bfVar#90|)))
+ ((OR (ATOM |bfVar#95|)
+ (PROGN (SETQ |d| (CAR |bfVar#95|)) NIL))
+ (RETURN (NREVERSE |bfVar#96|)))
('T
- (SETQ |bfVar#90|
+ (SETQ |bfVar#96|
(APPEND (REVERSE (|shoeComps| (|bfDef1| |d|)))
- |bfVar#90|))))
- (SETQ |bfVar#89| (CDR |bfVar#89|))))))))))
+ |bfVar#96|))))
+ (SETQ |bfVar#95| (CDR |bfVar#95|))))))))))
(DEFUN |shoeComps| (|x|)
(PROG ()
(RETURN
- (LET ((|bfVar#92| NIL) (|bfVar#91| |x|) (|def| NIL))
+ (LET ((|bfVar#98| NIL) (|bfVar#97| |x|) (|def| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#91|)
- (PROGN (SETQ |def| (CAR |bfVar#91|)) NIL))
- (RETURN (NREVERSE |bfVar#92|)))
- ('T (SETQ |bfVar#92| (CONS (|shoeComp| |def|) |bfVar#92|))))
- (SETQ |bfVar#91| (CDR |bfVar#91|)))))))
+ ((OR (ATOM |bfVar#97|)
+ (PROGN (SETQ |def| (CAR |bfVar#97|)) NIL))
+ (RETURN (NREVERSE |bfVar#98|)))
+ ('T (SETQ |bfVar#98| (CONS (|shoeComp| |def|) |bfVar#98|))))
+ (SETQ |bfVar#97| (CDR |bfVar#97|)))))))
(DEFUN |shoeComp| (|x|)
(PROG (|a|)
@@ -2737,11 +1631,11 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
((MEMQ U '(PROG LAMBDA))
(PROGN
(SETQ |newbindings| NIL)
- (LET ((|bfVar#93| (CADR |x|)) (|y| NIL))
+ (LET ((|bfVar#99| (CADR |x|)) (|y| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#93|)
- (PROGN (SETQ |y| (CAR |bfVar#93|)) NIL))
+ ((OR (ATOM |bfVar#99|)
+ (PROGN (SETQ |y| (CAR |bfVar#99|)) NIL))
(RETURN NIL))
(#1='T
(COND
@@ -2751,23 +1645,23 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
(SETQ |$locVars| (CONS |y| |$locVars|))
(SETQ |newbindings|
(CONS |y| |newbindings|))))))))
- (SETQ |bfVar#93| (CDR |bfVar#93|))))
+ (SETQ |bfVar#99| (CDR |bfVar#99|))))
(SETQ |res| (|shoeCompTran1| (CDDR |x|)))
(SETQ |$locVars|
- (LET ((|bfVar#95| NIL) (|bfVar#94| |$locVars|)
+ (LET ((|bfVar#101| NIL) (|bfVar#100| |$locVars|)
(|y| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#94|)
+ ((OR (ATOM |bfVar#100|)
(PROGN
- (SETQ |y| (CAR |bfVar#94|))
+ (SETQ |y| (CAR |bfVar#100|))
NIL))
- (RETURN (NREVERSE |bfVar#95|)))
+ (RETURN (NREVERSE |bfVar#101|)))
(#1#
(AND (NULL (MEMQ |y| |newbindings|))
- (SETQ |bfVar#95|
- (CONS |y| |bfVar#95|)))))
- (SETQ |bfVar#94| (CDR |bfVar#94|)))))))
+ (SETQ |bfVar#101|
+ (CONS |y| |bfVar#101|)))))
+ (SETQ |bfVar#100| (CDR |bfVar#100|)))))))
(#0#
(PROGN
(|shoeCompTran1| (CAR |x|))
@@ -2859,14 +1753,14 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
(RETURN
(PROGN
(SETQ |a|
- (LET ((|bfVar#96| NIL) (|c| |l|))
+ (LET ((|bfVar#102| NIL) (|c| |l|))
(LOOP
(COND
- ((ATOM |c|) (RETURN (NREVERSE |bfVar#96|)))
+ ((ATOM |c|) (RETURN (NREVERSE |bfVar#102|)))
('T
- (SETQ |bfVar#96|
+ (SETQ |bfVar#102|
(APPEND (REVERSE (|bfFlattenSeq| |c|))
- |bfVar#96|))))
+ |bfVar#102|))))
(SETQ |c| (CDR |c|)))))
(COND
((NULL |a|) NIL)
@@ -2886,17 +1780,17 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
((EQCAR |f| 'PROGN)
(COND
((CDR |x|)
- (LET ((|bfVar#98| NIL) (|bfVar#97| (CDR |f|))
+ (LET ((|bfVar#104| NIL) (|bfVar#103| (CDR |f|))
(|i| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#97|)
- (PROGN (SETQ |i| (CAR |bfVar#97|)) NIL))
- (RETURN (NREVERSE |bfVar#98|)))
+ ((OR (ATOM |bfVar#103|)
+ (PROGN (SETQ |i| (CAR |bfVar#103|)) NIL))
+ (RETURN (NREVERSE |bfVar#104|)))
('T
(AND (NULL (ATOM |i|))
- (SETQ |bfVar#98| (CONS |i| |bfVar#98|)))))
- (SETQ |bfVar#97| (CDR |bfVar#97|)))))
+ (SETQ |bfVar#104| (CONS |i| |bfVar#104|)))))
+ (SETQ |bfVar#103| (CDR |bfVar#103|)))))
(#0# (CDR |f|))))
(#0# (LIST |f|)))))))))
@@ -2909,11 +1803,11 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
(#0='T
(PROGN
(SETQ |transform|
- (LET ((|bfVar#100| NIL) (|bfVar#99| |l|) (|x| NIL))
+ (LET ((|bfVar#106| NIL) (|bfVar#105| |l|) (|x| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#99|)
- (PROGN (SETQ |x| (CAR |bfVar#99|)) NIL)
+ ((OR (ATOM |bfVar#105|)
+ (PROGN (SETQ |x| (CAR |bfVar#105|)) NIL)
(NOT (AND (CONSP |x|) (EQ (CAR |x|) 'COND)
(PROGN
(SETQ |ISTMP#1| (CDR |x|))
@@ -2948,11 +1842,11 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
(SETQ |b|
(CAR |ISTMP#5|))
'T))))))))))))))
- (RETURN (NREVERSE |bfVar#100|)))
+ (RETURN (NREVERSE |bfVar#106|)))
('T
- (SETQ |bfVar#100|
- (CONS (LIST |a| |b|) |bfVar#100|))))
- (SETQ |bfVar#99| (CDR |bfVar#99|)))))
+ (SETQ |bfVar#106|
+ (CONS (LIST |a| |b|) |bfVar#106|))))
+ (SETQ |bfVar#105| (CDR |bfVar#105|)))))
(SETQ |no| (LENGTH |transform|))
(SETQ |before| (|bfTake| |no| |l|))
(SETQ |aft| (|bfDrop| |no| |l|))
@@ -2985,12 +1879,12 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
(SETQ |defs| (CADR . #0=(|LETTMP#1|)))
(SETQ |nondefs| (CADDR . #0#))
(SETQ |a|
- (LET ((|bfVar#102| NIL) (|bfVar#101| |defs|) (|d| NIL))
+ (LET ((|bfVar#108| NIL) (|bfVar#107| |defs|) (|d| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#101|)
- (PROGN (SETQ |d| (CAR |bfVar#101|)) NIL))
- (RETURN (NREVERSE |bfVar#102|)))
+ ((OR (ATOM |bfVar#107|)
+ (PROGN (SETQ |d| (CAR |bfVar#107|)) NIL))
+ (RETURN (NREVERSE |bfVar#108|)))
('T
(AND (CONSP |d|)
(PROGN
@@ -3009,11 +1903,11 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
(PROGN
(SETQ |body| (CAR |ISTMP#3|))
'T)))))))
- (SETQ |bfVar#102|
+ (SETQ |bfVar#108|
(CONS (LIST |def| |op| |args|
(|bfSUBLIS| |opassoc| |body|))
- |bfVar#102|)))))
- (SETQ |bfVar#101| (CDR |bfVar#101|)))))
+ |bfVar#108|)))))
+ (SETQ |bfVar#107| (CDR |bfVar#107|)))))
(SETQ |$wheredefs| (APPEND |a| |$wheredefs|))
(|bfMKPROGN|
(|bfSUBLIS| |opassoc| (NCONC |nondefs| (LIST |expr|))))))))
@@ -3090,16 +1984,16 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
(PROG ()
(RETURN
(|bfTuple|
- (LET ((|bfVar#104| NIL) (|bfVar#103| |arglist|) (|i| NIL))
+ (LET ((|bfVar#110| NIL) (|bfVar#109| |arglist|) (|i| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#103|)
- (PROGN (SETQ |i| (CAR |bfVar#103|)) NIL))
- (RETURN (NREVERSE |bfVar#104|)))
+ ((OR (ATOM |bfVar#109|)
+ (PROGN (SETQ |i| (CAR |bfVar#109|)) NIL))
+ (RETURN (NREVERSE |bfVar#110|)))
('T
- (SETQ |bfVar#104|
- (CONS (|bfCreateDef| |i|) |bfVar#104|))))
- (SETQ |bfVar#103| (CDR |bfVar#103|))))))))
+ (SETQ |bfVar#110|
+ (CONS (|bfCreateDef| |i|) |bfVar#110|))))
+ (SETQ |bfVar#109| (CDR |bfVar#109|))))))))
(DEFUN |bfCreateDef| (|x|)
(PROG (|a| |f|)
@@ -3109,17 +2003,17 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
(LIST 'SETQ |f| (LIST 'LIST (LIST 'QUOTE |f|))))
('T
(SETQ |a|
- (LET ((|bfVar#106| NIL) (|bfVar#105| (CDR |x|))
+ (LET ((|bfVar#112| NIL) (|bfVar#111| (CDR |x|))
(|i| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#105|)
- (PROGN (SETQ |i| (CAR |bfVar#105|)) NIL))
- (RETURN (NREVERSE |bfVar#106|)))
+ ((OR (ATOM |bfVar#111|)
+ (PROGN (SETQ |i| (CAR |bfVar#111|)) NIL))
+ (RETURN (NREVERSE |bfVar#112|)))
('T
- (SETQ |bfVar#106|
- (CONS (|bfGenSymbol|) |bfVar#106|))))
- (SETQ |bfVar#105| (CDR |bfVar#105|)))))
+ (SETQ |bfVar#112|
+ (CONS (|bfGenSymbol|) |bfVar#112|))))
+ (SETQ |bfVar#111| (CDR |bfVar#111|)))))
(LIST 'DEFUN (CAR |x|) |a|
(LIST 'CONS (LIST 'QUOTE (CAR |x|)) (CONS 'LIST |a|))))))))
@@ -3140,22 +2034,22 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
(DEFUN |bfCaseItems| (|g| |x|)
(PROG (|j| |ISTMP#1| |i|)
(RETURN
- (LET ((|bfVar#109| NIL) (|bfVar#108| |x|) (|bfVar#107| NIL))
+ (LET ((|bfVar#115| NIL) (|bfVar#114| |x|) (|bfVar#113| NIL))
(LOOP
(COND
- ((OR (ATOM |bfVar#108|)
- (PROGN (SETQ |bfVar#107| (CAR |bfVar#108|)) NIL))
- (RETURN (NREVERSE |bfVar#109|)))
+ ((OR (ATOM |bfVar#114|)
+ (PROGN (SETQ |bfVar#113| (CAR |bfVar#114|)) NIL))
+ (RETURN (NREVERSE |bfVar#115|)))
('T
- (AND (CONSP |bfVar#107|)
+ (AND (CONSP |bfVar#113|)
(PROGN
- (SETQ |i| (CAR |bfVar#107|))
- (SETQ |ISTMP#1| (CDR |bfVar#107|))
+ (SETQ |i| (CAR |bfVar#113|))
+ (SETQ |ISTMP#1| (CDR |bfVar#113|))
(AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL)
(PROGN (SETQ |j| (CAR |ISTMP#1|)) 'T)))
- (SETQ |bfVar#109|
- (CONS (|bfCI| |g| |i| |j|) |bfVar#109|)))))
- (SETQ |bfVar#108| (CDR |bfVar#108|)))))))
+ (SETQ |bfVar#115|
+ (CONS (|bfCI| |g| |i| |j|) |bfVar#115|)))))
+ (SETQ |bfVar#114| (CDR |bfVar#114|)))))))
(DEFUN |bfCI| (|g| |x| |y|)
(PROG (|b| |a|)
@@ -3166,18 +2060,18 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
((NULL |a|) (LIST (CAR |x|) |y|))
('T
(SETQ |b|
- (LET ((|bfVar#111| NIL) (|bfVar#110| |a|) (|i| NIL)
+ (LET ((|bfVar#117| NIL) (|bfVar#116| |a|) (|i| NIL)
(|j| 0))
(LOOP
(COND
- ((OR (ATOM |bfVar#110|)
- (PROGN (SETQ |i| (CAR |bfVar#110|)) NIL))
- (RETURN (NREVERSE |bfVar#111|)))
+ ((OR (ATOM |bfVar#116|)
+ (PROGN (SETQ |i| (CAR |bfVar#116|)) NIL))
+ (RETURN (NREVERSE |bfVar#117|)))
('T
- (SETQ |bfVar#111|
+ (SETQ |bfVar#117|
(CONS (LIST |i| (|bfCARCDR| |j| |g|))
- |bfVar#111|))))
- (SETQ |bfVar#110| (CDR |bfVar#110|))
+ |bfVar#117|))))
+ (SETQ |bfVar#116| (CDR |bfVar#116|))
(SETQ |j| (+ |j| 1)))))
(LIST (CAR |x|) (LIST 'LET |b| |y|))))))))
@@ -3190,6 +2084,3 @@ bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1))
(RETURN
(COND ((EQL |n| 0) "") ('T (CONCAT "D" (|bfDs| (- |n| 1))))))))
-@
-
-\end{document}
diff --git a/src/boot/strap/includer.clisp b/src/boot/strap/includer.clisp
new file mode 100644
index 00000000..a2324315
--- /dev/null
+++ b/src/boot/strap/includer.clisp
@@ -0,0 +1,553 @@
+(EVAL-WHEN (:COMPILE-TOPLEVEL) (PROVIDE "boot-includer"))
+
+(IMPORT-MODULE "tokens")
+
+(IN-PACKAGE "BOOTTRAN")
+
+(DEFUN PNAME (|x|)
+ (PROG ()
+ (RETURN
+ (COND
+ ((SYMBOLP |x|) (SYMBOL-NAME |x|))
+ ((CHARACTERP |x|) (STRING |x|))
+ ('T NIL)))))
+
+(DEFUN |char| (|x|) (PROG () (RETURN (CHAR (PNAME |x|) 0))))
+
+(DEFUN EQCAR (|x| |y|)
+ (PROG () (RETURN (AND (CONSP |x|) (EQ (CAR |x|) |y|)))))
+
+(DEFUN STRINGIMAGE (|x|) (PROG () (RETURN (WRITE-TO-STRING |x|))))
+
+(DEFUN |shoeCLOSE| (|stream|) (PROG () (RETURN (CLOSE |stream|))))
+
+(DEFUN |shoeNotFound| (|fn|)
+ (PROG ()
+ (RETURN (PROGN (|coreError| (LIST |fn| " not found")) NIL))))
+
+(DEFUN |shoeReadLispString| (|s| |n|)
+ (PROG (|l|)
+ (RETURN
+ (PROGN
+ (SETQ |l| (LENGTH |s|))
+ (COND
+ ((NOT (< |n| |l|)) NIL)
+ ('T
+ (READ-FROM-STRING
+ (CONCAT '|(| (SUBSTRING |s| |n| (- |l| |n|)) '|)|))))))))
+
+(DEFUN |shoeReadLine| (|stream|)
+ (PROG () (RETURN (READ-LINE |stream| NIL NIL))))
+
+(DEFUN |shoeConsole| (|line|)
+ (PROG () (RETURN (WRITE-LINE |line| *TERMINAL-IO*))))
+
+(DEFUN |shoeSpaces| (|n|) (PROG () (RETURN (MAKE-FULL-CVEC |n| "."))))
+
+(DEFUN |SoftShoeError| (|posn| |key|)
+ (PROG ()
+ (RETURN
+ (PROGN
+ (|coreError| (LIST "in line " (STRINGIMAGE (|lineNo| |posn|))))
+ (|shoeConsole| (|lineString| |posn|))
+ (|shoeConsole|
+ (CONCAT (|shoeSpaces| (|lineCharacter| |posn|)) "|"))
+ (|shoeConsole| |key|)))))
+
+(DEFUN |bpSpecificErrorAtToken| (|tok| |key|)
+ (PROG (|a|)
+ (RETURN
+ (PROGN
+ (SETQ |a| (|shoeTokPosn| |tok|))
+ (|SoftShoeError| |a| |key|)))))
+
+(DEFUN |bpSpecificErrorHere| (|key|)
+ (PROG ()
+ (DECLARE (SPECIAL |$stok|))
+ (RETURN (|bpSpecificErrorAtToken| |$stok| |key|))))
+
+(DEFUN |bpGeneralErrorHere| ()
+ (PROG () (RETURN (|bpSpecificErrorHere| "syntax error"))))
+
+(DEFUN |bpIgnoredFromTo| (|pos1| |pos2|)
+ (PROG ()
+ (RETURN
+ (PROGN
+ (|shoeConsole|
+ (CONCAT "ignored from line "
+ (STRINGIMAGE (|lineNo| |pos1|))))
+ (|shoeConsole| (|lineString| |pos1|))
+ (|shoeConsole|
+ (CONCAT (|shoeSpaces| (|lineCharacter| |pos1|)) "|"))
+ (|shoeConsole|
+ (CONCAT "ignored through line "
+ (STRINGIMAGE (|lineNo| |pos2|))))
+ (|shoeConsole| (|lineString| |pos2|))
+ (|shoeConsole|
+ (CONCAT (|shoeSpaces| (|lineCharacter| |pos2|)) "|"))))))
+
+(DEFUN |lineNo| (|p|) (PROG () (RETURN (CDAAR |p|))))
+
+(DEFUN |lineString| (|p|) (PROG () (RETURN (CAAAR |p|))))
+
+(DEFUN |lineCharacter| (|p|) (PROG () (RETURN (CDR |p|))))
+
+(DEFUN |shoePackageStartsAt| (|lines| |sz| |name| |stream|)
+ (PROG (|a|)
+ (RETURN
+ (COND
+ ((|bStreamNull| |stream|) (LIST NIL (LIST '|nullstream|)))
+ ('T
+ (PROGN
+ (SETQ |a| (CAAR |stream|))
+ (COND
+ ((AND (NOT (< (LENGTH |a|) 8))
+ (EQUAL (SUBSTRING |a| 0 8) ")package"))
+ (|shoePackageStartsAt| (CONS (CAAR |stream|) |lines|)
+ |sz| |name| (CDR |stream|)))
+ ((< (LENGTH |a|) |sz|)
+ (|shoePackageStartsAt| |lines| |sz| |name|
+ (CDR |stream|)))
+ ((AND (EQUAL (SUBSTRING |a| 0 |sz|) |name|)
+ (< |sz| (LENGTH |a|))
+ (NULL (|shoeIdChar| (ELT |a| |sz|))))
+ (LIST |lines| |stream|))
+ ('T
+ (|shoePackageStartsAt| |lines| |sz| |name|
+ (CDR |stream|))))))))))
+
+(DEFUN |shoeFindLines| (|fn| |name| |a|)
+ (PROG (|b| |lines| |LETTMP#1|)
+ (RETURN
+ (COND
+ ((NULL |a|) (|shoeNotFound| |fn|) NIL)
+ (#0='T
+ (SETQ |LETTMP#1|
+ (|shoePackageStartsAt| NIL (LENGTH |name|) |name|
+ (|shoeInclude|
+ (|bAddLineNumber| (|bRgen| |a|) (|bIgen| 0)))))
+ (SETQ |lines| (CAR |LETTMP#1|)) (SETQ |b| (CADR |LETTMP#1|))
+ (SETQ |b| (|shoeTransform2| |b|))
+ (COND
+ ((|bStreamNull| |b|)
+ (|shoeConsole| (CONCAT |name| " not found in " |fn|)) NIL)
+ (#0#
+ (COND
+ ((NULL |lines|) (|shoeConsole| ")package not found")))
+ (APPEND (REVERSE |lines|) (CAR |b|)))))))))
+
+(DEFPARAMETER |$bStreamNil| (LIST '|nullstream|))
+
+(DEFUN |bStreamNull| (|x|)
+ (PROG (|st|)
+ (RETURN
+ (COND
+ ((OR (NULL |x|) (EQCAR |x| '|nullstream|)) T)
+ ('T
+ (PROGN
+ (LOOP
+ (COND
+ ((NOT (EQCAR |x| '|nonnullstream|)) (RETURN NIL))
+ ('T
+ (PROGN
+ (SETQ |st| (APPLY (CADR |x|) (CDDR |x|)))
+ (RPLACA |x| (CAR |st|))
+ (RPLACD |x| (CDR |st|))))))
+ (EQCAR |x| '|nullstream|)))))))
+
+(DEFUN |bMap| (|f| |x|)
+ (PROG () (RETURN (|bDelay| #'|bMap1| (LIST |f| |x|)))))
+
+(DEFUN |bMap1| (&REST |z|)
+ (PROG (|x| |f|)
+ (DECLARE (SPECIAL |$bStreamNil|))
+ (RETURN
+ (PROGN
+ (SETQ |f| (CAR |z|))
+ (SETQ |x| (CADR |z|))
+ (COND
+ ((|bStreamNull| |x|) |$bStreamNil|)
+ ('T (CONS (FUNCALL |f| (CAR |x|)) (|bMap| |f| (CDR |x|)))))))))
+
+(DEFUN |shoeFileMap| (|f| |fn|)
+ (PROG (|a|)
+ (DECLARE (SPECIAL |$bStreamNil|))
+ (RETURN
+ (PROGN
+ (SETQ |a| (|shoeInputFile| |fn|))
+ (COND
+ ((NULL |a|)
+ (PROGN
+ (|shoeConsole| (CONCAT |fn| " NOT FOUND"))
+ |$bStreamNil|))
+ ('T
+ (PROGN
+ (|shoeConsole| (CONCAT "READING " |fn|))
+ (|shoeInclude|
+ (|bAddLineNumber| (|bMap| |f| (|bRgen| |a|))
+ (|bIgen| 0))))))))))
+
+(DEFUN |bDelay| (|f| |x|)
+ (PROG () (RETURN (CONS '|nonnullstream| (CONS |f| |x|)))))
+
+(DEFUN |bAppend| (|x| |y|)
+ (PROG () (RETURN (|bDelay| #'|bAppend1| (LIST |x| |y|)))))
+
+(DEFUN |bAppend1| (&REST |z|)
+ (PROG ()
+ (RETURN
+ (COND
+ ((|bStreamNull| (CAR |z|))
+ (COND
+ ((|bStreamNull| (CADR |z|)) (LIST '|nullstream|))
+ (#0='T (CADR |z|))))
+ (#0# (CONS (CAAR |z|) (|bAppend| (CDAR |z|) (CADR |z|))))))))
+
+(DEFUN |bNext| (|f| |s|)
+ (PROG () (RETURN (|bDelay| #'|bNext1| (LIST |f| |s|)))))
+
+(DEFUN |bNext1| (|f| |s|)
+ (PROG (|h|)
+ (RETURN
+ (COND
+ ((|bStreamNull| |s|) (LIST '|nullstream|))
+ ('T
+ (PROGN
+ (SETQ |h| (APPLY |f| (LIST |s|)))
+ (|bAppend| (CAR |h|) (|bNext| |f| (CDR |h|)))))))))
+
+(DEFUN |bRgen| (|s|)
+ (PROG () (RETURN (|bDelay| #'|bRgen1| (LIST |s|)))))
+
+(DEFUN |bRgen1| (&REST |s|)
+ (PROG (|a|)
+ (RETURN
+ (PROGN
+ (SETQ |a| (|shoeReadLine| (CAR |s|)))
+ (COND
+ ((|shoePLACEP| |a|) (LIST '|nullstream|))
+ ('T (CONS |a| (|bRgen| (CAR |s|)))))))))
+
+(DEFUN |bIgen| (|n|)
+ (PROG () (RETURN (|bDelay| #'|bIgen1| (LIST |n|)))))
+
+(DEFUN |bIgen1| (&REST |n|)
+ (PROG ()
+ (RETURN
+ (PROGN (SETQ |n| (+ (CAR |n|) 1)) (CONS |n| (|bIgen| |n|))))))
+
+(DEFUN |bAddLineNumber| (|f1| |f2|)
+ (PROG () (RETURN (|bDelay| #'|bAddLineNumber1| (LIST |f1| |f2|)))))
+
+(DEFUN |bAddLineNumber1| (&REST |f|)
+ (PROG (|f2| |f1|)
+ (RETURN
+ (PROGN
+ (SETQ |f1| (CAR |f|))
+ (SETQ |f2| (CADR |f|))
+ (COND
+ ((|bStreamNull| |f1|) (LIST '|nullstream|))
+ ((|bStreamNull| |f2|) (LIST '|nullstream|))
+ ('T
+ (CONS (CONS (CAR |f1|) (CAR |f2|))
+ (|bAddLineNumber| (CDR |f1|) (CDR |f2|)))))))))
+
+(DEFUN |shoeFileInput| (|fn|)
+ (PROG () (RETURN (|shoeFileMap| #'IDENTITY |fn|))))
+
+(DEFUN |shoePrefixLisp| (|x|) (PROG () (RETURN (CONCAT ")lisp" |x|))))
+
+(DEFUN |shoeLispFileInput| (|fn|)
+ (PROG () (RETURN (|shoeFileMap| #'|shoePrefixLisp| |fn|))))
+
+(DEFUN |shoePrefixLine| (|x|) (PROG () (RETURN (CONCAT ")line" |x|))))
+
+(DEFUN |shoeLineFileInput| (|fn|)
+ (PROG () (RETURN (|shoeFileMap| #'|shoePrefixLine| |fn|))))
+
+(DEFUN |shoePrefix?| (|prefix| |whole|)
+ (PROG (|good|)
+ (RETURN
+ (COND
+ ((< (LENGTH |whole|) (LENGTH |prefix|)) NIL)
+ ('T
+ (PROGN
+ (SETQ |good| T)
+ (LET ((|bfVar#1| (- (LENGTH |prefix|) 1)) (|i| 0) (|j| 0))
+ (LOOP
+ (COND
+ ((OR (> |i| |bfVar#1|) (NOT |good|)) (RETURN NIL))
+ ('T
+ (SETQ |good|
+ (EQUAL (ELT |prefix| |i|) (ELT |whole| |j|)))))
+ (SETQ |i| (+ |i| 1))
+ (SETQ |j| (+ |j| 1))))
+ (COND
+ (|good| (SUBSTRING |whole| (LENGTH |prefix|) NIL))
+ ('T |good|))))))))
+
+(DEFUN |shoePlainLine?| (|s|)
+ (PROG ()
+ (RETURN
+ (COND
+ ((EQL (LENGTH |s|) 0) T)
+ ('T (NOT (EQUAL (ELT |s| 0) (|char| '|)|))))))))
+
+(DEFUN |shoeSay?| (|s|) (PROG () (RETURN (|shoePrefix?| ")say" |s|))))
+
+(DEFUN |shoeEval?| (|s|)
+ (PROG () (RETURN (|shoePrefix?| ")eval" |s|))))
+
+(DEFUN |shoeInclude?| (|s|)
+ (PROG () (RETURN (|shoePrefix?| ")include" |s|))))
+
+(DEFUN |shoeFin?| (|s|) (PROG () (RETURN (|shoePrefix?| ")fin" |s|))))
+
+(DEFUN |shoeIf?| (|s|) (PROG () (RETURN (|shoePrefix?| ")if" |s|))))
+
+(DEFUN |shoeEndIf?| (|s|)
+ (PROG () (RETURN (|shoePrefix?| ")endif" |s|))))
+
+(DEFUN |shoeElse?| (|s|)
+ (PROG () (RETURN (|shoePrefix?| ")else" |s|))))
+
+(DEFUN |shoeElseIf?| (|s|)
+ (PROG () (RETURN (|shoePrefix?| ")elseif" |s|))))
+
+(DEFUN |shoePackage?| (|s|)
+ (PROG () (RETURN (|shoePrefix?| ")package" |s|))))
+
+(DEFUN |shoeLisp?| (|s|)
+ (PROG () (RETURN (|shoePrefix?| ")lisp" |s|))))
+
+(DEFUN |shoeIncludeLisp?| (|s|)
+ (PROG () (RETURN (|shoePrefix?| ")includelisp" |s|))))
+
+(DEFUN |shoeLine?| (|s|)
+ (PROG () (RETURN (|shoePrefix?| ")line" |s|))))
+
+(DEFUN |shoeIncludeLines?| (|s|)
+ (PROG () (RETURN (|shoePrefix?| ")includelines" |s|))))
+
+(DEFUN |shoeIncludeFunction?| (|s|)
+ (PROG () (RETURN (|shoePrefix?| ")includefunction" |s|))))
+
+(DEFUN |shoeBiteOff| (|x|)
+ (PROG (|n1| |n|)
+ (RETURN
+ (PROGN
+ (SETQ |n| (STRPOSL " " |x| 0 T))
+ (COND
+ ((NULL |n|) NIL)
+ (#0='T
+ (PROGN
+ (SETQ |n1| (STRPOSL " " |x| |n| NIL))
+ (COND
+ ((NULL |n1|) (LIST (SUBSTRING |x| |n| NIL) ""))
+ (#0#
+ (LIST (SUBSTRING |x| |n| (- |n1| |n|))
+ (SUBSTRING |x| |n1| NIL)))))))))))
+
+(DEFUN |shoeFileName| (|x|)
+ (PROG (|c| |a|)
+ (RETURN
+ (PROGN
+ (SETQ |a| (|shoeBiteOff| |x|))
+ (COND
+ ((NULL |a|) "")
+ (#0='T
+ (PROGN
+ (SETQ |c| (|shoeBiteOff| (CADR |a|)))
+ (COND
+ ((NULL |c|) (CAR |a|))
+ (#0# (CONCAT (CAR |a|) "." (CAR |c|)))))))))))
+
+(DEFUN |shoeFnFileName| (|x|)
+ (PROG (|c| |a|)
+ (RETURN
+ (PROGN
+ (SETQ |a| (|shoeBiteOff| |x|))
+ (COND
+ ((NULL |a|) (LIST "" ""))
+ (#0='T
+ (PROGN
+ (SETQ |c| (|shoeFileName| (CADR |a|)))
+ (COND
+ ((NULL |c|) (LIST (CAR |a|) ""))
+ (#0# (LIST (CAR |a|) |c|))))))))))
+
+(DEFUN |shoeFunctionFileInput| (|bfVar#2|)
+ (PROG (|fn| |fun|)
+ (RETURN
+ (PROGN
+ (SETQ |fun| (CAR |bfVar#2|))
+ (SETQ |fn| (CADR |bfVar#2|))
+ (|shoeOpenInputFile| |a| |fn|
+ (|shoeInclude|
+ (|bAddLineNumber| (|shoeFindLines| |fn| |fun| |a|)
+ (|bIgen| 0))))))))
+
+(DEFUN |shoeInclude| (|s|)
+ (PROG () (RETURN (|bDelay| #'|shoeInclude1| (LIST |s|)))))
+
+(DEFUN |shoeInclude1| (|s|)
+ (PROG (|command| |string| |t| |h|)
+ (DECLARE (SPECIAL |$bStreamNil|))
+ (RETURN
+ (COND
+ ((|bStreamNull| |s|) |s|)
+ (#0='T
+ (PROGN
+ (SETQ |h| (CAR |s|))
+ (SETQ |t| (CDR |s|))
+ (SETQ |string| (CAR |h|))
+ (COND
+ ((SETQ |command| (|shoeFin?| |string|)) |$bStreamNil|)
+ ((SETQ |command| (|shoeIf?| |string|))
+ (|shoeThen| (LIST T) (LIST (STTOMC |command|)) |t|))
+ (#0#
+ (|bAppend| (|shoeSimpleLine| |h|) (|shoeInclude| |t|))))))))))
+
+(DEFUN |shoeSimpleLine| (|h|)
+ (PROG (|command| |string|)
+ (RETURN
+ (PROGN
+ (SETQ |string| (CAR |h|))
+ (COND
+ ((|shoePlainLine?| |string|) (LIST |h|))
+ ((SETQ |command| (|shoeLisp?| |string|)) (LIST |h|))
+ ((SETQ |command| (|shoeIncludeLisp?| |string|))
+ (|shoeLispFileInput| (|shoeFileName| |command|)))
+ ((SETQ |command| (|shoeIncludeFunction?| |string|))
+ (|shoeFunctionFileInput| (|shoeFnFileName| |command|)))
+ ((SETQ |command| (|shoeLine?| |string|)) (LIST |h|))
+ ((SETQ |command| (|shoeIncludeLines?| |string|))
+ (|shoeLineFileInput| (|shoeFileName| |command|)))
+ ((SETQ |command| (|shoeInclude?| |string|))
+ (|shoeFileInput| (|shoeFileName| |command|)))
+ ((SETQ |command| (|shoePackage?| |string|)) (LIST |h|))
+ ((SETQ |command| (|shoeSay?| |string|))
+ (PROGN (|shoeConsole| |command|) NIL))
+ ((SETQ |command| (|shoeEval?| |string|))
+ (PROGN (STTOMC |command|) NIL))
+ ('T (PROGN (|shoeLineSyntaxError| |h|) NIL)))))))
+
+(DEFUN |shoeThen| (|keep| |b| |s|)
+ (PROG () (RETURN (|bDelay| #'|shoeThen1| (LIST |keep| |b| |s|)))))
+
+(DEFUN |shoeThen1| (|keep| |b| |s|)
+ (PROG (|b1| |keep1| |command| |string| |t| |h|)
+ (RETURN
+ (COND
+ ((|bPremStreamNull| |s|) |s|)
+ (#0='T
+ (PROGN
+ (SETQ |h| (CAR |s|))
+ (SETQ |t| (CDR |s|))
+ (SETQ |string| (CAR |h|))
+ (COND
+ ((SETQ |command| (|shoeFin?| |string|))
+ (|bPremStreamNil| |h|))
+ (#0#
+ (PROGN
+ (SETQ |keep1| (CAR |keep|))
+ (SETQ |b1| (CAR |b|))
+ (COND
+ ((SETQ |command| (|shoeIf?| |string|))
+ (COND
+ ((AND |keep1| |b1|)
+ (|shoeThen| (CONS T |keep|)
+ (CONS (STTOMC |command|) |b|) |t|))
+ (#0#
+ (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|))))
+ ((SETQ |command| (|shoeElseIf?| |string|))
+ (COND
+ ((AND |keep1| (NULL |b1|))
+ (|shoeThen| (CONS T (CDR |keep|))
+ (CONS (STTOMC |command|) (CDR |b|)) |t|))
+ (#0#
+ (|shoeThen| (CONS NIL (CDR |keep|))
+ (CONS NIL (CDR |b|)) |t|))))
+ ((SETQ |command| (|shoeElse?| |string|))
+ (COND
+ ((AND |keep1| (NULL |b1|))
+ (|shoeElse| (CONS T (CDR |keep|))
+ (CONS T (CDR |b|)) |t|))
+ (#0#
+ (|shoeElse| (CONS NIL (CDR |keep|))
+ (CONS NIL (CDR |b|)) |t|))))
+ ((SETQ |command| (|shoeEndIf?| |string|))
+ (COND
+ ((NULL (CDR |b|)) (|shoeInclude| |t|))
+ (#0# (|shoeThen| (CDR |keep|) (CDR |b|) |t|))))
+ ((AND |keep1| |b1|)
+ (|bAppend| (|shoeSimpleLine| |h|)
+ (|shoeThen| |keep| |b| |t|)))
+ (#0# (|shoeThen| |keep| |b| |t|))))))))))))
+
+(DEFUN |shoeElse| (|keep| |b| |s|)
+ (PROG () (RETURN (|bDelay| #'|shoeElse1| (LIST |keep| |b| |s|)))))
+
+(DEFUN |shoeElse1| (|keep| |b| |s|)
+ (PROG (|keep1| |b1| |command| |string| |t| |h|)
+ (RETURN
+ (COND
+ ((|bPremStreamNull| |s|) |s|)
+ (#0='T
+ (PROGN
+ (SETQ |h| (CAR |s|))
+ (SETQ |t| (CDR |s|))
+ (SETQ |string| (CAR |h|))
+ (COND
+ ((SETQ |command| (|shoeFin?| |string|))
+ (|bPremStreamNil| |h|))
+ (#0#
+ (PROGN
+ (SETQ |b1| (CAR |b|))
+ (SETQ |keep1| (CAR |keep|))
+ (COND
+ ((SETQ |command| (|shoeIf?| |string|))
+ (COND
+ ((AND |keep1| |b1|)
+ (|shoeThen| (CONS T |keep|)
+ (CONS (STTOMC |command|) |b|) |t|))
+ (#0#
+ (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|))))
+ ((SETQ |command| (|shoeEndIf?| |string|))
+ (COND
+ ((NULL (CDR |b|)) (|shoeInclude| |t|))
+ (#0# (|shoeThen| (CDR |keep|) (CDR |b|) |t|))))
+ ((AND |keep1| |b1|)
+ (|bAppend| (|shoeSimpleLine| |h|)
+ (|shoeElse| |keep| |b| |t|)))
+ (#0# (|shoeElse| |keep| |b| |t|))))))))))))
+
+(DEFUN |shoeLineSyntaxError| (|h|)
+ (PROG ()
+ (RETURN
+ (PROGN
+ (|shoeConsole|
+ (CONCAT "INCLUSION SYNTAX ERROR IN LINE "
+ (STRINGIMAGE (CDR |h|))))
+ (|shoeConsole| (CAR |h|))
+ (|shoeConsole| "LINE IGNORED")))))
+
+(DEFUN |bPremStreamNil| (|h|)
+ (PROG ()
+ (DECLARE (SPECIAL |$bStreamNil|))
+ (RETURN
+ (PROGN
+ (|shoeConsole|
+ (CONCAT "UNEXPECTED )fin IN LINE " (STRINGIMAGE (CDR |h|))))
+ (|shoeConsole| (CAR |h|))
+ (|shoeConsole| "REST OF FILE IGNORED")
+ |$bStreamNil|))))
+
+(DEFUN |bPremStreamNull| (|s|)
+ (PROG ()
+ (RETURN
+ (COND
+ ((|bStreamNull| |s|)
+ (|shoeConsole| "FILE TERMINATED BEFORE )endif") T)
+ ('T NIL)))))
+
diff --git a/src/boot/parser.boot.pamphlet b/src/boot/strap/parser.clisp
index 2ff33d38..cfc9b0fa 100644
--- a/src/boot/parser.boot.pamphlet
+++ b/src/boot/strap/parser.clisp
@@ -1,1144 +1,3 @@
-\documentclass{article}
-\usepackage{axiom}
-\usepackage{fancyvrb}
-
-\CustomVerbatimEnvironment{Grammar}{Verbatim}%
- {frame=none,fontsize=\small,commandchars=\\\{\}}
-\newcommand{\production}[1]{{\rmfamily\itshape{#1}}}
-\newcommand{\Terminal}[1]{\ensuremath{\mathbf{#1}}}
-\newcommand{\Bar}{\ensuremath{\mid}}
-\newcommand{\Comment}[1]{-- \textrm{#1}}
-
-\title{\File{src/boot/parser.boot} Pamphlet}
-\author{The Axiom Team}
-
-\begin{document}
-\maketitle
-
-\begin{abstract}
- This file defines the Boot grammar and parser. The parser
- is hand-written based on \emph{parser combinators} technology.
-\end{abstract}
-
-\tableofcontents
-\eject
-
-\section{Introduction}
-\label{sec:intro}
-
-This file defines the grammar, and implements the parser for the
-Boot language. The parser is
-recursive descent and uses \emph{parser combinators} techniques.
-
-\section{The Parser}
-\label{sec:parser}
-
-
-\subsection{Names}
-\label{sec:parser:name}
-
-\begin{Grammar}
- \production{Name:}
- \Terminal{ID}
- \production{Name} :: \Terminal{ID}
-\end{Grammar}
-
-<<Name>>=
--- A fully qualified name could be interpreted as a left reduction
--- of an '::' infix operator. At the moment, we don't use
--- that general interpretation.
-
--- When this routine is called, a symbol is already pushed on the
--- stack. When this routine finished execution, we have either
--- reduced a '::' and a name, or nothing. In either case, a
--- symbol is present on the stack.
-bpQualifiedName() ==
- bpEqPeek "COLON-COLON" =>
- bpNext()
- EQCAR($stok, "ID") and bpPushId() and bpNext()
- and bpPush bfColonColon(bpPop2(), bpPop1())
- false
-
-bpName() ==
- EQCAR( $stok,"ID") =>
- bpPushId()
- bpNext()
- bpAnyNo function bpQualifiedName
- false
-@
-
-
-\subsection{Constants}
-\label{sec:parser:constant}
-
-\begin{Grammar}
- \production{Constant:}
- \Terminal{INTEGER}
- \Bar \Terminal{FLOAT}
- \Bar \Terminal{LISP}
- \Bar \Terminal{LISPEXPR}
- \Bar \Terminal{LINE}
- \Bar \Terminal{QUOTE} \production{S-Expression}
- \Bar \Terminal{STRING}
-\end{Grammar}
-
-<<Constant>>=
-bpConstTok() ==
- MEMQ(shoeTokType $stok, '(INTEGER FLOAT)) =>
- bpPush $ttok
- bpNext()
- EQCAR($stok,"LISP")=> bpPush bfReadLisp $ttok and bpNext()
- EQCAR($stok,"LISPEXP")=> bpPush $ttok and bpNext()
- EQCAR($stok,"LINE")=> bpPush ["+LINE", $ttok] and bpNext()
- bpEqPeek "QUOTE" =>
- bpNext()
- (bpSexp() or bpTrap()) and
- bpPush bfSymbol bpPop1()
- bpString()
-@
-
-\subsection{Wildchar}
-\label{sec:parser:dot}
-
-The dot character (\verb!.!) is used both as a selection operator and
-as wild character in patterns.
-\begin{Grammar}
- \production{Dot:}
- \Terminal{DOT}
-\end{Grammar}
-
-<<Dot>>=
-bpDot()== bpEqKey "DOT" and bpPush bfDot ()
-@
-
-
-\subsection{Prefix operators}
-\label{sec:parser:prefix-op}
-
-Boot has two prefix operators.
-\begin{Grammar}
- \production{PrefixOperator:} \textrm{one of}
- ^ #
-\end{Grammar}
-
-<<PrefixOperator>>=
-bpPrefixOperator()==
- EQCAR( $stok,"KEY") and
- GET($ttok,"SHOEPRE") and bpPushId() and bpNext()
-@
-
-\subsection{Infix operators}
-\label{sec:parser:infix-op}
-
-\begin{Grammar}
- \production{InfixOperator:} \textrm{one of}
- = * + is isnt and or / ** - < > <= >= ^=
-\end{Grammar}
-
-<<InfixOperator>>=
-bpInfixOperator()==
- EQCAR( $stok,"KEY") and
- GET($ttok,"SHOEINF") and bpPushId() and bpNext()
-@
-
-\section{License}
-
-<<license>>=
--- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
--- 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.
---
--- - Neither the name of The Numerical ALgorithms Group Ltd. nor the
--- names of its contributors may be used to endorse or promote products
--- derived from this software without specific prior written permission.
---
--- 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 OWNER
--- 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.
-
-@
-<<*>>=
-<<license>>
-
-module '"boot-parser"
-import '"includer"
-import '"scanner"
-import '"ast"
-
-)package "BOOTTRAN"
-
-
-++ true when the current function definition has its parameters
-++ written round parenthesis.
-$sawParenthesizedHead := false
-
-++ true if the current function definition has a return statement.
-$bodyHasReturn := false
-
-
-bpFirstToken()==
- $stok:=
- if null $inputStream
- then shoeTokConstruct("ERROR","NOMORE",shoeTokPosn $stok)
- else CAR $inputStream
- $ttok:=shoeTokPart $stok
- true
-
-bpFirstTok()==
- $stok:=
- if null $inputStream
- then shoeTokConstruct("ERROR","NOMORE",shoeTokPosn $stok)
- else CAR $inputStream
- $ttok:=shoeTokPart $stok
- $bpParenCount>0 and EQCAR($stok,"KEY") =>
- EQ($ttok,"SETTAB")=>
- $bpCount:=$bpCount+1
- bpNext()
- EQ($ttok,"BACKTAB")=>
- $bpCount:=$bpCount-1
- bpNext()
- EQ($ttok,"BACKSET")=>
- bpNext()
- true
- true
-
-bpNext() ==
- $inputStream := CDR($inputStream)
- bpFirstTok()
-
-bpNextToken() ==
- $inputStream := CDR($inputStream)
- bpFirstToken()
-
-bpState()== [$inputStream,$stack,$bpParenCount,$bpCount]
---cons($inputStream,$stack)
-
-bpRestore(x)==
- $inputStream:=CAR x
- bpFirstToken()
- $stack:=CADR x
- $bpParenCount:=CADDR x
- $bpCount:=CADDDR x
- true
-
-bpPush x==$stack:=CONS(x,$stack)
-
-bpPushId()==
- $stack:=CONS(bfReName $ttok,$stack)
-
-bpPop1()==
- a:=CAR $stack
- $stack:=CDR $stack
- a
-
-bpPop2()==
- a:=CADR $stack
- RPLACD($stack,CDDR $stack)
- a
-
-bpPop3()==
- a:=CADDR $stack
- RPLACD(CDR $stack,CDDDR $stack)
- a
-
-bpIndentParenthesized f==
- $bpCount:local:=0
- a:=$stok
- if bpEqPeek "OPAREN"
- then
- $bpParenCount:=$bpParenCount+1
- bpNext()
- if APPLY(f,nil) and bpFirstTok() and
- (bpEqPeek "CPAREN" or bpParenTrap(a))
- then
- $bpParenCount:=$bpParenCount-1
- bpNextToken()
- $bpCount=0 => true
- $inputStream:=append( bpAddTokens $bpCount,$inputStream)
- bpFirstToken()
- $bpParenCount=0 =>
- bpCancel()
- true
- true
- else if bpEqPeek "CPAREN"
- then
- bpPush bfTuple []
- $bpParenCount:=$bpParenCount-1
- bpNextToken()
- true
- else bpParenTrap(a)
- else false
-
-bpParenthesized f==
- a:=$stok
- if bpEqKey "OPAREN"
- then
- if APPLY(f,nil) and (bpEqKey "CPAREN" or bpParenTrap(a))
- then true
- else if bpEqKey "CPAREN"
- then
- bpPush bfTuple []
- true
- else bpParenTrap(a)
- else false
-
-bpBracket f==
- a:=$stok
- if bpEqKey "OBRACK"
- then
- if APPLY(f,nil) and (bpEqKey "CBRACK" or bpBrackTrap(a))
- then bpPush bfBracket bpPop1 ()
- else if bpEqKey "CBRACK"
- then bpPush []
- else bpBrackTrap(a)
- else false
-
-bpPileBracketed f==
- if bpEqKey "SETTAB"
- then if bpEqKey "BACKTAB"
- then true
- else if APPLY(f,nil) and
- (bpEqKey "BACKTAB" or bpPileTrap())
- then bpPush bfPile bpPop1()
- else false
- else false
-
-bpListof(f,str1,g)==
- if APPLY(f,nil)
- then
- if bpEqKey str1 and (APPLY(f,nil) or bpTrap())
- then
- a:=$stack
- $stack:=nil
- while bpEqKey str1 and (APPLY(f,nil) or bpTrap()) repeat 0
- $stack:=cons(NREVERSE $stack,a)
- bpPush FUNCALL(g, [bpPop3(),bpPop2(),:bpPop1()])
- else
- true
- else false
-
-
--- to do ,<backset>
-bpListofFun(f,h,g)==
- if APPLY(f,nil)
- then
- if APPLY(h,nil) and (APPLY(f,nil) or bpTrap())
- then
- a:=$stack
- $stack:=nil
- while APPLY(h,nil) and (APPLY(f,nil) or bpTrap()) repeat 0
- $stack:=cons(NREVERSE $stack,a)
- bpPush FUNCALL(g, bfListOf [bpPop3(),bpPop2(),:bpPop1()])
- else
- true
- else false
-
-bpList(f,str1,g)==
- if APPLY(f,nil)
- then
- if bpEqKey str1 and (APPLY(f,nil) or bpTrap())
- then
- a:=$stack
- $stack:=nil
- while bpEqKey str1 and (APPLY(f,nil) or bpTrap()) repeat 0
- $stack:=cons(NREVERSE $stack,a)
- bpPush FUNCALL(g, [bpPop3(),bpPop2(),:bpPop1()])
- else
- bpPush FUNCALL(g, [bpPop1()])
- else bpPush FUNCALL(g, [])
-
-bpOneOrMore f==
- APPLY(f,nil)=>
- a:=$stack
- $stack:=nil
- while APPLY(f,nil) repeat 0
- $stack:=cons(NREVERSE $stack,a)
- bpPush cons(bpPop2(),bpPop1())
- false
-
-
--- s must transform the head of the stack
-bpAnyNo s==
- while APPLY(s,nil) repeat 0
- true
-
-
--- AndOr(k,p,f)= k p
-bpAndOr(keyword,p,f)==
- bpEqKey keyword and (APPLY(p,nil) or bpTrap())
- and bpPush FUNCALL(f, bpPop1())
-
-bpConditional f==
- if bpEqKey "IF" and (bpWhere() or bpTrap()) and
- (bpEqKey "BACKSET" or true)
- then
- if bpEqKey "SETTAB"
- then if bpEqKey "THEN"
- then (APPLY(f,nil) or bpTrap()) and bpElse(f) and bpEqKey "BACKTAB"
- else bpMissing "THEN"
- else if bpEqKey "THEN"
- then (APPLY(f,nil) or bpTrap()) and bpElse(f)
- else bpMissing "then"
- else false
-
-bpElse(f)==
- a:=bpState()
- if bpBacksetElse()
- then (APPLY(f,nil) or bpTrap()) and
- bpPush bfIf(bpPop3(),bpPop2(),bpPop1())
- else
- bpRestore a
- bpPush bfIfThenOnly(bpPop2(),bpPop1())
-
-bpBacksetElse()==
- if bpEqKey "BACKSET"
- then bpEqKey "ELSE"
- else bpEqKey "ELSE"
-
-bpEqPeek s == EQCAR($stok,"KEY") and EQ(s,$ttok)
-
-bpEqKey s == EQCAR($stok,"KEY") and EQ(s,$ttok) and bpNext()
-bpEqKeyNextTok s == EQCAR($stok,"KEY") and EQ(s,$ttok) and
- bpNextToken()
-
-bpPileTrap() == bpMissing "BACKTAB"
-bpBrackTrap(x) == bpMissingMate("]",x)
-bpParenTrap(x) == bpMissingMate(")",x)
-
-bpMissingMate(close,open)==
- bpSpecificErrorAtToken(open, '"possibly missing mate")
- bpMissing close
-
-bpMissing s==
- bpSpecificErrorHere(CONCAT(PNAME s,'" possibly missing"))
- THROW("TRAPPOINT","TRAPPED")
-
-bpCompMissing s == bpEqKey s or bpMissing s
-
-bpTrap()==
- bpGeneralErrorHere()
- THROW("TRAPPOINT","TRAPPED")
-
-bpRecoverTrap()==
- bpFirstToken()
- pos1 := shoeTokPosn $stok
- bpMoveTo 0
- pos2 := shoeTokPosn $stok
- bpIgnoredFromTo(pos1, pos2)
- bpPush [['"pile syntax error"]]
-
-bpListAndRecover(f)==
- a:=$stack
- b:=nil
- $stack:=nil
- done:=false
- c:=$inputStream
- while not done repeat
--- $trapped:local:=false
- found:=CATCH("TRAPPOINT",APPLY(f,nil))
- if found="TRAPPED"
- then
- $inputStream:=c
- bpRecoverTrap()
- else if not found
- then
- $inputStream:=c
- bpGeneralErrorHere()
- bpRecoverTrap()
- if bpEqKey "BACKSET"
- then
- c:=$inputStream
- else if bpEqPeek "BACKTAB" or null $inputStream
- then
- done:=true
- else
- $inputStream:=c
- bpGeneralErrorHere()
- bpRecoverTrap()
- if bpEqPeek "BACKTAB" or null $inputStream
- then done:=true
- else
- bpNext()
- c:=$inputStream
- b:=cons(bpPop1(),b)
- $stack:=a
- bpPush NREVERSE b
-
-bpMoveTo n==
- null $inputStream => true
- bpEqPeek "BACKTAB" =>
- n=0 => true
- bpNextToken()
- $bpCount:=$bpCount-1
- bpMoveTo(n-1)
- bpEqPeek "BACKSET" =>
- n=0 => true
- bpNextToken()
- bpMoveTo n
- bpEqPeek "SETTAB" =>
- bpNextToken()
- bpMoveTo(n+1)
- bpEqPeek "OPAREN" =>
- bpNextToken()
- $bpParenCount:=$bpParenCount+1
- bpMoveTo n
- bpEqPeek "CPAREN" =>
- bpNextToken()
- $bpParenCount:=$bpParenCount-1
- bpMoveTo n
- bpNextToken()
- bpMoveTo n
-
-<<Name>>
-
-<<Constant>>
-
-++ Parse a module definitoin
-++ Module:
-++ MODULE QUOTE String
-bpModule() ==
- bpEqKey "MODULE" =>
- -- we really want to check that the next token is indeed
- -- a string. For the moment, we delay the type checking
- -- to the Lisp compiler/interpreter. That is likely to
- -- cause cryptic diagnostics. To be fixed.
- bpConstTok() and bpPush Module bpPop1()
- false
-
-++ Parse a module import, or a import declaration for a foreign entity.
-++ Import:
-++ IMPORT Name for Signature
-++ IMPORT QUOTE String
-bpImport() ==
- bpEqKey "IMPORT" =>
- (bpName() and (bpEqKey "FOR" or bpTrap()) and bpSignature()
- and bpPush ImportSignature(bpPop2(), bpPop1()))
- or
- -- we really want to check that the next token is indeed
- -- a string. For the moment, we delay the type checking
- -- to the Lisp compiler/interpreter. That is likely to
- -- cause cryptic diagnostics. To be fixed.
- (bpConstTok() and bpPush Import bpPop1())
- false
-
--- Parse a type alias defnition:
--- type-alias-definition:
--- identifier <=> logical-expression
-bpTypeAliasDefition() ==
- (bpName() or bpTrap()) and
- bpEqKey "TDEF" and bpLogical() and
- bpPush TypeAlias(bpPop2(), nil, bpPop1())
-
-++ Parse a signature declaration
-++ Signature:
-++ Name COLON Mapping
-bpSignature() ==
- bpName() and bpEqKey "COLON" and bpMapping()
- and bpPush Signature(bpPop2(), bpPop1())
-
-++ Parse a mapping expression
-++ Mapping:
-++ (Name | IdList) -> Name
-bpMapping() ==
- (bpName() or bpIdList()) and bpEqKey "ARROW" and bpName()
- and bpPush Mapping(bpPop1(), bpPop1())
-
-bpCancel()==
- a:=bpState()
- if bpEqKeyNextTok "SETTAB"
- then if bpCancel()
- then if bpEqKeyNextTok "BACKTAB"
- then true
- else
- bpRestore a
- false
- else
- if bpEqKeyNextTok "BACKTAB"
- then true
- else
- bpRestore a
- false
- else false
-bpAddTokens n==
- n=0 => nil
- n>0=> cons(shoeTokConstruct("KEY","SETTAB",shoeTokPosn $stok),bpAddTokens(n-1))
- cons(shoeTokConstruct("KEY","BACKTAB",shoeTokPosn $stok),bpAddTokens(n+1))
-
-bpExceptions()==
- bpEqPeek "DOT" or bpEqPeek "QUOTE" or
- bpEqPeek "OPAREN" or bpEqPeek "CPAREN" or
- bpEqPeek "SETTAB" or bpEqPeek "BACKTAB"
- or bpEqPeek "BACKSET"
-
-
-bpSexpKey()==
- EQCAR( $stok,"KEY") and not bpExceptions()=>
- a:=GET($ttok,"SHOEINF")
- null a=> bpPush $ttok and bpNext()
- bpPush a and bpNext()
- false
-
-bpAnyId()==
- bpEqKey "MINUS" and (EQCAR($stok,"INTEGER") or bpTrap()) and
- bpPush MINUS $ttok and bpNext() or
- bpSexpKey() or
- MEMQ(shoeTokType $stok, '(ID INTEGER STRING FLOAT))
- and bpPush $ttok and bpNext()
-
-bpSexp()==
- bpAnyId() or
- bpEqKey "QUOTE" and (bpSexp() or bpTrap())
- and bpPush bfSymbol bpPop1() or
- bpIndentParenthesized function bpSexp1
-
-bpSexp1()== bpFirstTok() and
- bpSexp() and
- (bpEqKey "DOT" and bpSexp() and bpPush CONS (bpPop2(),bpPop1())or
- bpSexp1() and bpPush CONS (bpPop2(),bpPop1())) or
- bpPush nil
-
-bpPrimary1() ==
- bpName() or
- bpDot() or
- bpConstTok() or
- bpConstruct() or
- bpCase() or
- bpStruct() or
- bpPDefinition() or
- bpBPileDefinition()
-
-bpPrimary()== bpFirstTok() and (bpPrimary1() or bpPrefixOperator())
-
-<<Dot>>
-
-<<PrefixOperator>>
-
-<<InfixOperator>>
-
-bpSelector()==
- bpEqKey "DOT" and (bpPrimary()
- and bpPush(bfElt(bpPop2(),bpPop1()))
- or bpPush bfSuffixDot bpPop1() )
-
-bpOperator()== bpPrimary() and bpAnyNo function bpSelector
-
-bpApplication()==
- bpPrimary() and bpAnyNo function bpSelector and
- (bpApplication() and
- bpPush(bfApplication(bpPop2(),bpPop1())) or true)
-
-bpTagged()==
- bpApplication() and
- (bpEqKey "COLON" and (bpApplication() or bpTrap()) and
- bpPush bfTagged(bpPop2(),bpPop1()) or true)
-
-bpExpt()== bpRightAssoc('(POWER),function bpTagged)
-
-bpInfKey s==
- EQCAR( $stok,"KEY") and
- MEMBER($ttok,s) and bpPushId() and bpNext()
-
-bpInfGeneric s== bpInfKey s and (bpEqKey "BACKSET" or true)
-
-bpRightAssoc(o,p)==
- a:=bpState()
- if APPLY(p,nil)
- then
- while bpInfGeneric o and (bpRightAssoc(o,p) or bpTrap()) repeat
- bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1())
- true
- else
- bpRestore a
- false
-
-bpLeftAssoc(operations,parser)==
- if APPLY(parser,nil)
- then
- while bpInfGeneric(operations) and
- (APPLY(parser,nil) or bpTrap())
- repeat
- bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1())
- true
- else false
-
-bpString()==
- EQ(shoeTokType $stok,"STRING") and
- bpPush(["QUOTE",INTERN $ttok]) and bpNext()
-
-bpThetaName() ==
- if EQCAR( $stok,"ID") and GET($ttok,"SHOETHETA")
- then
- bpPushId()
- bpNext()
- else false
-
-bpReduceOperator()==
- bpInfixOperator() or bpString()
- or bpThetaName()
-
-bpReduce()==
- a:=bpState()
- if bpReduceOperator() and bpEqKey "SLASH"
- then
- bpEqPeek "OBRACK" => (bpDConstruct() or bpTrap()) and
- bpPush bfReduceCollect(bpPop2(),bpPop1())
- (bpApplication() or bpTrap()) and
- bpPush bfReduce(bpPop2(),bpPop1())
- else
- bpRestore a
- false
-
-bpTimes()==
- bpReduce() or bpLeftAssoc('(TIMES SLASH),function bpExpt)
-
-bpMinus()==
- bpInfGeneric '(MINUS) and (bpTimes() or bpTrap())
- and bpPush(bfApplication(bpPop2(),bpPop1()))
- or bpTimes()
-
-bpArith()==bpLeftAssoc('(PLUS MINUS),function bpMinus)
-
-bpIs()==
- bpArith() and (bpInfKey '(IS ISNT) and (bpPattern() or bpTrap())
- and bpPush bfISApplication(bpPop2(),bpPop2(),bpPop1())
- or true)
-
-bpBracketConstruct(f)==
- bpBracket f and bpPush bfConstruct bpPop1 ()
-
-bpCompare()==
- bpIs() and (bpInfKey '(SHOEEQ SHOENE LT LE GT GE IN)
- and (bpIs() or bpTrap())
- and bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1())
- or true)
-
-bpAnd()== bpLeftAssoc('(AND),function bpCompare)
-
-
-++ Note the fact that a return statement is used in the body
-++ of current function definition.
-bpNoteReturnStmt() ==
- $bodyHasReturn := true
- true
-
-bpReturn()==
- (bpEqKey "RETURN" and bpNoteReturnStmt() and
- (bpAnd() or bpTrap()) and
- bpPush bfReturnNoName bpPop1()) or bpAnd()
-
-
-bpLogical()== bpLeftAssoc('(OR),function bpReturn)
-
-bpExpression()==
- bpEqKey "COLON" and (bpLogical() and
- bpPush bfApplication ("COLON",bpPop1())
- or bpTrap()) or bpLogical()
-
-bpStatement()==
- bpConditional function bpWhere or bpLoop() or bpExpression()
-
-bpLoop()==
- bpIterators() and
- (bpCompMissing "REPEAT" and
- (bpWhere() or bpTrap()) and
- bpPush bfLp(bpPop2(),bpPop1()))
- or
- bpEqKey "REPEAT" and (bpLogical() or bpTrap()) and
- bpPush bfLoop1 bpPop1 ()
-
-bpSuchThat()==bpAndOr("BAR",function bpWhere,function bfSuchthat)
-
-bpWhile()==bpAndOr ("WHILE",function bpLogical,function bfWhile)
-
-bpUntil()==bpAndOr ("UNTIL",function bpLogical,function bfUntil)
-
-bpForIn()==
- bpEqKey "FOR" and (bpVariable() or bpTrap()) and (bpCompMissing "IN")
- and ((bpSeg() or bpTrap()) and
- (bpEqKey "BY" and (bpArith() or bpTrap()) and
- bpPush bfForInBy(bpPop3(),bpPop2(),bpPop1())) or
- bpPush bfForin(bpPop2(),bpPop1()))
-
-bpSeg()==
- bpArith() and
- (bpEqKey "SEG" and
- (bpArith() and bpPush(bfSegment2(bpPop2(),bpPop1()))
- or bpPush(bfSegment1(bpPop1()))) or true)
-
-bpIterator()==
- bpForIn() or bpSuchThat() or bpWhile() or bpUntil()
-
-bpIteratorList()==bpOneOrMore function bpIterator
- and bpPush bfIterators bpPop1 ()
-
-bpCrossBackSet()== bpEqKey "CROSS" and (bpEqKey "BACKSET" or true)
-
-bpIterators()==
- bpListofFun(function bpIteratorList,
- function bpCrossBackSet,function bfCross)
-
-bpAssign()==
- a:=bpState()
- if bpStatement()
- then
- if bpEqPeek "BEC"
- then
- bpRestore a
- bpAssignment() or bpTrap()
- else true
- else
- bpRestore a
- false
-
-bpAssignment()==
- bpAssignVariable() and
- bpEqKey "BEC" and
- (bpAssign() or bpTrap()) and
- bpPush bfAssign (bpPop2(),bpPop1())
-
--- should only be allowed in sequences
-bpExit()==
- bpAssign() and (bpEqKey "EXIT" and
- ((bpWhere() or bpTrap()) and
- bpPush bfExit (bpPop2(),bpPop1()))
- or true)
-
-++ returns true if the next token introduces a definition.
-bpBeginDefinition() ==
- bpEqPeek "DEF" or
- $sawParenthesizedHead and bpEqPeek "COLON"
-
-bpDefinition()==
- a:=bpState()
- bpExit() =>
- bpBeginDefinition() =>
- bpRestore a
- bpDef()
- bpEqPeek "TDEF" =>
- bpRestore a
- bpTypeAliasDefition()
- bpEqPeek "MDEF" =>
- bpRestore a
- bpMdef()
- true
- bpRestore a
- false
-
-bpStoreName()==
- $op := car $stack
- $wheredefs := nil
- $typings := nil
- $returnType := true -- assume we may return anything
- $bodyHasReturn := false
- true
-
-bpReturnType() ==
- -- a return type is acceptable for a function definition only
- -- if its parameters are written in round parenthesis.
- -- In particular, we reject the situation `foo x:Integer == ...'
- $sawParenthesizedHead and bpEqKey "COLON" =>
- bpApplication() or bpTrap()
- $returnType := bpPop1()
- true
- true
-
-bpDef() ==
- bpName() and bpStoreName() and
- bpDefTail() and bpPush bfCompDef bpPop1 ()
-
-bpDDef() == bpName() and bpDefTail()
-
-++ Parse the remaining of a simple definition.
-bpSimpleDefinitionTail() ==
- bpEqKey "DEF" and
- (bpWhere() or bpTrap())
- and bpPush ConstantDefinition(bpPop2(), bpPop1())
-
-++ Parse the remaining of a compound definition.
-bpCompoundDefinitionTail() ==
- bpVariable() and bpReturnType() and
- bpEqKey "DEF" and (bpWhere() or bpTrap())
- and bpPush bfDefinition(bpPop3(),bpPop2(),bpPop1())
-
-
-++ Parse the remainding of a definition. When we reach this point
-++ we know we must parse a definition and we have already parsed
-++ the name of the main operator in the definition.
-bpDefTail() ==
- bpSimpleDefinitionTail()
- or bpCompoundDefinitionTail()
-
-
-bpMDefTail()==
- -- bpEqKey "MDEF" and
- -- (bpWhere() or bpTrap())
- -- and bpPush bfMDefinition1(bpPop2(),bpPop1())
- -- or
- (bpVariable() or bpTrap()) and
- bpEqKey "MDEF" and (bpWhere() or bpTrap())
- and bpPush bfMDefinition(bpPop3(),bpPop2(),bpPop1())
-
-bpMdef()== bpName() and bpStoreName() and bpMDefTail()
-
-bpWhere()==
- bpDefinition() and
- (bpEqKey "WHERE" and (bpDefinitionItem() or bpTrap())
- and bpPush bfWhere(bpPop1(),bpPop1()) or true)
-
-bpDefinitionItem()==
- a:=bpState()
- if bpDDef()
- then true
- else
- bpRestore a
- if bpBDefinitionPileItems()
- then true
- else
- bpRestore a
- if bpPDefinitionItems()
- then true
- else
- bpRestore a
- bpWhere()
-
-bpDefinitionPileItems()==
- bpListAndRecover function bpDefinitionItem
- and bpPush bfDefSequence bpPop1()
-
-bpBDefinitionPileItems()== bpPileBracketed function bpDefinitionPileItems
-
-bpSemiColonDefinition()==bpSemiListing
- (function bpDefinitionItem,function bfDefSequence)
-
-bpPDefinitionItems()==bpParenthesized function bpSemiColonDefinition
-
-bpComma()==
- bpModule() or bpImport() or
- bpTuple function bpWhere
-
-bpTuple(p)==bpListofFun(p,function bpCommaBackSet,function bfTuple)
-
-bpCommaBackSet()== bpEqKey "COMMA" and (bpEqKey "BACKSET" or true)
-
-bpSemiColon()==bpSemiListing (function bpComma,function bfSequence)
-
-bpSemiListing(p,f)==bpListofFun(p,function bpSemiBackSet,f)
-
-bpSemiBackSet()== bpEqKey "SEMICOLON" and (bpEqKey "BACKSET" or true)
-
-bpPDefinition()== bpIndentParenthesized function bpSemiColon
-
-bpPileItems()==
- bpListAndRecover function bpSemiColon and bpPush bfSequence bpPop1()
-
-bpBPileDefinition()== bpPileBracketed function bpPileItems
-
-bpIteratorTail()==
- (bpEqKey "REPEAT" or true) and bpIterators()
-
---bpExpression()== bpLogical()
-
-bpConstruct()==bpBracket function bpConstruction
-
-bpConstruction()==
- bpComma() and
- (bpIteratorTail() and
- bpPush bfCollect (bpPop2(),bpPop1()) or
- bpPush bfTupleConstruct bpPop1())
-
-bpDConstruct()==bpBracket function bpDConstruction
-
-bpDConstruction()==
- bpComma() and
- (bpIteratorTail() and
- bpPush bfDCollect (bpPop2(),bpPop1()) or
- bpPush bfDTuple bpPop1())
-
-
-
---PATTERN
-
---bpNameOrDot() == bpName() or bpDot() or bpEqual()
-
-bpPattern()== bpBracketConstruct function bpPatternL
- or bpName() or bpConstTok()
-
-bpEqual()==
- bpEqKey "SHOEEQ" and (bpApplication() or bpConstTok() or
- bpTrap()) and bpPush bfEqual bpPop1()
-
-bpRegularPatternItem() ==
- bpEqual() or
- bpConstTok() or bpDot() or
- bpName() and
- ((bpEqKey "BEC" and (bpPattern() or bpTrap())
- and bpPush bfAssign(bpPop2(),bpPop1())) or true)
- or bpBracketConstruct function bpPatternL
-
-bpRegularPatternItemL()==
- bpRegularPatternItem() and bpPush [bpPop1()]
-
-bpRegularList()==
- bpListof(function bpRegularPatternItemL,"COMMA",function bfAppend)
-
-bpPatternColon()==
- bpEqKey "COLON" and (bpRegularPatternItem() or bpTrap())
- and bpPush [bfColon bpPop1()]
-
-
--- only one colon
-bpPatternL() == bpPatternList() and bpPush bfTuple bpPop1()
-
-bpPatternList()==
- if bpRegularPatternItemL()
- then
- while (bpEqKey "COMMA" and (bpRegularPatternItemL() or
- (bpPatternTail()
- and bpPush append(bpPop2(),bpPop1())
- or bpTrap();false) )) repeat
- bpPush append(bpPop2(),bpPop1())
- true
- else bpPatternTail()
-
-bpPatternTail()==
- bpPatternColon() and
- (bpEqKey "COMMA" and (bpRegularList() or bpTrap())
- and bpPush append (bpPop2(),bpPop1()) or true)
-
--- BOUND VARIABLE
-bpRegularBVItem() ==
- bpBVString() or
- bpConstTok() or
- (bpName() and
- (bpEqKey "COLON" and (bpApplication() or bpTrap())
- and bpPush bfTagged(bpPop2(), bpPop1()) or
- bpEqKey "BEC" and (bpPattern() or bpTrap())
- and bpPush bfAssign(bpPop2(),bpPop1()) or
- (bpEqKey "IS" and (bpPattern() or bpTrap())
- and bpPush bfAssign(bpPop2(),bpPop1())) or true))
- or bpBracketConstruct function bpPatternL
-
-bpBVString()==
- EQ(shoeTokType $stok,"STRING") and
- bpPush(["BVQUOTE",INTERN $ttok]) and bpNext()
-
-bpRegularBVItemL() ==
- bpRegularBVItem() and bpPush [bpPop1()]
-
-bpColonName()==
- bpEqKey "COLON" and (bpName() or bpBVString() or bpTrap())
-
-
--- at most one colon at end
-bpBoundVariablelist()==
- if bpRegularBVItemL()
- then
- while (bpEqKey "COMMA" and (bpRegularBVItemL() or
- (bpColonName()
- and bpPush bfColonAppend(bpPop2(),bpPop1())
- or bpTrap();false) )) repeat
- bpPush append(bpPop2(),bpPop1())
- true
- else bpColonName() and bpPush bfColonAppend(nil,bpPop1())
-
-
-++ Mark the start of parameter list enclosed in round parenthesis
-bpBeginParameterList() ==
- $sawParenthesizedHead := false
- true
-
-++ Mark the end of parameter list enclosed in round parenthesis
-bpEndParameterList() ==
- $sawParenthesizedHead := true
-
-bpVariable()==
- bpBeginParameterList() and
- bpParenthesized function bpBoundVariablelist and
- bpPush bfTupleIf bpPop1() and bpEndParameterList()
- or bpBracketConstruct function bpPatternL
- or bpName() or bpConstTok()
-
-bpAssignVariable()==
- bpBracketConstruct function bpPatternL or bpAssignLHS()
-
-bpAssignLHS()==
- bpName() and (bpEqKey "COLON" and (bpApplication() or bpTrap())
- and bpPush bfLocal(bpPop2(),bpPop1())
- or bpEqKey "DOT" and bpList(function bpPrimary,"DOT",
- function bfListOf)
- and bpChecknull() and
- bpPush bfTuple(cons(bpPop2(),bpPop1()))
- or true)
-bpChecknull()==
- a:=bpPop1()
- if null a
- then bpTrap()
- else bpPush a
-
-bpStruct()==
- bpEqKey "STRUCTURE" and
- (bpName() or bpTrap()) and
- (bpEqKey "DEF" or bpTrap()) and
- bpTypeList() and bpPush bfStruct(bpPop2(),bpPop1())
-
-bpTypeList() == bpPileBracketed function bpTypeItemList
- or bpTerm() and bpPush [bpPop1()]
-
-bpTypeItemList() == bpListAndRecover function bpTerm
-
-bpTerm() ==
- (bpName() or bpTrap()) and
- ((bpParenthesized function bpIdList and
- bpPush bfNameArgs (bpPop2(),bpPop1()))
- or bpName() and bpPush bfNameArgs(bpPop2(),bpPop1()))
- or bpPush(bfNameOnly bpPop1())
-
-bpIdList()== bpTuple function bpName
-
-bpCase()==
- bpEqKey "CASE" and
- (bpWhere() or bpTrap()) and
- (bpEqKey "OF" or bpMissing "OF") and
- bpPiledCaseItems()
-
-bpPiledCaseItems()==
- bpPileBracketed function bpCaseItemList and
- bpPush bfCase(bpPop2(),bpPop1())
-bpCaseItemList()==
- bpListAndRecover function bpCaseItem
-
-bpCaseItem()==
- (bpTerm() or bpTrap()) and
- (bpEqKey "EXIT" or bpTrap()) and
- (bpWhere() or bpTrap()) and
- bpPush bfCaseItem (bpPop2(),bpPop1())
-
-@
-
-
-\section{The Common Lisp translation}
-\label{sec:cl-translation}
-
-<<parser.clisp>>=
(EVAL-WHEN (:COMPILE-TOPLEVEL) (PROVIDE "boot-parser"))
(IMPORT-MODULE "includer")
@@ -1655,7 +514,10 @@ bpCaseItem()==
(RETURN
(COND
((|bpEqKey| 'IMPORT)
- (AND (|bpConstTok|) (|bpPush| (|Import| (|bpPop1|)))))
+ (OR (AND (|bpName|) (OR (|bpEqKey| 'FOR) (|bpTrap|))
+ (|bpSignature|)
+ (|bpPush| (|ImportSignature| (|bpPop2|) (|bpPop1|))))
+ (AND (|bpConstTok|) (|bpPush| (|Import| (|bpPop1|))))))
('T NIL)))))
(DEFUN |bpTypeAliasDefition| ()
@@ -1664,6 +526,18 @@ bpCaseItem()==
(AND (OR (|bpName|) (|bpTrap|)) (|bpEqKey| 'TDEF) (|bpLogical|)
(|bpPush| (|TypeAlias| (|bpPop2|) NIL (|bpPop1|)))))))
+(DEFUN |bpSignature| ()
+ (PROG ()
+ (RETURN
+ (AND (|bpName|) (|bpEqKey| 'COLON) (|bpMapping|)
+ (|bpPush| (|Signature| (|bpPop2|) (|bpPop1|)))))))
+
+(DEFUN |bpMapping| ()
+ (PROG ()
+ (RETURN
+ (AND (OR (|bpName|) (|bpIdList|)) (|bpEqKey| 'ARROW) (|bpName|)
+ (|bpPush| (|Mapping| (|bpPop1|) (|bpPop1|)))))))
+
(DEFUN |bpCancel| ()
(PROG (|a|)
(RETURN
@@ -2455,6 +1329,3 @@ bpCaseItem()==
(OR (|bpWhere|) (|bpTrap|))
(|bpPush| (|bfCaseItem| (|bpPop2|) (|bpPop1|)))))))
-@
-
-\end{document}
diff --git a/src/boot/pile.boot.pamphlet b/src/boot/strap/pile.clisp
index eaad129f..caa56d3e 100644
--- a/src/boot/pile.boot.pamphlet
+++ b/src/boot/strap/pile.clisp
@@ -1,171 +1,3 @@
-\documentclass{article}
-\usepackage{axiom}
-
-\title{\File{src/boot/pile.boot} Pamphlet}
-\author{The Axiom Team}
-
-\begin{document}
-\maketitle
-
-\begin{abstract}
-\end{abstract}
-
-\eject
-\tableofcontents
-\eject
-
-\section{License}
-
-<<license>>=
--- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
--- 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.
---
--- - Neither the name of The Numerical ALgorithms Group Ltd. nor the
--- names of its contributors may be used to endorse or promote products
--- derived from this software without specific prior written permission.
---
--- 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 OWNER
--- 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.
-
-@
-<<*>>=
-<<license>>
-
-module '"boot-pile"
-import '"includer"
-import '"scanner"
-
-)package "BOOTTRAN"
-shoeFirstTokPosn t== shoeTokPosn CAAR t
-shoeLastTokPosn t== shoeTokPosn CADR t
-shoePileColumn t==CDR shoeTokPosn CAAR t
-
--- s is a token-dq-stream
-
-shoePileInsert (s)==
- if bStreamNull s
- then cons([],s)
- else
- toktype:=shoeTokType CAAAR s
- if toktype ="LISP" or toktype = "LINE"
- then cons([car s],cdr s)
- else
- a:=shoePileTree(-1,s)
- cons([a.2],a.3)
-
-shoePileTree(n,s)==
- if bStreamNull s
- then [false,n,[],s]
- else
- [h,t]:=[car s,cdr s]
- hh:=shoePileColumn h
- if hh > n
- then shoePileForests(h,hh,t)
- else [false,n,[],s]
-
-eqshoePileTree(n,s)==
- if bStreamNull s
- then [false,n,[],s]
- else
- [h,t]:=[car s,cdr s]
- hh:=shoePileColumn h
- if hh = n
- then shoePileForests(h,hh,t)
- else [false,n,[],s]
-
-shoePileForest(n,s)==
- [b,hh,h,t]:= shoePileTree(n,s)
- if b
- then
- [h1,t1]:=shoePileForest1(hh,t)
- [cons(h,h1),t1]
- else [[],s]
-
-shoePileForest1(n,s)==
- [b,n1,h,t]:= eqshoePileTree(n,s)
- if b
- then
- [h1,t1]:=shoePileForest1(n,t)
- [cons(h,h1),t1]
- else [[],s]
-
-shoePileForests(h,n,s)==
- [h1,t1]:=shoePileForest(n,s)
- if bStreamNull h1
- then [true,n,h,s]
- else shoePileForests(shoePileCtree(h,h1),n,t1)
-
-shoePileCtree(x,y)==dqAppend(x,shoePileCforest y)
-
--- only enshoePiles forests with >=2 trees
-
-shoePileCforest x==
- if null x
- then []
- else if null cdr x
- then car x
- else
- a:=car x
- b:=shoePileCoagulate(a,rest x)
- if null cdr b
- then car b
- else shoeEnPile shoeSeparatePiles b
-
-shoePileCoagulate(a,b)==
- if null b
- then [a]
- else
- c:=car b
- if EQ(shoeTokPart CAAR c,"THEN") or EQ(shoeTokPart CAAR c,"ELSE")
- then shoePileCoagulate (dqAppend(a,c),cdr b)
- else
- d:=CADR a
- e:=shoeTokPart d
- if EQCAR(d,"KEY") and
- (GET(e,"SHOEINF") or EQ(e,"COMMA") or EQ(e,"SEMICOLON"))
- then shoePileCoagulate(dqAppend(a,c),cdr b)
- else cons(a,shoePileCoagulate(c,rest b))
-
-shoeSeparatePiles x==
- if null x
- then []
- else if null cdr x
- then car x
- else
- a:=car x
- semicolon:=dqUnit
- shoeTokConstruct("KEY", "BACKSET",shoeLastTokPosn a)
- dqConcat [a,semicolon,shoeSeparatePiles cdr x]
-
-shoeEnPile x==
- dqConcat [dqUnit shoeTokConstruct("KEY","SETTAB",shoeFirstTokPosn x),
- x, _
- dqUnit shoeTokConstruct("KEY","BACKTAB",shoeLastTokPosn x)]
-
-@
-
-<<pile.clisp>>=
(EVAL-WHEN (:COMPILE-TOPLEVEL) (PROVIDE "boot-pile"))
(IMPORT-MODULE "includer")
@@ -320,6 +152,3 @@ shoeEnPile x==
(|shoeTokConstruct| 'KEY 'BACKTAB
(|shoeLastTokPosn| |x|))))))))
-@
-
-\end{document}
diff --git a/src/boot/scanner.boot.pamphlet b/src/boot/strap/scanner.clisp
index b6bc1175..50078c3d 100644
--- a/src/boot/scanner.boot.pamphlet
+++ b/src/boot/strap/scanner.clisp
@@ -1,537 +1,3 @@
-\documentclass{article}
-\usepackage{axiom}
-
-\title{\File{src/boot/scanner.boot} Pamphlet}
-\author{The Axiom Team}
-
-\begin{document}
-\maketitle
-\begin{abstract}
-\end{abstract}
-\eject
-\tableofcontents
-\eject
-
-\section{License}
-
-<<license>>=
--- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
--- 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.
---
--- - Neither the name of The Numerical ALgorithms Group Ltd. nor the
--- names of its contributors may be used to endorse or promote products
--- derived from this software without specific prior written permission.
---
--- 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 OWNER
--- 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.
-
-@
-
-<<*>>=
-<<license>>
-
-module '"boot-lexer"
-import '"tokens"
-import '"includer"
-
-)package "BOOTTRAN"
-
--- converts X to double-float.
-double x ==
- FLOAT(x, 1.0)
-
-dqUnit s==(a:=[s];CONS(a,a))
-
-dqAppend(x,y)==
- if null x
- then y
- else if null y
- then x
- else
- RPLACD (CDR x,CAR y)
- RPLACD (x, CDR y)
- x
-
-dqConcat ld==
- if null ld
- then nil
- else if null rest ld
- then first ld
- else dqAppend(first ld,dqConcat rest ld)
-
-dqToList s==if null s then nil else CAR s
-
-shoeConstructToken(ln,lp,b,n)==[b.0,b.1,:cons(lp,n)]
-shoeTokType x== CAR x
-shoeTokPart x== CADR x
-shoeTokPosn x== CDDR x
-shoeTokConstruct(x,y,z)==[x,y,:z]
-
-shoeNextLine(s)==
- if bStreamNull s
- then false
- else
- $linepos:=s
- $f:= CAR s
- $r:= CDR s
- $ln:=CAR $f
- $n:=STRPOSL('" ",$ln,0,true)
- $sz :=# $ln
- null $n => true
- QENUM($ln,$n)=shoeTAB =>
- a:=MAKE_-FULL_-CVEC (7-REM($n,8) ,'" ")
- $ln.$n:='" ".0
- $ln:=CONCAT(a,$ln)
- s1:=cons(cons($ln,CDR $f),$r)
- shoeNextLine s1
- true
-
-shoeLineToks(s)==
- $f: local:=nil
- $r:local :=nil
- $ln:local :=nil
- $n:local:=nil
- $sz:local := nil
- $floatok:local:=true
- $linepos:local:=s
- not shoeNextLine s => CONS(nil,nil)
- null $n => shoeLineToks $r
- fst:=QENUM($ln,0)
- EQL(fst,shoeCLOSEPAREN)=>
- command:=shoeLine? $ln=>
- dq:=dqUnit shoeConstructToken
- ($ln,$linepos,shoeLeafLine command,0)
- cons([dq],$r)
- command:=shoeLisp? $ln=> shoeLispToken($r,command)
- command:=shoePackage? $ln=>
- -- z:=car shoeBiteOff command
- a:=CONCAT('"(IN-PACKAGE ",command,'")")
- dq:=dqUnit shoeConstructToken
- ($ln,$linepos,shoeLeafLisp a,0)
- cons([dq],$r)
- shoeLineToks $r
- toks:=[]
- while $n<$sz repeat toks:=dqAppend(toks,shoeToken())
- null toks => shoeLineToks $r
- cons([toks],$r)
-
-shoeLispToken(s,string)==
- string:=
- # string=0 or EQL(QENUM(string,0),QENUM('";",0))=> '""
- string
- ln:=$ln
- linepos:=$linepos
- [r,:st]:=shoeAccumulateLines(s,string)
- dq:=dqUnit shoeConstructToken(ln,linepos,shoeLeafLisp st,0)
- cons([dq],r)
-
-shoeAccumulateLines(s,string)==
- not shoeNextLine s => CONS(s,string)
- null $n => shoeAccumulateLines($r,string)
- # $ln=0 => shoeAccumulateLines($r,string)
- fst:=QENUM($ln,0)
- EQL(fst,shoeCLOSEPAREN)=>
- command:=shoeLisp? $ln
- command and #command>0 =>
- EQL(QENUM(command,0),QENUM('";",0))=>
- shoeAccumulateLines($r,string)
- a:=STRPOS('";",command,0,nil)
- a=>
- shoeAccumulateLines($r,
- CONCAT(string,SUBSTRING(command,0,a-1)))
- shoeAccumulateLines($r,CONCAT(string,command))
- shoeAccumulateLines($r,string)
- CONS(s,string)
-
--- returns true if token t is closing `parenthesis'.
-shoeCloser t ==
- MEMQ(shoeKeyWord t, '(CPAREN CBRACK))
-
-shoeToken () ==
- ln:=$ln
- c:=QENUM($ln,$n)
- linepos:=$linepos
- n:=$n
- ch:=$ln.$n
- b:=
- shoeStartsComment() =>
- shoeComment()
- []
- shoeStartsNegComment() =>
- shoeNegComment()
- []
- c=shoeLispESCAPE =>
- shoeLispEscape()
- shoePunctuation c => shoePunct ()
- shoeStartsId ch => shoeWord (false)
- c=shoeSPACE =>
- shoeSpace ()
- []
- c = shoeSTRING_CHAR => shoeString ()
- shoeDigit ch => shoeNumber ()
- c=shoeESCAPE => shoeEscape()
- c=shoeTAB =>
- $n:=$n+1
- []
- shoeError ()
- null b => nil
- dqUnit shoeConstructToken(ln,linepos,b,n)
-
--- to pair badge and badgee
-shoeLeafId x== ["ID",INTERN x]
-
-shoeLeafKey x==["KEY",shoeKeyWord x]
-
-shoeLeafInteger x==["INTEGER",shoeIntValue x]
-
-shoeLeafFloat(a,w,e)==
- b:=shoeIntValue CONCAT(a,w)
- c:= double b * EXPT(double 10, e-#w)
- ["FLOAT",c]
-
-shoeLeafString x == ["STRING",x]
-
-shoeLeafLisp x == ["LISP",x]
-shoeLeafLispExp x == ["LISPEXP",x]
-
-shoeLeafLine x == ["LINE",x]
-
-shoeLeafComment x == ["COMMENT", x]
-
-shoeLeafNegComment x== ["NEGCOMMENT", x]
-
-shoeLeafError x == ["ERROR",x]
-
-shoeLeafSpaces x == ["SPACES",x]
-
-shoeLispEscape()==
- $n:=$n+1
- if $n>=$sz
- then
- SoftShoeError(cons($linepos,$n),'"lisp escape error")
- shoeLeafError ($ln.$n)
- else
- a:=shoeReadLispString($ln,$n)
- null a =>
- SoftShoeError(cons($linepos,$n),'"lisp escape error")
- shoeLeafError ($ln.$n)
- [exp,n]:=a
- null n =>
- $n:= $sz
- shoeLeafLispExp exp
- $n:=n
- shoeLeafLispExp exp
-shoeEscape()==
- $n:=$n+1
- a:=shoeEsc()
- if a then shoeWord true else nil
-
-shoeEsc()==
- if $n>=$sz
- then if shoeNextLine($r)
- then
- while null $n repeat shoeNextLine($r)
- shoeEsc()
- false
- else false
- else
- n1:=STRPOSL('" ",$ln,$n,true)
- if null n1
- then
- shoeNextLine($r)
- while null $n repeat shoeNextLine($r)
- shoeEsc()
- false
- else true
-
-shoeStartsComment()==
- if $n<$sz
- then
- if QENUM($ln,$n)=shoePLUSCOMMENT
- then
- www:=$n+1
- if www>=$sz
- then false
- else QENUM($ln,www) = shoePLUSCOMMENT
- else false
- else false
-
-shoeStartsNegComment()==
- if $n< $sz
- then
- if QENUM($ln,$n)=shoeMINUSCOMMENT
- then
- www:=$n+1
- if www>=$sz
- then false
- else QENUM($ln,www) = shoeMINUSCOMMENT
- else false
- else false
-
-shoeNegComment()==
- n:=$n
- $n:=$sz
- shoeLeafNegComment SUBSTRING($ln,n,nil)
-
-shoeComment()==
- n:=$n
- $n:=$sz
- shoeLeafComment SUBSTRING($ln,n,nil)
-
-shoePunct()==
- sss:=shoeMatch($ln,$n)
- $n:=$n+#sss
- shoeKeyTr sss
-
-shoeKeyTr w==
- if EQ(shoeKeyWord w,"DOT")
- then if $floatok
- then shoePossFloat(w)
- else shoeLeafKey w
- else
- $floatok:=not shoeCloser w
- shoeLeafKey w
-
-shoePossFloat (w)==
- if $n>=$sz or not shoeDigit $ln.$n
- then shoeLeafKey w
- else
- w:=shoeInteger()
- shoeExponent('"0",w)
-
-
-shoeSpace()==
- n:=$n
- $n:=STRPOSL('" ",$ln,$n,true)
- $floatok:=true
- if null $n
- then
- shoeLeafSpaces 0
- $n:= # $ln
- else shoeLeafSpaces ($n-n)
-
-shoeString()==
- $n:=$n+1
- $floatok:=false
- shoeLeafString shoeS ()
-
-shoeS()==
- if $n>=$sz
- then
- SoftShoeError(cons($linepos,$n),'"quote added")
- '""
- else
- n:=$n
- strsym :=STRPOS ('"_"",$ln,$n,nil) or $sz
- escsym:=STRPOS ('"__"
- ,$ln,$n,nil) or $sz
- mn:=MIN(strsym,escsym)
- if mn=$sz
- then
- $n:=$sz
- SoftShoeError(cons($linepos,$n),'"quote added")
- SUBSTRING($ln,n,nil)
- else if mn=strsym
- then
- $n:=mn+1
- SUBSTRING($ln,n,mn-n)
- else
- str:=SUBSTRING($ln,n,mn-n)
- $n:=mn+1
- a:=shoeEsc()
- b:=if a
- then
- str:=CONCAT(str,$ln.$n)
- $n:=$n+1
- shoeS()
- else shoeS()
- CONCAT(str,b)
-
-
-
-
-shoeIdEnd(line,n)==
- while n<#line and shoeIdChar line.n repeat n:=n+1
- n
-
-
-shoeDigit x== DIGIT_-CHAR_-P x
-
-shoeW(b)==
- n1:=$n
- $n:=$n+1
- l:=$sz
- endid:=shoeIdEnd($ln,$n)
- if endid=l or QENUM($ln,endid)^=shoeESCAPE
- then
- $n:=endid
- [b,SUBSTRING($ln,n1,endid-n1)]
- else
- str:=SUBSTRING($ln,n1,endid-n1)
- $n:=endid+1
- a:=shoeEsc()
- bb:=if a
- then shoeW(true)
- else [b,'""] -- escape finds space or newline
- [bb.0 or b,CONCAT(str,bb.1)]
-
-shoeWord(esp) ==
- aaa:=shoeW(false)
- w:=aaa.1
- $floatok:=false
- if esp or aaa.0
- then shoeLeafId w
- else if shoeKeyWordP w
- then
- $floatok:=true
- shoeLeafKey w
- else shoeLeafId w
-
-shoeInteger()==shoeInteger1(false)
-
-shoeInteger1(zro) ==
- n:=$n
- l:= $sz
- while $n<l and shoeDigit($ln.$n) repeat $n:=$n+1
- if $n=l or QENUM($ln,$n)^=shoeESCAPE
- then if n=$n and zro
- then '"0"
- else SUBSTRING($ln,n,$n-n)
- else
- str:=SUBSTRING($ln,n,$n-n)
- $n:=$n+1
- a:=shoeEsc()
- bb:=shoeInteger1(zro)
- CONCAT(str,bb)
-
-shoeIntValue(s) ==
- ns := #s
- ival := 0
- for i in 0..ns-1 repeat
- d := shoeOrdToNum ELT(s,i)
- ival := 10*ival + d
- ival
-
-shoeNumber() ==
- a := shoeInteger()
- if $n>=$sz
- then shoeLeafInteger a
- else
- if $floatok and QENUM($ln,$n)=shoeDOT
- then
- n:=$n
- $n:=$n+1
- if $n<$sz and QENUM($ln,$n)=shoeDOT
- then
- $n:=n
- shoeLeafInteger a
- else
- w:=shoeInteger1(true)
- shoeExponent(a,w)
- else shoeLeafInteger a
-
-shoeExponent(a,w)==
- if $n>=$sz
- then shoeLeafFloat(a,w,0)
- else
- n:=$n
- c:=QENUM($ln,$n)
- if c=shoeEXPONENT1 or c=shoeEXPONENT2
- then
- $n:=$n+1
- if $n>=$sz
- then
- $n:=n
- shoeLeafFloat(a,w,0)
- else if shoeDigit($ln.$n)
- then
- e:=shoeInteger()
- e:=shoeIntValue e
- shoeLeafFloat(a,w,e)
- else
- c1:=QENUM($ln,$n)
- if c1=shoePLUSCOMMENT or c1=shoeMINUSCOMMENT
- then
- $n:=$n+1
- if $n>=$sz
- then
- $n:=n
- shoeLeafFloat(a,w,0)
- else
- if shoeDigit($ln.$n)
- then
- e:=shoeInteger()
- e:=shoeIntValue e
- shoeLeafFloat(a,w,
- (if c1=shoeMINUSCOMMENT then MINUS e else e))
- else
- $n:=n
- shoeLeafFloat(a,w,0)
- else shoeLeafFloat(a,w,0)
-
-shoeError()==
- n:=$n
- $n:=$n+1
- SoftShoeError(cons($linepos,n),
- CONCAT( '"The character whose number is ",
- STRINGIMAGE QENUM($ln,n),'" is not a Boot character"))
- shoeLeafError ($ln.n)
-
-shoeOrdToNum x== DIGIT_-CHAR_-P x
-
-shoeKeyWord st == GETHASH(st,shoeKeyTable)
-
-shoeKeyWordP st == not null GETHASH(st,shoeKeyTable)
-
-shoeMatch(l,i)==shoeSubStringMatch(l,shoeDict,i)
-
-shoeSubStringMatch (l,d,i)==
- h:= QENUM(l, i)
- u:=ELT(d,h)
- ll:=SIZE l
- done:=false
- s1:='""
- for j in 0.. SIZE u - 1 while not done repeat
- s:=ELT(u,j)
- ls:=SIZE s
- done:=if ls+i > ll
- then false
- else
- eql:= true
- for k in 1..ls-1 while eql repeat
- eql:= EQL(QENUM(s,k),QENUM(l,k+i))
- if eql
- then
- s1:=s
- true
- else false
- s1
-
-shoePunctuation c== shoePun.c =1
-
-@
-<<scanner.clisp>>=
(EVAL-WHEN (:COMPILE-TOPLEVEL) (PROVIDE "boot-lexer"))
(IMPORT-MODULE "tokens")
@@ -1158,6 +624,3 @@ shoePunctuation c== shoePun.c =1
(DEFUN |shoePunctuation| (|c|)
(PROG () (RETURN (EQL (ELT |shoePun| |c|) 1))))
-@
-
-\end{document}
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
new file mode 100644
index 00000000..3ce6a7c8
--- /dev/null
+++ b/src/boot/strap/tokens.clisp
@@ -0,0 +1,352 @@
+(EVAL-WHEN (:COMPILE-TOPLEVEL) (PROVIDE "boot-tokens"))
+
+(IMPORT-MODULE "initial-env")
+
+(IN-PACKAGE "BOOTTRAN")
+
+(DEFPARAMETER |shoeKeyWords|
+ (LIST (LIST "and" 'AND) (LIST "by" 'BY) (LIST "case" 'CASE)
+ (LIST "cross" 'CROSS) (LIST "else" 'ELSE) (LIST "for" 'FOR)
+ (LIST "if" 'IF) (LIST "import" 'IMPORT) (LIST "in" 'IN)
+ (LIST "is" 'IS) (LIST "isnt" 'ISNT) (LIST "module" 'MODULE)
+ (LIST "of" 'OF) (LIST "or" 'OR) (LIST "repeat" 'REPEAT)
+ (LIST "return" 'RETURN) (LIST "structure" 'STRUCTURE)
+ (LIST "then" 'THEN) (LIST "until" 'UNTIL)
+ (LIST "where" 'WHERE) (LIST "while" 'WHILE) (LIST "." 'DOT)
+ (LIST ":" 'COLON) (LIST "::" 'COLON-COLON) (LIST "," 'COMMA)
+ (LIST ";" 'SEMICOLON) (LIST "*" 'TIMES) (LIST "**" 'POWER)
+ (LIST "/" 'SLASH) (LIST "+" 'PLUS) (LIST "-" 'MINUS)
+ (LIST "<" 'LT) (LIST ">" 'GT) (LIST "<=" 'LE) (LIST ">=" 'GE)
+ (LIST "=" 'SHOEEQ) (LIST "^" 'NOT) (LIST "^=" 'SHOENE)
+ (LIST ".." 'SEG) (LIST "#" 'LENGTH) (LIST "=>" 'EXIT)
+ (LIST "->" 'ARROW) (LIST ":=" 'BEC) (LIST "==" 'DEF)
+ (LIST "==>" 'MDEF) (LIST "<=>" 'TDEF) (LIST "(" 'OPAREN)
+ (LIST ")" 'CPAREN) (LIST "(|" 'OBRACK) (LIST "|)" 'CBRACK)
+ (LIST "[" 'OBRACK) (LIST "]" 'CBRACK) (LIST "suchthat" 'BAR)
+ (LIST "'" 'QUOTE) (LIST "|" 'BAR)))
+
+(DEFUN |shoeKeyTableCons| ()
+ (PROG (|KeyTable|)
+ (RETURN
+ (PROGN
+ (SETQ |KeyTable| (MAKE-HASHTABLE 'CVEC))
+ (LET ((|bfVar#1| |shoeKeyWords|) (|st| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#1|)
+ (PROGN (SETQ |st| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ ('T (HPUT |KeyTable| (CAR |st|) (CADR |st|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ |KeyTable|))))
+
+(DEFPARAMETER |shoeKeyTable| (|shoeKeyTableCons|))
+
+(DEFPARAMETER |shoeSPACE| (QENUM " " 0))
+
+(DEFPARAMETER |shoeESCAPE| (QENUM "_ " 0))
+
+(DEFPARAMETER |shoeLispESCAPE| (QENUM "! " 0))
+
+(DEFPARAMETER |shoeSTRINGCHAR| (QENUM "\" " 0))
+
+(DEFPARAMETER |shoePLUSCOMMENT| (QENUM "+ " 0))
+
+(DEFPARAMETER |shoeMINUSCOMMENT| (QENUM "- " 0))
+
+(DEFPARAMETER |shoeDOT| (QENUM ". " 0))
+
+(DEFPARAMETER |shoeEXPONENT1| (QENUM "E " 0))
+
+(DEFPARAMETER |shoeEXPONENT2| (QENUM "e " 0))
+
+(DEFPARAMETER |shoeCLOSEPAREN| (QENUM ") " 0))
+
+(DEFPARAMETER |shoeTAB| 9)
+
+(DEFUN |shoeInsert| (|s| |d|)
+ (PROG (|v| |k| |n| |u| |h| |l|)
+ (RETURN
+ (PROGN
+ (SETQ |l| (LENGTH |s|))
+ (SETQ |h| (QENUM |s| 0))
+ (SETQ |u| (ELT |d| |h|))
+ (SETQ |n| (LENGTH |u|))
+ (SETQ |k| 0)
+ (LOOP
+ (COND
+ ((< (LENGTH (ELT |u| |k|)) |l|) (RETURN NIL))
+ (#0='T (SETQ |k| (+ |k| 1)))))
+ (SETQ |v| (MAKE-VEC (+ |n| 1)))
+ (LET ((|bfVar#2| (- |k| 1)) (|i| 0))
+ (LOOP
+ (COND
+ ((> |i| |bfVar#2|) (RETURN NIL))
+ (#0# (VEC-SETELT |v| |i| (ELT |u| |i|))))
+ (SETQ |i| (+ |i| 1))))
+ (VEC-SETELT |v| |k| |s|)
+ (LET ((|bfVar#3| (- |n| 1)) (|i| |k|))
+ (LOOP
+ (COND
+ ((> |i| |bfVar#3|) (RETURN NIL))
+ (#0# (VEC-SETELT |v| (+ |i| 1) (ELT |u| |i|))))
+ (SETQ |i| (+ |i| 1))))
+ (VEC-SETELT |d| |h| |v|)
+ |s|))))
+
+(DEFUN |shoeDictCons| ()
+ (PROG (|d| |b| |a| |l|)
+ (RETURN
+ (PROGN
+ (SETQ |l| (HKEYS |shoeKeyTable|))
+ (SETQ |d|
+ (PROGN
+ (SETQ |a| (MAKE-VEC 256))
+ (SETQ |b| (MAKE-VEC 1))
+ (VEC-SETELT |b| 0 (MAKE-CVEC 0))
+ (LET ((|i| 0))
+ (LOOP
+ (COND
+ ((> |i| 255) (RETURN NIL))
+ (#0='T (VEC-SETELT |a| |i| |b|)))
+ (SETQ |i| (+ |i| 1))))
+ |a|))
+ (LET ((|bfVar#4| |l|) (|s| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#4|)
+ (PROGN (SETQ |s| (CAR |bfVar#4|)) NIL))
+ (RETURN NIL))
+ (#0# (|shoeInsert| |s| |d|)))
+ (SETQ |bfVar#4| (CDR |bfVar#4|))))
+ |d|))))
+
+(DEFPARAMETER |shoeDict| (|shoeDictCons|))
+
+(DEFUN |shoePunCons| ()
+ (PROG (|a| |listing|)
+ (RETURN
+ (PROGN
+ (SETQ |listing| (HKEYS |shoeKeyTable|))
+ (SETQ |a| (MAKE-BVEC 256))
+ (LET ((|i| 0))
+ (LOOP
+ (COND
+ ((> |i| 255) (RETURN NIL))
+ (#0='T (BVEC-SETELT |a| |i| 0)))
+ (SETQ |i| (+ |i| 1))))
+ (LET ((|bfVar#5| |listing|) (|k| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#5|)
+ (PROGN (SETQ |k| (CAR |bfVar#5|)) NIL))
+ (RETURN NIL))
+ (#0#
+ (COND
+ ((NULL (|shoeStartsId| (ELT |k| 0)))
+ (BVEC-SETELT |a| (QENUM |k| 0) 1)))))
+ (SETQ |bfVar#5| (CDR |bfVar#5|))))
+ |a|))))
+
+(DEFPARAMETER |shoePun| (|shoePunCons|))
+
+(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL)
+ (PROG ()
+ (RETURN
+ (LET ((|bfVar#6| (LIST 'NOT 'LENGTH)) (|i| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#6|)
+ (PROGN (SETQ |i| (CAR |bfVar#6|)) NIL))
+ (RETURN NIL))
+ ('T (SETF (GET |i| 'SHOEPRE) 'T)))
+ (SETQ |bfVar#6| (CDR |bfVar#6|)))))))
+
+(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL)
+ (PROG ()
+ (RETURN
+ (LET ((|bfVar#7|
+ (LIST (LIST 'SHOEEQ '=) (LIST 'TIMES '*)
+ (LIST 'PLUS '+) (LIST 'IS '|is|)
+ (LIST 'ISNT '|isnt|) (LIST 'AND '|and|)
+ (LIST 'OR '|or|) (LIST 'SLASH '/)
+ (LIST 'POWER '**) (LIST 'MINUS '-) (LIST 'LT '<)
+ (LIST 'GT '>) (LIST 'LE '<=) (LIST 'GE '>=)
+ (LIST 'SHOENE '^=)))
+ (|i| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#7|)
+ (PROGN (SETQ |i| (CAR |bfVar#7|)) NIL))
+ (RETURN NIL))
+ ('T (SETF (GET (CAR |i|) 'SHOEINF) (CADR |i|))))
+ (SETQ |bfVar#7| (CDR |bfVar#7|)))))))
+
+(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL)
+ (PROG ()
+ (RETURN
+ (LET ((|bfVar#8|
+ (LIST (LIST '+ 0) (LIST '|gcd| 0) (LIST '|lcm| 1)
+ (LIST 'STRCONC "") (LIST '|strconc| "")
+ (LIST 'MAX (- 999999)) (LIST 'MIN 999999)
+ (LIST '* 1) (LIST '|times| 1) (LIST 'CONS NIL)
+ (LIST 'APPEND NIL) (LIST '|append| NIL)
+ (LIST 'UNION NIL) (LIST 'UNIONQ NIL)
+ (LIST '|union| NIL) (LIST 'NCONC NIL)
+ (LIST '|and| 'T) (LIST '|or| NIL) (LIST 'AND 'T)
+ (LIST 'OR NIL)))
+ (|i| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#8|)
+ (PROGN (SETQ |i| (CAR |bfVar#8|)) NIL))
+ (RETURN NIL))
+ ('T (SETF (GET (CAR |i|) 'SHOETHETA) (CDR |i|))))
+ (SETQ |bfVar#8| (CDR |bfVar#8|)))))))
+
+(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL)
+ (PROG ()
+ (RETURN
+ (LET ((|bfVar#9|
+ (LIST (LIST '|and| 'AND) (LIST '|append| 'APPEND)
+ (LIST '|apply| 'APPLY) (LIST '|atom| 'ATOM)
+ (LIST '|car| 'CAR) (LIST '|cdr| 'CDR)
+ (LIST '|cons| 'CONS) (LIST '|copy| 'COPY)
+ (LIST '|croak| 'CROAK) (LIST '|drop| 'DROP)
+ (LIST '|exit| 'EXIT) (LIST '|false| 'NIL)
+ (LIST '|first| 'CAR) (LIST '|function| 'FUNCTION)
+ (LIST '|genvar| 'GENVAR) (LIST 'IN 'MEMBER)
+ (LIST '|is| 'IS) (LIST '|isnt| 'ISNT)
+ (LIST '|lastNode| 'LAST) (LIST 'LAST '|last|)
+ (LIST '|list| 'LIST) (LIST '|mkpf| 'MKPF)
+ (LIST '|nconc| 'NCONC) (LIST '|nil| NIL)
+ (LIST '|not| 'NULL) (LIST 'NOT 'NULL)
+ (LIST '|nreverse| 'NREVERSE) (LIST '|null| 'NULL)
+ (LIST '|or| 'OR) (LIST '|otherwise| 'T)
+ (LIST 'PAIRP 'CONSP)
+ (LIST '|removeDuplicates| 'REMDUP)
+ (LIST '|rest| 'CDR) (LIST '|reverse| 'REVERSE)
+ (LIST '|setDifference| 'SETDIFFERENCE)
+ (LIST '|setIntersection| 'INTERSECTION)
+ (LIST '|setPart| 'SETELT)
+ (LIST '|setUnion| 'UNION) (LIST '|size| 'SIZE)
+ (LIST '|strconc| 'CONCAT)
+ (LIST '|substitute| 'SUBST) (LIST '|take| 'TAKE)
+ (LIST '|true| 'T) (LIST 'PLUS '+)
+ (LIST 'MINUS '-) (LIST 'TIMES '*)
+ (LIST 'POWER 'EXPT) (LIST 'SLASH '/)
+ (LIST 'LT '<) (LIST 'GT '>) (LIST 'LE '<=)
+ (LIST 'GE '>=) (LIST 'SHOEEQ 'EQUAL)
+ (LIST 'SHOENE '/=) (LIST 'T 'T$)))
+ (|i| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#9|)
+ (PROGN (SETQ |i| (CAR |bfVar#9|)) NIL))
+ (RETURN NIL))
+ ('T (SETF (GET (CAR |i|) 'SHOERENAME) (CDR |i|))))
+ (SETQ |bfVar#9| (CDR |bfVar#9|)))))))
+
+(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL)
+ (PROG ()
+ (RETURN
+ (LET ((|bfVar#10|
+ (LIST (LIST 'PLUS 'PLUS) (LIST '|and| 'AND)
+ (LIST '|append| 'APPEND) (LIST '|apply| 'APPLY)
+ (LIST '|atom| 'ATOM) (LIST '|brace| 'REMDUP)
+ (LIST '|car| 'CAR) (LIST '|cdr| 'CDR)
+ (LIST '|cons| 'CONS) (LIST '|copy| 'COPY)
+ (LIST '|croak| 'CROAK) (LIST '|drop| 'DROP)
+ (LIST '|exit| 'EXIT) (LIST '|false| 'NIL)
+ (LIST '|first| 'CAR) (LIST '|genvar| 'GENVAR)
+ (LIST '|in| '|member|) (LIST '|is| 'IS)
+ (LIST '|lastNode| 'LASTNODE) (LIST '|list| 'LIST)
+ (LIST '|mkpf| 'MKPF) (LIST '|nconc| 'NCONC)
+ (LIST '|nil| 'NIL) (LIST '|not| 'NULL)
+ (LIST 'NOT 'NULL) (LIST '|nreverse| 'NREVERSE)
+ (LIST '|null| 'NULL) (LIST '|or| 'OR)
+ (LIST '|otherwise| 'T)
+ (LIST '|removeDuplicates| 'REMDUP)
+ (LIST '|rest| 'CDR) (LIST '|return| 'RETURN)
+ (LIST '|reverse| 'REVERSE)
+ (LIST '|setDifference| 'SETDIFFERENCE)
+ (LIST '|setIntersection| '|intersection|)
+ (LIST '|setPart| 'SETELT)
+ (LIST '|setUnion| '|union|) (LIST '|size| 'SIZE)
+ (LIST '|strconc| 'STRCONC)
+ (LIST '|substitute| 'MSUBST)
+ (LIST 'SUBST 'MSUBST) (LIST '|take| 'TAKE)
+ (LIST '|true| 'T) (LIST '|where| 'WHERE)
+ (LIST 'TIMES 'TIMES) (LIST 'POWER 'EXPT)
+ (LIST 'NOT 'NULL) (LIST 'SHOENE 'NEQUAL)
+ (LIST 'MINUS 'SPADDIFFERENCE)
+ (LIST 'SLASH 'QUOTIENT) (LIST '= 'EQUAL)
+ (LIST 'SHOEEQ 'EQUAL) (LIST 'ASSOC '|assoc|)
+ (LIST 'DELETE '|delete|) (LIST 'GET 'GETL)
+ (LIST 'INTERSECTION '|intersection|)
+ (LIST 'LAST '|last|) (LIST 'MEMBER '|member|)
+ (LIST 'RASSOC '|rassoc|) (LIST 'READ 'VMREAD)
+ (LIST 'READ-LINE '|read-line|)
+ (LIST 'REDUCE 'SPADREDUCE)
+ (LIST 'REMOVE '|remove|) (LIST 'BAR 'SUCHTHAT)
+ (LIST 'T 'T$) (LIST 'IN '|member|)
+ (LIST 'UNION '|union|)))
+ (|i| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#10|)
+ (PROGN (SETQ |i| (CAR |bfVar#10|)) NIL))
+ (RETURN NIL))
+ ('T (SETF (GET (CAR |i|) 'OLD-BOOT) (CDR |i|))))
+ (SETQ |bfVar#10| (CDR |bfVar#10|)))))))
+
+(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL)
+ (PROG ()
+ (RETURN
+ (LET ((|bfVar#11|
+ (LIST 'LT 'LE 'GT 'GE 'SHOENE 'TIMES 'PLUS 'MINUS
+ '|function| 'PAIRP))
+ (|i| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#11|)
+ (PROGN (SETQ |i| (CAR |bfVar#11|)) NIL))
+ (RETURN NIL))
+ ('T (SETF (GET |i| 'RENAME-OK) T)))
+ (SETQ |bfVar#11| (CDR |bfVar#11|)))))))
+
+(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL)
+ (PROG ()
+ (RETURN
+ (LET ((|bfVar#12|
+ (LIST (LIST '|setName| 0) (LIST '|setLabel| 1)
+ (LIST '|setLevel| 2) (LIST '|setType| 3)
+ (LIST '|setVar| 4) (LIST '|setLeaf| 5)
+ (LIST '|setDef| 6) (LIST '|aGeneral| 4)
+ (LIST '|aMode| 1) (LIST '|aModeSet| 3)
+ (LIST '|aTree| 0) (LIST '|aValue| 2)
+ (LIST '|attributes| 'CADDR)
+ (LIST '|cacheCount| 'CADDDDR)
+ (LIST '|cacheName| 'CADR)
+ (LIST '|cacheReset| 'CADDDR)
+ (LIST '|cacheType| 'CADDR) (LIST '|env| 'CADDR)
+ (LIST '|expr| 'CAR) (LIST 'CAR 'CAR)
+ (LIST '|mmCondition| 'CAADR) (LIST '|mmDC| 'CAAR)
+ (LIST '|mmImplementation| 'CADADR)
+ (LIST '|mmSignature| 'CDAR)
+ (LIST '|mmTarget| 'CADAR) (LIST '|mode| 'CADR)
+ (LIST '|op| 'CAR) (LIST '|opcode| 'CADR)
+ (LIST '|opSig| 'CADR) (LIST 'CDR 'CDR)
+ (LIST '|sig| 'CDDR) (LIST '|source| 'CDR)
+ (LIST '|streamCode| 'CADDDR)
+ (LIST '|streamDef| 'CADDR)
+ (LIST '|streamName| 'CADR) (LIST '|target| 'CAR)))
+ (|i| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#12|)
+ (PROGN (SETQ |i| (CAR |bfVar#12|)) NIL))
+ (RETURN NIL))
+ ('T (SETF (GET (CAR |i|) 'SHOESELFUNCTION) (CADR |i|))))
+ (SETQ |bfVar#12| (CDR |bfVar#12|)))))))
+
diff --git a/src/boot/translator.boot.pamphlet b/src/boot/strap/translator.clisp
index c66ba1f2..0b849cfc 100644
--- a/src/boot/translator.boot.pamphlet
+++ b/src/boot/strap/translator.clisp
@@ -1,818 +1,3 @@
-\documentclass{article}
-\usepackage{axiom}
-
-\title{\File{src/boot/translator.boot} Pamphlet}
-\author{The Axiom Team}
-
-\begin{document}
-\maketitle
-
-\begin{abstract}
-This file implement various Boot translaters.
-\end{abstract}
-\eject
-
-\tableofcontents
-\eject
-
-\section{Entry points to this module}
-
-The only entry points to this module are:
-\begin{itemize}
-\item [BOOTTOCL]
-\item [BOOTCLAM]
-\item [BOOTTOCLC]
-\item [BOOTTOMC]
-\item [EVAL-BOOT-FILE]
-\item [BO]
-\item [BOCLAM]
-\item [STOUT]
-\item [STEVAL]
-\item [STTOMC]
-\end{itemize}
-
-Calling other functions defined here, from outside of this module,
-may lead to unpredictable results.
-
-
-We assume that we are translating a file called {\bf ``foo.boot''}
-and expect to generate a file called {\bf ``foo.clisp''}.
-
-\section{BOOTTOCLLINES}
-
-The {\bf BOOTTOCLLINES} function cleans up the function names.
-When called during system build from {\bf BOOTTOCL} the {\bf lines}
-variable has the value {\bf NIL} and the {\bf fn} variable has the
-value {\bf ``foo.boot''}.
-
-The infn variable is the input file name, {\bf ``foo.boot''}.
-
-The outfn variable is the output file name, {\bf ``foo.clisp''}.
-
-Calling {\bf shoeOpenInputFile} will create {\bf ``foo.clisp''} and
-return the string ``foo.clisp PRODUCED''.
-
-<<BOOTTOCLLINES>>=
-BOOTTOCLLINES(lines, fn, outfn)==
- -- The default floating point number is double-float.
- SETQ(_*READ_-DEFAULT_-FLOAT_-FORMAT_*, 'DOUBLE_-FLOAT)
- callingPackage := _*PACKAGE_*
- IN_-PACKAGE '"BOOTTRAN"
- infn:=shoeAddbootIfNec fn
- result := shoeOpenInputFile(a,infn,
- shoeClLines(a,fn,lines,outfn))
- setCurrentPackage callingPackage
- result
-
-@
-
-\section{License}
-
-<<license>>=
--- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
--- 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.
---
--- - Neither the name of The Numerical ALgorithms Group Ltd. nor the
--- names of its contributors may be used to endorse or promote products
--- derived from this software without specific prior written permission.
---
--- 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 OWNER
--- 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.
-
-@
-<<*>>=
-<<license>>
-
-module '"boot-translator"
-import '"includer"
-import '"scanner"
-import '"pile"
-import '"parser"
-import '"ast"
-
-)package "BOOTTRAN"
-
-+++ True if we are translating code written in Old Boot.
-$translatingOldBoot := false
-
-AxiomCore::%sysInit() ==
- if cdr ASSOC(Option '"boot", %systemOptions()) = '"old"
- then $translatingOldBoot := true
-
--- Make x, the current package
-setCurrentPackage x ==
- SETQ(_*PACKAGE_*,x)
-
--- Compiles the input Lisp file designated by lspFileName.
-shoeCOMPILE_-FILE lspFileName ==
- COMPILE_-FILE lspFileName
-
--- (boottocl "filename") translates the file "filename.boot" to
--- the common lisp file "filename.clisp"
-
-BOOTTOCL(fn, out) ==
- BOOTTOCLLINES(nil,fn, out)
-
--- (bootclam "filename") translates the file "filename.boot" to
--- the common lisp file "filename.clisp" , producing, for each function
--- a hash table to store previously computed values indexed by argument
--- list.
-
-BOOTCLAM(fn, out) ==
- $bfClamming := true
- BOOTCLAMLINES(nil,fn, out)
-
-BOOTCLAMLINES(lines, fn, out) ==
- BOOTTOCLLINES(lines, fn, out)
-
-<<BOOTTOCLLINES>>
-shoeClLines(a,fn,lines,outfn)==
- if null a
- then shoeNotFound fn
- else
- $GenVarCounter:local := 0
- shoeOpenOutputFile(stream,outfn,
- (for line in lines repeat shoeFileLine (line,stream);
- shoeFileTrees(shoeTransformStream a,stream)))
- outfn
-
--- (boottoclc "filename") translates the file "filename.boot" to
--- the common lisp file "filename.clisp" with the original boot
--- code as comments
-
-BOOTTOCLC(fn, out)==BOOTTOCLCLINES(nil, fn, out)
-
-BOOTTOCLCLINES(lines, fn, outfn)==
- callingPackage := _*PACKAGE_*
- IN_-PACKAGE '"BOOTTRAN"
- infn:=shoeAddbootIfNec fn
- result := shoeOpenInputFile(a,infn,
- shoeClCLines(a,fn,lines,outfn))
- setCurrentPackage callingPackage
- result
-
-
-shoeClCLines(a,fn,lines,outfn)==
- if null a
- then shoeNotFound fn
- else
- $GenVarCounter:local := 0
- shoeOpenOutputFile(stream,outfn,
- (for line in lines repeat shoeFileLine (line,stream);
- shoeFileTrees(shoeTransformToFile(stream,
- shoeInclude bAddLineNumber(bRgen a,bIgen 0)),stream)))
- outfn
-
--- (boottomc "filename") translates the file "filename.boot"
--- to machine code and loads it one item at a time
-
-BOOTTOMC fn==
- callingPackage := _*PACKAGE_*
- IN_-PACKAGE '"BOOTTRAN"
- $GenVarCounter:local := 0
- infn:=shoeAddbootIfNec fn
- result := shoeOpenInputFile(a,infn,shoeMc(a,fn))
- setCurrentPackage callingPackage
- result
-
-shoeMc(a,fn)==
- if null a
- then shoeNotFound fn
- else
- shoePCompileTrees shoeTransformStream a
- shoeConsole CONCAT(fn,'" COMPILED AND LOADED")
-
-EVAL_-BOOT_-FILE fn ==
- b := _*PACKAGE_*
- IN_-PACKAGE '"BOOTTRAN"
- infn:=shoeAddbootIfNec fn
- outfn:=CONCAT(shoeRemovebootIfNec fn,'".",_*LISP_-SOURCE_-FILETYPE_*)
- shoeOpenInputFile(a,infn,shoeClLines(a,infn,[],outfn))
- setCurrentPackage b
- LOAD outfn
-
--- (boot "filename") translates the file "filename.boot"
--- and prints the result at the console
-
-BO fn==
- b := _*PACKAGE_*
- IN_-PACKAGE '"BOOTTRAN"
- $GenVarCounter:local := 0
- infn:=shoeAddbootIfNec fn
- shoeOpenInputFile(a,infn,shoeToConsole(a,fn))
- setCurrentPackage b
-
-BOCLAM fn==
- callingPackage := _*PACKAGE_*
- IN_-PACKAGE '"BOOTTRAN"
- $GenVarCounter:local := 0
- $bfClamming:local := true
- infn:=shoeAddbootIfNec fn
- result := shoeOpenInputFile(a,infn,shoeToConsole(a,fn))
- setCurrentPackage callingPackage
- result
-
-shoeToConsole(a,fn)==
- if null a
- then shoeNotFound fn
- else
- shoeConsoleTrees shoeTransformToConsole
- shoeInclude bAddLineNumber(bRgen a,bIgen 0)
-
--- (stout "string") translates the string "string"
--- and prints the result at the console
-
-STOUT string== PSTOUT [string]
--- $GenVarCounter:local := 0
--- $bfClamming:local:=false
--- shoeConsoleTrees shoeTransformString [string]
-
-STEVAL string==
- callingPackage := _*PACKAGE_*
- IN_-PACKAGE '"BOOTTRAN"
- $GenVarCounter:local := 0
- a:= shoeTransformString [string]
- result :=
- bStreamPackageNull a => nil
- fn:=stripm(CAR a,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN")
- EVAL fn
- setCurrentPackage callingPackage
- result
-
--- (sttomc "string") translates the string "string"
--- to common lisp, and compiles it.
-
-STTOMC string==
- callingPackage := _*PACKAGE_*
- IN_-PACKAGE '"BOOTTRAN"
- $GenVarCounter:local := 0
- a:= shoeTransformString [string]
- result :=
- bStreamPackageNull a => nil
- shoePCompile car a
- setCurrentPackage callingPackage
- result
-
-
-shoeCompileTrees s==
- while not bStreamNull s repeat
- shoeCompile car s
- s:=cdr s
-
-shoeCompile fn==
- fn is ['DEFUN,name,bv,:body]=>
- COMPILE (name,['LAMBDA,bv,:body])
- EVAL fn
-
-shoeTransform str==
- bNext(function shoeTreeConstruct,
- bNext(function shoePileInsert,
- bNext(function shoeLineToks, str)))
-
-shoeTransformString s==
- shoeTransform shoeInclude bAddLineNumber(s,bIgen 0)
-shoeTransformStream s==shoeTransformString bRgen s
--- shoeTransform shoeInclude bAddLineNumber(bRgen s,bIgen 0)
-
-shoeTransformToConsole str==
- bNext(function shoeConsoleItem,
- bNext(function shoePileInsert,
- bNext(function shoeLineToks, str)))
-
-shoeTransformToFile(fn,str)==
- bFileNext(fn,
- bNext(function shoePileInsert,
- bNext(function shoeLineToks, str)))
-
-shoeConsoleItem (str)==
- dq:=CAR str
- shoeConsoleLines shoeDQlines dq
- cons(shoeParseTrees dq,CDR str)
-
-bFileNext(fn,s)==bDelay(function bFileNext1,[fn,s])
-
-bFileNext1(fn,s)==
- bStreamNull s=> ["nullstream"]
- dq:=CAR s
- shoeFileLines(shoeDQlines dq,fn)
- bAppend(shoeParseTrees dq,bFileNext(fn,cdr s))
-
-shoeParseTrees dq==
- toklist := dqToList dq
- null toklist => []
- shoeOutParse toklist
-
-shoeTreeConstruct (str)==
- cons(shoeParseTrees CAR str,CDR str)
-
-shoeDQlines dq==
- a:= CDAAR shoeLastTokPosn dq
- b:= CDAAR shoeFirstTokPosn dq
- streamTake (a-b+1,CAR shoeFirstTokPosn dq)
-
-streamTake(n,s)==
- if bStreamNull s
- then nil
- else if EQL(n,0)
- then nil
- else cons(car s,streamTake(n-1,cdr s))
-
-shoeFileLines (lines,fn) ==
- shoeFileLine( '" ",fn)
- for line in lines repeat shoeFileLine (shoeAddComment line,fn)
- shoeFileLine ('" ",fn)
-
-shoeConsoleLines lines ==
- shoeConsole '" "
- for line in lines repeat shoeConsole shoeAddComment line
- shoeConsole '" "
-
-shoeFileLine(x, stream) ==
- WRITE_-LINE(x, stream)
- x
-
-shoeFileTrees(s,st)==
- while not bStreamNull s repeat
- a:=CAR s
- if EQCAR (a,"+LINE")
- then shoeFileLine(CADR a,st)
- else
- REALLYPRETTYPRINT(a,st)
- TERPRI st
- s:=CDR s
-
-
-shoePPtoFile(x, stream) ==
- SHOENOTPRETTYPRINT(x, stream)
- x
-
-shoeConsoleTrees s ==
- while not bStreamPackageNull s repeat
--- while not bStreamNull s repeat
- fn:=stripm(CAR s,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN")
- REALLYPRETTYPRINT fn
- s:=CDR s
-
-shoeAddComment l== CONCAT('"; ",CAR l)
-
-++ Generate an import declaration for `op' as equivalent of the
-++ foreign signature `sig'. Here, `foreign' operationally means that
-++ the entity is from the C language world.
-genImportDeclaration(op, sig) ==
- sig isnt ["Signature", op', m] => coreError '"invalid signature"
- m isnt ["Mapping", t, s] => coreError '"invalid function type"
- %hasFeature KEYWORD::GCL =>
- if SYMBOLP s then s := [s]
- ["DEFENTRY", op, s, [t, SYMBOL_-NAME op']]
- fatalError '"import declaration not implemented for this Lisp"
-
-shoeOutParse stream ==
- $inputStream :local:= stream
- $stack:local :=nil
- $stok:local := nil
- $ttok:local := nil
- $op:local :=nil
- $wheredefs:local:=nil
- $typings:local:=nil
- $returns:local :=nil
- $bpCount:local:=0
- $bpParenCount:local:=0
- bpFirstTok()
- found:=CATCH("TRAPPOINT",bpOutItem())
- if found="TRAPPED"
- then nil
- else if not bStreamNull $inputStream
- then
- bpGeneralErrorHere()
- nil
- else if null $stack
- then
- bpGeneralErrorHere()
- nil
- else CAR $stack
-
-bpOutItem()==
- bpComma() or bpTrap()
- b:=bpPop1()
- EQCAR(b,"TUPLE")=> bpPush cdr b
- EQCAR(b,"+LINE")=> bpPush [ b ]
- b is ["L%T",l,r] and IDENTP l =>
- bpPush [["DEFPARAMETER",l,r]]
- case b of
- Module(m) =>
- bpPush [shoeCompileTimeEvaluation ["PROVIDE", m]]
-
- Import(m) =>
- bpPush [["IMPORT-MODULE", m]]
-
- ImportSignature(x, sig) =>
- bpPush [genImportDeclaration(x, sig)]
-
- TypeAlias(t, args, rhs) =>
- bpPush [["DEFTYPE", t, args, ["QUOTE", rhs]]]
-
- ConstantDefinition(n, e) =>
- bpPush [["DEFCONSTANT", n, e]]
-
- otherwise =>
- b:=shoeCompTran ["LAMBDA",["x"],b]
- bpPush [shoeEVALANDFILEACTQ CADDR b]
-
---shoeStartsAt (sz,name,stream)==
--- bStreamNull stream => ['nullstream]
--- a:=CAAR stream
--- if #a<sz
--- then shoeStartsAt(sz,name,CDR stream)
--- else if SUBSTRING(a,0,sz)=name and (#a>sz and not shoeIdChar(a.sz))
--- then stream
--- else shoeStartsAt(sz,name,CDR stream)
-
---FC(name,fn)==
--- $bfClamming:local:=false
--- $GenVarCounter:local := 0
--- infn:=shoeAddbootIfNec fn
--- shoeOpenInputFile(a,infn,shoeFindName(fn,name, a))
-
---shoeFindName(fn,name,a)==
--- shoeFindAndDoSomething(FUNCTION shoeCompile,fn,name,a)
---shoeTransform1 str==
--- bNext(function shoeTreeConstruct,
--- streamTake(1, bNext(function shoePileInsert,
--- bNext(function shoeLineToks, str))))
-
---BOOT_-DO_-SOMETHING_-TO_-DEFINITION_-FROM_-FILE(fun,fn,symbol)==
--- $bfClamming:local:=false
--- infn:=shoeAddbootIfNec NAMESTRING fn
--- name:=PNAME symbol
--- shoeOpenInputFile(a,infn,shoeFindAndDoSomething(fun,fn,name, a))
-
---shoeFindAndDoSomething(fun,fn,name,a)==
--- if null a
--- then shoeNotFound fn
--- else
--- b:=shoeStartsAt(#name,name, shoeInclude
--- bAddLineNumber(bRgen a,bIgen 0))
--- if bStreamNull b
--- then shoeConsole CONCAT (name,'" not found in ",fn)
--- else
--- $GenVarCounter:local := 0
--- shoeLoop(fun,shoeTransform1 b)
-
---BOOT_-COMPILE_-DEFINITION_-FROM_-FILE(fn,symbol)==
--- BOOT_-DO_-SOMETHING_-TO_-DEFINITION_-FROM_-FILE
--- (FUNCTION shoeCompile,fn,symbol)
-
---BOOT_-EVAL_-DEFINITION_-FROM_-FILE(fn,symbol)==
--- BOOT_-DO_-SOMETHING_-TO_-DEFINITION_-FROM_-FILE
--- (FUNCTION EVAL,fn,symbol)
-
---BOOT_-PRINT_-DEFINITION_-FROM_-FILE(fn,symbol)==
--- BOOT_-DO_-SOMETHING_-TO_-DEFINITION_-FROM_-FILE
--- (FUNCTION REALLYPRETTYPRINT,fn,symbol)
-
---shoeLoop(fun, s)==
--- while not bStreamNull s repeat
--- FUNCALL(fun, car s)
--- s:=cdr s
-
-shoeAddbootIfNec s==shoeAddStringIfNec('".boot",s)
-
-shoeRemovebootIfNec s==shoeRemoveStringIfNec('".boot",s)
-shoeAddStringIfNec(str,s)==
- a:=STRPOS(str,s,0,nil)
- if null a
- then CONCAT(s,str)
- else s
-
-shoeRemoveStringIfNec(str,s)==
- a:=STRPOS(str,s,0,nil)
- if null a
- then s
- else SUBSTRING(s,0,a)
-
--- DEFUSE prints the definitions not used and the words used and
--- not defined in the input file and common lisp.
-
-DEFUSE fn==
- infn:=CONCAT(fn,'".boot")
- shoeOpenInputFile(a,infn,shoeDfu(a,fn))
-
-shoeDfu(a,fn)==
- if null a
- then shoeNotFound fn
- else
- $lispWordTable:local :=MAKE_-HASHTABLE ("EQ")
- DO_-SYMBOLS(i(FIND_-PACKAGE "LISP"),HPUT($lispWordTable,i,true))
- $bootDefined:local :=MAKE_-HASHTABLE "EQ"
- $bootUsed:local :=MAKE_-HASHTABLE "EQ"
- $bootDefinedTwice:local:=nil
- $GenVarCounter:local :=0
- $bfClamming:local:=false
- shoeDefUse shoeTransformStream a
- out:=CONCAT(fn,'".defuse")
- shoeOpenOutputFile(stream,out,shoeReport stream)
- out
-
-shoeReport stream==
- shoeFileLine('"DEFINED and not USED",stream)
- a:=[i for i in HKEYS $bootDefined | not GETHASH(i,$bootUsed)]
- bootOut(SSORT a,stream)
- shoeFileLine('" ",stream)
- shoeFileLine('"DEFINED TWICE",stream)
- bootOut(SSORT $bootDefinedTwice,stream)
- shoeFileLine('" ",stream)
- shoeFileLine('"USED and not DEFINED",stream)
- a:=[i for i in HKEYS $bootUsed |
- not GETHASH(i,$bootDefined)]
- for i in SSORT a repeat
- b:=CONCAT(PNAME i,'" is used in ")
- bootOutLines( SSORT GETHASH(i,$bootUsed),stream,b)
-
-shoeDefUse(s)==
- while not bStreamPackageNull s repeat
- defuse([],CAR s)
- s:=CDR s
-
-defuse(e,x)==
- x:=stripm(x,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN")
- $used:local:=nil
- [nee,niens]:=
- x is ['DEFUN,name,bv,:body] => [name,['LAMBDA,bv,:body]]
- x is ['DEFMACRO,name,bv,:body] => [name,['LAMBDA,bv,:body]]
- x is ["EVAL_-WHEN",.,["SETQ",id,exp]]=>[id,exp]
- x is ["SETQ",id,exp]=>[id,exp]
- ["TOP-LEVEL", x]
- if GETHASH(nee,$bootDefined)
- then
- $bootDefinedTwice:=
- nee="TOP-LEVEL"=> $bootDefinedTwice
- cons(nee,$bootDefinedTwice)
- else HPUT($bootDefined,nee,true)
- defuse1 (e,niens)
- for i in $used repeat
- HPUT($bootUsed,i,cons(nee,GETHASH(i,$bootUsed)))
-
-defuse1(e,y)==
- ATOM y =>
- IDENTP y =>
- $used:=
- MEMQ(y,e)=>$used
- MEMQ(y,$used)=>$used
- defusebuiltin y =>$used
- UNION([y],$used)
- []
- y is ["LAMBDA",a,:b]=> defuse1 (append(unfluidlist a,e),b)
- y is ["PROG",a,:b]=>
- [dol,ndol]:=defSeparate a
- for i in dol repeat
- HPUT($bootDefined,i,true)
- defuse1 (append(ndol,e),b)
- y is ["QUOTE",:a] => []
- y is ["+LINE",:a] => []
- for i in y repeat defuse1(e,i)
-
-defSeparate x==
- if null x
- then [[],[]]
- else
- f:=car x
- [x1,x2]:=defSeparate cdr x
- if bfBeginsDollar f
- then [cons(f,x1),x2]
- else [x1,cons(f,x2)]
-unfluidlist x==
- NULL x => []
- ATOM x=> [x]
- x is ["&REST",y]=> [y]
- cons(car x,unfluidlist cdr x)
-
-defusebuiltin x== GETHASH(x,$lispWordTable)
-
-bootOut (l,outfn)==
- for i in l repeat shoeFileLine (CONCAT ('" ",PNAME i),outfn)
-
-CLESSP(s1,s2)==not(SHOEGREATERP(s1,s2))
-SSORT l == SORT(l,function CLESSP)
-
-bootOutLines(l,outfn,s)==
- if null l
- then shoeFileLine(s,outfn)
- else
- a:=PNAME car l
- if #s +#a > 70
- then
- shoeFileLine(s,outfn)
- bootOutLines(l,outfn,'" ")
- else bootOutLines(cdr l,outfn,CONCAT(s,'" ",a))
-
-
--- (xref "fn") produces a cross reference listing in "fn.xref"
--- It contains each name
--- used in "fn.boot", together with a list of functions that use it.
-
-XREF fn==
- infn:=CONCAT(fn,'".boot")
- shoeOpenInputFile(a,infn,shoeXref(a,fn))
-
-shoeXref(a,fn)==
- if null a
- then shoeNotFound fn
- else
- $lispWordTable:local :=MAKE_-HASHTABLE ("EQ")
- DO_-SYMBOLS(i(FIND_-PACKAGE "LISP"),HPUT($lispWordTable,i,true))
- $bootDefined:local :=MAKE_-HASHTABLE "EQ"
- $bootUsed:local :=MAKE_-HASHTABLE "EQ"
- $GenVarCounter:local :=0
- $bfClamming:local:=false
- shoeDefUse shoeTransformStream a
- out:=CONCAT(fn,'".xref")
- shoeOpenOutputFile(stream,out,shoeXReport stream)
- out
-
-
-shoeXReport stream==
- shoeFileLine('"USED and where DEFINED",stream)
- c:=SSORT HKEYS $bootUsed
- for i in c repeat
- a:=CONCAT(PNAME i,'" is used in ")
- bootOutLines( SSORT GETHASH(i,$bootUsed),stream,a)
-
---FC (name,fn)== shoeGeneralFC(function BOOT,name,fn)
-
-FBO (name,fn)== shoeGeneralFC(function BO,name,fn)
-
-FEV(name,fn)== shoeGeneralFC(function EVAL_-BOOT_-FILE,name,fn)
-
-shoeGeneralFC(f,name,fn)==
- $bfClamming:local:=false
- $GenVarCounter:local := 0
- infn:=shoeAddbootIfNec fn
- a:= shoeOpenInputFile(a,infn,shoeFindName2(fn,name, a))
- filename:= if # name > 8 then SUBSTRING(name,0,8) else name
- a => FUNCALL(f, CONCAT('"/tmp/",filename))
- nil
-
-shoeFindName2(fn,name,a)==
- lines:=shoeFindLines(fn,name,a)
- lines =>
- filename:= if # name > 8 then SUBSTRING(name,0,8) else name
- filename := CONCAT ('"/tmp/",filename,'".boot")
- shoeOpenOutputFile(stream, filename,
- for line in lines repeat shoeFileLine (line,stream))
- true
- false
-
-shoeTransform2 str==
- bNext(function shoeItem,
- streamTake(1, bNext(function shoePileInsert,
- bNext(function shoeLineToks, str))))
-
-shoeItem (str)==
- dq:=CAR str
- cons([[CAR line for line in shoeDQlines dq]],CDR str)
-
---shoeLines lines == [CAR line for line in lines]
-
---shoeFindAndDoSomething2(fun,fn,name,a)==
--- if null a
--- then shoeNotFound fn
--- else
--- [lines,b]:=shoePackageStartsAt([],#name,name, shoeInclude
--- bAddLineNumber(bRgen a,bIgen 0))
--- if bStreamNull b
--- then
--- shoeConsole CONCAT (name,'" not found in ",fn)
--- []
--- else
--- if null lines
--- then shoeConsole '")package not found"
--- $GenVarCounter:local := 0
--- shoeLoopPackage(fun,shoeTransform2 b,lines)
-
---shoeLoopPackage(fun, s,lines)==
--- while not bStreamNull s repeat
--- FUNCALL(fun, append (reverse lines,car s))
--- s:=cdr s
--- true
-stripm (x,pk,bt)==
- ATOM x =>
- IDENTP x =>
- SYMBOL_-PACKAGE x = bt => INTERN(PNAME x,pk)
- x
- x
- CONS(stripm(CAR x,pk,bt),stripm(CDR x,pk,bt))
-
-shoePCompile fn==
- fn:=stripm(fn,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN")
- fn is ['DEFUN,name,bv,:body]=>
- COMPILE (name,['LAMBDA,bv,:body])
- EVAL fn
-
-FC(name,fn)==
- $GenVarCounter:local := 0
- infn:=shoeAddbootIfNec fn
- shoeOpenInputFile(a,infn,shoeFindName(fn,name, a))
-
-shoeFindName(fn,name,a)==
- lines:=shoeFindLines(fn,name,a)
- shoePCompileTrees shoeTransformString lines
-
-shoePCompileTrees s==
- while not bStreamPackageNull s repeat
- REALLYPRETTYPRINT shoePCompile car s
- s:=cdr s
-
-bStreamPackageNull s==
- a := _*PACKAGE_*
- IN_-PACKAGE '"BOOTTRAN"
- b:=bStreamNull s
- setCurrentPackage a
- b
-
-PSTTOMC string==
- $GenVarCounter:local := 0
- shoePCompileTrees shoeTransformString string
-
-BOOTLOOP ()==
- a:=READ_-LINE()
- #a=0=>
- WRITE_-LINE '"Boot Loop; to exit type ] "
- BOOTLOOP()
- b:=shoePrefix? ('")console",a)
- b =>
- stream:= _*TERMINAL_-IO_*
- PSTTOMC bRgen stream
- BOOTLOOP()
- a.0='"]".0 => nil
- PSTTOMC [a]
- BOOTLOOP()
-
-BOOTPO ()==
- a:=READ_-LINE()
- #a=0=>
- WRITE_-LINE '"Boot Loop; to exit type ] "
- BOOTPO()
- b:=shoePrefix? ('")console",a)
- b =>
- stream:= _*TERMINAL_-IO_*
- PSTOUT bRgen stream
- BOOTPO()
- a.0='"]".0 => nil
- PSTOUT [a]
- BOOTPO()
-
-PSTOUT string==
- callingPackage := _*PACKAGE_*
- IN_-PACKAGE '"BOOTTRAN"
- $GenVarCounter:local := 0
- result := shoeConsoleTrees shoeTransformString string
- setCurrentPackage callingPackage
- result
-
-
-defaultBootToLispFile file ==
- CONCAT(shoeRemovebootIfNec file,'".clisp")
-
-translateBootFile(progname, options, file) ==
- outFile := getOutputPathname(options)
- BOOTTOCL(file, ENOUGH_-NAMESTRING outFile)
-
-compileBootHandler(progname, options, file) ==
- intFile := BOOTTOCL(file, defaultBootToLispFile file)
- intFile =>
- objFile := compileLispHandler(progname, options, intFile)
- DELETE_-FILE intFile
- objFile
- nil
-
-associateRequestWithFileType(Option '"translate", '"boot",
- function translateBootFile)
-associateRequestWithFileType(Option '"compile", '"boot",
- function compileBootHandler)
-@
-
-<<translator.clisp>>=
(EVAL-WHEN (:COMPILE-TOPLEVEL) (PROVIDE "boot-translator"))
(IMPORT-MODULE "includer")
@@ -1219,6 +404,44 @@ associateRequestWithFileType(Option '"compile", '"boot",
(DEFUN |shoeAddComment| (|l|)
(PROG () (RETURN (CONCAT "; " (CAR |l|)))))
+(DEFUN |genImportDeclaration| (|op| |sig|)
+ (PROG (|s| |t| |m| |ISTMP#2| |op'| |ISTMP#1|)
+ (RETURN
+ (COND
+ ((NOT (AND (CONSP |sig|) (EQ (CAR |sig|) '|Signature|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |sig|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |op'| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|)
+ (EQ (CDR |ISTMP#2|) NIL)
+ (PROGN
+ (SETQ |m| (CAR |ISTMP#2|))
+ #0='T)))))))
+ (|coreError| "invalid signature"))
+ ((NOT (AND (CONSP |m|) (EQ (CAR |m|) '|Mapping|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |m|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |t| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|)
+ (EQ (CDR |ISTMP#2|) NIL)
+ (PROGN
+ (SETQ |s| (CAR |ISTMP#2|))
+ #0#)))))))
+ (|coreError| "invalid function type"))
+ ((|%hasFeature| :GCL)
+ (PROGN
+ (COND ((SYMBOLP |s|) (SETQ |s| (LIST |s|))))
+ (LIST 'DEFENTRY |op| |s| (LIST |t| (SYMBOL-NAME |op'|)))))
+ ('T
+ (|fatalError|
+ "import declaration not implemented for this Lisp"))))))
+
(DEFUN |shoeOutParse| (|stream|)
(PROG (|$bpParenCount| |$bpCount| |$returns| |$typings| |$wheredefs|
|$op| |$ttok| |$stok| |$stack| |$inputStream| |found|)
@@ -1280,6 +503,11 @@ associateRequestWithFileType(Option '"compile", '"boot",
(|Import|
(LET ((|m| (CAR |bfVar#6|)))
(|bpPush| (LIST (LIST 'IMPORT-MODULE |m|)))))
+ (|ImportSignature|
+ (LET ((|x| (CAR |bfVar#6|))
+ (|sig| (CADR |bfVar#6|)))
+ (|bpPush|
+ (LIST (|genImportDeclaration| |x| |sig|)))))
(|TypeAlias|
(LET ((|t| (CAR |bfVar#6|))
(|args| (CADR |bfVar#6|))
@@ -1926,6 +1154,3 @@ associateRequestWithFileType(Option '"compile", '"boot",
(|associateRequestWithFileType| (|Option| "compile") "boot"
#'|compileBootHandler|))))
-@
-
-\end{document}
diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot
new file mode 100644
index 00000000..a64c6d56
--- /dev/null
+++ b/src/boot/tokens.boot
@@ -0,0 +1,411 @@
+-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+-- All rights reserved.
+-- Copyright (C) 2007-2008, Gabriel Dos Reis.
+-- 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.
+--
+-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+-- names of its contributors may be used to endorse or promote products
+-- derived from this software without specific prior written permission.
+--
+-- 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 OWNER
+-- 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.
+--
+
+module '"boot-tokens"
+import '"initial-env"
+
+)package "BOOTTRAN"
+
+++ Table of Boot keywords and their token name.
+shoeKeyWords := [ _
+ ['"and","AND"] , _
+ ['"by", "BY" ], _
+ ['"case","CASE"] , _
+ ['"cross","CROSS"] , _
+ ['"else", "ELSE"] , _
+ ['"for", "FOR"] , _
+ ['"if", "IF"], _
+ ['"import", "IMPORT"], _
+ ['"in", "IN" ], _
+ ['"is", "IS"], _
+ ['"isnt", "ISNT"] , _
+ ['"module", "MODULE"], _
+ ['"of", "OF"] , _
+ ['"or", "OR"] , _
+ ['"repeat", "REPEAT"] , _
+ ['"return", "RETURN"], _
+ ['"structure", "STRUCTURE"], _
+ ['"then", "THEN"], _
+ ['"until", "UNTIL"], _
+ ['"where", "WHERE"], _
+ ['"while", "WHILE"], _
+ ['".", "DOT"], _
+ ['":", "COLON"], _
+ ['"::", "COLON-COLON"], _
+ ['",", "COMMA"], _
+ ['";", "SEMICOLON"], _
+ ['"*", "TIMES"], _
+ ['"**", "POWER"], _
+ ['"/", "SLASH"], _
+ ['"+", "PLUS"], _
+ ['"-", "MINUS"], _
+ ['"<", "LT"], _
+ ['">", "GT"] , _
+ ['"<=","LE" ], _
+ ['">=","GE" ], _
+ ['"=", "SHOEEQ"], _
+ ['"^", "NOT"], _
+ ['"^=","SHOENE" ], _
+ ['"..","SEG" ], _
+ ['"#", "LENGTH"], _
+ ['"=>","EXIT" ], _
+ ['"->", "ARROW"],_
+ ['":=", "BEC"], _
+ ['"==", "DEF"], _
+ ['"==>","MDEF" ], _
+ ['"<=>", "TDEF"], _
+ ['"(", "OPAREN"], _
+ ['")", "CPAREN"], _
+ ['"(|", "OBRACK"], _
+ ['"|)", "CBRACK"], _
+ ['"[", "OBRACK"], _
+ ['"]", "CBRACK"], _
+ ['"suchthat","BAR"], _
+ ['"'", "QUOTE"], _
+ ['"|", "BAR"] ]
+
+
+
+shoeKeyTableCons()==
+ KeyTable:=MAKE_-HASHTABLE("CVEC")
+ for st in shoeKeyWords repeat
+ HPUT(KeyTable,CAR st,CADR st)
+ KeyTable
+
+shoeKeyTable:=shoeKeyTableCons()
+
+shoeSPACE := QENUM('" ", 0)
+
+shoeESCAPE := QENUM('"__ ", 0)
+shoeLispESCAPE := QENUM('"! ", 0)
+
+shoeSTRING_CHAR := QENUM('"_" ", 0)
+
+shoePLUSCOMMENT := QENUM('"+ ", 0)
+
+shoeMINUSCOMMENT:= QENUM('"- ", 0)
+
+shoeDOT := QENUM('". ", 0)
+
+shoeEXPONENT1 := QENUM('"E ", 0)
+
+shoeEXPONENT2 := QENUM('"e ", 0)
+
+shoeCLOSEPAREN := QENUM('") ", 0)
+
+--shoeCLOSEANGLE := QENUM('"> ", 0)
+shoeTAB := 9
+
+shoeInsert(s,d) ==
+ l := #s
+ h := QENUM(s,0)
+ u := ELT(d,h)
+ n := #u
+ k:=0
+ while l <= #(ELT(u,k)) repeat
+ k:=k+1
+ v := MAKE_-VEC(n+1)
+ for i in 0..k-1 repeat VEC_-SETELT(v,i,ELT(u,i))
+ VEC_-SETELT(v,k,s)
+ for i in k..n-1 repeat VEC_-SETELT(v,i+1,ELT(u,i))
+ VEC_-SETELT(d,h,v)
+ s
+
+shoeDictCons()==
+ l:= HKEYS shoeKeyTable
+ d :=
+ a:=MAKE_-VEC(256)
+ b:=MAKE_-VEC(1)
+ VEC_-SETELT(b,0,MAKE_-CVEC 0)
+ for i in 0..255 repeat VEC_-SETELT(a,i,b)
+ a
+ for s in l repeat shoeInsert(s,d)
+ d
+
+shoeDict:=shoeDictCons()
+
+
+shoePunCons()==
+ listing := HKEYS shoeKeyTable
+ a:=MAKE_-BVEC 256
+ for i in 0..255 repeat BVEC_-SETELT(a,i,0)
+ for k in listing repeat
+ if not shoeStartsId k.0
+ then BVEC_-SETELT(a,QENUM(k,0),1)
+ a
+
+shoePun:=shoePunCons()
+
+++ List of prefix operators.
+for i in [ _
+ "NOT", _
+-- "COLON", _
+-- "SHOEEQ", _
+ "LENGTH" _
+ ] _
+ repeat SETF (GET(i,'SHOEPRE),'T)
+
+++ List of infix operators.
+for i in [ _
+ ["SHOEEQ" ,"="], _
+ ["TIMES" ,"*"], _
+ ["PLUS" ,"+"], _
+ ["IS" ,"is"], _
+ ["ISNT" ,"isnt"], _
+ ["AND" ,"and"], _
+ ["OR" ,"or"], _
+ ["SLASH" ,"/"], _
+ ["POWER" ,"**"], _
+ ["MINUS" ,"-"], _
+ ["LT" ,"<"], _
+ ["GT" ,">"], _
+ ["LE" ,"<="], _
+ ["GE" ,">="], _
+ ["SHOENE" ,"^="] _
+ ]_
+ repeat SETF (GET(CAR i,'SHOEINF),CADR i)
+
+
+++ List of monoid operations and their neutral elements.
+++ Note that `CONS' is not a monoid operations but support
+++ right reduction.
+for i in [ _
+ ["+", 0] , _
+ ["gcd", 0] , _
+ ["lcm", 1] , _
+ ["STRCONC", '""] , _
+ ["strconc", '""] , _
+ ["MAX", -999999] , _
+ ["MIN", 999999] , _
+ ["*", 1] , _
+ ["times", 1] , _
+ ["CONS", NIL] , _
+ ["APPEND", NIL] , _
+ ["append", NIL] , _
+ ["UNION", NIL] , _
+ ["UNIONQ", NIL] , _
+ ["union", NIL] , _
+ ["NCONC", NIL] , _
+ ["and", 'T] , _
+ ["or", NIL] , _
+ ["AND", 'T] , _
+ ["OR", NIL] _
+ ]
+
+ repeat SETF (GET(CAR i,'SHOETHETA),CDR i)
+for i in [ _
+ ["and", "AND"] , _
+ ["append", "APPEND"] , _
+ ["apply", "APPLY"] , _
+ ["atom", "ATOM"] , _
+ ["car", "CAR"] , _
+ ["cdr", "CDR"] , _
+ ["cons", "CONS"] , _
+ ["copy", "COPY"] , _
+ ["croak", "CROAK"] , _
+ ["drop", "DROP"] , _
+ ["exit", "EXIT"] , _
+ ["false", 'NIL] , _
+ ["first", "CAR"] , _
+ ["function","FUNCTION"] , _
+ ["genvar", "GENVAR"] , _
+ ["IN", "MEMBER"] , _
+ ["is", "IS"] , _
+ ["isnt", "ISNT"] , _
+ ["lastNode", "LAST"] , _
+ ["LAST", "last"] , _
+ ["list", "LIST"] , _
+-- ["member", "MEMBER"] , _
+ ["mkpf", "MKPF"] , _
+ ["nconc", "NCONC"] , _
+ ["nil" ,NIL ] , _
+ ["not", "NULL"] , _
+ ["NOT", "NULL"] , _
+ ["nreverse", "NREVERSE"] , _
+ ["null", "NULL"] , _
+ ["or", "OR"] , _
+ ["otherwise", "T"] , _
+ ["PAIRP", "CONSP"] , _
+ ["removeDuplicates", "REMDUP"] , _
+ ["rest", "CDR"] , _
+ ["reverse", "REVERSE"] , _
+ ["setDifference", "SETDIFFERENCE"] , _
+ ["setIntersection", "INTERSECTION"] , _
+ ["setPart", "SETELT"] , _
+ ["setUnion", "UNION"] , _
+ ["size", "SIZE"] , _
+ ["strconc", "CONCAT"] , _
+ ["substitute", "SUBST"] , _
+ ["take", "TAKE"] , _
+ ["true", "T"] , _
+ ["PLUS", "+"] , _
+ ["MINUS", "-"] , _
+ ["TIMES", "*"] , _
+ ["POWER", "EXPT"] , _
+ ["SLASH", "/"] , _
+ ["LT", "<"], _
+ ["GT", ">"] , _
+ ["LE", "<="], _
+ ["GE", ">="], _
+ ["SHOEEQ", "EQUAL"], _
+ ["SHOENE", "/="], _
+ ["T", "T$"] _
+ ]
+ repeat SETF (GET(CAR i,'SHOERENAME),CDR i)
+
+-- For code written in `Old Boot', we would like to warn about
+-- the difference in renaming.
+for i in [ _
+ ["PLUS", "PLUS"], _
+ ["and", "AND"], _
+ ["append", "APPEND"], _
+ ["apply", "APPLY"], _
+ ["atom", "ATOM"], _
+ ["brace", "REMDUP"], _
+ ["car", "CAR"], _
+ ["cdr", "CDR"], _
+ ["cons", "CONS"], _
+ ["copy", "COPY"], _
+ ["croak", "CROAK"], _
+ ["drop", "DROP"], _
+ ["exit", "EXIT"], _
+ ["false", "NIL"], _
+ ["first", "CAR"], _
+ ["genvar", "GENVAR"], _
+ ["in", "member"], _
+ ["is", "IS"], _
+ ["lastNode", "LASTNODE"], _
+ ["list", "LIST"], _
+ ["mkpf", "MKPF"], _
+ ["nconc", "NCONC"], _
+ ["nil", "NIL"], _
+ ["not", "NULL"], _
+ ["NOT", "NULL"], _
+ ["nreverse", "NREVERSE"], _
+ ["null", "NULL"], _
+ ["or", "OR"], _
+ ["otherwise", "T"], _
+ ["removeDuplicates", "REMDUP"], _
+ ["rest", "CDR"], _
+ ["return", "RETURN"], _
+ ["reverse", "REVERSE"], _
+ ["setDifference", "SETDIFFERENCE"], _
+ ["setIntersection", "intersection"], _
+ ["setPart", "SETELT"], _
+ ["setUnion", "union"], _
+ ["size", "SIZE"], _
+ ["strconc", "STRCONC"], _
+ ["substitute", "MSUBST"], _
+ ["SUBST", "MSUBST"], _
+ ["take", "TAKE"], _
+ ["true", "T"], _
+ ["where", "WHERE"], _
+ ["TIMES", "TIMES"], _
+ ["POWER", "EXPT"], _
+ ["NOT", "NULL"], _
+ ["SHOENE", "NEQUAL"], _
+ ["MINUS", "SPADDIFFERENCE"], _
+ ["SLASH", "QUOTIENT"], _
+ ["=", "EQUAL"], _
+ ["SHOEEQ", "EQUAL"], _
+ ["ASSOC", "assoc"], _
+ ["DELETE", "delete"], _
+ ["GET", "GETL"], _
+ ["INTERSECTION", "intersection"], _
+ ["LAST", "last"], _
+ ["MEMBER", "member"], _
+ ["RASSOC", "rassoc"], _
+ ["READ", "VMREAD"], _
+ ["READ-LINE", "read-line"], _
+ ["REDUCE", "SPADREDUCE"], _
+ ["REMOVE", "remove"], _
+ ["BAR", "SUCHTHAT"], _
+ ["T", "T$"], _
+ ["IN", "member"], _
+ ["UNION", "union"]_
+ ]
+ repeat SETF (GET(CAR i,'OLD_-BOOT),CDR i)
+
+-- The following difference in renaming are verified to be OK.
+for i in [ _
+ "LT", "LE", _
+ "GT", "GE", _
+ "SHOENE", _
+ "TIMES", "PLUS", _
+ "MINUS", "function",_
+ "PAIRP"
+ ]
+ repeat SETF(GET(i, 'RENAME_-OK), true)
+
+
+
+for i in [ _
+ ["setName", 0] , _
+ ["setLabel", 1] , _
+ ["setLevel", 2] , _
+ ["setType", 3] , _
+ ["setVar", 4] , _
+ ["setLeaf", 5] , _
+ ["setDef", 6] , _
+ ["aGeneral", 4] , _
+ ["aMode", 1] , _
+ ["aModeSet", 3] , _
+ ["aTree", 0] , _
+ ["aValue", 2] , _
+ ["attributes", "CADDR"] , _
+ ["cacheCount", "CADDDDR"] , _
+ ["cacheName", "CADR"] , _
+ ["cacheReset", "CADDDR"] , _
+ ["cacheType", "CADDR"] , _
+ ["env", "CADDR"] , _
+ ["expr", "CAR"] , _
+ ["CAR", "CAR"] , _
+ ["mmCondition", "CAADR"] , _
+ ["mmDC", "CAAR"] , _
+ ["mmImplementation","CADADR"] , _
+ ["mmSignature", "CDAR"] , _
+ ["mmTarget", "CADAR"] , _
+ ["mode", "CADR"] , _
+ ["op", "CAR"] , _
+ ["opcode", "CADR"] , _
+ ["opSig", "CADR"] , _
+ ["CDR", "CDR"] , _
+ ["sig", "CDDR"] , _
+ ["source", "CDR"] , _
+ ["streamCode", "CADDDR"] , _
+ ["streamDef", "CADDR"] , _
+ ["streamName", "CADR"] , _
+ ["target", "CAR"] _
+ ] _
+ repeat SETF (GET(CAR i,'SHOESELFUNCTION),CADR i)
diff --git a/src/boot/tokens.boot.pamphlet b/src/boot/tokens.boot.pamphlet
deleted file mode 100644
index bb4d7ec2..00000000
--- a/src/boot/tokens.boot.pamphlet
+++ /dev/null
@@ -1,897 +0,0 @@
-\documentclass{article}
-\usepackage{axiom}
-
-\title{\File{src/boot/tokens.boot} Pamphlet}
-\author{The Axiom Team}
-
-\begin{document}
-\maketitle
-
-\begin{abstract}
-\end{abstract}
-
-\tableofcontents
-\eject
-
-
-\section{License}
-
-<<license>>=
--- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
--- 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.
---
--- - Neither the name of The Numerical ALgorithms Group Ltd. nor the
--- names of its contributors may be used to endorse or promote products
--- derived from this software without specific prior written permission.
---
--- 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 OWNER
--- 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.
-@
-
-
-\section{Key words}
-\label{sec:boot:key-words}
-
-The following tokens are reserved as Boot key words:
-\begin{center}
-\begin{tabular}{lllllll}
- \Code{and} & \Code{by} & \Code{case} &
- \Code{cross} & \Code{else} & \Code{for} & \Code{if}
- \\
- \Code{import} & \Code{in} & \Code{is} &
- \Code{isnt} & \Code{module} & \Code{of} & \Code{or}
- \\
- \Code{repeat} &\Code{return} & \Code{structure} &
- \Code{then} & \Code{until} & \Code{where} & \Code{while}
- \\
- \Code{.} & \Code{:} & \Code{::} &
- \Code{,} & \Code{;} & \Code{*} & \Code{**}
- \\
- \Code{/} & \Code{+} & \Code{-} &
- \Code{<} & \Code{>} & \Code{<=} & \Code{>=}
- \\
- \Code{=} & \Code{\^} & \verb!\^=! &
- \Code{..} & \Code{\#} & \Code{=>} & \Code{:=}
- \\
- \Code{==} & \Code{==>} & \Code{(} &
- \Code{)} & \Code{[} & \Code{]} & \Code{'}
- \\
- \Code{|}
-\end{tabular}
-\end{center}
-
-
-\section{Prefix operators}
-\label{sec:boot:prefix-ops}
-
-The following key words designate prefix operators
-\begin{center}
- \begin{tabular}{ll}
- \Code{not} & \Code{\#}
- \end{tabular}
-\end{center}
-
-
-\section{Infix operators}
-\label{sec:boot:infix-ops}
-
-The following key words designate infix operators
-\begin{center}
- \begin{tabular}{llllll}
- \Code{=} & \Code{*} & \Code{+} & \Code{is} & \Code{isnt} & \Code{and}
- \\
- \Code{or} & \Code{/} & \Code{**} & \Code{-} & \Code{<} & \Code{>}
- \\
- & \Code{<=} & \Code{>=} & \verb!^=!
- \end{tabular}
-\end{center}
-
-
-\section{Monoid operations and reduction}
-\label{sec:boot:monoid-ops}
-
-Some Boot standard operations are monoid functions, therefore
-usable as operand to the reduction functional. We list below
-all such Boot standard operations, along with their neutral elements.
-\begin{center}
- \begin{tabular}{|ll|ll|ll|}
- \hline
- Operation & Unit & Operation & Unit & Operation & Unit
- \\
- \hline
- \Code{+} & \Code{0} &
- \Code{gdc} & \Code{0} &
- \Code{lcm} & \Code{1}
- \\
- \Code{STRCONC} & \Code{""} &
- \Code{strconc} & \Code{""} &
- \Code{MAX} & \Code{-999999}
- \\
- \Code{MIN} & \Code{999999} &
- \Code{*} & \Code{1} &
- \Code{times} & \Code{1}
- \\
- \Code{CONS} & \Code{nil} &
- \Code{APPEND} & \Code{nil} &
- \Code{append} & \Code{nil}
- \\
- \Code{UNION} & \Code{nil} &
- \Code{UNIONQ} & \Code{nil} &
- \Code{union} & \Code{nil}
- \\
- \Code{NCONC} & \Code{nil} &
- \Code{and} & \Code{true} &
- \Code{or} & \Code{false}
- \\
- \Code{AND} & \Code{true} &
- \Code{OR} & \Code{false} &
- \\
- \hline
- \end{tabular}
-\end{center}
-
-Note that \Code{CONS} is not a monoid operation; it however supports
-right reduction.
-
-
-
-
-\section{Putting everything together}
-
-<<*>>=
-<<license>>
-
-module '"boot-tokens"
-import '"initial-env"
-
-)package "BOOTTRAN"
-
-shoeKeyWords := [ _
- ['"and","AND"] , _
- ['"by", "BY" ], _
- ['"case","CASE"] , _
- ['"cross","CROSS"] , _
- ['"else", "ELSE"] , _
- ['"for", "FOR"] , _
- ['"if", "IF"], _
- ['"import", "IMPORT"], _
- ['"in", "IN" ], _
- ['"is", "IS"], _
- ['"isnt", "ISNT"] , _
- ['"module", "MODULE"], _
- ['"of", "OF"] , _
- ['"or", "OR"] , _
- ['"repeat", "REPEAT"] , _
- ['"return", "RETURN"], _
- ['"structure", "STRUCTURE"], _
- ['"then", "THEN"], _
- ['"until", "UNTIL"], _
- ['"where", "WHERE"], _
- ['"while", "WHILE"], _
- ['".", "DOT"], _
- ['":", "COLON"], _
- ['"::", "COLON-COLON"], _
- ['",", "COMMA"], _
- ['";", "SEMICOLON"], _
- ['"*", "TIMES"], _
- ['"**", "POWER"], _
- ['"/", "SLASH"], _
- ['"+", "PLUS"], _
- ['"-", "MINUS"], _
- ['"<", "LT"], _
- ['">", "GT"] , _
- ['"<=","LE" ], _
- ['">=","GE" ], _
- ['"=", "SHOEEQ"], _
- ['"^", "NOT"], _
- ['"^=","SHOENE" ], _
- ['"..","SEG" ], _
- ['"#", "LENGTH"], _
- ['"=>","EXIT" ], _
- ['"->", "ARROW"],_
- ['":=", "BEC"], _
- ['"==", "DEF"], _
- ['"==>","MDEF" ], _
- ['"<=>", "TDEF"], _
- ['"(", "OPAREN"], _
- ['")", "CPAREN"], _
- ['"(|", "OBRACK"], _
- ['"|)", "CBRACK"], _
- ['"[", "OBRACK"], _
- ['"]", "CBRACK"], _
- ['"suchthat","BAR"], _
- ['"'", "QUOTE"], _
- ['"|", "BAR"] ]
-
-
-
-shoeKeyTableCons()==
- KeyTable:=MAKE_-HASHTABLE("CVEC")
- for st in shoeKeyWords repeat
- HPUT(KeyTable,CAR st,CADR st)
- KeyTable
-
-shoeKeyTable:=shoeKeyTableCons()
-
-shoeSPACE := QENUM('" ", 0)
-
-shoeESCAPE := QENUM('"__ ", 0)
-shoeLispESCAPE := QENUM('"! ", 0)
-
-shoeSTRING_CHAR := QENUM('"_" ", 0)
-
-shoePLUSCOMMENT := QENUM('"+ ", 0)
-
-shoeMINUSCOMMENT:= QENUM('"- ", 0)
-
-shoeDOT := QENUM('". ", 0)
-
-shoeEXPONENT1 := QENUM('"E ", 0)
-
-shoeEXPONENT2 := QENUM('"e ", 0)
-
-shoeCLOSEPAREN := QENUM('") ", 0)
-
---shoeCLOSEANGLE := QENUM('"> ", 0)
-shoeTAB := 9
-
-shoeInsert(s,d) ==
- l := #s
- h := QENUM(s,0)
- u := ELT(d,h)
- n := #u
- k:=0
- while l <= #(ELT(u,k)) repeat
- k:=k+1
- v := MAKE_-VEC(n+1)
- for i in 0..k-1 repeat VEC_-SETELT(v,i,ELT(u,i))
- VEC_-SETELT(v,k,s)
- for i in k..n-1 repeat VEC_-SETELT(v,i+1,ELT(u,i))
- VEC_-SETELT(d,h,v)
- s
-
-shoeDictCons()==
- l:= HKEYS shoeKeyTable
- d :=
- a:=MAKE_-VEC(256)
- b:=MAKE_-VEC(1)
- VEC_-SETELT(b,0,MAKE_-CVEC 0)
- for i in 0..255 repeat VEC_-SETELT(a,i,b)
- a
- for s in l repeat shoeInsert(s,d)
- d
-
-shoeDict:=shoeDictCons()
-
-
-shoePunCons()==
- listing := HKEYS shoeKeyTable
- a:=MAKE_-BVEC 256
- for i in 0..255 repeat BVEC_-SETELT(a,i,0)
- for k in listing repeat
- if not shoeStartsId k.0
- then BVEC_-SETELT(a,QENUM(k,0),1)
- a
-
-shoePun:=shoePunCons()
-
-for i in [ _
- "NOT", _
--- "COLON", _
--- "SHOEEQ", _
- "LENGTH" _
- ] _
- repeat SETF (GET(i,'SHOEPRE),'T)
-
-for i in [ _
- ["SHOEEQ" ,"="], _
- ["TIMES" ,"*"], _
- ["PLUS" ,"+"], _
- ["IS" ,"is"], _
- ["ISNT" ,"isnt"], _
- ["AND" ,"and"], _
- ["OR" ,"or"], _
- ["SLASH" ,"/"], _
- ["POWER" ,"**"], _
- ["MINUS" ,"-"], _
- ["LT" ,"<"], _
- ["GT" ,">"], _
- ["LE" ,"<="], _
- ["GE" ,">="], _
- ["SHOENE" ,"^="] _
- ]_
- repeat SETF (GET(CAR i,'SHOEINF),CADR i)
-
-
-for i in [ _
- ["+", 0] , _
- ["gcd", 0] , _
- ["lcm", 1] , _
- ["STRCONC", '""] , _
- ["strconc", '""] , _
- ["MAX", -999999] , _
- ["MIN", 999999] , _
- ["*", 1] , _
- ["times", 1] , _
- ["CONS", NIL] , _
- ["APPEND", NIL] , _
- ["append", NIL] , _
- ["UNION", NIL] , _
- ["UNIONQ", NIL] , _
- ["union", NIL] , _
- ["NCONC", NIL] , _
- ["and", 'T] , _
- ["or", NIL] , _
- ["AND", 'T] , _
- ["OR", NIL] _
- ]
-
- repeat SETF (GET(CAR i,'SHOETHETA),CDR i)
-for i in [ _
- ["and", "AND"] , _
- ["append", "APPEND"] , _
- ["apply", "APPLY"] , _
- ["atom", "ATOM"] , _
- ["car", "CAR"] , _
- ["cdr", "CDR"] , _
- ["cons", "CONS"] , _
- ["copy", "COPY"] , _
- ["croak", "CROAK"] , _
- ["drop", "DROP"] , _
- ["exit", "EXIT"] , _
- ["false", 'NIL] , _
- ["first", "CAR"] , _
- ["function","FUNCTION"] , _
- ["genvar", "GENVAR"] , _
- ["IN", "MEMBER"] , _
- ["is", "IS"] , _
- ["isnt", "ISNT"] , _
- ["lastNode", "LAST"] , _
- ["LAST", "last"] , _
- ["list", "LIST"] , _
--- ["member", "MEMBER"] , _
- ["mkpf", "MKPF"] , _
- ["nconc", "NCONC"] , _
- ["nil" ,NIL ] , _
- ["not", "NULL"] , _
- ["NOT", "NULL"] , _
- ["nreverse", "NREVERSE"] , _
- ["null", "NULL"] , _
- ["or", "OR"] , _
- ["otherwise", "T"] , _
- ["PAIRP", "CONSP"] , _
- ["removeDuplicates", "REMDUP"] , _
- ["rest", "CDR"] , _
- ["reverse", "REVERSE"] , _
- ["setDifference", "SETDIFFERENCE"] , _
- ["setIntersection", "INTERSECTION"] , _
- ["setPart", "SETELT"] , _
- ["setUnion", "UNION"] , _
- ["size", "SIZE"] , _
- ["strconc", "CONCAT"] , _
- ["substitute", "SUBST"] , _
- ["take", "TAKE"] , _
- ["true", "T"] , _
- ["PLUS", "+"] , _
- ["MINUS", "-"] , _
- ["TIMES", "*"] , _
- ["POWER", "EXPT"] , _
- ["SLASH", "/"] , _
- ["LT", "<"], _
- ["GT", ">"] , _
- ["LE", "<="], _
- ["GE", ">="], _
- ["SHOEEQ", "EQUAL"], _
- ["SHOENE", "/="], _
- ["T", "T$"] _
- ]
- repeat SETF (GET(CAR i,'SHOERENAME),CDR i)
-
--- For code written in `Old Boot', we would like to warn about
--- the difference in renaming.
-for i in [ _
- ["PLUS", "PLUS"], _
- ["and", "AND"], _
- ["append", "APPEND"], _
- ["apply", "APPLY"], _
- ["atom", "ATOM"], _
- ["brace", "REMDUP"], _
- ["car", "CAR"], _
- ["cdr", "CDR"], _
- ["cons", "CONS"], _
- ["copy", "COPY"], _
- ["croak", "CROAK"], _
- ["drop", "DROP"], _
- ["exit", "EXIT"], _
- ["false", "NIL"], _
- ["first", "CAR"], _
- ["genvar", "GENVAR"], _
- ["in", "member"], _
- ["is", "IS"], _
- ["lastNode", "LASTNODE"], _
- ["list", "LIST"], _
- ["mkpf", "MKPF"], _
- ["nconc", "NCONC"], _
- ["nil", "NIL"], _
- ["not", "NULL"], _
- ["NOT", "NULL"], _
- ["nreverse", "NREVERSE"], _
- ["null", "NULL"], _
- ["or", "OR"], _
- ["otherwise", "T"], _
- ["removeDuplicates", "REMDUP"], _
- ["rest", "CDR"], _
- ["return", "RETURN"], _
- ["reverse", "REVERSE"], _
- ["setDifference", "SETDIFFERENCE"], _
- ["setIntersection", "intersection"], _
- ["setPart", "SETELT"], _
- ["setUnion", "union"], _
- ["size", "SIZE"], _
- ["strconc", "STRCONC"], _
- ["substitute", "MSUBST"], _
- ["SUBST", "MSUBST"], _
- ["take", "TAKE"], _
- ["true", "T"], _
- ["where", "WHERE"], _
- ["TIMES", "TIMES"], _
- ["POWER", "EXPT"], _
- ["NOT", "NULL"], _
- ["SHOENE", "NEQUAL"], _
- ["MINUS", "SPADDIFFERENCE"], _
- ["SLASH", "QUOTIENT"], _
- ["=", "EQUAL"], _
- ["SHOEEQ", "EQUAL"], _
- ["ASSOC", "assoc"], _
- ["DELETE", "delete"], _
- ["GET", "GETL"], _
- ["INTERSECTION", "intersection"], _
- ["LAST", "last"], _
- ["MEMBER", "member"], _
- ["RASSOC", "rassoc"], _
- ["READ", "VMREAD"], _
- ["READ-LINE", "read-line"], _
- ["REDUCE", "SPADREDUCE"], _
- ["REMOVE", "remove"], _
- ["BAR", "SUCHTHAT"], _
- ["T", "T$"], _
- ["IN", "member"], _
- ["UNION", "union"]_
- ]
- repeat SETF (GET(CAR i,'OLD_-BOOT),CDR i)
-
--- The following difference in renaming are verified to be OK.
-for i in [ _
- "LT", "LE", _
- "GT", "GE", _
- "SHOENE", _
- "TIMES", "PLUS", _
- "MINUS", "function",_
- "PAIRP"
- ]
- repeat SETF(GET(i, 'RENAME_-OK), true)
-
-
-
-for i in [ _
- ["setName", 0] , _
- ["setLabel", 1] , _
- ["setLevel", 2] , _
- ["setType", 3] , _
- ["setVar", 4] , _
- ["setLeaf", 5] , _
- ["setDef", 6] , _
- ["aGeneral", 4] , _
- ["aMode", 1] , _
- ["aModeSet", 3] , _
- ["aTree", 0] , _
- ["aValue", 2] , _
- ["attributes", "CADDR"] , _
- ["cacheCount", "CADDDDR"] , _
- ["cacheName", "CADR"] , _
- ["cacheReset", "CADDDR"] , _
- ["cacheType", "CADDR"] , _
- ["env", "CADDR"] , _
- ["expr", "CAR"] , _
- ["CAR", "CAR"] , _
- ["mmCondition", "CAADR"] , _
- ["mmDC", "CAAR"] , _
- ["mmImplementation","CADADR"] , _
- ["mmSignature", "CDAR"] , _
- ["mmTarget", "CADAR"] , _
- ["mode", "CADR"] , _
- ["op", "CAR"] , _
- ["opcode", "CADR"] , _
- ["opSig", "CADR"] , _
- ["CDR", "CDR"] , _
- ["sig", "CDDR"] , _
- ["source", "CDR"] , _
- ["streamCode", "CADDDR"] , _
- ["streamDef", "CADDR"] , _
- ["streamName", "CADR"] , _
- ["target", "CAR"] _
- ] _
- repeat SETF (GET(CAR i,'SHOESELFUNCTION),CADR i)
-@
-
-<<tokens.clisp>>=
-(EVAL-WHEN (:COMPILE-TOPLEVEL) (PROVIDE "boot-tokens"))
-
-(IMPORT-MODULE "initial-env")
-
-(IN-PACKAGE "BOOTTRAN")
-
-(DEFPARAMETER |shoeKeyWords|
- (LIST (LIST "and" 'AND) (LIST "by" 'BY) (LIST "case" 'CASE)
- (LIST "cross" 'CROSS) (LIST "else" 'ELSE) (LIST "for" 'FOR)
- (LIST "if" 'IF) (LIST "import" 'IMPORT) (LIST "in" 'IN)
- (LIST "is" 'IS) (LIST "isnt" 'ISNT) (LIST "module" 'MODULE)
- (LIST "of" 'OF) (LIST "or" 'OR) (LIST "repeat" 'REPEAT)
- (LIST "return" 'RETURN) (LIST "structure" 'STRUCTURE)
- (LIST "then" 'THEN) (LIST "until" 'UNTIL)
- (LIST "where" 'WHERE) (LIST "while" 'WHILE) (LIST "." 'DOT)
- (LIST ":" 'COLON) (LIST "::" 'COLON-COLON) (LIST "," 'COMMA)
- (LIST ";" 'SEMICOLON) (LIST "*" 'TIMES) (LIST "**" 'POWER)
- (LIST "/" 'SLASH) (LIST "+" 'PLUS) (LIST "-" 'MINUS)
- (LIST "<" 'LT) (LIST ">" 'GT) (LIST "<=" 'LE) (LIST ">=" 'GE)
- (LIST "=" 'SHOEEQ) (LIST "^" 'NOT) (LIST "^=" 'SHOENE)
- (LIST ".." 'SEG) (LIST "#" 'LENGTH) (LIST "=>" 'EXIT)
- (LIST ":=" 'BEC) (LIST "==" 'DEF) (LIST "==>" 'MDEF)
- (LIST "<=>" 'TDEF) (LIST "(" 'OPAREN) (LIST ")" 'CPAREN)
- (LIST "(|" 'OBRACK) (LIST "|)" 'CBRACK) (LIST "[" 'OBRACK)
- (LIST "]" 'CBRACK) (LIST "suchthat" 'BAR) (LIST "'" 'QUOTE)
- (LIST "|" 'BAR)))
-
-(DEFUN |shoeKeyTableCons| ()
- (PROG (|KeyTable|)
- (RETURN
- (PROGN
- (SETQ |KeyTable| (MAKE-HASHTABLE 'CVEC))
- (LET ((|bfVar#1| |shoeKeyWords|) (|st| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#1|)
- (PROGN (SETQ |st| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- ('T (HPUT |KeyTable| (CAR |st|) (CADR |st|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- |KeyTable|))))
-
-(DEFPARAMETER |shoeKeyTable| (|shoeKeyTableCons|))
-
-(DEFPARAMETER |shoeSPACE| (QENUM " " 0))
-
-(DEFPARAMETER |shoeESCAPE| (QENUM "_ " 0))
-
-(DEFPARAMETER |shoeLispESCAPE| (QENUM "! " 0))
-
-(DEFPARAMETER |shoeSTRINGCHAR| (QENUM "\" " 0))
-
-(DEFPARAMETER |shoePLUSCOMMENT| (QENUM "+ " 0))
-
-(DEFPARAMETER |shoeMINUSCOMMENT| (QENUM "- " 0))
-
-(DEFPARAMETER |shoeDOT| (QENUM ". " 0))
-
-(DEFPARAMETER |shoeEXPONENT1| (QENUM "E " 0))
-
-(DEFPARAMETER |shoeEXPONENT2| (QENUM "e " 0))
-
-(DEFPARAMETER |shoeCLOSEPAREN| (QENUM ") " 0))
-
-(DEFPARAMETER |shoeTAB| 9)
-
-(DEFUN |shoeInsert| (|s| |d|)
- (PROG (|v| |k| |n| |u| |h| |l|)
- (RETURN
- (PROGN
- (SETQ |l| (LENGTH |s|))
- (SETQ |h| (QENUM |s| 0))
- (SETQ |u| (ELT |d| |h|))
- (SETQ |n| (LENGTH |u|))
- (SETQ |k| 0)
- (LOOP
- (COND
- ((< (LENGTH (ELT |u| |k|)) |l|) (RETURN NIL))
- (#0='T (SETQ |k| (+ |k| 1)))))
- (SETQ |v| (MAKE-VEC (+ |n| 1)))
- (LET ((|bfVar#2| (- |k| 1)) (|i| 0))
- (LOOP
- (COND
- ((> |i| |bfVar#2|) (RETURN NIL))
- (#0# (VEC-SETELT |v| |i| (ELT |u| |i|))))
- (SETQ |i| (+ |i| 1))))
- (VEC-SETELT |v| |k| |s|)
- (LET ((|bfVar#3| (- |n| 1)) (|i| |k|))
- (LOOP
- (COND
- ((> |i| |bfVar#3|) (RETURN NIL))
- (#0# (VEC-SETELT |v| (+ |i| 1) (ELT |u| |i|))))
- (SETQ |i| (+ |i| 1))))
- (VEC-SETELT |d| |h| |v|)
- |s|))))
-
-(DEFUN |shoeDictCons| ()
- (PROG (|d| |b| |a| |l|)
- (RETURN
- (PROGN
- (SETQ |l| (HKEYS |shoeKeyTable|))
- (SETQ |d|
- (PROGN
- (SETQ |a| (MAKE-VEC 256))
- (SETQ |b| (MAKE-VEC 1))
- (VEC-SETELT |b| 0 (MAKE-CVEC 0))
- (LET ((|i| 0))
- (LOOP
- (COND
- ((> |i| 255) (RETURN NIL))
- (#0='T (VEC-SETELT |a| |i| |b|)))
- (SETQ |i| (+ |i| 1))))
- |a|))
- (LET ((|bfVar#4| |l|) (|s| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#4|)
- (PROGN (SETQ |s| (CAR |bfVar#4|)) NIL))
- (RETURN NIL))
- (#0# (|shoeInsert| |s| |d|)))
- (SETQ |bfVar#4| (CDR |bfVar#4|))))
- |d|))))
-
-(DEFPARAMETER |shoeDict| (|shoeDictCons|))
-
-(DEFUN |shoePunCons| ()
- (PROG (|a| |listing|)
- (RETURN
- (PROGN
- (SETQ |listing| (HKEYS |shoeKeyTable|))
- (SETQ |a| (MAKE-BVEC 256))
- (LET ((|i| 0))
- (LOOP
- (COND
- ((> |i| 255) (RETURN NIL))
- (#0='T (BVEC-SETELT |a| |i| 0)))
- (SETQ |i| (+ |i| 1))))
- (LET ((|bfVar#5| |listing|) (|k| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#5|)
- (PROGN (SETQ |k| (CAR |bfVar#5|)) NIL))
- (RETURN NIL))
- (#0#
- (COND
- ((NULL (|shoeStartsId| (ELT |k| 0)))
- (BVEC-SETELT |a| (QENUM |k| 0) 1)))))
- (SETQ |bfVar#5| (CDR |bfVar#5|))))
- |a|))))
-
-(DEFPARAMETER |shoePun| (|shoePunCons|))
-
-(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL)
- (PROG ()
- (RETURN
- (LET ((|bfVar#6| (LIST 'NOT 'LENGTH)) (|i| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#6|)
- (PROGN (SETQ |i| (CAR |bfVar#6|)) NIL))
- (RETURN NIL))
- ('T (SETF (GET |i| 'SHOEPRE) 'T)))
- (SETQ |bfVar#6| (CDR |bfVar#6|)))))))
-
-(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL)
- (PROG ()
- (RETURN
- (LET ((|bfVar#7|
- (LIST (LIST 'SHOEEQ '=) (LIST 'TIMES '*)
- (LIST 'PLUS '+) (LIST 'IS '|is|)
- (LIST 'ISNT '|isnt|) (LIST 'AND '|and|)
- (LIST 'OR '|or|) (LIST 'SLASH '/)
- (LIST 'POWER '**) (LIST 'MINUS '-) (LIST 'LT '<)
- (LIST 'GT '>) (LIST 'LE '<=) (LIST 'GE '>=)
- (LIST 'SHOENE '^=)))
- (|i| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#7|)
- (PROGN (SETQ |i| (CAR |bfVar#7|)) NIL))
- (RETURN NIL))
- ('T (SETF (GET (CAR |i|) 'SHOEINF) (CADR |i|))))
- (SETQ |bfVar#7| (CDR |bfVar#7|)))))))
-
-(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL)
- (PROG ()
- (RETURN
- (LET ((|bfVar#8|
- (LIST (LIST '+ 0) (LIST '|gcd| 0) (LIST '|lcm| 1)
- (LIST 'STRCONC "") (LIST '|strconc| "")
- (LIST 'MAX (- 999999)) (LIST 'MIN 999999)
- (LIST '* 1) (LIST '|times| 1) (LIST 'CONS NIL)
- (LIST 'APPEND NIL) (LIST '|append| NIL)
- (LIST 'UNION NIL) (LIST 'UNIONQ NIL)
- (LIST '|union| NIL) (LIST 'NCONC NIL)
- (LIST '|and| 'T) (LIST '|or| NIL) (LIST 'AND 'T)
- (LIST 'OR NIL)))
- (|i| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#8|)
- (PROGN (SETQ |i| (CAR |bfVar#8|)) NIL))
- (RETURN NIL))
- ('T (SETF (GET (CAR |i|) 'SHOETHETA) (CDR |i|))))
- (SETQ |bfVar#8| (CDR |bfVar#8|)))))))
-
-(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL)
- (PROG ()
- (RETURN
- (LET ((|bfVar#9|
- (LIST (LIST '|and| 'AND) (LIST '|append| 'APPEND)
- (LIST '|apply| 'APPLY) (LIST '|atom| 'ATOM)
- (LIST '|car| 'CAR) (LIST '|cdr| 'CDR)
- (LIST '|cons| 'CONS) (LIST '|copy| 'COPY)
- (LIST '|croak| 'CROAK) (LIST '|drop| 'DROP)
- (LIST '|exit| 'EXIT) (LIST '|false| 'NIL)
- (LIST '|first| 'CAR) (LIST '|function| 'FUNCTION)
- (LIST '|genvar| 'GENVAR) (LIST 'IN 'MEMBER)
- (LIST '|is| 'IS) (LIST '|isnt| 'ISNT)
- (LIST '|lastNode| 'LAST) (LIST 'LAST '|last|)
- (LIST '|list| 'LIST) (LIST '|mkpf| 'MKPF)
- (LIST '|nconc| 'NCONC) (LIST '|nil| NIL)
- (LIST '|not| 'NULL) (LIST 'NOT 'NULL)
- (LIST '|nreverse| 'NREVERSE) (LIST '|null| 'NULL)
- (LIST '|or| 'OR) (LIST '|otherwise| 'T)
- (LIST 'PAIRP 'CONSP)
- (LIST '|removeDuplicates| 'REMDUP)
- (LIST '|rest| 'CDR) (LIST '|reverse| 'REVERSE)
- (LIST '|setDifference| 'SETDIFFERENCE)
- (LIST '|setIntersection| 'INTERSECTION)
- (LIST '|setPart| 'SETELT)
- (LIST '|setUnion| 'UNION) (LIST '|size| 'SIZE)
- (LIST '|strconc| 'CONCAT)
- (LIST '|substitute| 'SUBST) (LIST '|take| 'TAKE)
- (LIST '|true| 'T) (LIST 'PLUS '+)
- (LIST 'MINUS '-) (LIST 'TIMES '*)
- (LIST 'POWER 'EXPT) (LIST 'SLASH '/)
- (LIST 'LT '<) (LIST 'GT '>) (LIST 'LE '<=)
- (LIST 'GE '>=) (LIST 'SHOEEQ 'EQUAL)
- (LIST 'SHOENE '/=) (LIST 'T 'T$)))
- (|i| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#9|)
- (PROGN (SETQ |i| (CAR |bfVar#9|)) NIL))
- (RETURN NIL))
- ('T (SETF (GET (CAR |i|) 'SHOERENAME) (CDR |i|))))
- (SETQ |bfVar#9| (CDR |bfVar#9|)))))))
-
-(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL)
- (PROG ()
- (RETURN
- (LET ((|bfVar#10|
- (LIST (LIST 'PLUS 'PLUS) (LIST '|and| 'AND)
- (LIST '|append| 'APPEND) (LIST '|apply| 'APPLY)
- (LIST '|atom| 'ATOM) (LIST '|brace| 'REMDUP)
- (LIST '|car| 'CAR) (LIST '|cdr| 'CDR)
- (LIST '|cons| 'CONS) (LIST '|copy| 'COPY)
- (LIST '|croak| 'CROAK) (LIST '|drop| 'DROP)
- (LIST '|exit| 'EXIT) (LIST '|false| 'NIL)
- (LIST '|first| 'CAR) (LIST '|genvar| 'GENVAR)
- (LIST '|in| '|member|) (LIST '|is| 'IS)
- (LIST '|lastNode| 'LASTNODE) (LIST '|list| 'LIST)
- (LIST '|mkpf| 'MKPF) (LIST '|nconc| 'NCONC)
- (LIST '|nil| 'NIL) (LIST '|not| 'NULL)
- (LIST 'NOT 'NULL) (LIST '|nreverse| 'NREVERSE)
- (LIST '|null| 'NULL) (LIST '|or| 'OR)
- (LIST '|otherwise| 'T)
- (LIST '|removeDuplicates| 'REMDUP)
- (LIST '|rest| 'CDR) (LIST '|return| 'RETURN)
- (LIST '|reverse| 'REVERSE)
- (LIST '|setDifference| 'SETDIFFERENCE)
- (LIST '|setIntersection| '|intersection|)
- (LIST '|setPart| 'SETELT)
- (LIST '|setUnion| '|union|) (LIST '|size| 'SIZE)
- (LIST '|strconc| 'STRCONC)
- (LIST '|substitute| 'MSUBST)
- (LIST 'SUBST 'MSUBST) (LIST '|take| 'TAKE)
- (LIST '|true| 'T) (LIST '|where| 'WHERE)
- (LIST 'TIMES 'TIMES) (LIST 'POWER 'EXPT)
- (LIST 'NOT 'NULL) (LIST 'SHOENE 'NEQUAL)
- (LIST 'MINUS 'SPADDIFFERENCE)
- (LIST 'SLASH 'QUOTIENT) (LIST '= 'EQUAL)
- (LIST 'SHOEEQ 'EQUAL) (LIST 'ASSOC '|assoc|)
- (LIST 'DELETE '|delete|) (LIST 'GET 'GETL)
- (LIST 'INTERSECTION '|intersection|)
- (LIST 'LAST '|last|) (LIST 'MEMBER '|member|)
- (LIST 'RASSOC '|rassoc|) (LIST 'READ 'VMREAD)
- (LIST 'READ-LINE '|read-line|)
- (LIST 'REDUCE 'SPADREDUCE)
- (LIST 'REMOVE '|remove|) (LIST 'BAR 'SUCHTHAT)
- (LIST 'T 'T$) (LIST 'IN '|member|)
- (LIST 'UNION '|union|)))
- (|i| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#10|)
- (PROGN (SETQ |i| (CAR |bfVar#10|)) NIL))
- (RETURN NIL))
- ('T (SETF (GET (CAR |i|) 'OLD-BOOT) (CDR |i|))))
- (SETQ |bfVar#10| (CDR |bfVar#10|)))))))
-
-(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL)
- (PROG ()
- (RETURN
- (LET ((|bfVar#11|
- (LIST 'LT 'LE 'GT 'GE 'SHOENE 'TIMES 'PLUS 'MINUS
- '|function| 'PAIRP))
- (|i| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#11|)
- (PROGN (SETQ |i| (CAR |bfVar#11|)) NIL))
- (RETURN NIL))
- ('T (SETF (GET |i| 'RENAME-OK) T)))
- (SETQ |bfVar#11| (CDR |bfVar#11|)))))))
-
-(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL)
- (PROG ()
- (RETURN
- (LET ((|bfVar#12|
- (LIST (LIST '|setName| 0) (LIST '|setLabel| 1)
- (LIST '|setLevel| 2) (LIST '|setType| 3)
- (LIST '|setVar| 4) (LIST '|setLeaf| 5)
- (LIST '|setDef| 6) (LIST '|aGeneral| 4)
- (LIST '|aMode| 1) (LIST '|aModeSet| 3)
- (LIST '|aTree| 0) (LIST '|aValue| 2)
- (LIST '|attributes| 'CADDR)
- (LIST '|cacheCount| 'CADDDDR)
- (LIST '|cacheName| 'CADR)
- (LIST '|cacheReset| 'CADDDR)
- (LIST '|cacheType| 'CADDR) (LIST '|env| 'CADDR)
- (LIST '|expr| 'CAR) (LIST 'CAR 'CAR)
- (LIST '|mmCondition| 'CAADR) (LIST '|mmDC| 'CAAR)
- (LIST '|mmImplementation| 'CADADR)
- (LIST '|mmSignature| 'CDAR)
- (LIST '|mmTarget| 'CADAR) (LIST '|mode| 'CADR)
- (LIST '|op| 'CAR) (LIST '|opcode| 'CADR)
- (LIST '|opSig| 'CADR) (LIST 'CDR 'CDR)
- (LIST '|sig| 'CDDR) (LIST '|source| 'CDR)
- (LIST '|streamCode| 'CADDDR)
- (LIST '|streamDef| 'CADDR)
- (LIST '|streamName| 'CADR) (LIST '|target| 'CAR)))
- (|i| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#12|)
- (PROGN (SETQ |i| (CAR |bfVar#12|)) NIL))
- (RETURN NIL))
- ('T (SETF (GET (CAR |i|) 'SHOESELFUNCTION) (CADR |i|))))
- (SETQ |bfVar#12| (CDR |bfVar#12|)))))))
-
-@
-\eject
-
-\section*{Acknowledgment}
-Gabriel Dos Reis contributed initial documentation of this pamphlet.
-
-\end{document}
diff --git a/src/boot/translator.boot b/src/boot/translator.boot
new file mode 100644
index 00000000..0fc79fa0
--- /dev/null
+++ b/src/boot/translator.boot
@@ -0,0 +1,751 @@
+-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+-- All rights reserved.
+-- Copyright (C) 2007-2008, Gabriel Dos Reis.
+-- 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.
+--
+-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+-- names of its contributors may be used to endorse or promote products
+-- derived from this software without specific prior written permission.
+--
+-- 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 OWNER
+-- 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.
+--
+
+
+module '"boot-translator"
+import '"includer"
+import '"scanner"
+import '"pile"
+import '"parser"
+import '"ast"
+
+)package "BOOTTRAN"
+
++++ True if we are translating code written in Old Boot.
+$translatingOldBoot := false
+
+AxiomCore::%sysInit() ==
+ if cdr ASSOC(Option '"boot", %systemOptions()) = '"old"
+ then $translatingOldBoot := true
+
+-- Make x, the current package
+setCurrentPackage x ==
+ SETQ(_*PACKAGE_*,x)
+
+-- Compiles the input Lisp file designated by lspFileName.
+shoeCOMPILE_-FILE lspFileName ==
+ COMPILE_-FILE lspFileName
+
+-- (boottocl "filename") translates the file "filename.boot" to
+-- the common lisp file "filename.clisp"
+
+BOOTTOCL(fn, out) ==
+ BOOTTOCLLINES(nil,fn, out)
+
+-- (bootclam "filename") translates the file "filename.boot" to
+-- the common lisp file "filename.clisp" , producing, for each function
+-- a hash table to store previously computed values indexed by argument
+-- list.
+
+BOOTCLAM(fn, out) ==
+ $bfClamming := true
+ BOOTCLAMLINES(nil,fn, out)
+
+BOOTCLAMLINES(lines, fn, out) ==
+ BOOTTOCLLINES(lines, fn, out)
+
+BOOTTOCLLINES(lines, fn, outfn)==
+ -- The default floating point number is double-float.
+ SETQ(_*READ_-DEFAULT_-FLOAT_-FORMAT_*, 'DOUBLE_-FLOAT)
+ callingPackage := _*PACKAGE_*
+ IN_-PACKAGE '"BOOTTRAN"
+ infn:=shoeAddbootIfNec fn
+ result := shoeOpenInputFile(a,infn,
+ shoeClLines(a,fn,lines,outfn))
+ setCurrentPackage callingPackage
+ result
+
+shoeClLines(a,fn,lines,outfn)==
+ if null a
+ then shoeNotFound fn
+ else
+ $GenVarCounter:local := 0
+ shoeOpenOutputFile(stream,outfn,
+ (for line in lines repeat shoeFileLine (line,stream);
+ shoeFileTrees(shoeTransformStream a,stream)))
+ outfn
+
+-- (boottoclc "filename") translates the file "filename.boot" to
+-- the common lisp file "filename.clisp" with the original boot
+-- code as comments
+
+BOOTTOCLC(fn, out)==BOOTTOCLCLINES(nil, fn, out)
+
+BOOTTOCLCLINES(lines, fn, outfn)==
+ callingPackage := _*PACKAGE_*
+ IN_-PACKAGE '"BOOTTRAN"
+ infn:=shoeAddbootIfNec fn
+ result := shoeOpenInputFile(a,infn,
+ shoeClCLines(a,fn,lines,outfn))
+ setCurrentPackage callingPackage
+ result
+
+
+shoeClCLines(a,fn,lines,outfn)==
+ if null a
+ then shoeNotFound fn
+ else
+ $GenVarCounter:local := 0
+ shoeOpenOutputFile(stream,outfn,
+ (for line in lines repeat shoeFileLine (line,stream);
+ shoeFileTrees(shoeTransformToFile(stream,
+ shoeInclude bAddLineNumber(bRgen a,bIgen 0)),stream)))
+ outfn
+
+-- (boottomc "filename") translates the file "filename.boot"
+-- to machine code and loads it one item at a time
+
+BOOTTOMC fn==
+ callingPackage := _*PACKAGE_*
+ IN_-PACKAGE '"BOOTTRAN"
+ $GenVarCounter:local := 0
+ infn:=shoeAddbootIfNec fn
+ result := shoeOpenInputFile(a,infn,shoeMc(a,fn))
+ setCurrentPackage callingPackage
+ result
+
+shoeMc(a,fn)==
+ if null a
+ then shoeNotFound fn
+ else
+ shoePCompileTrees shoeTransformStream a
+ shoeConsole CONCAT(fn,'" COMPILED AND LOADED")
+
+EVAL_-BOOT_-FILE fn ==
+ b := _*PACKAGE_*
+ IN_-PACKAGE '"BOOTTRAN"
+ infn:=shoeAddbootIfNec fn
+ outfn:=CONCAT(shoeRemovebootIfNec fn,'".",_*LISP_-SOURCE_-FILETYPE_*)
+ shoeOpenInputFile(a,infn,shoeClLines(a,infn,[],outfn))
+ setCurrentPackage b
+ LOAD outfn
+
+-- (boot "filename") translates the file "filename.boot"
+-- and prints the result at the console
+
+BO fn==
+ b := _*PACKAGE_*
+ IN_-PACKAGE '"BOOTTRAN"
+ $GenVarCounter:local := 0
+ infn:=shoeAddbootIfNec fn
+ shoeOpenInputFile(a,infn,shoeToConsole(a,fn))
+ setCurrentPackage b
+
+BOCLAM fn==
+ callingPackage := _*PACKAGE_*
+ IN_-PACKAGE '"BOOTTRAN"
+ $GenVarCounter:local := 0
+ $bfClamming:local := true
+ infn:=shoeAddbootIfNec fn
+ result := shoeOpenInputFile(a,infn,shoeToConsole(a,fn))
+ setCurrentPackage callingPackage
+ result
+
+shoeToConsole(a,fn)==
+ if null a
+ then shoeNotFound fn
+ else
+ shoeConsoleTrees shoeTransformToConsole
+ shoeInclude bAddLineNumber(bRgen a,bIgen 0)
+
+-- (stout "string") translates the string "string"
+-- and prints the result at the console
+
+STOUT string== PSTOUT [string]
+-- $GenVarCounter:local := 0
+-- $bfClamming:local:=false
+-- shoeConsoleTrees shoeTransformString [string]
+
+STEVAL string==
+ callingPackage := _*PACKAGE_*
+ IN_-PACKAGE '"BOOTTRAN"
+ $GenVarCounter:local := 0
+ a:= shoeTransformString [string]
+ result :=
+ bStreamPackageNull a => nil
+ fn:=stripm(CAR a,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN")
+ EVAL fn
+ setCurrentPackage callingPackage
+ result
+
+-- (sttomc "string") translates the string "string"
+-- to common lisp, and compiles it.
+
+STTOMC string==
+ callingPackage := _*PACKAGE_*
+ IN_-PACKAGE '"BOOTTRAN"
+ $GenVarCounter:local := 0
+ a:= shoeTransformString [string]
+ result :=
+ bStreamPackageNull a => nil
+ shoePCompile car a
+ setCurrentPackage callingPackage
+ result
+
+
+shoeCompileTrees s==
+ while not bStreamNull s repeat
+ shoeCompile car s
+ s:=cdr s
+
+shoeCompile fn==
+ fn is ['DEFUN,name,bv,:body]=>
+ COMPILE (name,['LAMBDA,bv,:body])
+ EVAL fn
+
+shoeTransform str==
+ bNext(function shoeTreeConstruct,
+ bNext(function shoePileInsert,
+ bNext(function shoeLineToks, str)))
+
+shoeTransformString s==
+ shoeTransform shoeInclude bAddLineNumber(s,bIgen 0)
+shoeTransformStream s==shoeTransformString bRgen s
+-- shoeTransform shoeInclude bAddLineNumber(bRgen s,bIgen 0)
+
+shoeTransformToConsole str==
+ bNext(function shoeConsoleItem,
+ bNext(function shoePileInsert,
+ bNext(function shoeLineToks, str)))
+
+shoeTransformToFile(fn,str)==
+ bFileNext(fn,
+ bNext(function shoePileInsert,
+ bNext(function shoeLineToks, str)))
+
+shoeConsoleItem (str)==
+ dq:=CAR str
+ shoeConsoleLines shoeDQlines dq
+ cons(shoeParseTrees dq,CDR str)
+
+bFileNext(fn,s)==bDelay(function bFileNext1,[fn,s])
+
+bFileNext1(fn,s)==
+ bStreamNull s=> ["nullstream"]
+ dq:=CAR s
+ shoeFileLines(shoeDQlines dq,fn)
+ bAppend(shoeParseTrees dq,bFileNext(fn,cdr s))
+
+shoeParseTrees dq==
+ toklist := dqToList dq
+ null toklist => []
+ shoeOutParse toklist
+
+shoeTreeConstruct (str)==
+ cons(shoeParseTrees CAR str,CDR str)
+
+shoeDQlines dq==
+ a:= CDAAR shoeLastTokPosn dq
+ b:= CDAAR shoeFirstTokPosn dq
+ streamTake (a-b+1,CAR shoeFirstTokPosn dq)
+
+streamTake(n,s)==
+ if bStreamNull s
+ then nil
+ else if EQL(n,0)
+ then nil
+ else cons(car s,streamTake(n-1,cdr s))
+
+shoeFileLines (lines,fn) ==
+ shoeFileLine( '" ",fn)
+ for line in lines repeat shoeFileLine (shoeAddComment line,fn)
+ shoeFileLine ('" ",fn)
+
+shoeConsoleLines lines ==
+ shoeConsole '" "
+ for line in lines repeat shoeConsole shoeAddComment line
+ shoeConsole '" "
+
+shoeFileLine(x, stream) ==
+ WRITE_-LINE(x, stream)
+ x
+
+shoeFileTrees(s,st)==
+ while not bStreamNull s repeat
+ a:=CAR s
+ if EQCAR (a,"+LINE")
+ then shoeFileLine(CADR a,st)
+ else
+ REALLYPRETTYPRINT(a,st)
+ TERPRI st
+ s:=CDR s
+
+
+shoePPtoFile(x, stream) ==
+ SHOENOTPRETTYPRINT(x, stream)
+ x
+
+shoeConsoleTrees s ==
+ while not bStreamPackageNull s repeat
+-- while not bStreamNull s repeat
+ fn:=stripm(CAR s,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN")
+ REALLYPRETTYPRINT fn
+ s:=CDR s
+
+shoeAddComment l== CONCAT('"; ",CAR l)
+
+++ Generate an import declaration for `op' as equivalent of the
+++ foreign signature `sig'. Here, `foreign' operationally means that
+++ the entity is from the C language world.
+genImportDeclaration(op, sig) ==
+ sig isnt ["Signature", op', m] => coreError '"invalid signature"
+ m isnt ["Mapping", t, s] => coreError '"invalid function type"
+ %hasFeature KEYWORD::GCL =>
+ if SYMBOLP s then s := [s]
+ ["DEFENTRY", op, s, [t, SYMBOL_-NAME op']]
+ fatalError '"import declaration not implemented for this Lisp"
+
+shoeOutParse stream ==
+ $inputStream :local:= stream
+ $stack:local :=nil
+ $stok:local := nil
+ $ttok:local := nil
+ $op:local :=nil
+ $wheredefs:local:=nil
+ $typings:local:=nil
+ $returns:local :=nil
+ $bpCount:local:=0
+ $bpParenCount:local:=0
+ bpFirstTok()
+ found:=CATCH("TRAPPOINT",bpOutItem())
+ if found="TRAPPED"
+ then nil
+ else if not bStreamNull $inputStream
+ then
+ bpGeneralErrorHere()
+ nil
+ else if null $stack
+ then
+ bpGeneralErrorHere()
+ nil
+ else CAR $stack
+
+bpOutItem()==
+ bpComma() or bpTrap()
+ b:=bpPop1()
+ EQCAR(b,"TUPLE")=> bpPush cdr b
+ EQCAR(b,"+LINE")=> bpPush [ b ]
+ b is ["L%T",l,r] and IDENTP l =>
+ bpPush [["DEFPARAMETER",l,r]]
+ case b of
+ Module(m) =>
+ bpPush [shoeCompileTimeEvaluation ["PROVIDE", m]]
+
+ Import(m) =>
+ bpPush [["IMPORT-MODULE", m]]
+
+ ImportSignature(x, sig) =>
+ bpPush [genImportDeclaration(x, sig)]
+
+ TypeAlias(t, args, rhs) =>
+ bpPush [["DEFTYPE", t, args, ["QUOTE", rhs]]]
+
+ ConstantDefinition(n, e) =>
+ bpPush [["DEFCONSTANT", n, e]]
+
+ otherwise =>
+ b:=shoeCompTran ["LAMBDA",["x"],b]
+ bpPush [shoeEVALANDFILEACTQ CADDR b]
+
+--shoeStartsAt (sz,name,stream)==
+-- bStreamNull stream => ['nullstream]
+-- a:=CAAR stream
+-- if #a<sz
+-- then shoeStartsAt(sz,name,CDR stream)
+-- else if SUBSTRING(a,0,sz)=name and (#a>sz and not shoeIdChar(a.sz))
+-- then stream
+-- else shoeStartsAt(sz,name,CDR stream)
+
+--FC(name,fn)==
+-- $bfClamming:local:=false
+-- $GenVarCounter:local := 0
+-- infn:=shoeAddbootIfNec fn
+-- shoeOpenInputFile(a,infn,shoeFindName(fn,name, a))
+
+--shoeFindName(fn,name,a)==
+-- shoeFindAndDoSomething(FUNCTION shoeCompile,fn,name,a)
+--shoeTransform1 str==
+-- bNext(function shoeTreeConstruct,
+-- streamTake(1, bNext(function shoePileInsert,
+-- bNext(function shoeLineToks, str))))
+
+--BOOT_-DO_-SOMETHING_-TO_-DEFINITION_-FROM_-FILE(fun,fn,symbol)==
+-- $bfClamming:local:=false
+-- infn:=shoeAddbootIfNec NAMESTRING fn
+-- name:=PNAME symbol
+-- shoeOpenInputFile(a,infn,shoeFindAndDoSomething(fun,fn,name, a))
+
+--shoeFindAndDoSomething(fun,fn,name,a)==
+-- if null a
+-- then shoeNotFound fn
+-- else
+-- b:=shoeStartsAt(#name,name, shoeInclude
+-- bAddLineNumber(bRgen a,bIgen 0))
+-- if bStreamNull b
+-- then shoeConsole CONCAT (name,'" not found in ",fn)
+-- else
+-- $GenVarCounter:local := 0
+-- shoeLoop(fun,shoeTransform1 b)
+
+--BOOT_-COMPILE_-DEFINITION_-FROM_-FILE(fn,symbol)==
+-- BOOT_-DO_-SOMETHING_-TO_-DEFINITION_-FROM_-FILE
+-- (FUNCTION shoeCompile,fn,symbol)
+
+--BOOT_-EVAL_-DEFINITION_-FROM_-FILE(fn,symbol)==
+-- BOOT_-DO_-SOMETHING_-TO_-DEFINITION_-FROM_-FILE
+-- (FUNCTION EVAL,fn,symbol)
+
+--BOOT_-PRINT_-DEFINITION_-FROM_-FILE(fn,symbol)==
+-- BOOT_-DO_-SOMETHING_-TO_-DEFINITION_-FROM_-FILE
+-- (FUNCTION REALLYPRETTYPRINT,fn,symbol)
+
+--shoeLoop(fun, s)==
+-- while not bStreamNull s repeat
+-- FUNCALL(fun, car s)
+-- s:=cdr s
+
+shoeAddbootIfNec s==shoeAddStringIfNec('".boot",s)
+
+shoeRemovebootIfNec s==shoeRemoveStringIfNec('".boot",s)
+shoeAddStringIfNec(str,s)==
+ a:=STRPOS(str,s,0,nil)
+ if null a
+ then CONCAT(s,str)
+ else s
+
+shoeRemoveStringIfNec(str,s)==
+ a:=STRPOS(str,s,0,nil)
+ if null a
+ then s
+ else SUBSTRING(s,0,a)
+
+-- DEFUSE prints the definitions not used and the words used and
+-- not defined in the input file and common lisp.
+
+DEFUSE fn==
+ infn:=CONCAT(fn,'".boot")
+ shoeOpenInputFile(a,infn,shoeDfu(a,fn))
+
+shoeDfu(a,fn)==
+ if null a
+ then shoeNotFound fn
+ else
+ $lispWordTable:local :=MAKE_-HASHTABLE ("EQ")
+ DO_-SYMBOLS(i(FIND_-PACKAGE "LISP"),HPUT($lispWordTable,i,true))
+ $bootDefined:local :=MAKE_-HASHTABLE "EQ"
+ $bootUsed:local :=MAKE_-HASHTABLE "EQ"
+ $bootDefinedTwice:local:=nil
+ $GenVarCounter:local :=0
+ $bfClamming:local:=false
+ shoeDefUse shoeTransformStream a
+ out:=CONCAT(fn,'".defuse")
+ shoeOpenOutputFile(stream,out,shoeReport stream)
+ out
+
+shoeReport stream==
+ shoeFileLine('"DEFINED and not USED",stream)
+ a:=[i for i in HKEYS $bootDefined | not GETHASH(i,$bootUsed)]
+ bootOut(SSORT a,stream)
+ shoeFileLine('" ",stream)
+ shoeFileLine('"DEFINED TWICE",stream)
+ bootOut(SSORT $bootDefinedTwice,stream)
+ shoeFileLine('" ",stream)
+ shoeFileLine('"USED and not DEFINED",stream)
+ a:=[i for i in HKEYS $bootUsed |
+ not GETHASH(i,$bootDefined)]
+ for i in SSORT a repeat
+ b:=CONCAT(PNAME i,'" is used in ")
+ bootOutLines( SSORT GETHASH(i,$bootUsed),stream,b)
+
+shoeDefUse(s)==
+ while not bStreamPackageNull s repeat
+ defuse([],CAR s)
+ s:=CDR s
+
+defuse(e,x)==
+ x:=stripm(x,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN")
+ $used:local:=nil
+ [nee,niens]:=
+ x is ['DEFUN,name,bv,:body] => [name,['LAMBDA,bv,:body]]
+ x is ['DEFMACRO,name,bv,:body] => [name,['LAMBDA,bv,:body]]
+ x is ["EVAL_-WHEN",.,["SETQ",id,exp]]=>[id,exp]
+ x is ["SETQ",id,exp]=>[id,exp]
+ ["TOP-LEVEL", x]
+ if GETHASH(nee,$bootDefined)
+ then
+ $bootDefinedTwice:=
+ nee="TOP-LEVEL"=> $bootDefinedTwice
+ cons(nee,$bootDefinedTwice)
+ else HPUT($bootDefined,nee,true)
+ defuse1 (e,niens)
+ for i in $used repeat
+ HPUT($bootUsed,i,cons(nee,GETHASH(i,$bootUsed)))
+
+defuse1(e,y)==
+ ATOM y =>
+ IDENTP y =>
+ $used:=
+ MEMQ(y,e)=>$used
+ MEMQ(y,$used)=>$used
+ defusebuiltin y =>$used
+ UNION([y],$used)
+ []
+ y is ["LAMBDA",a,:b]=> defuse1 (append(unfluidlist a,e),b)
+ y is ["PROG",a,:b]=>
+ [dol,ndol]:=defSeparate a
+ for i in dol repeat
+ HPUT($bootDefined,i,true)
+ defuse1 (append(ndol,e),b)
+ y is ["QUOTE",:a] => []
+ y is ["+LINE",:a] => []
+ for i in y repeat defuse1(e,i)
+
+defSeparate x==
+ if null x
+ then [[],[]]
+ else
+ f:=car x
+ [x1,x2]:=defSeparate cdr x
+ if bfBeginsDollar f
+ then [cons(f,x1),x2]
+ else [x1,cons(f,x2)]
+unfluidlist x==
+ NULL x => []
+ ATOM x=> [x]
+ x is ["&REST",y]=> [y]
+ cons(car x,unfluidlist cdr x)
+
+defusebuiltin x== GETHASH(x,$lispWordTable)
+
+bootOut (l,outfn)==
+ for i in l repeat shoeFileLine (CONCAT ('" ",PNAME i),outfn)
+
+CLESSP(s1,s2)==not(SHOEGREATERP(s1,s2))
+SSORT l == SORT(l,function CLESSP)
+
+bootOutLines(l,outfn,s)==
+ if null l
+ then shoeFileLine(s,outfn)
+ else
+ a:=PNAME car l
+ if #s +#a > 70
+ then
+ shoeFileLine(s,outfn)
+ bootOutLines(l,outfn,'" ")
+ else bootOutLines(cdr l,outfn,CONCAT(s,'" ",a))
+
+
+-- (xref "fn") produces a cross reference listing in "fn.xref"
+-- It contains each name
+-- used in "fn.boot", together with a list of functions that use it.
+
+XREF fn==
+ infn:=CONCAT(fn,'".boot")
+ shoeOpenInputFile(a,infn,shoeXref(a,fn))
+
+shoeXref(a,fn)==
+ if null a
+ then shoeNotFound fn
+ else
+ $lispWordTable:local :=MAKE_-HASHTABLE ("EQ")
+ DO_-SYMBOLS(i(FIND_-PACKAGE "LISP"),HPUT($lispWordTable,i,true))
+ $bootDefined:local :=MAKE_-HASHTABLE "EQ"
+ $bootUsed:local :=MAKE_-HASHTABLE "EQ"
+ $GenVarCounter:local :=0
+ $bfClamming:local:=false
+ shoeDefUse shoeTransformStream a
+ out:=CONCAT(fn,'".xref")
+ shoeOpenOutputFile(stream,out,shoeXReport stream)
+ out
+
+
+shoeXReport stream==
+ shoeFileLine('"USED and where DEFINED",stream)
+ c:=SSORT HKEYS $bootUsed
+ for i in c repeat
+ a:=CONCAT(PNAME i,'" is used in ")
+ bootOutLines( SSORT GETHASH(i,$bootUsed),stream,a)
+
+--FC (name,fn)== shoeGeneralFC(function BOOT,name,fn)
+
+FBO (name,fn)== shoeGeneralFC(function BO,name,fn)
+
+FEV(name,fn)== shoeGeneralFC(function EVAL_-BOOT_-FILE,name,fn)
+
+shoeGeneralFC(f,name,fn)==
+ $bfClamming:local:=false
+ $GenVarCounter:local := 0
+ infn:=shoeAddbootIfNec fn
+ a:= shoeOpenInputFile(a,infn,shoeFindName2(fn,name, a))
+ filename:= if # name > 8 then SUBSTRING(name,0,8) else name
+ a => FUNCALL(f, CONCAT('"/tmp/",filename))
+ nil
+
+shoeFindName2(fn,name,a)==
+ lines:=shoeFindLines(fn,name,a)
+ lines =>
+ filename:= if # name > 8 then SUBSTRING(name,0,8) else name
+ filename := CONCAT ('"/tmp/",filename,'".boot")
+ shoeOpenOutputFile(stream, filename,
+ for line in lines repeat shoeFileLine (line,stream))
+ true
+ false
+
+shoeTransform2 str==
+ bNext(function shoeItem,
+ streamTake(1, bNext(function shoePileInsert,
+ bNext(function shoeLineToks, str))))
+
+shoeItem (str)==
+ dq:=CAR str
+ cons([[CAR line for line in shoeDQlines dq]],CDR str)
+
+--shoeLines lines == [CAR line for line in lines]
+
+--shoeFindAndDoSomething2(fun,fn,name,a)==
+-- if null a
+-- then shoeNotFound fn
+-- else
+-- [lines,b]:=shoePackageStartsAt([],#name,name, shoeInclude
+-- bAddLineNumber(bRgen a,bIgen 0))
+-- if bStreamNull b
+-- then
+-- shoeConsole CONCAT (name,'" not found in ",fn)
+-- []
+-- else
+-- if null lines
+-- then shoeConsole '")package not found"
+-- $GenVarCounter:local := 0
+-- shoeLoopPackage(fun,shoeTransform2 b,lines)
+
+--shoeLoopPackage(fun, s,lines)==
+-- while not bStreamNull s repeat
+-- FUNCALL(fun, append (reverse lines,car s))
+-- s:=cdr s
+-- true
+stripm (x,pk,bt)==
+ ATOM x =>
+ IDENTP x =>
+ SYMBOL_-PACKAGE x = bt => INTERN(PNAME x,pk)
+ x
+ x
+ CONS(stripm(CAR x,pk,bt),stripm(CDR x,pk,bt))
+
+shoePCompile fn==
+ fn:=stripm(fn,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN")
+ fn is ['DEFUN,name,bv,:body]=>
+ COMPILE (name,['LAMBDA,bv,:body])
+ EVAL fn
+
+FC(name,fn)==
+ $GenVarCounter:local := 0
+ infn:=shoeAddbootIfNec fn
+ shoeOpenInputFile(a,infn,shoeFindName(fn,name, a))
+
+shoeFindName(fn,name,a)==
+ lines:=shoeFindLines(fn,name,a)
+ shoePCompileTrees shoeTransformString lines
+
+shoePCompileTrees s==
+ while not bStreamPackageNull s repeat
+ REALLYPRETTYPRINT shoePCompile car s
+ s:=cdr s
+
+bStreamPackageNull s==
+ a := _*PACKAGE_*
+ IN_-PACKAGE '"BOOTTRAN"
+ b:=bStreamNull s
+ setCurrentPackage a
+ b
+
+PSTTOMC string==
+ $GenVarCounter:local := 0
+ shoePCompileTrees shoeTransformString string
+
+BOOTLOOP ()==
+ a:=READ_-LINE()
+ #a=0=>
+ WRITE_-LINE '"Boot Loop; to exit type ] "
+ BOOTLOOP()
+ b:=shoePrefix? ('")console",a)
+ b =>
+ stream:= _*TERMINAL_-IO_*
+ PSTTOMC bRgen stream
+ BOOTLOOP()
+ a.0='"]".0 => nil
+ PSTTOMC [a]
+ BOOTLOOP()
+
+BOOTPO ()==
+ a:=READ_-LINE()
+ #a=0=>
+ WRITE_-LINE '"Boot Loop; to exit type ] "
+ BOOTPO()
+ b:=shoePrefix? ('")console",a)
+ b =>
+ stream:= _*TERMINAL_-IO_*
+ PSTOUT bRgen stream
+ BOOTPO()
+ a.0='"]".0 => nil
+ PSTOUT [a]
+ BOOTPO()
+
+PSTOUT string==
+ callingPackage := _*PACKAGE_*
+ IN_-PACKAGE '"BOOTTRAN"
+ $GenVarCounter:local := 0
+ result := shoeConsoleTrees shoeTransformString string
+ setCurrentPackage callingPackage
+ result
+
+
+defaultBootToLispFile file ==
+ CONCAT(shoeRemovebootIfNec file,'".clisp")
+
+translateBootFile(progname, options, file) ==
+ outFile := getOutputPathname(options)
+ BOOTTOCL(file, ENOUGH_-NAMESTRING outFile)
+
+compileBootHandler(progname, options, file) ==
+ intFile := BOOTTOCL(file, defaultBootToLispFile file)
+ intFile =>
+ objFile := compileLispHandler(progname, options, intFile)
+ DELETE_-FILE intFile
+ objFile
+ nil
+
+associateRequestWithFileType(Option '"translate", '"boot",
+ function translateBootFile)
+associateRequestWithFileType(Option '"compile", '"boot",
+ function compileBootHandler)
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-14 20:13:51 +0000