diff options
Diffstat (limited to 'src/boot')
| -rw-r--r-- | src/boot/ChangeLog | 414 | ||||
| -rw-r--r-- | src/boot/ChangeLog.gdr-sandbox | 142 | ||||
| -rw-r--r-- | src/boot/Makefile.in | 166 | ||||
| -rw-r--r-- | src/boot/Makefile.pamphlet | 1644 | ||||
| -rw-r--r-- | src/boot/ast.boot.pamphlet | 3090 | ||||
| -rw-r--r-- | src/boot/includer.boot.pamphlet | 1224 | ||||
| -rw-r--r-- | src/boot/initial-env.lisp.pamphlet | 243 | ||||
| -rw-r--r-- | src/boot/parser.boot.pamphlet | 2453 | ||||
| -rw-r--r-- | src/boot/pile.boot.pamphlet | 325 | ||||
| -rw-r--r-- | src/boot/scanner.boot.pamphlet | 1175 | ||||
| -rw-r--r-- | src/boot/tokens.boot.pamphlet | 751 | ||||
| -rw-r--r-- | src/boot/translator.boot.pamphlet | 1935 |
12 files changed, 13562 insertions, 0 deletions
diff --git a/src/boot/ChangeLog b/src/boot/ChangeLog new file mode 100644 index 00000000..94a882d5 --- /dev/null +++ b/src/boot/ChangeLog @@ -0,0 +1,414 @@ +2007-08-07 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * ast.boot.pamphlet (bfColonColon): Use SYMBOL-NAME, not + STRINGIMAGE. + +2007-08-05 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet (stage0/bootsys$(EXEEXT)): Use + AxiomCore::topLevel as entry point. + (stage1/bootsys$(EXEEXT)): Likewise. + (stage2/bootsys$(EXEEXT)): Likewise. + * Makefile.in: Regenerate. + * initial-env.lisp.pamphlet (main): Remove. + +2007-08-05 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * ast.boot.pamphlet: Don't guard IMPORT-MODULE with eval-when. + * includer.boot.pamphlet: Likewise. + * parser.boot.pamphlet: Likewise. + * pile.boot.pamphlet: Likewise. + * scanner.boot.pamphlet: Likewise. + * tokens.boot.pamphlet: Likewise. + * translator.boot.pamphlet: Likewise. + * initial-env.lisp.pamphlet: Rework. + + * Makefile.pamphlet (AXIOM_LOCAL_LISP): Set to ../lisp/base-lisp. + (boot_objects_extra): Remove. + (boot_objects): Include "initial-env". + (boot_SOURCES): Include initial-env.lisp.pamphlet. + (pamphlets): Update. + (%/tokens.($FASLEXT)): New. + (%/includer.$(FASLEXT)): Likewise. + (%/scanner.$(FASLEXT)): Likewise. + (%/pile.$(FASLEXT)): Likewise. + (%/ast.$(FASLEXT)): Likewise. + (%/parser.$(FASLEXT)): Likewise. + (%/translator.$(FASLEXT)): Likewise. + (quiet_flags, eval_flags): Remove. + (stage0-pre): Likewise. + (stage0/%.$(FASLEXT)): Don't require initial-env.$(FASLEXT) here. + (axiom_o): Remove. + ($(AXIOM_LOCAL_LISP)): Likewise. + (%/initial-env.$(FASLEXT)): Make generic. + * Makefile.in: Regenerate. + +2007-05-31 Gabriel Dos Reis <gdr@cs.tamu,edu> + + * initial-env.lisp.pamphlet (diagnostic-message): New. + (|fatalError|): New. Handle fatal errors. + (|internalError|): New. Handle internal translator errors. + (get-command-line-arguments): New. + (|$driverTable|): New. + (|installDriver|): New. Use it. + +2007-05-27 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * parser.boot.pamphlet ($sawParenthesizedHead): New. + (bpBeginDefinition): Likewise. + (bpDefinition): Use it to detect toplevel definition. + (bpStoreName): Tentatively set the return type to Any type. + (bpSimpleDefinitionTail): Break out from bpDefTail + (bpCompoundDefinitionTail): Likewise. + (bpDefTail): Use them. Makes logic simpler. + (bpRegularBVItem): Allow typed parameters. + (bpBeginParameterList): New. + (bpEndParameterList): Likewise. + (bpVariable): Use them. Remember when parameters are enclosed in + parenthesis. + Update Lisp translation. + +2007-05-26 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet: Add dependencies for FASL files. + * ast.boot.pamphlet: Update Lisp translation. + * includer.booot.pamphlet: Likewise. + * initial-env.lisp.pamphlet (shoe-provide-module): New. Define + only for SBCL. + * parser.boot.pamphlet: Update Lisp translation. + * pile.boot.pamphlet: Likewise. + * scanner.boot.pamphlet: Likewise. + * tokens.boot.pamphlet: Likewise. + * translator.boot.pamphlet: Likewise. + +2007-05-28 Gabriel Dos Reis <gdr@cs.tamu,edu> + + * Makefile.pamphlet (stage0/bootsys$(EXEEXT)): Don't use AX_FLAGS. + (stage1/bootsys$(EXEEXT)): Likewise. + (stage2/bootsys$(EXEEXT)): Likewise. + +2007-05-22 Gabriel Dos Reis <gdr@cs.tamu.edu> + + Add support for simple type specifier definitions. + * translator.boot.pamphlet (bpOutItem): Handle specially type + alias definitions. + * tokens.boot.pamphlet (shoeKeyWords): Add new token "<=>" for + type alias definition. + * parser.boot.pamphlet (bpTypeAliasDefition): New. + (bpDefinition): Use it to parse type alias definitions. + * ast.boot.pamphlet (bfTypeAliasDefinition): New. + +2007-05-21 Gabriel Dos Reis <gdr@cs.tamu.edu> + + Translate definitions of global variables as defparameters. + * ast.boot.pamphlet: Update Lisp translation. + * includer.boot.pamphlet: Likwise. + * tokens.boot.pamphlet: Likewise. + * translator.boot.pamphlet (bpOutItem): Use DEFPARAMETER for + assignment at global scope. + Update Lisp translation. + +2007-05-19 Gabriel Dos Reis <gdr@cs.tamu.edu> + + Add package call syntax + * tokens.boot.pamphlet (shoeKwyWords): Add new token. Document + existing tokens. Update Lisp translation. + * scanner.boot.pamphlet: Update Lisp translation. + * parser.boot.pamphlet (bpQualifiedName): New. + (bpName): Use it. Allow explicit package qualification. + Update Lisp translation. + * includer.boot.pamphlet: Update Lisp translation. + * ast.boot.pamphlet (bfColonColon): New. + Update Lisp translation. + * Makefile.pamphlet (clean-local): Remove .clisp files too. + * Makefile.in: Regenerate. + * translator.boot.pamphlet (shoeEVALANDFILEACTQ): Use + :EXECUTE and :LOAD-TOPLEVEL instead of deprecated forms EVAL and + LOAD. Update Lisp translation. + +2007-05-19 Gabriel Dos Reis <gdr@cs.tamu,edu> + + Give meaningful names to pamphlet files. + * translator.boot.pamphlet: Rename from ptyout.boot.pamphlet. + * tokens.boot.pamphlet: Rename from typrops.boot.pamphlet. + * scanner.boot.pamphlet: Rename from btscan2.boot.pamphlet. + * pile.boot.pamphlet: Rename from btpile2.boot.pamphlet. + * parser.boot.pamphlet: Rename from typars.boot.pamphlet. + * includer.boot.pamphlet: Rename from btincl2.boot.pamphlet. + * ast.boot.pamphlet: Rename from tytree1.boot.pamphlet. + +2007-05-13 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * initial-env.lisp.pamphlet (|shoeConsole|, |char|, |shoeCLOSE|, + stringimage): Move to ... + * btincl2.boot.pamphlet (shoeConsole, char shoeCLOSE, + STRINGIMAGE): ... here. Define as Boot code. Update Lisp + translation. + * initial-env.lisp.pamphlet (double): Move to ... + * btscan2.boot.pamphlet (DOUBLE): ... here. Define as Boot code. + Update Lisp translation. + * initial-env.lisp.pamphlet (pname): Move to ... + * typars.boot.pamphlet (PNAME): ... here. Define as Boot code. + Update Lisp translation. + * initial-env.lisp.pamphlet (|shoeCOMPILE-FILE|): Move to ... + * ptyout.boot.pamphlet (shoeCOMPILE_-FILE): ... here. Define as + Boot code. Update Lisp translation. + * initial-env.lisp.pamphlet (shoeGREATERP): Remove. + (|$lispType|, |$lispName|, |$machineType|): Likewise. + +2007-05-13 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * initial-env.lisp.pamphlet ("BOOTTRAN"): Write exported + functions in canonical form. + ($ieee): Define here. + (|shoeCloser|): Move to... + * btscan2.boot.pamphlet (shoeCloser): ... here. Define as Boot + function. Include Lisp translation. + +2007-05-12 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * initial-env.lisp.pamphlet (exit-repl): New. + (translate-boot-to-lisp): Likewise. + (compile-lisp-file): Likewise. + +2007-04-07 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * tytree1.boot.pamphlet ($inDefIS): Define. Update cached Lisp + translation. + +2007-04-05 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * tytree1.boot.pamphlet: Use bfAND to build AND expressions. + Update cached Lisp translation. + +2007-04-02 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * tytree1.boot.pamphlet (bfLET2): Handle literals in patterns. + Update cached Lisp translation. + +2007-03-24 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet: Fix typos. + +2007-03-13 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * btpile2.boot.pamphlet: Fix typo. + * initial-env.lisp.pamphlet: Really add to the repository. + +2007-03-13 Gabriel Dos Reis <gdr@cs.tamu.edu> + + Support build with GCL, SBCL, CLISP. + * btincl2.boot.pamphlet: Update cached Lisp translation. + * btpile2.boot.pamphlet: Likewise. + * btscan2.boot.pamphlet: Likewise. + * tytree1.boot.pamphlet: Likewise. + * typars.boot.pamphlet: Likewise. + * ptyout.boot.pamphlet: Likewise. + (setCurrentPackage): New function. + (BOOTTOCLCLINES): Use it. + (BOOTTOMC): Likewise. + (BO): Likewise. + (BOCLAM): Likewise. + (STEVAL): Likewise. + (STTOMC): Likewise. + (PSTOUT): Likewise. + * npextras.lisp.pamphlet: Remove. + * exports.lisp.pamphlet: Likewise. + * boothdr.lisp.pamphlet: Likewise. + * initial-env.lisp.pamphlet: New file. + * Makefile.pamphlet: Simplify. Document [[AXIOM_LOCAL_LISP]]. + Remove outdated and obsolete documentation. + (LISPSYS): Remove. + (AXIOM_LOCAL_LISP): Rename from LOADSYS. + (AXIOM_LOCAL_LISP_sources): New. + (boot_sources_without_deps): Remove. + (boot_sources_with_deps): Likewise. + (boot_clisp_with_deps): Likewise. + (boot_data_with_deps): Likewise. + (boot_clisp_without_deps): Likewise. + (boot_data_without_deps): Likewise. + (boot_objects, boot_sources): Adjust. + (COMPILE_LISP_WITH_DEPS): Remove. + (COMPILE_LISP): Adjust. + (BOOT_TO_LISP): Likewise. + (stage0_boot_clisp): Rename from stage0_boot_clisp_with_deps. + (stage0_boot_objects): Rename from stage0_boot_objects_with_deps. + (stage0/bootsys$(EXEEXT): Adjust. + (stage1/bootsys$(EXEEXT): Likewise. + (stage2/bootsys$(EXEEXT): Likewise. + ($(AXIOM_LOCAL_LISP)): New rule. + (initial-env.lisp): Likewise. + (clean-local): Adjust. + * Makefile.in: Regenerate. + +2007-03-04 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * ptyout.boot.pamphlet: Fix typo. + * btincl2.boot.pamphlet: Document call graphs of functions defined + in this pamphlet. + * Makefile.pamphlet: Fix whitespace glitche around + <<environment>> chunk that confuses noweb. + (pamplhets): Fix spellling. + * Makefile.in: Regenerate. + +2007-02-16 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet (bootsys$(EXEEXT)): Fix thinko. + * Makefile.in: Regenerate. + +2006-12-26 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet (COMPILE_LISP): Use -batch -eval form. + (COMPILE_LISP_WITH_DEPS): Likewise. + * Makefile.in: Regenerate. + +2006-12-11 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * typrops.boot.pamphlet: Temporarily isable "member" as special + new Boot function. + +2006-11-26 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet (\subsection{The Parser}): Update. + (boot_sources_with_deps): Lose tyextra.boot. + * Makefile.in: Regenerate. + * tyextra.boot.pamphlet: Fold content into typars.boot.pamphlet + and tytree1.boot.pamphlet. Remove. + * typars.boot.pamphlet: Update bootstrap code. + * tytree1.boot.pamphlet: Likewise. + +2006-11-26 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet: Add support for OS that require extension for + executable binaries. + * Makefile.in: Regenerate. + +2006-11-21 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * ccl-debugsys.lsp.pamphlet: Move to ../interp. + +2006-11-20 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet (BOOT_TO_LISP): Use $(axiom_build_document) to + translate from Boot. + * Makefile.in: Regenerate. + +2006-11-19 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * ptyout.boot.pamphlet (STEVAL, STTOMC): Fix thinko. + +2006-11-19 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * typars.boot.pamphlet: Start documentation. + +2006-11-18 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet (BOOT_TO_LISP): Use boottoclc. + +2006-11-18 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet: Document the purpose of each file. + +2006-11-16 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * ptyout.boot.pamphlet (BOOTTOCLLINES, BOOTTOMC, BOCLAM, + STEVAL, STTOMC, PSTOU): Temporarily push + into package BootTran and default float format to double. + (BOOTTOCL): Don't do it here. + (shoeNotFound): Return nil. + +2006-11-15 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * ptyout.boot.pamphlet (shoeClLines): Return the result of + shoeNotFound is input file is not existent. + +2006-11-15 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * ptyout.boot.pamphlet (shoeFileTrees): Use REALLYPRETTYPRINT + instead of shoePPtoFile. + +2006-11-15 Waldek Hebisch <hebisch@math.uni.wroc.pl> + + * Makefile.pamphlet: Correct a typo + +2006-11-15 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * ptyout.boot.pamphlet (boottoclc): Fix description to match + implementation. + * Makefile.pamphlet: Likewise. + (BOOT_TO_LISP): Use boottran::boottoclc. + +2006-10-31 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet (\subsubsection{Keywords}): Sync documentation + and implementation. + +2006-10-28 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet (mostlyclean-local): Remove stamp if present. + +2006-10-11 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet (COMPILE_LISP, COMPILE_LISP_WITH_DEPS, + BOOT_TO_LISP): Remove ($(BYE)). + * Makefile.in: Regenerate. + +2006-10-02 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet: Tidy bootstrapping rules. + * Makefile.in: Regenerate. + +2006-09-29 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet: Rework. + * Makefile.in: Regenerate. + +2006-09-26 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet (all): Create stamp file. + * Makefile.in: Regenerate. + +2006-09-18 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet: Remove generic rules for making DVI, they are + now generated by the build machinery. + (DOCFILES): Remove. + (document): Remove. + (clean-local): Rename from clean. + (distclean-local): Rename from distclean. + (mostlyclean): New. + (pamphlet, boot_SOURCES): New. + +2006-09-18 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet (subdir): New. + * Makefile.in: Regenerate. + +2006-09-17 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet (LISPSYS, LOADSYS): Point to + $(axiom_build_bindir)/lisp. + * Makefile.in: Regenerate. + +2006-09-13 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet: Throughout replace {O} with (OBJEXT). OBJEXT + is Autoconf-detected. + * Makefile.in: Regenerate. + +2006-09-04 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet: Simplify. Use generic rules. emove special + cased-rules. Build to $(builddir). + * Makefile.in: Regenerate. + +2006-08-27 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet (${OUT}/boothdr.${O}, ${OUT}/btincl2.${O}, + btincl2.boot, ${OUT}/btpile2.${O}, btpile2.boot, + ${OUT}/btscan2.${O}, btscan2.boot, ${OUT}/exports.${O}, + ${OUT}/npextras.${O}, ${OUT}/ptyout.${O}, ptyout.boot, + ${OUT}/tyextra.${O}, ${OUT}/typars.${O}, typars.boot, + ${OUT}/typrops.${O}, typrops.boot, ${OUT}/tytree1.${O}, + tytree1.boot): Don't overwrite $(TMP)/trace, append instead. + diff --git a/src/boot/ChangeLog.gdr-sandbox b/src/boot/ChangeLog.gdr-sandbox new file mode 100644 index 00000000..1c46b13b --- /dev/null +++ b/src/boot/ChangeLog.gdr-sandbox @@ -0,0 +1,142 @@ +2007-06-25 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * initial-env.lisp.pamphlet (|$originalLispTopLevel|): New + variable. + (handle-command-line): Use it. Now call into the base system + top level if the command line is empty. + (save-core): Now take an optional argument, the executable entry + point. Tidy. + (make-program): Likewise. + (|getMainEntryPoint|): New function. + (|makeHandler|): Use it. + (parse-option-value): Rename from get-option-value. + (process-command-line): Adjust call. + (|getOptionValue|): New. + (main): Rename from main-entry-point. + (|error|): Tidy. + + * Makefile.pamphlet (stage0/bootsys$(EXEEXT)): Explicitly specify + entry point of the resulting executable. + ($(AXIOM_LOCAL_LISP)): Likewise. + (stage1/bootsys$(EXEEXT)): Likewise. + (stage2/bootsys$(EXEEXT)): Likewise. + (initial-env.$(FASLEXT)): If compiling with ECL, build both the + FASL and the object file. + * Makefile.in: Regenerate. + +2007-06-23 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet (boot_objects_extra): New variable. + (<<build bootsys>>): Remove. + (stage0/bootsys$(EXEEXT)): Tidy. + (axiom_o): New variable. Use to pre-load "initial-env" when + building with ECL. + * Makefile.in: Regenerate. + * scanner.boot.pamphlet (double): Rename from DOUBLE. + * includer.boot.pamphlet ($bStreamNil): Rename from bStreamNil. + * initial-env.lisp.pamphlet (exit-repl): Add support for ECL. + (make-program): Likewise. + (get-command-line-arguments): Likewise. Tidy. + (|$LispFileType|): Define as constant. + (|doCompileLispFile|): New. + (|compileLispFile|): Use it. Add support for ECL. + (main-entry-point): Unconditionally set current package to BOOTTRAN. + (|ensureTrailingSlash|): New. + (make-load-path): Use it. + (do-import-module): Make nested function of import-module. + (import-module): Restructure. + * translator.boot.pamphlet (BOOT): Remove. + (COMPILE-BOOT-FILE): Likewise. + +2007-06-19 Gabriel Dos Reis <gdr@cs.tamu,edu> + + * ast.boot.pamphlet (bfDefinition1): Remove. + (bfDefinition): Rename from bfDefinition2. + (bfMDefinition): Rename from bfMDefinition2. + * parser.boot.pamphlet: Update. + +2007-06-19 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * bootload.lisp.pamphlet: Remove. + * ccl-bootsys.lsp.pamphlet: Likewise. + * boot-proclaims.lisp: Likewise. + +2007-06-18 Gabriel Dos Reis <gdr@cs.tamu,edu> + + * ast.boot.pamphlet (bfModule, bfImport, bfTypeAliasDefinition): + Remove. + * parser.boot.pamphlet (bpModule): Update. Call Module instead of + bfModule. + (bpImport): Call Import instead of bfImport. + (bpTypeAliasDefinition): Call TypeAlias instead of + bfTypeAliasDefinition. + * translator.boot.pamphlet (bpOutItem): Update. Use + case-statements. + +2007-06-18 Gabriel Dos Reis <gdr@cs.tamu,edu> + + * ast.boot.pamphlet (<<abstract syntax tree>>): New chunk. Define + the core of the Boot syntax tree as Boot data type. Update cached + Lisp translation. + +2007-06-15 Gabriel Dos Reis <gdr@cs.tamu,edu> + + * initial-env.lisp.pamphlet: Add more documentation. + ("BOOTTRAN"): Remove export section. + (exit-repl): Tidy. + +2007-05-21 Gabriel Dos Reis <gdr@cs.tamu,edu> + + Add experimental support for modules. + * translator.boot.pamphlet: Import "includer", "scanner", "pile", + "parser", "ast". + (shoeEVALANDFILEACTQ): Move to ast.boot.pamphlet. + (SoftShoeError, shoeSpaces, bpIgnoredFromTo, lineNo, lineString, + lineCharacter, bStreamNull, bDelay, bDelay1, bMap, bMap1, bNext, + bNext1, bRgen, bRgen1, bIgen, bIgen1, bAddLineNumber, + bAddLineNumber1, shoeFindLines, shoePackageStartsAt): Move to + includer.boot.pamphlet. + (shoeOutParse): Handle import and module declarations. + Update Lisp translation. + + * tokens.boot.pamphlet: Document key words. + (shoeInserts, shoeKeyTableCons, shoDictCons, shoePunCons): Move + from scanner.boot.pamphlet. + (shoeKeyWords): Add new keywords "module" and "import". + Update Lisp translation. + + * scanner.boot.pamphlet: Import "tokens", "includer". + (shoeInserts, shoeKeyTableCons, shoDictCons, shoePunCons): Move to + tokens.boot.pamphlet. + Update Lisp translation. + + * pile.boot.pamphlet: Import "includer", "scanner". + + * parser.boot.pamphlet: Import "includer", "scanner", "ast". + (PNAME, bpSpecificErrorAtToken, bpSpecificErrorHere, + bpGeneralErrorHere): Move to includer.boot.pamphlet. + (bpModule, bpImport): New. + (bpComma): Use them. + Update Lisp translation. + + * includer.boot.pamphlet: Import "tokens". + (PNAME, bpSpecificErrorAtToken, bpSpecificErrorHere, + bpGeneralErrorHere): Move from parser.boot.pamphlet. + (EQCAR, shoeNotFound, shoeSpaces, SoftShoeError): + (bpIgnoredFromTo, lineNo, lineString, lineCharacter, + shoeFindLines, bStreamNil, bStreamNull, bMap, bMap1, bDelay, + bDelay1, bAppend, bAppend1, bNext, bNext1, bRgen, bRgen1, bIgen, + bIgen1, bAddLineNumber, bAddLineNumber1): Move from + translator.boot.oamphlet. + (shoeReadLispString): Move to ast.boot.pamphlet. + Update Lisp translation. + + * ast.boot.pamphlet: Import "includer". + (bfModule, bfImport): New. + (shoeReadLispString): Move to includer.boot.pamphlet. + (shoeCompileTimeEvaluation, shoeEVALANDFILEACTQ): Move from + translator.boot.pamphlet. + Update Lisp translation. + * Makefile.pamphlet (boot_sources): Reorder list. + * Makefile.in: Regenerate. + diff --git a/src/boot/Makefile.in b/src/boot/Makefile.in new file mode 100644 index 00000000..444748bf --- /dev/null +++ b/src/boot/Makefile.in @@ -0,0 +1,166 @@ +AXIOM_LOCAL_LISP_sources = initial-env.lisp +AXIOM_LOCAL_LISP = ../lisp/base-lisp$(EXEEXT) +BOOTSYS_FOR_TARGET = $(axiom_target_bindir)/bootsys$(EXEEXT) +PROCLAIMS=(load "$(srcdir)/boot-proclaims.lisp") + +boot_objects = initial-env.$(FASLEXT) $(boot_sources:.boot=.$(FASLEXT)) + +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 $< + +subdir = src/boot/ + +.PHONY: all-ax all-boot +all: all-ax all-boot + +all-ax all-boot: stamp + +stamp: $(BOOTSYS_FOR_TARGET) + @rm -f stamp + $(STAMP) $@ + +$(BOOTSYS_FOR_TARGET): stage2/bootsys$(EXEEXT) + $(INSTALL_PROGRAM) stage2/bootsys$(EXEEXT) $(axiom_build_bindir) + +.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 \ + $(stage0_boot_objects) + + +.PHONY: mk-stage0-dir +mk-stage0-dir: + @[ -d stage0 ] || $(mkinstalldirs) stage0 + +$(stage0_boot_objects): $(AXIOM_LOCAL_LISP) + +stage0/%.$(FASLEXT): stage0/%.clisp + $(AXIOM_LOCAL_LISP) -- --compile \ + --load-directory=stage0 --output=$@ $< + + +stage0/%.clisp: $(srcdir)/%.boot.pamphlet mk-stage0-dir + $(axiom_build_document) --tangle=$*.clisp --output=$@ $< + +%/initial-env.$(FASLEXT): initial-env.lisp mk-%-dir + $(AXIOM_LOCAL_LISP) -- --compile --output=$@ $< + +.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 \ + $(addprefix stage1/, $(boot_objects)) + +stage1/%.$(FASLEXT): stage1/%.clisp + $(AXIOM_LOCAL_LISP) -- --compile \ + --load-directory=stage1 $< + +stage1/%.clisp: %.boot stage0/stamp mk-stage1-dir + stage0/bootsys -- --translate --output=$@ $< + +.PHONY: mk-stage1-dir +mk-stage1-dir: + @[ -d stage1 ] || $(mkinstalldirs) stage1 + +.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 \ + $(addprefix stage2/, $(boot_objects)) + +stage2/%.$(FASLEXT): stage2/%.clisp + $(AXIOM_LOCAL_LISP) -- --compile \ + --load-directory=stage2 $< + +stage2/%.clisp: %.boot stage1/stamp mk-stage2-dir + stage1/bootsys -- --translate --output=$@ $< + +.PHONY: mk-stage2-dir +mk-stage2-dir: + @[ -d stage2 ] || $(mkinstalldirs) stage2 + +## Dependency for various modules. +## FIXME: This should be automatically extracted from the +## Boot source file at packaging time. + +%/tokens.($FASLEXT): %/initial-env.$(FASLEXT) + +%/includer.$(FASLEXT): %/tokens.$(FASLEXT) + +%/scanner.$(FASLEXT): %/tokens.$(FASLEXT) %/includer.$(FASLEXT) + +%/pile.$(FASLEXT): %/scanner.$(FASLEXT) %/includer.$(FASLEXT) + +%/ast.$(FASLEXT): %/includer.$(FASLEXT) + +%/parser.$(FASLEXT): %/ast.$(FASLEXT) %/scanner.$(FASLEXT) %/includer.$(FASLEXT) + +%/translator.$(FASLEXT): %/parser.$(FASLEXT) %/ast.$(FASLEXT) \ + %/pile.$(FASLEXT) %/scanner.$(FASLEXT) \ + %/includer.$(FASLEXT) + +.PRECIOUS: %.boot +%.boot: $(srcdir)/%.boot.pamphlet + $(axiom_build_document) --tangle $< +.PRECIOUS: %.boot + +%.boot: $(srcdir)/%.boot.pamphlet + $(axiom_build_document) --tangle $< +.PRECIOUS: %.lisp + +initial-env.lisp: initial-env.lisp.pamphlet + $(axiom_build_document) --tangle $< + +mostlyclean-local: + @rm -f $(AXIOM_LOCAL_LISP) + @rm -f $(BOOTSYS_FOR_TARGET) + @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 diff --git a/src/boot/Makefile.pamphlet b/src/boot/Makefile.pamphlet new file mode 100644 index 00000000..f53ee379 --- /dev/null +++ b/src/boot/Makefile.pamphlet @@ -0,0 +1,1644 @@ +%% 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{Axiom} 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]].} First we create a Lisp image +that contains at least three macros for translating +Boot source files. We do this by loading \File{initial-env.lisp} +in [[AXIOM_LISP]], and saving the resulting image. That image is then +used to build the bootstrapping Boot translator. +<<environment>>= +AXIOM_LOCAL_LISP_sources = initial-env.lisp +AXIOM_LOCAL_LISP = ../lisp/base-lisp$(EXEEXT) +@ + +\paragraph{[[BOOTSYS_FOR_TARGET]].} +The [[$(BOOTSYS_FOR_TARGET)]] image is the final Boot translator image, +produced after several bootstrap stages. That is the result of +running the \Tool{Make} target [[all-boot]]. +<<environment>>= +BOOTSYS_FOR_TARGET = $(axiom_target_bindir)/bootsys$(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)) + +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 Axiom (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 Axiom 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): %/initial-env.$(FASLEXT) + +%/includer.$(FASLEXT): %/tokens.$(FASLEXT) + +%/scanner.$(FASLEXT): %/tokens.$(FASLEXT) %/includer.$(FASLEXT) + +%/pile.$(FASLEXT): %/scanner.$(FASLEXT) %/includer.$(FASLEXT) + +%/ast.$(FASLEXT): %/includer.$(FASLEXT) + +%/parser.$(FASLEXT): %/ast.$(FASLEXT) %/scanner.$(FASLEXT) %/includer.$(FASLEXT) + +%/translator.$(FASLEXT): %/parser.$(FASLEXT) %/ast.$(FASLEXT) \ + %/pile.$(FASLEXT) %/scanner.$(FASLEXT) \ + %/includer.$(FASLEXT) + +<<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 Axiom 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 Axiom 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 \ + $(stage0_boot_objects) + + +.PHONY: mk-stage0-dir +mk-stage0-dir: + @[ -d stage0 ] || $(mkinstalldirs) stage0 + +$(stage0_boot_objects): $(AXIOM_LOCAL_LISP) + +stage0/%.$(FASLEXT): stage0/%.clisp + $(AXIOM_LOCAL_LISP) -- --compile \ + --load-directory=stage0 --output=$@ $< + + +stage0/%.clisp: $(srcdir)/%.boot.pamphlet mk-stage0-dir + $(axiom_build_document) --tangle=$*.clisp --output=$@ $< + +%/initial-env.$(FASLEXT): initial-env.lisp mk-%-dir + $(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 \ + $(addprefix stage1/, $(boot_objects)) + +stage1/%.$(FASLEXT): stage1/%.clisp + $(AXIOM_LOCAL_LISP) -- --compile \ + --load-directory=stage1 $< + +stage1/%.clisp: %.boot stage0/stamp mk-stage1-dir + stage0/bootsys -- --translate --output=$@ $< + +.PHONY: mk-stage1-dir +mk-stage1-dir: + @[ -d stage1 ] || $(mkinstalldirs) stage1 +@ + +\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 \ + $(addprefix stage2/, $(boot_objects)) + +stage2/%.$(FASLEXT): stage2/%.clisp + $(AXIOM_LOCAL_LISP) -- --compile \ + --load-directory=stage2 $< + +stage2/%.clisp: %.boot stage1/stamp mk-stage2-dir + stage1/bootsys -- --translate --output=$@ $< + +.PHONY: mk-stage2-dir +mk-stage2-dir: + @[ -d stage2 ] || $(mkinstalldirs) stage2 +@ + +<<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_LOCAL_LISP) + @rm -f $(BOOTSYS_FOR_TARGET) + @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: $(BOOTSYS_FOR_TARGET) + @rm -f stamp + $(STAMP) $@ + +$(BOOTSYS_FOR_TARGET): stage2/bootsys$(EXEEXT) + $(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.pamphlet b/src/boot/ast.boot.pamphlet new file mode 100644 index 00000000..bd38fa39 --- /dev/null +++ b/src/boot/ast.boot.pamphlet @@ -0,0 +1,3090 @@ +\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 declaration + TypeAlias(Name, List, List) -- type alias definition + 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 + Definition(Name, List, Ast, Ast) -- x == y or 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" +<<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 [def,op,args,body]== bfDef(def,op,args,body) + +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,g1,g]] + 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:= + [["LAMBDA",vars, + ["LOOP",exits,:sucs]],:inits] + 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)) + +bfSUBLIS1(p,e)== + null p =>e + f:=CAR p + EQ(CAR f,e)=>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]) + + +bfReName x== + a:=GET(x,"SHOERENAME") + if a + then car a + else x + +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") + +(IN-PACKAGE "BOOTTRAN") + +(DEFTYPE |String| () 'STRING) + +(DEFTYPE |Symbol| () 'SYMBOL) + +(DEFTYPE |Sequence| () 'SEQUENCE) + +(DEFTYPE |List| () '(OR NIL CONS)) + +(DEFUN |Name| #0=(|bfVar#1|) (CONS '|Name| (LIST . #0#))) + +(DEFUN |Command| #0=(|bfVar#2|) (CONS '|Command| (LIST . #0#))) + +(DEFUN |Module| #0=(|bfVar#3|) (CONS '|Module| (LIST . #0#))) + +(DEFUN |Import| #0=(|bfVar#4|) (CONS '|Import| (LIST . #0#))) + +(DEFUN |TypeAlias| #0=(|bfVar#5| |bfVar#6| |bfVar#7|) + (CONS '|TypeAlias| (LIST . #0#))) + +(DEFUN |SuffixDot| #0=(|bfVar#8|) (CONS '|SuffixDot| (LIST . #0#))) + +(DEFUN |Quote| #0=(|bfVar#9|) (CONS '|Quote| (LIST . #0#))) + +(DEFUN |EqualName| #0=(|bfVar#10|) (CONS '|EqualName| (LIST . #0#))) + +(DEFUN |Colon| #0=(|bfVar#11|) (CONS '|Colon| (LIST . #0#))) + +(DEFUN |QualifiedName| #0=(|bfVar#12| |bfVar#13|) + (CONS '|QualifiedName| (LIST . #0#))) + +(DEFUN |Bracket| #0=(|bfVar#14|) (CONS '|Bracket| (LIST . #0#))) + +(DEFUN |UnboundedSegment| #0=(|bfVar#15|) + (CONS '|UnboundedSegment| (LIST . #0#))) + +(DEFUN |BoundedSgement| #0=(|bfVar#16| |bfVar#17|) + (CONS '|BoundedSgement| (LIST . #0#))) + +(DEFUN |Tuple| #0=(|bfVar#18|) (CONS '|Tuple| (LIST . #0#))) + +(DEFUN |ColonAppend| #0=(|bfVar#19| |bfVar#20|) + (CONS '|ColonAppend| (LIST . #0#))) + +(DEFUN |Is| #0=(|bfVar#21| |bfVar#22|) (CONS '|Is| (LIST . #0#))) + +(DEFUN |Isnt| #0=(|bfVar#23| |bfVar#24|) (CONS '|Isnt| (LIST . #0#))) + +(DEFUN |Reduce| #0=(|bfVar#25| |bfVar#26|) + (CONS '|Reduce| (LIST . #0#))) + +(DEFUN |PrefixExpr| #0=(|bfVar#27| |bfVar#28|) + (CONS '|PrefixExpr| (LIST . #0#))) + +(DEFUN |Call| #0=(|bfVar#29| |bfVar#30|) (CONS '|Call| (LIST . #0#))) + +(DEFUN |InfixExpr| #0=(|bfVar#31| |bfVar#32| |bfVar#33|) + (CONS '|InfixExpr| (LIST . #0#))) + +(DEFUN |Definition| #0=(|bfVar#34| |bfVar#35| |bfVar#36| |bfVar#37|) + (CONS '|Definition| (LIST . #0#))) + +(DEFUN |Macro| #0=(|bfVar#38| |bfVar#39| |bfVar#40|) + (CONS '|Macro| (LIST . #0#))) + +(DEFUN |SuchThat| #0=(|bfVar#41|) (CONS '|SuchThat| (LIST . #0#))) + +(DEFUN |Assignment| #0=(|bfVar#42| |bfVar#43|) + (CONS '|Assignment| (LIST . #0#))) + +(DEFUN |While| #0=(|bfVar#44|) (CONS '|While| (LIST . #0#))) + +(DEFUN |Until| #0=(|bfVar#45|) (CONS '|Until| (LIST . #0#))) + +(DEFUN |For| #0=(|bfVar#46| |bfVar#47| |bfVar#48|) + (CONS '|For| (LIST . #0#))) + +(DEFUN |Exit| #0=(|bfVar#49| |bfVar#50|) (CONS '|Exit| (LIST . #0#))) + +(DEFUN |Iterators| #0=(|bfVar#51|) (CONS '|Iterators| (LIST . #0#))) + +(DEFUN |Cross| #0=(|bfVar#52|) (CONS '|Cross| (LIST . #0#))) + +(DEFUN |Repeat| #0=(|bfVar#53| |bfVar#54|) + (CONS '|Repeat| (LIST . #0#))) + +(DEFUN |Pile| #0=(|bfVar#55|) (CONS '|Pile| (LIST . #0#))) + +(DEFUN |Append| #0=(|bfVar#56|) (CONS '|Append| (LIST . #0#))) + +(DEFUN |Case| #0=(|bfVar#57| |bfVar#58|) (CONS '|Case| (LIST . #0#))) + +(DEFUN |Return| #0=(|bfVar#59|) (CONS '|Return| (LIST . #0#))) + +(DEFUN |Where| #0=(|bfVar#60| |bfVar#61|) + (CONS '|Where| (LIST . #0#))) + +(DEFUN |Structure| #0=(|bfVar#62| |bfVar#63|) + (CONS '|Structure| (LIST . #0#))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) (DEFPARAMETER |$inDefIS| NIL)) + +(DEFUN |bfGenSymbol| () + (PROG () + (DECLARE (SPECIAL |$GenVarCounter|)) + (RETURN + (PROGN + (SETQ |$GenVarCounter| (+ |$GenVarCounter| 1)) + (INTERN (CONCAT "bfVar#" (STRINGIMAGE |$GenVarCounter|))))))) + +(DEFUN |bfListOf| (|x|) (PROG () (RETURN |x|))) + +(DEFUN |bfColon| (|x|) (PROG () (RETURN (LIST 'COLON |x|)))) + +(DEFUN |bfColonColon| (|package| |name|) + (PROG () (RETURN (INTERN (SYMBOL-NAME |name|) |package|)))) + +(DEFUN |bfSymbol| (|x|) + (PROG () (RETURN (COND ((STRINGP |x|) |x|) ('T (LIST 'QUOTE |x|)))))) + +(DEFUN |bfDot| () (PROG () (RETURN 'DOT))) + +(DEFUN |bfSuffixDot| (|x|) (PROG () (RETURN (LIST |x| 'DOT)))) + +(DEFUN |bfEqual| (|name|) (PROG () (RETURN (LIST 'EQUAL |name|)))) + +(DEFUN |bfBracket| (|part|) (PROG () (RETURN |part|))) + +(DEFUN |bfPile| (|part|) (PROG () (RETURN |part|))) + +(DEFUN |bfAppend| (|x|) (PROG () (RETURN (APPLY #'APPEND |x|)))) + +(DEFUN |bfColonAppend| (|x| |y|) + (PROG (|a|) + (RETURN + (COND + ((NULL |x|) + (COND + ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE) + (PROGN (SETQ |a| (CDR |y|)) 'T)) + (LIST '&REST (CONS 'QUOTE |a|))) + (#0='T (LIST '&REST |y|)))) + (#0# (CONS (CAR |x|) (|bfColonAppend| (CDR |x|) |y|))))))) + +(DEFUN |bfDefinition| (|bflhsitems| |bfrhs| |body|) + (PROG () (RETURN (LIST 'DEF |bflhsitems| |bfrhs| |body|)))) + +(DEFUN |bfMDefinition| (|bflhsitems| |bfrhs| |body|) + (PROG () (RETURN (|bfMDef| 'MDEF |bflhsitems| |bfrhs| |body|)))) + +(DEFUN |bfCompDef| (|bfVar#64|) + (PROG (|body| |args| |op| |def|) + (RETURN + (PROGN + (SETQ |def| (CAR |bfVar#64|)) + (SETQ |op| (CADR . #0=(|bfVar#64|))) + (SETQ |args| (CADDR . #0#)) + (SETQ |body| (CADDDR . #0#)) + (|bfDef| |def| |op| |args| |body|))))) + +(DEFUN |bfBeginsDollar| (|x|) + (PROG () (RETURN (EQL (ELT "$" 0) (ELT (PNAME |x|) 0))))) + +(DEFUN |compFluid| (|id|) (PROG () (RETURN (LIST 'FLUID |id|)))) + +(DEFUN |compFluidize| (|x|) + (PROG () + (RETURN + (COND + ((AND (IDENTP |x|) (|bfBeginsDollar| |x|)) (|compFluid| |x|)) + ((ATOM |x|) |x|) + ((EQCAR |x| 'QUOTE) |x|) + ('T + (CONS (|compFluidize| (CAR |x|)) (|compFluidize| (CDR |x|)))))))) + +(DEFUN |bfTuple| (|x|) (PROG () (RETURN (CONS 'TUPLE |x|)))) + +(DEFUN |bfTupleP| (|x|) (PROG () (RETURN (EQCAR |x| 'TUPLE)))) + +(DEFUN |bfTupleIf| (|x|) + (PROG () + (RETURN (COND ((|bfTupleP| |x|) |x|) ('T (|bfTuple| |x|)))))) + +(DEFUN |bfTupleConstruct| (|b|) + (PROG (|ISTMP#1| |a|) + (RETURN + (PROGN + (SETQ |a| (COND ((|bfTupleP| |b|) (CDR |b|)) ('T (LIST |b|)))) + (COND + (((LAMBDA (|bfVar#66| |bfVar#65| |x|) + (LOOP + (COND + ((OR (ATOM |bfVar#65|) + (PROGN (SETQ |x| (CAR |bfVar#65|)) NIL)) + (RETURN |bfVar#66|)) + ('T + (PROGN + (SETQ |bfVar#66| + (AND (CONSP |x|) (EQ (CAR |x|) 'COLON) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) + (EQ (CDR |ISTMP#1|) NIL))))) + (COND (|bfVar#66| (RETURN |bfVar#66|)))))) + (SETQ |bfVar#65| (CDR |bfVar#65|)))) + NIL |a| NIL) + (|bfMakeCons| |a|)) + ('T (CONS 'LIST |a|))))))) + +(DEFUN |bfConstruct| (|b|) + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (COND ((|bfTupleP| |b|) (CDR |b|)) ('T (LIST |b|)))) + (|bfMakeCons| |a|))))) + +(DEFUN |bfMakeCons| (|l|) + (PROG (|l1| |a| |ISTMP#2| |ISTMP#1|) + (RETURN + (COND + ((NULL |l|) NIL) + ((AND (CONSP |l|) + (PROGN + (SETQ |ISTMP#1| (CAR |l|)) + (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'COLON) + (PROGN + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |a| (CAR |ISTMP#2|)) #0='T))))) + (PROGN (SETQ |l1| (CDR |l|)) #0#)) + (COND + (|l1| (LIST 'APPEND |a| (|bfMakeCons| |l1|))) + (#1='T |a|))) + (#1# (LIST 'CONS (CAR |l|) (|bfMakeCons| (CDR |l|)))))))) + +(DEFUN |bfFor| (|bflhs| U |step|) + (PROG () + (RETURN + (COND + ((EQCAR U '|tails|) (|bfForTree| 'ON |bflhs| (CADR U))) + ((EQCAR U 'SEGMENT) + (|bfSTEP| |bflhs| (CADR U) |step| (CADDR U))) + ('T (|bfForTree| 'IN |bflhs| U)))))) + +(DEFUN |bfForTree| (OP |lhs| |whole|) + (PROG (G) + (RETURN + (PROGN + (SETQ |whole| + (COND + ((|bfTupleP| |whole|) (|bfMakeCons| (CDR |whole|))) + (#0='T |whole|))) + (COND + ((ATOM |lhs|) (|bfINON| (LIST OP |lhs| |whole|))) + (#1='T + (PROGN + (SETQ |lhs| + (COND + ((|bfTupleP| |lhs|) (CADR |lhs|)) + (#0# |lhs|))) + (COND + ((EQCAR |lhs| 'L%T) + (PROGN + (SETQ G (CADR |lhs|)) + (APPEND (|bfINON| (LIST OP G |whole|)) + (|bfSuchthat| (|bfIS| G (CADDR |lhs|)))))) + (#1# + (PROGN + (SETQ G (|bfGenSymbol|)) + (APPEND (|bfINON| (LIST OP G |whole|)) + (|bfSuchthat| (|bfIS| G |lhs|))))))))))))) + +(DEFUN |bfSTEP| (|id| |fst| |step| |lst|) + (PROG (|suc| |ex| |pred| |final| |g2| |inc| |g1| |initval| |initvar|) + (RETURN + (PROGN + (SETQ |initvar| (LIST |id|)) + (SETQ |initval| (LIST |fst|)) + (SETQ |inc| + (COND + ((ATOM |step|) |step|) + (#0='T (SETQ |g1| (|bfGenSymbol|)) + (SETQ |initvar| (CONS |g1| |initvar|)) + (SETQ |initval| (CONS |step| |initval|)) |g1|))) + (SETQ |final| + (COND + ((ATOM |lst|) |lst|) + (#0# (SETQ |g2| (|bfGenSymbol|)) + (SETQ |initvar| (CONS |g2| |initvar|)) + (SETQ |initval| (CONS |lst| |initval|)) |g2|))) + (SETQ |ex| + (COND + ((NULL |lst|) NIL) + ((INTEGERP |inc|) + (PROGN + (SETQ |pred| (COND ((MINUSP |inc|) '<) (#0# '>))) + (LIST (LIST |pred| |id| |final|)))) + ('T + (LIST (LIST 'COND + (LIST (LIST 'MINUSP |inc|) + (LIST '< |id| |final|)) + (LIST 'T (LIST '> |id| |final|))))))) + (SETQ |suc| (LIST (LIST 'SETQ |id| (LIST '+ |id| |inc|)))) + (LIST (LIST |initvar| |initval| |suc| NIL |ex| NIL)))))) + +(DEFUN |bfINON| (|x|) + (PROG (|whole| |id| |op|) + (RETURN + (PROGN + (SETQ |op| (CAR |x|)) + (SETQ |id| (CADR . #0=(|x|))) + (SETQ |whole| (CADDR . #0#)) + (COND + ((EQ |op| 'ON) (|bfON| |id| |whole|)) + ('T (|bfIN| |id| |whole|))))))) + +(DEFUN |bfIN| (|x| E) + (PROG (|g|) + (RETURN + (PROGN + (SETQ |g| (|bfGenSymbol|)) + (LIST (LIST (LIST |g| |x|) (LIST E NIL) + (LIST (LIST 'SETQ |g| (LIST 'CDR |g|))) NIL + (LIST (LIST 'OR (LIST 'ATOM |g|) + (LIST 'PROGN + (LIST 'SETQ |x| (LIST 'CAR |g|)) + 'NIL))) + NIL)))))) + +(DEFUN |bfON| (|x| E) + (PROG () + (RETURN + (LIST (LIST (LIST |x|) (LIST E) + (LIST (LIST 'SETQ |x| (LIST 'CDR |x|))) NIL + (LIST (LIST 'ATOM |x|)) NIL))))) + +(DEFUN |bfSuchthat| (|p|) + (PROG () (RETURN (LIST (LIST NIL NIL NIL (LIST |p|) NIL NIL))))) + +(DEFUN |bfWhile| (|p|) + (PROG () + (RETURN (LIST (LIST NIL NIL NIL NIL (LIST (|bfNOT| |p|)) NIL))))) + +(DEFUN |bfUntil| (|p|) + (PROG (|g|) + (RETURN + (PROGN + (SETQ |g| (|bfGenSymbol|)) + (LIST (LIST (LIST |g|) (LIST NIL) (LIST (LIST 'SETQ |g| |p|)) + NIL (LIST |g|) NIL)))))) + +(DEFUN |bfIterators| (|x|) (PROG () (RETURN (CONS 'ITERATORS |x|)))) + +(DEFUN |bfCross| (|x|) (PROG () (RETURN (CONS 'CROSS |x|)))) + +(DEFUN |bfLp| (|iters| |body|) + (PROG () + (RETURN + (COND + ((EQCAR |iters| 'ITERATORS) (|bfLp1| (CDR |iters|) |body|)) + ('T (|bfLpCross| (CDR |iters|) |body|)))))) + +(DEFUN |bfLpCross| (|iters| |body|) + (PROG () + (RETURN + (COND + ((NULL (CDR |iters|)) (|bfLp| (CAR |iters|) |body|)) + ('T (|bfLp| (CAR |iters|) (|bfLpCross| (CDR |iters|) |body|))))))) + +(DEFUN |bfSep| (|iters|) + (PROG (|r| |f|) + (RETURN + (COND + ((NULL |iters|) (LIST NIL NIL NIL NIL NIL NIL)) + ('T (SETQ |f| (CAR |iters|)) (SETQ |r| (|bfSep| (CDR |iters|))) + ((LAMBDA (|bfVar#69| |bfVar#67| |i| |bfVar#68| |j|) + (LOOP + (COND + ((OR (ATOM |bfVar#67|) + (PROGN (SETQ |i| (CAR |bfVar#67|)) NIL) + (ATOM |bfVar#68|) + (PROGN (SETQ |j| (CAR |bfVar#68|)) NIL)) + (RETURN (NREVERSE |bfVar#69|))) + ('T + (SETQ |bfVar#69| (CONS (APPEND |i| |j|) |bfVar#69|)))) + (SETQ |bfVar#67| (CDR |bfVar#67|)) + (SETQ |bfVar#68| (CDR |bfVar#68|)))) + NIL |f| NIL |r| NIL)))))) + +(DEFUN |bfReduce| (|op| |y|) + (PROG (|it| |ny| |g2| |body| |g1| |g| |init| |a|) + (RETURN + (PROGN + (SETQ |a| + (COND ((EQCAR |op| 'QUOTE) (CADR |op|)) (#0='T |op|))) + (SETQ |op| (|bfReName| |a|)) + (SETQ |init| (GET |op| 'SHOETHETA)) + (SETQ |g| (|bfGenSymbol|)) + (SETQ |g1| (|bfGenSymbol|)) + (SETQ |body| (LIST 'SETQ |g| (LIST |op| |g1| |g|))) + (COND + ((NULL |init|) (SETQ |g2| (|bfGenSymbol|)) + (SETQ |init| (LIST 'CAR |g2|)) (SETQ |ny| (LIST 'CDR |g2|)) + (SETQ |it| + (CONS 'ITERATORS + (LIST (LIST (LIST (LIST |g|) (LIST |init|) NIL + NIL NIL (LIST |g|))) + (|bfIN| |g1| |ny|)))) + (|bfMKPROGN| + (LIST (LIST 'L%T |g2| |y|) (|bfLp| |it| |body|)))) + (#0# (SETQ |init| (CAR |init|)) + (SETQ |it| + (CONS 'ITERATORS + (LIST (LIST (LIST (LIST |g|) (LIST |init|) NIL + NIL NIL (LIST |g|))) + (|bfIN| |g1| |y|)))) + (|bfLp| |it| |body|))))))) + +(DEFUN |bfReduceCollect| (|op| |y|) + (PROG (|init| |a| |itl| |body|) + (RETURN + (COND + ((EQCAR |y| 'COLLECT) (SETQ |body| (ELT |y| 1)) + (SETQ |itl| (ELT |y| 2)) + (SETQ |a| + (COND ((EQCAR |op| 'QUOTE) (CADR |op|)) (#0='T |op|))) + (SETQ |op| (|bfReName| |a|)) + (SETQ |init| (GET |op| 'SHOETHETA)) + (|bfOpReduce| |op| |init| |body| |itl|)) + (#0# (SETQ |a| (|bfTupleConstruct| (ELT |y| 1))) + (|bfReduce| |op| |a|)))))) + +(DEFUN |bfDCollect| (|y| |itl|) + (PROG () (RETURN (LIST 'COLLECT |y| |itl|)))) + +(DEFUN |bfDTuple| (|x|) (PROG () (RETURN (LIST 'DTUPLE |x|)))) + +(DEFUN |bfCollect| (|y| |itl|) + (PROG (|newBody| |a| |ISTMP#1|) + (RETURN + (COND + ((AND (CONSP |y|) (EQ (CAR |y|) 'COLON) + (PROGN + (SETQ |ISTMP#1| (CDR |y|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |a| (CAR |ISTMP#1|)) 'T)))) + (|bf0APPEND| |a| |itl|)) + ((AND (CONSP |y|) (EQ (CAR |y|) 'TUPLE)) + (PROGN + (SETQ |newBody| (|bfConstruct| |y|)) + (|bf0APPEND| |newBody| |itl|))) + ('T (|bf0COLLECT| |y| |itl|)))))) + +(DEFUN |bf0COLLECT| (|y| |itl|) + (PROG () (RETURN (|bfListReduce| 'CONS |y| |itl|)))) + +(DEFUN |bf0APPEND| (|y| |itl|) + (PROG (|extrait| |body| |g|) + (RETURN + (PROGN + (SETQ |g| (|bfGenSymbol|)) + (SETQ |body| + (LIST 'SETQ |g| (LIST 'APPEND (LIST 'REVERSE |y|) |g|))) + (SETQ |extrait| + (LIST (LIST (LIST |g|) (LIST NIL) NIL NIL NIL + (LIST (LIST 'NREVERSE |g|))))) + (|bfLp2| |extrait| |itl| |body|))))) + +(DEFUN |bfListReduce| (|op| |y| |itl|) + (PROG (|extrait| |body| |g|) + (RETURN + (PROGN + (SETQ |g| (|bfGenSymbol|)) + (SETQ |body| (LIST 'SETQ |g| (LIST |op| |y| |g|))) + (SETQ |extrait| + (LIST (LIST (LIST |g|) (LIST NIL) NIL NIL NIL + (LIST (LIST 'NREVERSE |g|))))) + (|bfLp2| |extrait| |itl| |body|))))) + +(DEFUN |bfLp1| (|iters| |body|) + (PROG (|loop| |nbody| |value| |exits| |filters| |sucs| |inits| |vars| + |LETTMP#1|) + (RETURN + (PROGN + (SETQ |LETTMP#1| (|bfSep| (|bfAppend| |iters|))) + (SETQ |vars| (CAR |LETTMP#1|)) + (SETQ |inits| (CADR . #0=(|LETTMP#1|))) + (SETQ |sucs| (CADDR . #0#)) + (SETQ |filters| (CADDDR . #0#)) + (SETQ |exits| (CAR #1=(CDDDDR . #0#))) + (SETQ |value| (CADR #1#)) + (SETQ |nbody| + (COND + ((NULL |filters|) |body|) + (#2='T (|bfAND| (APPEND |filters| (CONS |body| NIL)))))) + (SETQ |value| (COND ((NULL |value|) 'NIL) (#2# (CAR |value|)))) + (SETQ |exits| + (LIST 'COND + (LIST (|bfOR| |exits|) (LIST 'RETURN |value|)) + (LIST ''T |nbody|))) + (SETQ |loop| + (CONS (LIST 'LAMBDA |vars| + (CONS 'LOOP (CONS |exits| |sucs|))) + |inits|)) + |loop|)))) + +(DEFUN |bfLp2| (|extrait| |itl| |body|) + (PROG (|iters|) + (RETURN + (COND + ((EQCAR |itl| 'ITERATORS) + (|bfLp1| (CONS |extrait| (CDR |itl|)) |body|)) + ('T + (PROGN + (SETQ |iters| (CDR |itl|)) + (|bfLpCross| + (CONS (CONS 'ITERATORS (CONS |extrait| (CDAR |iters|))) + (CDR |iters|)) + |body|))))))) + +(DEFUN |bfOpReduce| (|op| |init| |y| |itl|) + (PROG (|extrait| |g1| |body| |g|) + (RETURN + (PROGN + (SETQ |g| (|bfGenSymbol|)) + (SETQ |body| + (COND + ((EQ |op| 'AND) + (|bfMKPROGN| + (LIST (LIST 'SETQ |g| |y|) + (LIST 'COND + (LIST (LIST 'NOT |g|) + (LIST 'RETURN 'NIL)))))) + ((EQ |op| 'OR) + (|bfMKPROGN| + (LIST (LIST 'SETQ |g| |y|) + (LIST 'COND (LIST |g| (LIST 'RETURN |g|)))))) + ('T (LIST 'SETQ |g| (LIST |op| |g| |y|))))) + (COND + ((NULL |init|) (SETQ |g1| (|bfGenSymbol|)) + (SETQ |init| (LIST 'CAR |g1|)) (SETQ |y| (LIST 'CDR |g1|)) + (SETQ |extrait| + (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL + (LIST |g|)))) + (|bfMKPROGN| + (LIST (LIST 'L%T |g1| |y|) + (|bfLp2| |extrait| |itl| |body|)))) + ('T (SETQ |init| (CAR |init|)) + (SETQ |extrait| + (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL + (LIST |g|)))) + (|bfLp2| |extrait| |itl| |body|))))))) + +(DEFUN |bfLoop1| (|body|) + (PROG () (RETURN (|bfLp| (|bfIterators| NIL) |body|)))) + +(DEFUN |bfSegment1| (|lo|) + (PROG () (RETURN (LIST 'SEGMENT |lo| NIL)))) + +(DEFUN |bfSegment2| (|lo| |hi|) + (PROG () (RETURN (LIST 'SEGMENT |lo| |hi|)))) + +(DEFUN |bfForInBy| (|variable| |collection| |step|) + (PROG () (RETURN (|bfFor| |variable| |collection| |step|)))) + +(DEFUN |bfForin| (|lhs| U) (PROG () (RETURN (|bfFor| |lhs| U 1)))) + +(DEFUN |bfLocal| (|a| |b|) + (PROG () + (RETURN + (COND + ((EQ |b| 'FLUID) (|compFluid| |a|)) + ((EQ |b| '|fluid|) (|compFluid| |a|)) + ((EQ |b| '|local|) (|compFluid| |a|)) + ('T |a|))))) + +(DEFUN |bfTake| (|n| |x|) + (PROG () + (RETURN + (COND + ((NULL |x|) |x|) + ((EQL |n| 0) NIL) + ('T (CONS (CAR |x|) (|bfTake| (- |n| 1) (CDR |x|)))))))) + +(DEFUN |bfDrop| (|n| |x|) + (PROG () + (RETURN + (COND + ((OR (NULL |x|) (EQL |n| 0)) |x|) + ('T (|bfDrop| (- |n| 1) (CDR |x|))))))) + +(DEFUN |bfDefSequence| (|l|) (PROG () (RETURN (CONS 'SEQ |l|)))) + +(DEFUN |bfReturnNoName| (|a|) (PROG () (RETURN (LIST 'RETURN |a|)))) + +(DEFUN |bfSUBLIS| (|p| |e|) + (PROG () + (RETURN + (COND + ((ATOM |e|) (|bfSUBLIS1| |p| |e|)) + ((EQCAR |e| 'QUOTE) |e|) + ('T + (CONS (|bfSUBLIS| |p| (CAR |e|)) (|bfSUBLIS| |p| (CDR |e|)))))))) + +(DEFUN |bfSUBLIS1| (|p| |e|) + (PROG (|f|) + (RETURN + (COND + ((NULL |p|) |e|) + (#0='T + (PROGN + (SETQ |f| (CAR |p|)) + (COND + ((EQ (CAR |f|) |e|) (CDR |f|)) + (#0# (|bfSUBLIS1| (CDR |p|) |e|))))))))) + +(DEFUN |defSheepAndGoats| (|x|) + (PROG (|defstack| |op1| |opassoc| |argl| |body| |args| |op| |def|) + (DECLARE (SPECIAL |$op|)) + (RETURN + (COND + ((EQCAR |x| 'DEF) + (PROGN + (SETQ |def| (CAR |x|)) + (SETQ |op| (CADR . #0=(|x|))) + (SETQ |args| (CADDR . #0#)) + (SETQ |body| (CADDDR . #0#)) + (SETQ |argl| + (COND + ((|bfTupleP| |args|) (CDR |args|)) + (#1='T (LIST |args|)))) + (COND + ((NULL |argl|) (SETQ |opassoc| (LIST (CONS |op| |body|))) + (LIST |opassoc| NIL NIL)) + (#1# + (SETQ |op1| + (INTERN (CONCAT (PNAME |$op|) "," (PNAME |op|)))) + (SETQ |opassoc| (LIST (CONS |op| |op1|))) + (SETQ |defstack| (LIST (LIST 'DEF |op1| |args| |body|))) + (LIST |opassoc| |defstack| NIL))))) + ((EQCAR |x| 'SEQ) (|defSheepAndGoatsList| (CDR |x|))) + ('T (LIST NIL NIL (LIST |x|))))))) + +(DEFUN |defSheepAndGoatsList| (|x|) + (PROG (|nondefs1| |defs1| |opassoc1| |nondefs| |defs| |opassoc| + |LETTMP#1|) + (RETURN + (COND + ((NULL |x|) (LIST NIL NIL NIL)) + ('T (SETQ |LETTMP#1| (|defSheepAndGoats| (CAR |x|))) + (SETQ |opassoc| (CAR |LETTMP#1|)) + (SETQ |defs| (CADR . #0=(|LETTMP#1|))) + (SETQ |nondefs| (CADDR . #0#)) + (SETQ |LETTMP#1| (|defSheepAndGoatsList| (CDR |x|))) + (SETQ |opassoc1| (CAR |LETTMP#1|)) + (SETQ |defs1| (CADR . #1=(|LETTMP#1|))) + (SETQ |nondefs1| (CADDR . #1#)) + (LIST (APPEND |opassoc| |opassoc1|) (APPEND |defs| |defs1|) + (APPEND |nondefs| |nondefs1|))))))) + +(DEFUN |bfLetForm| (|lhs| |rhs|) + (PROG () (RETURN (LIST 'L%T |lhs| |rhs|)))) + +(DEFUN |bfLET1| (|lhs| |rhs|) + (PROG (|let1| |g| |l2| |l1| |name| |rhs1| |ISTMP#1|) + (DECLARE (SPECIAL |$letGenVarCounter|)) + (RETURN + (COND + ((IDENTP |lhs|) (|bfLetForm| |lhs| |rhs|)) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'FLUID) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL)))) + (|bfLetForm| |lhs| |rhs|)) + ((AND (IDENTP |rhs|) (NULL (|bfCONTAINED| |rhs| |lhs|))) + (PROGN + (SETQ |rhs1| (|bfLET2| |lhs| |rhs|)) + (COND + ((EQCAR |rhs1| 'L%T) (|bfMKPROGN| (LIST |rhs1| |rhs|))) + ((EQCAR |rhs1| 'PROGN) (APPEND |rhs1| (LIST |rhs|))) + (#0='T + (PROGN + (COND + ((IDENTP (CAR |rhs1|)) + (SETQ |rhs1| (CONS |rhs1| NIL)))) + (|bfMKPROGN| (APPEND |rhs1| (CONS |rhs| NIL)))))))) + ((AND (CONSP |rhs|) (EQCAR |rhs| 'L%T) + (IDENTP (SETQ |name| (CADR |rhs|)))) + (PROGN + (SETQ |l1| (|bfLET1| |name| (CADDR |rhs|))) + (SETQ |l2| (|bfLET1| |lhs| |name|)) + (COND + ((EQCAR |l2| 'PROGN) (|bfMKPROGN| (CONS |l1| (CDR |l2|)))) + (#0# + (PROGN + (COND + ((IDENTP (CAR |l2|)) (SETQ |l2| (CONS |l2| NIL)))) + (|bfMKPROGN| + (CONS |l1| (APPEND |l2| (CONS |name| NIL))))))))) + (#0# + (PROGN + (SETQ |g| + (INTERN (CONCAT "LETTMP#" + (STRINGIMAGE |$letGenVarCounter|)))) + (SETQ |$letGenVarCounter| (+ |$letGenVarCounter| 1)) + (SETQ |rhs1| (LIST 'L%T |g| |rhs|)) + (SETQ |let1| (|bfLET1| |lhs| |g|)) + (COND + ((EQCAR |let1| 'PROGN) + (|bfMKPROGN| (CONS |rhs1| (CDR |let1|)))) + (#0# + (PROGN + (COND + ((IDENTP (CAR |let1|)) + (SETQ |let1| (CONS |let1| NIL)))) + (|bfMKPROGN| + (CONS |rhs1| (APPEND |let1| (CONS |g| NIL))))))))))))) + +(DEFUN |bfCONTAINED| (|x| |y|) + (PROG () + (RETURN + (COND + ((EQ |x| |y|) T) + ((ATOM |y|) NIL) + ('T + (OR (|bfCONTAINED| |x| (CAR |y|)) + (|bfCONTAINED| |x| (CDR |y|)))))))) + +(DEFUN |bfLET2| (|lhs| |rhs|) + (PROG (|isPred| |val1| |ISTMP#3| |g| |rev| |patrev| |l2| |l1| |var2| + |var1| |b| |ISTMP#2| |a| |ISTMP#1|) + (DECLARE (SPECIAL |$inDefIS| |$letGenVarCounter|)) + (RETURN + (COND + ((IDENTP |lhs|) (|bfLetForm| |lhs| |rhs|)) + ((NULL |lhs|) NIL) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'FLUID) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL)))) + (|bfLetForm| |lhs| |rhs|)) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'L%T) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |a| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |b| (CAR |ISTMP#2|)) #0='T)))))) + (PROGN + (SETQ |a| (|bfLET2| |a| |rhs|)) + (COND + ((NULL (SETQ |b| (|bfLET2| |b| |rhs|))) |a|) + ((ATOM |b|) (LIST |a| |b|)) + ((CONSP (CAR |b|)) (CONS |a| |b|)) + (#1='T (LIST |a| |b|))))) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'CONS) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |var1| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |var2| (CAR |ISTMP#2|)) #0#)))))) + (COND + ((OR (EQ |var1| 'DOT) + (AND (CONSP |var1|) (EQCAR |var1| 'QUOTE))) + (|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|))) + (#1# + (PROGN + (SETQ |l1| (|bfLET2| |var1| (|addCARorCDR| 'CAR |rhs|))) + (COND + ((OR (NULL |var2|) (EQ |var2| 'DOT)) |l1|) + (#1# + (PROGN + (COND + ((AND (CONSP |l1|) (ATOM (CAR |l1|))) + (SETQ |l1| (CONS |l1| NIL)))) + (COND + ((IDENTP |var2|) + (APPEND |l1| + (CONS (|bfLetForm| |var2| + (|addCARorCDR| 'CDR |rhs|)) + NIL))) + (#1# + (PROGN + (SETQ |l2| + (|bfLET2| |var2| + (|addCARorCDR| 'CDR |rhs|))) + (COND + ((AND (CONSP |l2|) (ATOM (CAR |l2|))) + (SETQ |l2| (CONS |l2| NIL)))) + (APPEND |l1| |l2|))))))))))) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'APPEND) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |var1| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |var2| (CAR |ISTMP#2|)) #0#)))))) + (PROGN + (SETQ |patrev| (|bfISReverse| |var2| |var1|)) + (SETQ |rev| (LIST 'REVERSE |rhs|)) + (SETQ |g| + (INTERN (CONCAT "LETTMP#" + (STRINGIMAGE |$letGenVarCounter|)))) + (SETQ |$letGenVarCounter| (+ |$letGenVarCounter| 1)) + (SETQ |l2| (|bfLET2| |patrev| |g|)) + (COND + ((AND (CONSP |l2|) (ATOM (CAR |l2|))) + (SETQ |l2| (CONS |l2| NIL)))) + (COND + ((EQ |var1| 'DOT) (CONS (LIST 'L%T |g| |rev|) |l2|)) + ((PROGN + (SETQ |ISTMP#1| (|last| |l2|)) + (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'L%T) + (PROGN + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQUAL (CAR |ISTMP#2|) |var1|) + (PROGN + (SETQ |ISTMP#3| (CDR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (EQ (CDR |ISTMP#3|) NIL) + (PROGN + (SETQ |val1| (CAR |ISTMP#3|)) + #0#))))))) + (CONS (LIST 'L%T |g| |rev|) + (APPEND (REVERSE (CDR (REVERSE |l2|))) + (CONS (|bfLetForm| |var1| + (LIST 'NREVERSE |val1|)) + NIL)))) + (#1# + (CONS (LIST 'L%T |g| |rev|) + (APPEND |l2| + (CONS (|bfLetForm| |var1| + (LIST 'NREVERSE |var1|)) + NIL))))))) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'EQUAL) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |var1| (CAR |ISTMP#1|)) #0#)))) + (LIST 'COND (LIST (LIST 'EQUAL |var1| |rhs|) |var1|))) + (#1# + (PROGN + (SETQ |isPred| + (COND + (|$inDefIS| (|bfIS1| |rhs| |lhs|)) + (#1# (|bfIS| |rhs| |lhs|)))) + (LIST 'COND (LIST |isPred| |rhs|)))))))) + +(DEFUN |bfLET| (|lhs| |rhs|) + (PROG (|$letGenVarCounter|) + (DECLARE (SPECIAL |$letGenVarCounter|)) + (RETURN + (PROGN (SETQ |$letGenVarCounter| 1) (|bfLET1| |lhs| |rhs|))))) + +(DEFUN |addCARorCDR| (|acc| |expr|) + (PROG (|funsR| |funsA| |p| |funs|) + (RETURN + (COND + ((NULL (CONSP |expr|)) (LIST |acc| |expr|)) + ((AND (EQ |acc| 'CAR) (EQCAR |expr| 'REVERSE)) + (LIST 'CAR (CONS 'LAST (CDR |expr|)))) + (#0='T + (PROGN + (SETQ |funs| + '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR + CDAAR CDDAR CDADR CDDDR)) + (SETQ |p| (|bfPosition| (CAR |expr|) |funs|)) + (COND + ((EQUAL |p| (- 1)) (LIST |acc| |expr|)) + (#0# + (PROGN + (SETQ |funsA| + '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR + CAAADR CAADDR CADAAR CADDAR CADADR CADDDR)) + (SETQ |funsR| + '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR + CDAADR CDADDR CDDAAR CDDDAR CDDADR CDDDDR)) + (COND + ((EQ |acc| 'CAR) + (CONS (ELT |funsA| |p|) (CDR |expr|))) + ('T (CONS (ELT |funsR| |p|) (CDR |expr|))))))))))))) + +(DEFUN |bfPosition| (|x| |l|) (PROG () (RETURN (|bfPosn| |x| |l| 0)))) + +(DEFUN |bfPosn| (|x| |l| |n|) + (PROG () + (RETURN + (COND + ((NULL |l|) (- 1)) + ((EQUAL |x| (CAR |l|)) |n|) + ('T (|bfPosn| |x| (CDR |l|) (+ |n| 1))))))) + +(DEFUN |bfISApplication| (|op| |left| |right|) + (PROG () + (RETURN + (COND + ((EQ |op| 'IS) (|bfIS| |left| |right|)) + ((EQ |op| 'ISNT) (|bfNOT| (|bfIS| |left| |right|))) + ('T (LIST |op| |left| |right|)))))) + +(DEFUN |bfIS| (|left| |right|) + (PROG (|$inDefIS| |$isGenVarCounter|) + (DECLARE (SPECIAL |$inDefIS| |$isGenVarCounter|)) + (RETURN + (PROGN + (SETQ |$isGenVarCounter| 1) + (SETQ |$inDefIS| T) + (|bfIS1| |left| |right|))))) + +(DEFUN |bfISReverse| (|x| |a|) + (PROG (|y|) + (RETURN + (COND + ((AND (CONSP |x|) (EQ (CAR |x|) 'CONS)) + (COND + ((NULL (CADDR |x|)) (LIST 'CONS (CADR |x|) |a|)) + (#0='T + (PROGN + (SETQ |y| (|bfISReverse| (CADDR |x|) NIL)) + (RPLACA (CDDR |y|) (LIST 'CONS (CADR |x|) |a|)) + |y|)))) + (#0# + (PROGN + (|bpSpecificErrorHere| "Error in bfISReverse") + (|bpTrap|))))))) + +(DEFUN |bfIS1| (|lhs| |rhs|) + (PROG (|l2| |rev| |patrev| |cls| |b1| |a1| |b| |g| |l| |d| |ISTMP#2| + |c| |a| |ISTMP#1|) + (DECLARE (SPECIAL |$isGenVarCounter|)) + (RETURN + (COND + ((NULL |rhs|) (LIST 'NULL |lhs|)) + ((STRINGP |rhs|) (LIST 'EQ |lhs| (LIST 'QUOTE (INTERN |rhs|)))) + ((NUMBERP |rhs|) (LIST 'EQUAL |lhs| |rhs|)) + ((ATOM |rhs|) (LIST 'PROGN (|bfLetForm| |rhs| |lhs|) ''T)) + ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'QUOTE) + (PROGN + (SETQ |ISTMP#1| (CDR |rhs|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |a| (CAR |ISTMP#1|)) #0='T)))) + (COND + ((IDENTP |a|) (LIST 'EQ |lhs| |rhs|)) + (#1='T (LIST 'EQUAL |lhs| |rhs|)))) + ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'L%T) + (PROGN + (SETQ |ISTMP#1| (CDR |rhs|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |c| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |d| (CAR |ISTMP#2|)) #0#)))))) + (PROGN + (SETQ |l| (|bfLET| |c| |lhs|)) + (|bfAND| (LIST (|bfIS1| |lhs| |d|) + (|bfMKPROGN| (LIST |l| ''T)))))) + ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'EQUAL) + (PROGN + (SETQ |ISTMP#1| (CDR |rhs|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |a| (CAR |ISTMP#1|)) #0#)))) + (LIST 'EQUAL |lhs| |a|)) + ((CONSP |lhs|) + (PROGN + (SETQ |g| + (INTERN (CONCAT "ISTMP#" + (STRINGIMAGE |$isGenVarCounter|)))) + (SETQ |$isGenVarCounter| (+ |$isGenVarCounter| 1)) + (|bfMKPROGN| + (LIST (LIST 'L%T |g| |lhs|) (|bfIS1| |g| |rhs|))))) + ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'CONS) + (PROGN + (SETQ |ISTMP#1| (CDR |rhs|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |a| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |b| (CAR |ISTMP#2|)) #0#)))))) + (COND + ((EQ |a| 'DOT) + (COND + ((NULL |b|) + (|bfAND| (LIST (LIST 'CONSP |lhs|) + (LIST 'EQ (LIST 'CDR |lhs|) 'NIL)))) + (#1# + (|bfAND| (LIST (LIST 'CONSP |lhs|) + (|bfIS1| (LIST 'CDR |lhs|) |b|)))))) + ((NULL |b|) + (|bfAND| (LIST (LIST 'CONSP |lhs|) + (LIST 'EQ (LIST 'CDR |lhs|) 'NIL) + (|bfIS1| (LIST 'CAR |lhs|) |a|)))) + ((EQ |b| 'DOT) + (|bfAND| (LIST (LIST 'CONSP |lhs|) + (|bfIS1| (LIST 'CAR |lhs|) |a|)))) + (#1# + (PROGN + (SETQ |a1| (|bfIS1| (LIST 'CAR |lhs|) |a|)) + (SETQ |b1| (|bfIS1| (LIST 'CDR |lhs|) |b|)) + (COND + ((AND (CONSP |a1|) (EQ (CAR |a1|) 'PROGN) + (PROGN + (SETQ |ISTMP#1| (CDR |a1|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |c| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CDR |ISTMP#2|) NIL) + (EQUAL (CAR |ISTMP#2|) ''T))))) + (CONSP |b1|) (EQ (CAR |b1|) 'PROGN) + (PROGN (SETQ |cls| (CDR |b1|)) #0#)) + (|bfAND| (LIST (LIST 'CONSP |lhs|) + (|bfMKPROGN| (CONS |c| |cls|))))) + (#1# (|bfAND| (LIST (LIST 'CONSP |lhs|) |a1| |b1|)))))))) + ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'APPEND) + (PROGN + (SETQ |ISTMP#1| (CDR |rhs|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |a| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |b| (CAR |ISTMP#2|)) #0#)))))) + (PROGN + (SETQ |patrev| (|bfISReverse| |b| |a|)) + (SETQ |g| + (INTERN (CONCAT "ISTMP#" + (STRINGIMAGE |$isGenVarCounter|)))) + (SETQ |$isGenVarCounter| (+ |$isGenVarCounter| 1)) + (SETQ |rev| + (|bfAND| (LIST (LIST 'CONSP |lhs|) + (LIST 'PROGN + (LIST 'L%T |g| + (LIST 'REVERSE |lhs|)) + ''T)))) + (SETQ |l2| (|bfIS1| |g| |patrev|)) + (COND + ((AND (CONSP |l2|) (ATOM (CAR |l2|))) + (SETQ |l2| (CONS |l2| NIL)))) + (COND + ((EQ |a| 'DOT) (|bfAND| (CONS |rev| |l2|))) + (#1# + (|bfAND| (CONS |rev| + (APPEND |l2| + (CONS + (LIST 'PROGN + (|bfLetForm| |a| + (LIST 'NREVERSE |a|)) + ''T) + NIL)))))))) + (#1# + (PROGN + (|bpSpecificErrorHere| "bad IS code is generated") + (|bpTrap|))))))) + +(DEFUN |bfApplication| (|bfop| |bfarg|) + (PROG () + (RETURN + (COND + ((|bfTupleP| |bfarg|) (CONS |bfop| (CDR |bfarg|))) + ('T (CONS |bfop| (LIST |bfarg|))))))) + +(DEFUN |bfReName| (|x|) + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (GET |x| 'SHOERENAME)) + (COND (|a| (CAR |a|)) ('T |x|)))))) + +(DEFUN |bfInfApplication| (|op| |left| |right|) + (PROG () + (RETURN + (COND + ((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| (LIST |left| |right|))) + ((EQ |op| 'AND) (|bfAND| (LIST |left| |right|))) + ('T (LIST |op| |left| |right|)))))) + +(DEFUN |bfNOT| (|x|) + (PROG (|a| |ISTMP#1|) + (RETURN + (COND + ((AND (CONSP |x|) (EQ (CAR |x|) 'NOT) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |a| (CAR |ISTMP#1|)) #0='T)))) + |a|) + ((AND (CONSP |x|) (EQ (CAR |x|) 'NULL) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |a| (CAR |ISTMP#1|)) #0#)))) + |a|) + ('T (LIST 'NOT |x|)))))) + +(DEFUN |bfFlatten| (|op| |x|) + (PROG () + (RETURN (COND ((EQCAR |x| |op|) (CDR |x|)) ('T (LIST |x|)))))) + +(DEFUN |bfOR| (|l|) + (PROG () + (RETURN + (COND + ((NULL |l|) NIL) + ((NULL (CDR |l|)) (CAR |l|)) + ('T + (CONS 'OR + ((LAMBDA (|bfVar#71| |bfVar#70| |c|) + (LOOP + (COND + ((OR (ATOM |bfVar#70|) + (PROGN (SETQ |c| (CAR |bfVar#70|)) NIL)) + (RETURN (NREVERSE |bfVar#71|))) + ('T + (SETQ |bfVar#71| + (APPEND (REVERSE (|bfFlatten| 'OR |c|)) + |bfVar#71|)))) + (SETQ |bfVar#70| (CDR |bfVar#70|)))) + NIL |l| NIL))))))) + +(DEFUN |bfAND| (|l|) + (PROG () + (RETURN + (COND + ((NULL |l|) 'T) + ((NULL (CDR |l|)) (CAR |l|)) + ('T + (CONS 'AND + ((LAMBDA (|bfVar#73| |bfVar#72| |c|) + (LOOP + (COND + ((OR (ATOM |bfVar#72|) + (PROGN (SETQ |c| (CAR |bfVar#72|)) NIL)) + (RETURN (NREVERSE |bfVar#73|))) + ('T + (SETQ |bfVar#73| + (APPEND (REVERSE (|bfFlatten| 'AND |c|)) + |bfVar#73|)))) + (SETQ |bfVar#72| (CDR |bfVar#72|)))) + NIL |l| NIL))))))) + +(DEFUN |defQuoteId| (|x|) + (PROG () (RETURN (AND (EQCAR |x| 'QUOTE) (IDENTP (CADR |x|)))))) + +(DEFUN |bfSmintable| (|x|) + (PROG () + (RETURN + (OR (INTEGERP |x|) + (AND (CONSP |x|) (MEMQ (CAR |x|) '(SIZE LENGTH))))))) + +(DEFUN |bfQ| (|l| |r|) + (PROG () + (RETURN + (COND + ((OR (|bfSmintable| |l|) (|bfSmintable| |r|)) + (LIST 'EQL |l| |r|)) + ((OR (|defQuoteId| |l|) (|defQuoteId| |r|)) (LIST 'EQ |l| |r|)) + ((NULL |l|) (LIST 'NULL |r|)) + ((NULL |r|) (LIST 'NULL |l|)) + ('T (LIST 'EQUAL |l| |r|)))))) + +(DEFUN |bfLessp| (|l| |r|) + (PROG () + (RETURN + (COND ((EQL |r| 0) (LIST 'MINUSP |l|)) ('T (LIST '< |l| |r|)))))) + +(DEFUN |bfMDef| (|defOp| |op| |args| |body|) + (PROG (|def| |lamex| |sb2| |sb| |largl| |nargl| |sgargl| |gargl| + |LETTMP#1| |argl|) + (DECLARE (SPECIAL |$wheredefs|)) + (RETURN + (PROGN + (SETQ |argl| + (COND + ((|bfTupleP| |args|) (CDR |args|)) + ('T (LIST |args|)))) + (SETQ |LETTMP#1| (|bfGargl| |argl|)) + (SETQ |gargl| (CAR |LETTMP#1|)) + (SETQ |sgargl| (CADR . #0=(|LETTMP#1|))) + (SETQ |nargl| (CADDR . #0#)) + (SETQ |largl| (CADDDR . #0#)) + (SETQ |sb| + ((LAMBDA (|bfVar#76| |bfVar#74| |i| |bfVar#75| |j|) + (LOOP + (COND + ((OR (ATOM |bfVar#74|) + (PROGN (SETQ |i| (CAR |bfVar#74|)) NIL) + (ATOM |bfVar#75|) + (PROGN (SETQ |j| (CAR |bfVar#75|)) NIL)) + (RETURN (NREVERSE |bfVar#76|))) + (#1='T + (SETQ |bfVar#76| + (CONS (CONS |i| |j|) |bfVar#76|)))) + (SETQ |bfVar#74| (CDR |bfVar#74|)) + (SETQ |bfVar#75| (CDR |bfVar#75|)))) + NIL |nargl| NIL |sgargl| NIL)) + (SETQ |body| (SUBLIS |sb| |body|)) + (SETQ |sb2| + ((LAMBDA (|bfVar#79| |bfVar#77| |i| |bfVar#78| |j|) + (LOOP + (COND + ((OR (ATOM |bfVar#77|) + (PROGN (SETQ |i| (CAR |bfVar#77|)) NIL) + (ATOM |bfVar#78|) + (PROGN (SETQ |j| (CAR |bfVar#78|)) NIL)) + (RETURN (NREVERSE |bfVar#79|))) + (#1# + (SETQ |bfVar#79| + (CONS (LIST 'CONS (LIST 'QUOTE |i|) |j|) + |bfVar#79|)))) + (SETQ |bfVar#77| (CDR |bfVar#77|)) + (SETQ |bfVar#78| (CDR |bfVar#78|)))) + NIL |sgargl| NIL |largl| NIL)) + (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|) + ((LAMBDA (|bfVar#81| |bfVar#80| |d|) + (LOOP + (COND + ((OR (ATOM |bfVar#80|) + (PROGN (SETQ |d| (CAR |bfVar#80|)) NIL)) + (RETURN (NREVERSE |bfVar#81|))) + (#1# + (SETQ |bfVar#81| + (APPEND (REVERSE + (|shoeComps| (|bfDef1| |d|))) + |bfVar#81|)))) + (SETQ |bfVar#80| (CDR |bfVar#80|)))) + NIL |$wheredefs| NIL))))))) + +(DEFUN |bfGargl| (|argl|) + (PROG (|f| |d| |c| |b| |a| |LETTMP#1|) + (RETURN + (COND + ((NULL |argl|) (LIST NIL NIL NIL NIL)) + (#0='T (SETQ |LETTMP#1| (|bfGargl| (CDR |argl|))) + (SETQ |a| (CAR |LETTMP#1|)) + (SETQ |b| (CADR . #1=(|LETTMP#1|))) (SETQ |c| (CADDR . #1#)) + (SETQ |d| (CADDDR . #1#)) + (COND + ((EQ (CAR |argl|) '&REST) + (LIST (CONS (CAR |argl|) |b|) |b| |c| + (CONS (LIST 'CONS (LIST 'QUOTE 'LIST) (CAR |d|)) + (CDR |d|)))) + (#0# (SETQ |f| (|bfGenSymbol|)) + (LIST (CONS |f| |a|) (CONS |f| |b|) (CONS (CAR |argl|) |c|) + (CONS |f| |d|))))))))) + +(DEFUN |bfDef1| (|bfVar#82|) + (PROG (|arglp| |control| |quotes| |LETTMP#1| |argl| |body| |args| + |op| |defOp|) + (RETURN + (PROGN + (SETQ |defOp| (CAR |bfVar#82|)) + (SETQ |op| (CADR . #0=(|bfVar#82|))) + (SETQ |args| (CADDR . #0#)) + (SETQ |body| (CADDDR . #0#)) + (SETQ |argl| + (COND + ((|bfTupleP| |args|) (CDR |args|)) + ('T (LIST |args|)))) + (SETQ |LETTMP#1| (|bfInsertLet| |argl| |body|)) + (SETQ |quotes| (CAR |LETTMP#1|)) + (SETQ |control| (CADR . #1=(|LETTMP#1|))) + (SETQ |arglp| (CADDR . #1#)) + (SETQ |body| (CADDDR . #1#)) + (COND + (|quotes| (|shoeLAM| |op| |arglp| |control| |body|)) + ('T (LIST (LIST |op| (LIST 'LAMBDA |arglp| |body|))))))))) + +(DEFUN |shoeLAM| (|op| |args| |control| |body|) + (PROG (|innerfunc| |margs|) + (RETURN + (PROGN + (SETQ |margs| (|bfGenSymbol|)) + (SETQ |innerfunc| (INTERN (CONCAT (PNAME |op|) '|,LAM|))) + (LIST (LIST |innerfunc| (LIST 'LAMBDA |args| |body|)) + (LIST |op| + (LIST 'MLAMBDA (LIST '&REST |margs|) + (LIST 'CONS (LIST 'QUOTE |innerfunc|) + (LIST 'WRAP |margs| + (LIST 'QUOTE |control|)))))))))) + +(DEFUN |bfDef| (|defOp| |op| |args| |body|) + (PROG (|body1| |arg1| |op1| |LETTMP#1|) + (DECLARE (SPECIAL |$wheredefs| |$bfClamming|)) + (RETURN + (COND + (|$bfClamming| + (PROGN + (SETQ |LETTMP#1| + (|shoeComp| + (CAR (|bfDef1| + (LIST |defOp| |op| |args| |body|))))) + (SETQ |op1| (CADR . #0=(|LETTMP#1|))) + (SETQ |arg1| (CADDR . #0#)) + (SETQ |body1| (CDDDR . #0#)) + (|bfCompHash| |op1| |arg1| |body1|))) + ('T + (|bfTuple| + ((LAMBDA (|bfVar#84| |bfVar#83| |d|) + (LOOP + (COND + ((OR (ATOM |bfVar#83|) + (PROGN (SETQ |d| (CAR |bfVar#83|)) NIL)) + (RETURN (NREVERSE |bfVar#84|))) + ('T + (SETQ |bfVar#84| + (APPEND (REVERSE + (|shoeComps| (|bfDef1| |d|))) + |bfVar#84|)))) + (SETQ |bfVar#83| (CDR |bfVar#83|)))) + NIL (CONS (LIST |defOp| |op| |args| |body|) |$wheredefs|) + NIL))))))) + +(DEFUN |shoeComps| (|x|) + (PROG () + (RETURN + ((LAMBDA (|bfVar#86| |bfVar#85| |def|) + (LOOP + (COND + ((OR (ATOM |bfVar#85|) + (PROGN (SETQ |def| (CAR |bfVar#85|)) NIL)) + (RETURN (NREVERSE |bfVar#86|))) + ('T + (SETQ |bfVar#86| (CONS (|shoeComp| |def|) |bfVar#86|)))) + (SETQ |bfVar#85| (CDR |bfVar#85|)))) + NIL |x| NIL)))) + +(DEFUN |shoeComp| (|x|) + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|shoeCompTran| (CADR |x|))) + (COND + ((EQCAR |a| 'LAMBDA) + (CONS 'DEFUN (CONS (CAR |x|) (CONS (CADR |a|) (CDDR |a|))))) + ('T + (CONS 'DEFMACRO + (CONS (CAR |x|) (CONS (CADR |a|) (CDDR |a|)))))))))) + +(DEFUN |bfInsertLet| (|x| |body|) + (PROG (|body2| |name2| |norq1| |b1| |body1| |name1| |norq| |LETTMP#1| + |b| |a| |ISTMP#1|) + (RETURN + (COND + ((NULL |x|) (LIST NIL NIL |x| |body|)) + ((AND (CONSP |x|) (EQ (CAR |x|) '&REST) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |a| (CAR |ISTMP#1|)) #0='T)))) + (COND + ((AND (CONSP |a|) (EQ (CAR |a|) 'QUOTE) + (PROGN + (SETQ |ISTMP#1| (CDR |a|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |b| (CAR |ISTMP#1|)) #0#)))) + (LIST T 'QUOTE (LIST '&REST |b|) |body|)) + (#1='T (LIST NIL NIL |x| |body|)))) + (#1# (SETQ |LETTMP#1| (|bfInsertLet1| (CAR |x|) |body|)) + (SETQ |b| (CAR |LETTMP#1|)) + (SETQ |norq| (CADR . #2=(|LETTMP#1|))) + (SETQ |name1| (CADDR . #2#)) (SETQ |body1| (CADDDR . #2#)) + (SETQ |LETTMP#1| (|bfInsertLet| (CDR |x|) |body1|)) + (SETQ |b1| (CAR |LETTMP#1|)) + (SETQ |norq1| (CADR . #3=(|LETTMP#1|))) + (SETQ |name2| (CADDR . #3#)) (SETQ |body2| (CADDDR . #3#)) + (LIST (OR |b| |b1|) (CONS |norq| |norq1|) + (CONS |name1| |name2|) |body2|)))))) + +(DEFUN |bfInsertLet1| (|y| |body|) + (PROG (|g| |b| |r| |ISTMP#2| |l| |ISTMP#1|) + (RETURN + (COND + ((AND (CONSP |y|) (EQ (CAR |y|) 'L%T) + (PROGN + (SETQ |ISTMP#1| (CDR |y|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |l| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |r| (CAR |ISTMP#2|)) #0='T)))))) + (LIST NIL NIL |l| + (|bfMKPROGN| (LIST (|bfLET| |r| |l|) |body|)))) + ((IDENTP |y|) (LIST NIL NIL |y| |body|)) + ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE) + (PROGN + (SETQ |ISTMP#1| (CDR |y|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |b| (CAR |ISTMP#1|)) #0#)))) + (LIST T 'QUOTE |b| |body|)) + ('T (SETQ |g| (|bfGenSymbol|)) + (COND + ((ATOM |y|) (LIST NIL NIL |g| |body|)) + ('T + (LIST NIL NIL |g| + (|bfMKPROGN| + (LIST (|bfLET| (|compFluidize| |y|) |g|) |body|)))))))))) + +(DEFUN |shoeCompTran| (|x|) + (PROG (|$dollarVars| |$locVars| |$fluidVars| |fvs| |fl| |fvars| + |lvars| |body| |args| |lamtype|) + (DECLARE (SPECIAL |$typings| |$dollarVars| |$fluidVars| |$locVars|)) + (RETURN + (PROGN + (SETQ |lamtype| (CAR |x|)) + (SETQ |args| (CADR |x|)) + (SETQ |body| (CDDR |x|)) + (SETQ |$fluidVars| NIL) + (SETQ |$locVars| NIL) + (SETQ |$dollarVars| NIL) + (|shoeCompTran1| |body|) + (SETQ |$locVars| + (SETDIFFERENCE (SETDIFFERENCE |$locVars| |$fluidVars|) + (|shoeATOMs| |args|))) + (SETQ |body| + (COND + ((OR |$fluidVars| |$locVars| |$dollarVars| |$typings|) + (SETQ |lvars| (APPEND |$fluidVars| |$locVars|)) + (SETQ |$fluidVars| (UNION |$fluidVars| |$dollarVars|)) + (COND + ((NULL |$fluidVars|) + (COND + ((NULL |$typings|) (|shoePROG| |lvars| |body|)) + (#0='T + (|shoePROG| |lvars| + (CONS (CONS 'DECLARE |$typings|) |body|))))) + (#1='T + (SETQ |fvars| + (LIST 'DECLARE (CONS 'SPECIAL |$fluidVars|))) + (COND + ((NULL |$typings|) + (|shoePROG| |lvars| (CONS |fvars| |body|))) + (#0# + (|shoePROG| |lvars| + (CONS |fvars| + (CONS (CONS 'DECLARE |$typings|) + |body|)))))))) + (#1# (|shoePROG| NIL |body|)))) + (SETQ |fl| (|shoeFluids| |args|)) + (SETQ |body| + (COND + (|fl| (SETQ |fvs| (LIST 'DECLARE (CONS 'SPECIAL |fl|))) + (CONS |fvs| |body|)) + (#1# |body|))) + (CONS |lamtype| (CONS |args| |body|)))))) + +(DEFUN |shoePROG| (|v| |b|) + (PROG (|blist| |blast| |LETTMP#1|) + (RETURN + (COND + ((NULL |b|) (LIST (LIST 'PROG |v|))) + ('T + (PROGN + (SETQ |LETTMP#1| (REVERSE |b|)) + (SETQ |blast| (CAR |LETTMP#1|)) + (SETQ |blist| (NREVERSE (CDR |LETTMP#1|))) + (LIST (CONS 'PROG + (CONS |v| + (APPEND |blist| + (CONS (LIST 'RETURN |blast|) NIL))))))))))) + +(DEFUN |shoeFluids| (|x|) + (PROG () + (RETURN + (COND + ((NULL |x|) NIL) + ((AND (IDENTP |x|) (|bfBeginsDollar| |x|)) (LIST |x|)) + ((EQCAR |x| 'QUOTE) NIL) + ((ATOM |x|) NIL) + ('T (APPEND (|shoeFluids| (CAR |x|)) (|shoeFluids| (CDR |x|)))))))) + +(DEFUN |shoeATOMs| (|x|) + (PROG () + (RETURN + (COND + ((NULL |x|) NIL) + ((ATOM |x|) (LIST |x|)) + ('T (APPEND (|shoeATOMs| (CAR |x|)) (|shoeATOMs| (CDR |x|)))))))) + +(DEFUN |shoeCompTran1| (|x|) + (PROG (|res| |newbindings| |r| |ISTMP#2| |l| |ISTMP#1| U) + (DECLARE (SPECIAL |$fluidVars| |$locVars| |$dollarVars|)) + (RETURN + (COND + ((ATOM |x|) + (COND + ((AND (IDENTP |x|) (|bfBeginsDollar| |x|)) + (SETQ |$dollarVars| + (COND + ((MEMQ |x| |$dollarVars|) |$dollarVars|) + (#0='T (CONS |x| |$dollarVars|))))) + (#0# NIL))) + (#0# + (PROGN + (SETQ U (CAR |x|)) + (COND + ((EQ U 'QUOTE) NIL) + ((AND (CONSP |x|) (EQ (CAR |x|) 'L%T) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |l| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |r| (CAR |ISTMP#2|)) 'T)))))) + (PROGN + (RPLACA |x| 'SETQ) + (|shoeCompTran1| |r|) + (COND + ((IDENTP |l|) + (COND + ((NULL (|bfBeginsDollar| |l|)) + (SETQ |$locVars| + (COND + ((MEMQ |l| |$locVars|) |$locVars|) + (#0# (CONS |l| |$locVars|))))) + (#0# + (SETQ |$dollarVars| + (COND + ((MEMQ |l| |$dollarVars|) |$dollarVars|) + (#0# (CONS |l| |$dollarVars|))))))) + ((EQCAR |l| 'FLUID) + (PROGN + (SETQ |$fluidVars| + (COND + ((MEMQ (CADR |l|) |$fluidVars|) + |$fluidVars|) + (#0# (CONS (CADR |l|) |$fluidVars|)))) + (RPLACA (CDR |x|) (CADR |l|))))))) + ((MEMQ U '(PROG LAMBDA)) + (PROGN + (SETQ |newbindings| NIL) + ((LAMBDA (|bfVar#87| |y|) + (LOOP + (COND + ((OR (ATOM |bfVar#87|) + (PROGN (SETQ |y| (CAR |bfVar#87|)) NIL)) + (RETURN NIL)) + (#1='T + (COND + ((NULL (MEMQ |y| |$locVars|)) + (IDENTITY (PROGN + (SETQ |$locVars| + (CONS |y| |$locVars|)) + (SETQ |newbindings| + (CONS |y| |newbindings|)))))))) + (SETQ |bfVar#87| (CDR |bfVar#87|)))) + (CADR |x|) NIL) + (SETQ |res| (|shoeCompTran1| (CDDR |x|))) + (SETQ |$locVars| + ((LAMBDA (|bfVar#89| |bfVar#88| |y|) + (LOOP + (COND + ((OR (ATOM |bfVar#88|) + (PROGN + (SETQ |y| (CAR |bfVar#88|)) + NIL)) + (RETURN (NREVERSE |bfVar#89|))) + (#1# + (AND (NULL (MEMQ |y| |newbindings|)) + (SETQ |bfVar#89| + (CONS |y| |bfVar#89|))))) + (SETQ |bfVar#88| (CDR |bfVar#88|)))) + NIL |$locVars| NIL)))) + (#0# + (PROGN + (|shoeCompTran1| (CAR |x|)) + (|shoeCompTran1| (CDR |x|))))))))))) + +(DEFUN |bfTagged| (|a| |b|) + (PROG () + (DECLARE (SPECIAL |$typings|)) + (RETURN + (COND + ((IDENTP |a|) + (COND + ((EQ |b| 'FLUID) (|bfLET| (|compFluid| |a|) NIL)) + ((EQ |b| '|fluid|) (|bfLET| (|compFluid| |a|) NIL)) + ((EQ |b| '|local|) (|bfLET| (|compFluid| |a|) NIL)) + (#0='T + (PROGN + (SETQ |$typings| (CONS (LIST 'TYPE |b| |a|) |$typings|)) + |a|)))) + (#0# (LIST 'THE |b| |a|)))))) + +(DEFUN |bfAssign| (|l| |r|) + (PROG () + (RETURN + (COND + ((|bfTupleP| |l|) (|bfSetelt| (CADR |l|) (CDDR |l|) |r|)) + ('T (|bfLET| |l| |r|)))))) + +(DEFUN |bfSetelt| (|e| |l| |r|) + (PROG () + (RETURN + (COND + ((NULL (CDR |l|)) (|defSETELT| |e| (CAR |l|) |r|)) + ('T (|bfSetelt| (|bfElt| |e| (CAR |l|)) (CDR |l|) |r|)))))) + +(DEFUN |bfElt| (|expr| |sel|) + (PROG (|y|) + (RETURN + (PROGN + (SETQ |y| (AND (SYMBOLP |sel|) (GET |sel| 'SHOESELFUNCTION))) + (COND + (|y| (COND + ((INTEGERP |y|) (LIST 'ELT |expr| |y|)) + (#0='T (LIST |y| |expr|)))) + (#0# (LIST 'ELT |expr| |sel|))))))) + +(DEFUN |defSETELT| (|var| |sel| |expr|) + (PROG (|y|) + (RETURN + (PROGN + (SETQ |y| (AND (SYMBOLP |sel|) (GET |sel| 'SHOESELFUNCTION))) + (COND + (|y| (COND + ((INTEGERP |y|) + (LIST 'SETF (LIST 'ELT |var| |y|) |expr|)) + (#0='T (LIST 'SETF (LIST |y| |var|) |expr|)))) + (#0# (LIST 'SETF (LIST 'ELT |var| |sel|) |expr|))))))) + +(DEFUN |bfIfThenOnly| (|a| |b|) + (PROG (|b1|) + (RETURN + (PROGN + (SETQ |b1| + (COND ((EQCAR |b| 'PROGN) (CDR |b|)) ('T (LIST |b|)))) + (LIST 'COND (CONS |a| |b1|)))))) + +(DEFUN |bfIf| (|a| |b| |c|) + (PROG (|c1| |b1|) + (RETURN + (PROGN + (SETQ |b1| + (COND ((EQCAR |b| 'PROGN) (CDR |b|)) (#0='T (LIST |b|)))) + (COND + ((EQCAR |c| 'COND) + (CONS 'COND (CONS (CONS |a| |b1|) (CDR |c|)))) + ('T + (PROGN + (SETQ |c1| + (COND + ((EQCAR |c| 'PROGN) (CDR |c|)) + (#0# (LIST |c|)))) + (LIST 'COND (CONS |a| |b1|) (CONS ''T |c1|))))))))) + +(DEFUN |bfExit| (|a| |b|) + (PROG () (RETURN (LIST 'COND (LIST |a| (LIST 'IDENTITY |b|)))))) + +(DEFUN |bfMKPROGN| (|l|) + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| + ((LAMBDA (|bfVar#90| |c|) + (LOOP + (COND + ((ATOM |c|) (RETURN (NREVERSE |bfVar#90|))) + ('T + (SETQ |bfVar#90| + (APPEND (REVERSE (|bfFlattenSeq| |c|)) + |bfVar#90|)))) + (SETQ |c| (CDR |c|)))) + NIL |l|)) + (COND + ((NULL |a|) NIL) + ((NULL (CDR |a|)) (CAR |a|)) + ('T (CONS 'PROGN |a|))))))) + +(DEFUN |bfFlattenSeq| (|x|) + (PROG (|f|) + (RETURN + (COND + ((NULL |x|) NIL) + (#0='T + (PROGN + (SETQ |f| (CAR |x|)) + (COND + ((ATOM |f|) (COND ((CDR |x|) NIL) ('T (LIST |f|)))) + ((EQCAR |f| 'PROGN) + (COND + ((CDR |x|) + ((LAMBDA (|bfVar#92| |bfVar#91| |i|) + (LOOP + (COND + ((OR (ATOM |bfVar#91|) + (PROGN (SETQ |i| (CAR |bfVar#91|)) NIL)) + (RETURN (NREVERSE |bfVar#92|))) + ('T + (AND (NULL (ATOM |i|)) + (SETQ |bfVar#92| (CONS |i| |bfVar#92|))))) + (SETQ |bfVar#91| (CDR |bfVar#91|)))) + NIL (CDR |f|) NIL)) + (#0# (CDR |f|)))) + (#0# (LIST |f|))))))))) + +(DEFUN |bfSequence| (|l|) + (PROG (|f| |aft| |before| |no| |transform| |b| |ISTMP#5| |ISTMP#4| + |ISTMP#3| |a| |ISTMP#2| |ISTMP#1|) + (RETURN + (COND + ((NULL |l|) NIL) + (#0='T + (PROGN + (SETQ |transform| + ((LAMBDA (|bfVar#94| |bfVar#93| |x|) + (LOOP + (COND + ((OR (ATOM |bfVar#93|) + (PROGN (SETQ |x| (CAR |bfVar#93|)) NIL) + (NOT (AND (CONSP |x|) (EQ (CAR |x|) 'COND) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) + (EQ (CDR |ISTMP#1|) NIL) + (PROGN + (SETQ |ISTMP#2| + (CAR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (PROGN + (SETQ |a| + (CAR |ISTMP#2|)) + (SETQ |ISTMP#3| + (CDR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (EQ (CDR |ISTMP#3|) + NIL) + (PROGN + (SETQ |ISTMP#4| + (CAR |ISTMP#3|)) + (AND + (CONSP |ISTMP#4|) + (EQ (CAR |ISTMP#4|) + 'IDENTITY) + (PROGN + (SETQ |ISTMP#5| + (CDR |ISTMP#4|)) + (AND + (CONSP |ISTMP#5|) + (EQ + (CDR |ISTMP#5|) + NIL) + (PROGN + (SETQ |b| + (CAR + |ISTMP#5|)) + 'T)))))))))))))) + (RETURN (NREVERSE |bfVar#94|))) + ('T + (SETQ |bfVar#94| + (CONS (LIST |a| |b|) |bfVar#94|)))) + (SETQ |bfVar#93| (CDR |bfVar#93|)))) + NIL |l| NIL)) + (SETQ |no| (LENGTH |transform|)) + (SETQ |before| (|bfTake| |no| |l|)) + (SETQ |aft| (|bfDrop| |no| |l|)) + (COND + ((NULL |before|) + (COND + ((NULL (CDR |l|)) + (PROGN + (SETQ |f| (CAR |l|)) + (COND + ((EQCAR |f| 'PROGN) (|bfSequence| (CDR |f|))) + ('T |f|)))) + (#0# + (|bfMKPROGN| + (LIST (CAR |l|) (|bfSequence| (CDR |l|))))))) + ((NULL |aft|) (CONS 'COND |transform|)) + (#0# + (CONS 'COND + (APPEND |transform| + (CONS (LIST ''T (|bfSequence| |aft|)) NIL))))))))))) + +(DEFUN |bfWhere| (|context| |expr|) + (PROG (|a| |body| |ISTMP#3| |args| |ISTMP#2| |op| |ISTMP#1| |def| + |nondefs| |defs| |opassoc| |LETTMP#1|) + (DECLARE (SPECIAL |$wheredefs|)) + (RETURN + (PROGN + (SETQ |LETTMP#1| (|defSheepAndGoats| |context|)) + (SETQ |opassoc| (CAR |LETTMP#1|)) + (SETQ |defs| (CADR . #0=(|LETTMP#1|))) + (SETQ |nondefs| (CADDR . #0#)) + (SETQ |a| + ((LAMBDA (|bfVar#96| |bfVar#95| |d|) + (LOOP + (COND + ((OR (ATOM |bfVar#95|) + (PROGN (SETQ |d| (CAR |bfVar#95|)) NIL)) + (RETURN (NREVERSE |bfVar#96|))) + ('T + (AND (CONSP |d|) + (PROGN + (SETQ |def| (CAR |d|)) + (SETQ |ISTMP#1| (CDR |d|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |op| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (PROGN + (SETQ |args| (CAR |ISTMP#2|)) + (SETQ |ISTMP#3| (CDR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (EQ (CDR |ISTMP#3|) NIL) + (PROGN + (SETQ |body| (CAR |ISTMP#3|)) + 'T))))))) + (SETQ |bfVar#96| + (CONS (LIST |def| |op| |args| + (|bfSUBLIS| |opassoc| |body|)) + |bfVar#96|))))) + (SETQ |bfVar#95| (CDR |bfVar#95|)))) + NIL |defs| NIL)) + (SETQ |$wheredefs| (APPEND |a| |$wheredefs|)) + (|bfMKPROGN| + (|bfSUBLIS| |opassoc| (NCONC |nondefs| (LIST |expr|)))))))) + +(DEFUN |bfReadLisp| (|string|) + (PROG () (RETURN (|bfTuple| (|shoeReadLispString| |string| 0))))) + +(DEFUN |bfCompHash| (|op| |argl| |body|) + (PROG (|computeFunction| |auxfn|) + (RETURN + (PROGN + (SETQ |auxfn| (INTERN (CONCAT (PNAME |op|) ";"))) + (SETQ |computeFunction| + (CONS 'DEFUN (CONS |auxfn| (CONS |argl| |body|)))) + (|bfTuple| (CONS |computeFunction| (|bfMain| |auxfn| |op|))))))) + +(DEFUN |shoeCompileTimeEvaluation| (|x|) + (PROG () (RETURN (LIST 'EVAL-WHEN (LIST :COMPILE-TOPLEVEL) |x|)))) + +(DEFUN |shoeEVALANDFILEACTQ| (|x|) + (PROG () + (RETURN (LIST 'EVAL-WHEN (LIST :EXECUTE :LOAD-TOPLEVEL) |x|)))) + +(DEFUN |bfMain| (|auxfn| |op|) + (PROG (|cacheVector| |cacheCountCode| |cacheResetCode| |cacheType| + |mainFunction| |codeBody| |thirdPredPair| |putCode| + |secondPredPair| |getCode| |g2| |cacheName| |computeValue| + |arg| |g1|) + (RETURN + (PROGN + (SETQ |g1| (|bfGenSymbol|)) + (SETQ |arg| (LIST '&REST |g1|)) + (SETQ |computeValue| + (LIST 'APPLY (LIST 'FUNCTION |auxfn|) |g1|)) + (SETQ |cacheName| (INTERN (CONCAT (PNAME |op|) ";AL"))) + (SETQ |g2| (|bfGenSymbol|)) + (SETQ |getCode| (LIST 'GETHASH |g1| |cacheName|)) + (SETQ |secondPredPair| (LIST (LIST 'SETQ |g2| |getCode|) |g2|)) + (SETQ |putCode| (LIST 'SETF |getCode| |computeValue|)) + (SETQ |thirdPredPair| (LIST ''T |putCode|)) + (SETQ |codeBody| + (LIST 'PROG (LIST |g2|) + (LIST 'RETURN + (LIST 'COND |secondPredPair| |thirdPredPair|)))) + (SETQ |mainFunction| (LIST 'DEFUN |op| |arg| |codeBody|)) + (SETQ |cacheType| '|hash-table|) + (SETQ |cacheResetCode| + (LIST 'SETQ |cacheName| + (LIST 'MAKE-HASHTABLE (LIST 'QUOTE 'UEQUAL)))) + (SETQ |cacheCountCode| (LIST '|hashCount| |cacheName|)) + (SETQ |cacheVector| + (LIST |op| |cacheName| |cacheType| |cacheResetCode| + |cacheCountCode|)) + (LIST |mainFunction| + (|shoeEVALANDFILEACTQ| + (LIST 'SETF + (LIST 'GET (LIST 'QUOTE |op|) + (LIST 'QUOTE '|cacheInfo|)) + (LIST 'QUOTE |cacheVector|))) + (|shoeEVALANDFILEACTQ| |cacheResetCode|)))))) + +(DEFUN |bfNameOnly| (|x|) + (PROG () (RETURN (COND ((EQ |x| '|t|) (LIST 'T)) ('T (LIST |x|)))))) + +(DEFUN |bfNameArgs| (|x| |y|) + (PROG () + (RETURN + (PROGN + (SETQ |y| + (COND ((EQCAR |y| 'TUPLE) (CDR |y|)) ('T (LIST |y|)))) + (CONS |x| |y|))))) + +(DEFUN |bfStruct| (|name| |arglist|) + (PROG () + (RETURN + (|bfTuple| + ((LAMBDA (|bfVar#98| |bfVar#97| |i|) + (LOOP + (COND + ((OR (ATOM |bfVar#97|) + (PROGN (SETQ |i| (CAR |bfVar#97|)) NIL)) + (RETURN (NREVERSE |bfVar#98|))) + ('T + (SETQ |bfVar#98| + (CONS (|bfCreateDef| |i|) |bfVar#98|)))) + (SETQ |bfVar#97| (CDR |bfVar#97|)))) + NIL |arglist| NIL))))) + +(DEFUN |bfCreateDef| (|x|) + (PROG (|a| |f|) + (RETURN + (COND + ((NULL (CDR |x|)) (SETQ |f| (CAR |x|)) + (LIST 'SETQ |f| (LIST 'LIST (LIST 'QUOTE |f|)))) + ('T + (SETQ |a| + ((LAMBDA (|bfVar#100| |bfVar#99| |i|) + (LOOP + (COND + ((OR (ATOM |bfVar#99|) + (PROGN (SETQ |i| (CAR |bfVar#99|)) NIL)) + (RETURN (NREVERSE |bfVar#100|))) + ('T + (SETQ |bfVar#100| + (CONS (|bfGenSymbol|) |bfVar#100|)))) + (SETQ |bfVar#99| (CDR |bfVar#99|)))) + NIL (CDR |x|) NIL)) + (LIST 'DEFUN (CAR |x|) |a| + (LIST 'CONS (LIST 'QUOTE (CAR |x|)) (CONS 'LIST |a|)))))))) + +(DEFUN |bfCaseItem| (|x| |y|) (PROG () (RETURN (LIST |x| |y|)))) + +(DEFUN |bfCase| (|x| |y|) + (PROG (|c| |b| |a| |g1| |g|) + (RETURN + (PROGN + (SETQ |g| (|bfGenSymbol|)) + (SETQ |g1| (|bfGenSymbol|)) + (SETQ |a| (|bfLET| |g| |x|)) + (SETQ |b| (|bfLET| |g1| (LIST 'CDR |g|))) + (SETQ |c| (|bfCaseItems| |g1| |y|)) + (|bfMKPROGN| + (LIST |a| |b| (CONS 'CASE (CONS (LIST 'CAR |g|) |c|)))))))) + +(DEFUN |bfCaseItems| (|g| |x|) + (PROG (|j| |ISTMP#1| |i|) + (RETURN + ((LAMBDA (|bfVar#103| |bfVar#102| |bfVar#101|) + (LOOP + (COND + ((OR (ATOM |bfVar#102|) + (PROGN (SETQ |bfVar#101| (CAR |bfVar#102|)) NIL)) + (RETURN (NREVERSE |bfVar#103|))) + ('T + (AND (CONSP |bfVar#101|) + (PROGN + (SETQ |i| (CAR |bfVar#101|)) + (SETQ |ISTMP#1| (CDR |bfVar#101|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |j| (CAR |ISTMP#1|)) 'T))) + (SETQ |bfVar#103| + (CONS (|bfCI| |g| |i| |j|) |bfVar#103|))))) + (SETQ |bfVar#102| (CDR |bfVar#102|)))) + NIL |x| NIL)))) + +(DEFUN |bfCI| (|g| |x| |y|) + (PROG (|b| |a|) + (RETURN + (PROGN + (SETQ |a| (CDR |x|)) + (COND + ((NULL |a|) (LIST (CAR |x|) |y|)) + ('T + (SETQ |b| + ((LAMBDA (|bfVar#105| |bfVar#104| |i| |j|) + (LOOP + (COND + ((OR (ATOM |bfVar#104|) + (PROGN (SETQ |i| (CAR |bfVar#104|)) NIL)) + (RETURN (NREVERSE |bfVar#105|))) + ('T + (SETQ |bfVar#105| + (CONS (LIST |i| (|bfCARCDR| |j| |g|)) + |bfVar#105|)))) + (SETQ |bfVar#104| (CDR |bfVar#104|)) + (SETQ |j| (+ |j| 1)))) + NIL |a| NIL 0)) + (LIST (CAR |x|) (LIST 'LET |b| |y|)))))))) + +(DEFUN |bfCARCDR| (|n| |g|) + (PROG () + (RETURN (LIST (INTERN (CONCAT "CA" (|bfDs| |n|) "R")) |g|)))) + +(DEFUN |bfDs| (|n|) + (PROG () + (RETURN + (COND ((EQL |n| 0) "") ('T (CONCAT "D" (|bfDs| (- |n| 1)))))))) + +@ + +\end{document} diff --git a/src/boot/includer.boot.pamphlet b/src/boot/includer.boot.pamphlet new file mode 100644 index 00000000..803d5666 --- /dev/null +++ b/src/boot/includer.boot.pamphlet @@ -0,0 +1,1224 @@ +\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 == + error [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)== + error ['"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 (|error| (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 + (|error| (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|))))))))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (DEFPARAMETER |$bStreamNil| (LIST '|nullstream|))) + +(DEFUN |bStreamNull| (|x|) + (PROG (|st|) + (RETURN + (COND + ((OR (NULL |x|) (EQCAR |x| '|nullstream|)) T) + ('T + (PROGN + ((LAMBDA () + (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|) + (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|) + (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) + ((LAMBDA (|bfVar#1| |i| |j|) + (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)))) + (- (LENGTH |prefix|) 1) 0 0) + (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|) + (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 () + (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.pamphlet new file mode 100644 index 00000000..f06b6a65 --- /dev/null +++ b/src/boot/initial-env.lisp.pamphlet @@ -0,0 +1,243 @@ +%% 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. +;; +;; 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{The \code{BOOTTRAN} package} + +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" "SYSTEM")) + +@ + +\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") + +;## need the conditional here so it appears in boottran +#+:ieee-floating-point (defparameter $ieee t) +#-:ieee-floating-point (defparameter $ieee nil) + +(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 concat (&rest l) + (progn + (setq l (mapcar #'string l)) + (apply #'concatenate 'string l))) + +(defun |shoeInputFile| (filespec ) + (open filespec :direction :input :if-does-not-exist nil)) + +<<with-input-file>> + +<<with-output-file>> + +(defun shoeprettyprin1 (x &optional (stream *standard-output*)) + (let ((*print-pretty* t) + (*print-array* t) + (*print-circle* t) + (*print-level* nil) + (*print-length* nil)) + (prin1 x stream))) + +(defun reallyprettyprint (x &optional (stream *terminal-io*)) + (shoeprettyprin1 x stream) (terpri stream)) + +(defun shoeprettyprin0 (x &optional (stream *standard-output*)) + (let ((*print-pretty* 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)) + +(defun make-full-cvec (sint &optional (char #\space)) + (make-string sint :initial-element (character char))) + +(defun |shoePLACEP| (item) + (eq item nil)) + +(defun substring (cvec 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"))))) + (make-hash-table :test test))) + +(defun HKEYS (table) + (let (keys) + (maphash #'(lambda (key val) + (declare (ignore val)) + (push key keys)) table) + keys)) + + +(defun HPUT (table key value) + (setf (gethash key table) value)) + +(defun QENUM (cvec ind) + (char-code (char cvec ind))) + +(defun charmem (a b) + (member a b :test #'eql)) + +(defun |shoeIdChar| (x) + (or (ALPHANUMERICP x) + (charmem x '(#\' #\? #\%)))) + +(defun |shoeStartsId| (x) + (or (alpha-char-p x) + (charmem x '(#\$ #\? #\%)))) + +(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))))) + (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 ))) + +(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)) + +(defun make-bvec (n) + (bvec-make-full n 0)) + +(defun bvec-setelt (bv i x) + (setf (sbit bv i) x)) + +(defun size (l) + (cond ((vectorp l) (length l)) + ((consp l) (list-length l)) + (t 0))) + +(defun identp (a) + (and (symbolp a) a)) + +(defun |shoeReadLisp| (s n) + (multiple-value-list (read-from-string s nil nil :start n))) + +(defun |last| (x) + (car (last x))) +@ + + +\end{document} diff --git a/src/boot/parser.boot.pamphlet b/src/boot/parser.boot.pamphlet new file mode 100644 index 00000000..043dde0f --- /dev/null +++ b/src/boot/parser.boot.pamphlet @@ -0,0 +1,2453 @@ +\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>> + +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 + +bpImport() == + bpEqKey "IMPORT" => + -- 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()) + +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 NE 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 bfDefinition(bpPop2(),bfTuple nil, 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") + +(IMPORT-MODULE "scanner") + +(IMPORT-MODULE "ast") + +(IN-PACKAGE "BOOTTRAN") + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (DEFPARAMETER |$sawParenthesizedHead| NIL)) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (DEFPARAMETER |$bodyHasReturn| NIL)) + +(DEFUN |bpFirstToken| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok| |$inputStream|)) + (RETURN + (PROGN + (SETQ |$stok| + (COND + ((NULL |$inputStream|) + (|shoeTokConstruct| 'ERROR 'NOMORE + (|shoeTokPosn| |$stok|))) + ('T (CAR |$inputStream|)))) + (SETQ |$ttok| (|shoeTokPart| |$stok|)) + T)))) + +(DEFUN |bpFirstTok| () + (PROG () + (DECLARE (SPECIAL |$bpCount| |$bpParenCount| |$ttok| |$stok| + |$inputStream|)) + (RETURN + (PROGN + (SETQ |$stok| + (COND + ((NULL |$inputStream|) + (|shoeTokConstruct| 'ERROR 'NOMORE + (|shoeTokPosn| |$stok|))) + ('T (CAR |$inputStream|)))) + (SETQ |$ttok| (|shoeTokPart| |$stok|)) + (COND + ((AND (< 0 |$bpParenCount|) (EQCAR |$stok| 'KEY)) + (COND + ((EQ |$ttok| 'SETTAB) + (PROGN (SETQ |$bpCount| (+ |$bpCount| 1)) (|bpNext|))) + ((EQ |$ttok| 'BACKTAB) + (PROGN (SETQ |$bpCount| (- |$bpCount| 1)) (|bpNext|))) + ((EQ |$ttok| 'BACKSET) (|bpNext|)) + (#0='T T))) + (#0# T)))))) + +(DEFUN |bpNext| () + (PROG () + (DECLARE (SPECIAL |$inputStream|)) + (RETURN + (PROGN + (SETQ |$inputStream| (CDR |$inputStream|)) + (|bpFirstTok|))))) + +(DEFUN |bpNextToken| () + (PROG () + (DECLARE (SPECIAL |$inputStream|)) + (RETURN + (PROGN + (SETQ |$inputStream| (CDR |$inputStream|)) + (|bpFirstToken|))))) + +(DEFUN |bpState| () + (PROG () + (DECLARE (SPECIAL |$bpCount| |$bpParenCount| |$stack| + |$inputStream|)) + (RETURN (LIST |$inputStream| |$stack| |$bpParenCount| |$bpCount|)))) + +(DEFUN |bpRestore| (|x|) + (PROG () + (DECLARE (SPECIAL |$bpCount| |$bpParenCount| |$stack| + |$inputStream|)) + (RETURN + (PROGN + (SETQ |$inputStream| (CAR |x|)) + (|bpFirstToken|) + (SETQ |$stack| (CADR |x|)) + (SETQ |$bpParenCount| (CADDR |x|)) + (SETQ |$bpCount| (CADDDR |x|)) + T)))) + +(DEFUN |bpPush| (|x|) + (PROG () + (DECLARE (SPECIAL |$stack|)) + (RETURN (SETQ |$stack| (CONS |x| |$stack|))))) + +(DEFUN |bpPushId| () + (PROG () + (DECLARE (SPECIAL |$stack| |$ttok|)) + (RETURN (SETQ |$stack| (CONS (|bfReName| |$ttok|) |$stack|))))) + +(DEFUN |bpPop1| () + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (PROGN + (SETQ |a| (CAR |$stack|)) + (SETQ |$stack| (CDR |$stack|)) + |a|)))) + +(DEFUN |bpPop2| () + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (PROGN + (SETQ |a| (CADR |$stack|)) + (RPLACD |$stack| (CDDR |$stack|)) + |a|)))) + +(DEFUN |bpPop3| () + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (PROGN + (SETQ |a| (CADDR |$stack|)) + (RPLACD (CDR |$stack|) (CDDDR |$stack|)) + |a|)))) + +(DEFUN |bpIndentParenthesized| (|f|) + (PROG (|$bpCount| |a|) + (DECLARE (SPECIAL |$inputStream| |$bpCount| |$bpParenCount| + |$stok|)) + (RETURN + (PROGN + (SETQ |$bpCount| 0) + (SETQ |a| |$stok|) + (COND + ((|bpEqPeek| 'OPAREN) + (SETQ |$bpParenCount| (+ |$bpParenCount| 1)) (|bpNext|) + (COND + ((AND (APPLY |f| NIL) (|bpFirstTok|) + (OR (|bpEqPeek| 'CPAREN) (|bpParenTrap| |a|))) + (SETQ |$bpParenCount| (- |$bpParenCount| 1)) + (|bpNextToken|) + (COND + ((EQL |$bpCount| 0) T) + (#0='T + (PROGN + (SETQ |$inputStream| + (APPEND (|bpAddTokens| |$bpCount|) + |$inputStream|)) + (|bpFirstToken|) + (COND + ((EQL |$bpParenCount| 0) (PROGN (|bpCancel|) T)) + (#0# T)))))) + ((|bpEqPeek| 'CPAREN) (|bpPush| (|bfTuple| NIL)) + (SETQ |$bpParenCount| (- |$bpParenCount| 1)) + (|bpNextToken|) T) + (#1='T (|bpParenTrap| |a|)))) + (#1# NIL)))))) + +(DEFUN |bpParenthesized| (|f|) + (PROG (|a|) + (DECLARE (SPECIAL |$stok|)) + (RETURN + (PROGN + (SETQ |a| |$stok|) + (COND + ((|bpEqKey| 'OPAREN) + (COND + ((AND (APPLY |f| NIL) + (OR (|bpEqKey| 'CPAREN) (|bpParenTrap| |a|))) + T) + ((|bpEqKey| 'CPAREN) (|bpPush| (|bfTuple| NIL)) T) + (#0='T (|bpParenTrap| |a|)))) + (#0# NIL)))))) + +(DEFUN |bpBracket| (|f|) + (PROG (|a|) + (DECLARE (SPECIAL |$stok|)) + (RETURN + (PROGN + (SETQ |a| |$stok|) + (COND + ((|bpEqKey| 'OBRACK) + (COND + ((AND (APPLY |f| NIL) + (OR (|bpEqKey| 'CBRACK) (|bpBrackTrap| |a|))) + (|bpPush| (|bfBracket| (|bpPop1|)))) + ((|bpEqKey| 'CBRACK) (|bpPush| NIL)) + (#0='T (|bpBrackTrap| |a|)))) + (#0# NIL)))))) + +(DEFUN |bpPileBracketed| (|f|) + (PROG () + (RETURN + (COND + ((|bpEqKey| 'SETTAB) + (COND + ((|bpEqKey| 'BACKTAB) T) + ((AND (APPLY |f| NIL) + (OR (|bpEqKey| 'BACKTAB) (|bpPileTrap|))) + (|bpPush| (|bfPile| (|bpPop1|)))) + (#0='T NIL))) + (#0# NIL))))) + +(DEFUN |bpListof| (|f| |str1| |g|) + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (COND + ((APPLY |f| NIL) + (COND + ((AND (|bpEqKey| |str1|) (OR (APPLY |f| NIL) (|bpTrap|))) + (SETQ |a| |$stack|) (SETQ |$stack| NIL) + ((LAMBDA () + (LOOP + (COND + ((NOT (AND (|bpEqKey| |str1|) + (OR (APPLY |f| NIL) (|bpTrap|)))) + (RETURN NIL)) + ('T 0))))) + (SETQ |$stack| (CONS (NREVERSE |$stack|) |a|)) + (|bpPush| + (FUNCALL |g| + (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|)))))) + (#0='T T))) + (#0# NIL))))) + +(DEFUN |bpListofFun| (|f| |h| |g|) + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (COND + ((APPLY |f| NIL) + (COND + ((AND (APPLY |h| NIL) (OR (APPLY |f| NIL) (|bpTrap|))) + (SETQ |a| |$stack|) (SETQ |$stack| NIL) + ((LAMBDA () + (LOOP + (COND + ((NOT (AND (APPLY |h| NIL) + (OR (APPLY |f| NIL) (|bpTrap|)))) + (RETURN NIL)) + ('T 0))))) + (SETQ |$stack| (CONS (NREVERSE |$stack|) |a|)) + (|bpPush| + (FUNCALL |g| + (|bfListOf| + (CONS (|bpPop3|) + (CONS (|bpPop2|) (|bpPop1|))))))) + (#0='T T))) + (#0# NIL))))) + +(DEFUN |bpList| (|f| |str1| |g|) + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (COND + ((APPLY |f| NIL) + (COND + ((AND (|bpEqKey| |str1|) (OR (APPLY |f| NIL) (|bpTrap|))) + (SETQ |a| |$stack|) (SETQ |$stack| NIL) + ((LAMBDA () + (LOOP + (COND + ((NOT (AND (|bpEqKey| |str1|) + (OR (APPLY |f| NIL) (|bpTrap|)))) + (RETURN NIL)) + ('T 0))))) + (SETQ |$stack| (CONS (NREVERSE |$stack|) |a|)) + (|bpPush| + (FUNCALL |g| + (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|)))))) + (#0='T (|bpPush| (FUNCALL |g| (LIST (|bpPop1|))))))) + (#0# (|bpPush| (FUNCALL |g| NIL))))))) + +(DEFUN |bpOneOrMore| (|f|) + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (COND + ((APPLY |f| NIL) + (PROGN + (SETQ |a| |$stack|) + (SETQ |$stack| NIL) + ((LAMBDA () + (LOOP + (COND ((NOT (APPLY |f| NIL)) (RETURN NIL)) ('T 0))))) + (SETQ |$stack| (CONS (NREVERSE |$stack|) |a|)) + (|bpPush| (CONS (|bpPop2|) (|bpPop1|))))) + ('T NIL))))) + +(DEFUN |bpAnyNo| (|s|) + (PROG () + (RETURN + (PROGN + ((LAMBDA () + (LOOP (COND ((NOT (APPLY |s| NIL)) (RETURN NIL)) ('T 0))))) + T)))) + +(DEFUN |bpAndOr| (|keyword| |p| |f|) + (PROG () + (RETURN + (AND (|bpEqKey| |keyword|) (OR (APPLY |p| NIL) (|bpTrap|)) + (|bpPush| (FUNCALL |f| (|bpPop1|))))))) + +(DEFUN |bpConditional| (|f|) + (PROG () + (RETURN + (COND + ((AND (|bpEqKey| 'IF) (OR (|bpWhere|) (|bpTrap|)) + (OR (|bpEqKey| 'BACKSET) T)) + (COND + ((|bpEqKey| 'SETTAB) + (COND + ((|bpEqKey| 'THEN) + (AND (OR (APPLY |f| NIL) (|bpTrap|)) (|bpElse| |f|) + (|bpEqKey| 'BACKTAB))) + (#0='T (|bpMissing| 'THEN)))) + ((|bpEqKey| 'THEN) + (AND (OR (APPLY |f| NIL) (|bpTrap|)) (|bpElse| |f|))) + (#0# (|bpMissing| '|then|)))) + (#0# NIL))))) + +(DEFUN |bpElse| (|f|) + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((|bpBacksetElse|) + (AND (OR (APPLY |f| NIL) (|bpTrap|)) + (|bpPush| (|bfIf| (|bpPop3|) (|bpPop2|) (|bpPop1|))))) + ('T (|bpRestore| |a|) + (|bpPush| (|bfIfThenOnly| (|bpPop2|) (|bpPop1|))))))))) + +(DEFUN |bpBacksetElse| () + (PROG () + (RETURN + (COND + ((|bpEqKey| 'BACKSET) (|bpEqKey| 'ELSE)) + ('T (|bpEqKey| 'ELSE)))))) + +(DEFUN |bpEqPeek| (|s|) + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN (AND (EQCAR |$stok| 'KEY) (EQ |s| |$ttok|))))) + +(DEFUN |bpEqKey| (|s|) + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN (AND (EQCAR |$stok| 'KEY) (EQ |s| |$ttok|) (|bpNext|))))) + +(DEFUN |bpEqKeyNextTok| (|s|) + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (AND (EQCAR |$stok| 'KEY) (EQ |s| |$ttok|) (|bpNextToken|))))) + +(DEFUN |bpPileTrap| () (PROG () (RETURN (|bpMissing| 'BACKTAB)))) + +(DEFUN |bpBrackTrap| (|x|) + (PROG () (RETURN (|bpMissingMate| '] |x|)))) + +(DEFUN |bpParenTrap| (|x|) + (PROG () (RETURN (|bpMissingMate| '|)| |x|)))) + +(DEFUN |bpMissingMate| (|close| |open|) + (PROG () + (RETURN + (PROGN + (|bpSpecificErrorAtToken| |open| "possibly missing mate") + (|bpMissing| |close|))))) + +(DEFUN |bpMissing| (|s|) + (PROG () + (RETURN + (PROGN + (|bpSpecificErrorHere| + (CONCAT (PNAME |s|) " possibly missing")) + (THROW 'TRAPPOINT 'TRAPPED))))) + +(DEFUN |bpCompMissing| (|s|) + (PROG () (RETURN (OR (|bpEqKey| |s|) (|bpMissing| |s|))))) + +(DEFUN |bpTrap| () + (PROG () + (RETURN + (PROGN (|bpGeneralErrorHere|) (THROW 'TRAPPOINT 'TRAPPED))))) + +(DEFUN |bpRecoverTrap| () + (PROG (|pos2| |pos1|) + (DECLARE (SPECIAL |$stok|)) + (RETURN + (PROGN + (|bpFirstToken|) + (SETQ |pos1| (|shoeTokPosn| |$stok|)) + (|bpMoveTo| 0) + (SETQ |pos2| (|shoeTokPosn| |$stok|)) + (|bpIgnoredFromTo| |pos1| |pos2|) + (|bpPush| (LIST (LIST "pile syntax error"))))))) + +(DEFUN |bpListAndRecover| (|f|) + (PROG (|found| |c| |done| |b| |a|) + (DECLARE (SPECIAL |$inputStream| |$stack|)) + (RETURN + (PROGN + (SETQ |a| |$stack|) + (SETQ |b| NIL) + (SETQ |$stack| NIL) + (SETQ |done| NIL) + (SETQ |c| |$inputStream|) + ((LAMBDA () + (LOOP + (COND + (|done| (RETURN NIL)) + ('T + (PROGN + (SETQ |found| (CATCH 'TRAPPOINT (APPLY |f| NIL))) + (COND + ((EQ |found| 'TRAPPED) (SETQ |$inputStream| |c|) + (|bpRecoverTrap|)) + ((NULL |found|) (SETQ |$inputStream| |c|) + (|bpGeneralErrorHere|) (|bpRecoverTrap|))) + (COND + ((|bpEqKey| 'BACKSET) (SETQ |c| |$inputStream|)) + ((OR (|bpEqPeek| 'BACKTAB) (NULL |$inputStream|)) + (SETQ |done| T)) + (#0='T (SETQ |$inputStream| |c|) + (|bpGeneralErrorHere|) (|bpRecoverTrap|) + (COND + ((OR (|bpEqPeek| 'BACKTAB) + (NULL |$inputStream|)) + (SETQ |done| T)) + (#0# (|bpNext|) (SETQ |c| |$inputStream|))))) + (SETQ |b| (CONS (|bpPop1|) |b|)))))))) + (SETQ |$stack| |a|) + (|bpPush| (NREVERSE |b|)))))) + +(DEFUN |bpMoveTo| (|n|) + (PROG () + (DECLARE (SPECIAL |$bpParenCount| |$bpCount| |$inputStream|)) + (RETURN + (COND + ((NULL |$inputStream|) T) + ((|bpEqPeek| 'BACKTAB) + (COND + ((EQL |n| 0) T) + (#0='T + (PROGN + (|bpNextToken|) + (SETQ |$bpCount| (- |$bpCount| 1)) + (|bpMoveTo| (- |n| 1)))))) + ((|bpEqPeek| 'BACKSET) + (COND + ((EQL |n| 0) T) + (#0# (PROGN (|bpNextToken|) (|bpMoveTo| |n|))))) + ((|bpEqPeek| 'SETTAB) + (PROGN (|bpNextToken|) (|bpMoveTo| (+ |n| 1)))) + ((|bpEqPeek| 'OPAREN) + (PROGN + (|bpNextToken|) + (SETQ |$bpParenCount| (+ |$bpParenCount| 1)) + (|bpMoveTo| |n|))) + ((|bpEqPeek| 'CPAREN) + (PROGN + (|bpNextToken|) + (SETQ |$bpParenCount| (- |$bpParenCount| 1)) + (|bpMoveTo| |n|))) + (#0# (PROGN (|bpNextToken|) (|bpMoveTo| |n|))))))) + +(DEFUN |bpQualifiedName| () + (PROG () + (DECLARE (SPECIAL |$stok|)) + (RETURN + (COND + ((|bpEqPeek| 'COLON-COLON) + (PROGN + (|bpNext|) + (AND (EQCAR |$stok| 'ID) (|bpPushId|) (|bpNext|) + (|bpPush| (|bfColonColon| (|bpPop2|) (|bpPop1|)))))) + ('T NIL))))) + +(DEFUN |bpName| () + (PROG () + (DECLARE (SPECIAL |$stok|)) + (RETURN + (COND + ((EQCAR |$stok| 'ID) + (PROGN + (|bpPushId|) + (|bpNext|) + (|bpAnyNo| #'|bpQualifiedName|))) + ('T NIL))))) + +(DEFUN |bpConstTok| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (COND + ((MEMQ (|shoeTokType| |$stok|) '(INTEGER FLOAT)) + (PROGN (|bpPush| |$ttok|) (|bpNext|))) + ((EQCAR |$stok| 'LISP) + (AND (|bpPush| (|bfReadLisp| |$ttok|)) (|bpNext|))) + ((EQCAR |$stok| 'LISPEXP) (AND (|bpPush| |$ttok|) (|bpNext|))) + ((EQCAR |$stok| 'LINE) + (AND (|bpPush| (LIST '+LINE |$ttok|)) (|bpNext|))) + ((|bpEqPeek| 'QUOTE) + (PROGN + (|bpNext|) + (AND (OR (|bpSexp|) (|bpTrap|)) + (|bpPush| (|bfSymbol| (|bpPop1|)))))) + ('T (|bpString|)))))) + +(DEFUN |bpModule| () + (PROG () + (RETURN + (COND + ((|bpEqKey| 'MODULE) + (AND (|bpConstTok|) (|bpPush| (|Module| (|bpPop1|))))) + ('T NIL))))) + +(DEFUN |bpImport| () + (PROG () + (RETURN + (COND + ((|bpEqKey| 'IMPORT) + (AND (|bpConstTok|) (|bpPush| (|Import| (|bpPop1|))))) + ('T NIL))))) + +(DEFUN |bpTypeAliasDefition| () + (PROG () + (RETURN + (AND (OR (|bpName|) (|bpTrap|)) (|bpEqKey| 'TDEF) (|bpLogical|) + (|bpPush| (|TypeAlias| (|bpPop2|) NIL (|bpPop1|))))))) + +(DEFUN |bpCancel| () + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((|bpEqKeyNextTok| 'SETTAB) + (COND + ((|bpCancel|) + (COND + ((|bpEqKeyNextTok| 'BACKTAB) T) + (#0='T (|bpRestore| |a|) NIL))) + ((|bpEqKeyNextTok| 'BACKTAB) T) + (#0# (|bpRestore| |a|) NIL))) + (#0# NIL)))))) + +(DEFUN |bpAddTokens| (|n|) + (PROG () + (DECLARE (SPECIAL |$stok|)) + (RETURN + (COND + ((EQL |n| 0) NIL) + ((< 0 |n|) + (CONS (|shoeTokConstruct| 'KEY 'SETTAB + (|shoeTokPosn| |$stok|)) + (|bpAddTokens| (- |n| 1)))) + ('T + (CONS (|shoeTokConstruct| 'KEY 'BACKTAB + (|shoeTokPosn| |$stok|)) + (|bpAddTokens| (+ |n| 1)))))))) + +(DEFUN |bpExceptions| () + (PROG () + (RETURN + (OR (|bpEqPeek| 'DOT) (|bpEqPeek| 'QUOTE) (|bpEqPeek| 'OPAREN) + (|bpEqPeek| 'CPAREN) (|bpEqPeek| 'SETTAB) + (|bpEqPeek| 'BACKTAB) (|bpEqPeek| 'BACKSET))))) + +(DEFUN |bpSexpKey| () + (PROG (|a|) + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (COND + ((AND (EQCAR |$stok| 'KEY) (NULL (|bpExceptions|))) + (PROGN + (SETQ |a| (GET |$ttok| 'SHOEINF)) + (COND + ((NULL |a|) (AND (|bpPush| |$ttok|) (|bpNext|))) + (#0='T (AND (|bpPush| |a|) (|bpNext|)))))) + (#0# NIL))))) + +(DEFUN |bpAnyId| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (OR (AND (|bpEqKey| 'MINUS) + (OR (EQCAR |$stok| 'INTEGER) (|bpTrap|)) + (|bpPush| (- |$ttok|)) (|bpNext|)) + (|bpSexpKey|) + (AND (MEMQ (|shoeTokType| |$stok|) + '(ID INTEGER STRING FLOAT)) + (|bpPush| |$ttok|) (|bpNext|)))))) + +(DEFUN |bpSexp| () + (PROG () + (RETURN + (OR (|bpAnyId|) + (AND (|bpEqKey| 'QUOTE) (OR (|bpSexp|) (|bpTrap|)) + (|bpPush| (|bfSymbol| (|bpPop1|)))) + (|bpIndentParenthesized| #'|bpSexp1|))))) + +(DEFUN |bpSexp1| () + (PROG () + (RETURN + (OR (AND (|bpFirstTok|) (|bpSexp|) + (OR (AND (|bpEqKey| 'DOT) (|bpSexp|) + (|bpPush| (CONS (|bpPop2|) (|bpPop1|)))) + (AND (|bpSexp1|) + (|bpPush| (CONS (|bpPop2|) (|bpPop1|)))))) + (|bpPush| NIL))))) + +(DEFUN |bpPrimary1| () + (PROG () + (RETURN + (OR (|bpName|) (|bpDot|) (|bpConstTok|) (|bpConstruct|) + (|bpCase|) (|bpStruct|) (|bpPDefinition|) + (|bpBPileDefinition|))))) + +(DEFUN |bpPrimary| () + (PROG () + (RETURN + (AND (|bpFirstTok|) (OR (|bpPrimary1|) (|bpPrefixOperator|)))))) + +(DEFUN |bpDot| () + (PROG () (RETURN (AND (|bpEqKey| 'DOT) (|bpPush| (|bfDot|)))))) + +(DEFUN |bpPrefixOperator| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (AND (EQCAR |$stok| 'KEY) (GET |$ttok| 'SHOEPRE) (|bpPushId|) + (|bpNext|))))) + +(DEFUN |bpInfixOperator| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (AND (EQCAR |$stok| 'KEY) (GET |$ttok| 'SHOEINF) (|bpPushId|) + (|bpNext|))))) + +(DEFUN |bpSelector| () + (PROG () + (RETURN + (AND (|bpEqKey| 'DOT) + (OR (AND (|bpPrimary|) + (|bpPush| (|bfElt| (|bpPop2|) (|bpPop1|)))) + (|bpPush| (|bfSuffixDot| (|bpPop1|)))))))) + +(DEFUN |bpOperator| () + (PROG () (RETURN (AND (|bpPrimary|) (|bpAnyNo| #'|bpSelector|))))) + +(DEFUN |bpApplication| () + (PROG () + (RETURN + (AND (|bpPrimary|) (|bpAnyNo| #'|bpSelector|) + (OR (AND (|bpApplication|) + (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|)))) + T))))) + +(DEFUN |bpTagged| () + (PROG () + (RETURN + (AND (|bpApplication|) + (OR (AND (|bpEqKey| 'COLON) + (OR (|bpApplication|) (|bpTrap|)) + (|bpPush| (|bfTagged| (|bpPop2|) (|bpPop1|)))) + T))))) + +(DEFUN |bpExpt| () + (PROG () (RETURN (|bpRightAssoc| '(POWER) #'|bpTagged|)))) + +(DEFUN |bpInfKey| (|s|) + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (AND (EQCAR |$stok| 'KEY) (MEMBER |$ttok| |s|) (|bpPushId|) + (|bpNext|))))) + +(DEFUN |bpInfGeneric| (|s|) + (PROG () + (RETURN (AND (|bpInfKey| |s|) (OR (|bpEqKey| 'BACKSET) T))))) + +(DEFUN |bpRightAssoc| (|o| |p|) + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((APPLY |p| NIL) + ((LAMBDA () + (LOOP + (COND + ((NOT (AND (|bpInfGeneric| |o|) + (OR (|bpRightAssoc| |o| |p|) (|bpTrap|)))) + (RETURN NIL)) + ('T + (|bpPush| + (|bfInfApplication| (|bpPop2|) (|bpPop2|) + (|bpPop1|)))))))) + T) + ('T (|bpRestore| |a|) NIL)))))) + +(DEFUN |bpLeftAssoc| (|operations| |parser|) + (PROG () + (RETURN + (COND + ((APPLY |parser| NIL) + ((LAMBDA () + (LOOP + (COND + ((NOT (AND (|bpInfGeneric| |operations|) + (OR (APPLY |parser| NIL) (|bpTrap|)))) + (RETURN NIL)) + ('T + (|bpPush| + (|bfInfApplication| (|bpPop2|) (|bpPop2|) + (|bpPop1|)))))))) + T) + ('T NIL))))) + +(DEFUN |bpString| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (AND (EQ (|shoeTokType| |$stok|) 'STRING) + (|bpPush| (LIST 'QUOTE (INTERN |$ttok|))) (|bpNext|))))) + +(DEFUN |bpThetaName| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (COND + ((AND (EQCAR |$stok| 'ID) (GET |$ttok| 'SHOETHETA)) + (|bpPushId|) (|bpNext|)) + ('T NIL))))) + +(DEFUN |bpReduceOperator| () + (PROG () + (RETURN (OR (|bpInfixOperator|) (|bpString|) (|bpThetaName|))))) + +(DEFUN |bpReduce| () + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((AND (|bpReduceOperator|) (|bpEqKey| 'SLASH)) + (COND + ((|bpEqPeek| 'OBRACK) + (AND (OR (|bpDConstruct|) (|bpTrap|)) + (|bpPush| (|bfReduceCollect| (|bpPop2|) (|bpPop1|))))) + ('T + (AND (OR (|bpApplication|) (|bpTrap|)) + (|bpPush| (|bfReduce| (|bpPop2|) (|bpPop1|))))))) + ('T (|bpRestore| |a|) NIL)))))) + +(DEFUN |bpTimes| () + (PROG () + (RETURN + (OR (|bpReduce|) (|bpLeftAssoc| '(TIMES SLASH) #'|bpExpt|))))) + +(DEFUN |bpMinus| () + (PROG () + (RETURN + (OR (AND (|bpInfGeneric| '(MINUS)) (OR (|bpTimes|) (|bpTrap|)) + (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|)))) + (|bpTimes|))))) + +(DEFUN |bpArith| () + (PROG () (RETURN (|bpLeftAssoc| '(PLUS MINUS) #'|bpMinus|)))) + +(DEFUN |bpIs| () + (PROG () + (RETURN + (AND (|bpArith|) + (OR (AND (|bpInfKey| '(IS ISNT)) + (OR (|bpPattern|) (|bpTrap|)) + (|bpPush| + (|bfISApplication| (|bpPop2|) (|bpPop2|) + (|bpPop1|)))) + T))))) + +(DEFUN |bpBracketConstruct| (|f|) + (PROG () + (RETURN + (AND (|bpBracket| |f|) (|bpPush| (|bfConstruct| (|bpPop1|))))))) + +(DEFUN |bpCompare| () + (PROG () + (RETURN + (AND (|bpIs|) + (OR (AND (|bpInfKey| '(SHOEEQ NE LT LE GT GE IN)) + (OR (|bpIs|) (|bpTrap|)) + (|bpPush| + (|bfInfApplication| (|bpPop2|) (|bpPop2|) + (|bpPop1|)))) + T))))) + +(DEFUN |bpAnd| () + (PROG () (RETURN (|bpLeftAssoc| '(AND) #'|bpCompare|)))) + +(DEFUN |bpNoteReturnStmt| () + (PROG () + (DECLARE (SPECIAL |$bodyHasReturn|)) + (RETURN (PROGN (SETQ |$bodyHasReturn| T) T)))) + +(DEFUN |bpReturn| () + (PROG () + (RETURN + (OR (AND (|bpEqKey| 'RETURN) (|bpNoteReturnStmt|) + (OR (|bpAnd|) (|bpTrap|)) + (|bpPush| (|bfReturnNoName| (|bpPop1|)))) + (|bpAnd|))))) + +(DEFUN |bpLogical| () + (PROG () (RETURN (|bpLeftAssoc| '(OR) #'|bpReturn|)))) + +(DEFUN |bpExpression| () + (PROG () + (RETURN + (OR (AND (|bpEqKey| 'COLON) + (OR (AND (|bpLogical|) + (|bpPush| (|bfApplication| 'COLON (|bpPop1|)))) + (|bpTrap|))) + (|bpLogical|))))) + +(DEFUN |bpStatement| () + (PROG () + (RETURN + (OR (|bpConditional| #'|bpWhere|) (|bpLoop|) (|bpExpression|))))) + +(DEFUN |bpLoop| () + (PROG () + (RETURN + (OR (AND (|bpIterators|) (|bpCompMissing| 'REPEAT) + (OR (|bpWhere|) (|bpTrap|)) + (|bpPush| (|bfLp| (|bpPop2|) (|bpPop1|)))) + (AND (|bpEqKey| 'REPEAT) (OR (|bpLogical|) (|bpTrap|)) + (|bpPush| (|bfLoop1| (|bpPop1|)))))))) + +(DEFUN |bpSuchThat| () + (PROG () (RETURN (|bpAndOr| 'BAR #'|bpWhere| #'|bfSuchthat|)))) + +(DEFUN |bpWhile| () + (PROG () (RETURN (|bpAndOr| 'WHILE #'|bpLogical| #'|bfWhile|)))) + +(DEFUN |bpUntil| () + (PROG () (RETURN (|bpAndOr| 'UNTIL #'|bpLogical| #'|bfUntil|)))) + +(DEFUN |bpForIn| () + (PROG () + (RETURN + (AND (|bpEqKey| 'FOR) (OR (|bpVariable|) (|bpTrap|)) + (|bpCompMissing| 'IN) + (OR (AND (OR (|bpSeg|) (|bpTrap|)) (|bpEqKey| 'BY) + (OR (|bpArith|) (|bpTrap|)) + (|bpPush| + (|bfForInBy| (|bpPop3|) (|bpPop2|) (|bpPop1|)))) + (|bpPush| (|bfForin| (|bpPop2|) (|bpPop1|)))))))) + +(DEFUN |bpSeg| () + (PROG () + (RETURN + (AND (|bpArith|) + (OR (AND (|bpEqKey| 'SEG) + (OR (AND (|bpArith|) + (|bpPush| + (|bfSegment2| (|bpPop2|) (|bpPop1|)))) + (|bpPush| (|bfSegment1| (|bpPop1|))))) + T))))) + +(DEFUN |bpIterator| () + (PROG () + (RETURN (OR (|bpForIn|) (|bpSuchThat|) (|bpWhile|) (|bpUntil|))))) + +(DEFUN |bpIteratorList| () + (PROG () + (RETURN + (AND (|bpOneOrMore| #'|bpIterator|) + (|bpPush| (|bfIterators| (|bpPop1|))))))) + +(DEFUN |bpCrossBackSet| () + (PROG () + (RETURN (AND (|bpEqKey| 'CROSS) (OR (|bpEqKey| 'BACKSET) T))))) + +(DEFUN |bpIterators| () + (PROG () + (RETURN + (|bpListofFun| #'|bpIteratorList| #'|bpCrossBackSet| #'|bfCross|)))) + +(DEFUN |bpAssign| () + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((|bpStatement|) + (COND + ((|bpEqPeek| 'BEC) (|bpRestore| |a|) + (OR (|bpAssignment|) (|bpTrap|))) + (#0='T T))) + (#0# (|bpRestore| |a|) NIL)))))) + +(DEFUN |bpAssignment| () + (PROG () + (RETURN + (AND (|bpAssignVariable|) (|bpEqKey| 'BEC) + (OR (|bpAssign|) (|bpTrap|)) + (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|))))))) + +(DEFUN |bpExit| () + (PROG () + (RETURN + (AND (|bpAssign|) + (OR (AND (|bpEqKey| 'EXIT) (OR (|bpWhere|) (|bpTrap|)) + (|bpPush| (|bfExit| (|bpPop2|) (|bpPop1|)))) + T))))) + +(DEFUN |bpBeginDefinition| () + (PROG () + (DECLARE (SPECIAL |$sawParenthesizedHead|)) + (RETURN + (OR (|bpEqPeek| 'DEF) + (AND |$sawParenthesizedHead| (|bpEqPeek| 'COLON)))))) + +(DEFUN |bpDefinition| () + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((|bpExit|) + (COND + ((|bpBeginDefinition|) + (PROGN (|bpRestore| |a|) (|bpDef|))) + ((|bpEqPeek| 'TDEF) + (PROGN (|bpRestore| |a|) (|bpTypeAliasDefition|))) + ((|bpEqPeek| 'MDEF) (PROGN (|bpRestore| |a|) (|bpMdef|))) + (#0='T T))) + (#0# (PROGN (|bpRestore| |a|) NIL))))))) + +(DEFUN |bpStoreName| () + (PROG () + (DECLARE (SPECIAL |$bodyHasReturn| |$returnType| |$typings| + |$wheredefs| |$op| |$stack|)) + (RETURN + (PROGN + (SETQ |$op| (CAR |$stack|)) + (SETQ |$wheredefs| NIL) + (SETQ |$typings| NIL) + (SETQ |$returnType| T) + (SETQ |$bodyHasReturn| NIL) + T)))) + +(DEFUN |bpReturnType| () + (PROG () + (DECLARE (SPECIAL |$returnType| |$sawParenthesizedHead|)) + (RETURN + (COND + ((AND |$sawParenthesizedHead| (|bpEqKey| 'COLON)) + (PROGN + (OR (|bpApplication|) (|bpTrap|)) + (SETQ |$returnType| (|bpPop1|)) + T)) + ('T T))))) + +(DEFUN |bpDef| () + (PROG () + (RETURN + (AND (|bpName|) (|bpStoreName|) (|bpDefTail|) + (|bpPush| (|bfCompDef| (|bpPop1|))))))) + +(DEFUN |bpDDef| () (PROG () (RETURN (AND (|bpName|) (|bpDefTail|))))) + +(DEFUN |bpSimpleDefinitionTail| () + (PROG () + (RETURN + (AND (|bpEqKey| 'DEF) (OR (|bpWhere|) (|bpTrap|)) + (|bpPush| + (|bfDefinition| (|bpPop2|) (|bfTuple| NIL) (|bpPop1|))))))) + +(DEFUN |bpCompoundDefinitionTail| () + (PROG () + (RETURN + (AND (|bpVariable|) (|bpReturnType|) (|bpEqKey| 'DEF) + (OR (|bpWhere|) (|bpTrap|)) + (|bpPush| (|bfDefinition| (|bpPop3|) (|bpPop2|) (|bpPop1|))))))) + +(DEFUN |bpDefTail| () + (PROG () + (RETURN + (OR (|bpSimpleDefinitionTail|) (|bpCompoundDefinitionTail|))))) + +(DEFUN |bpMDefTail| () + (PROG () + (RETURN + (AND (OR (|bpVariable|) (|bpTrap|)) (|bpEqKey| 'MDEF) + (OR (|bpWhere|) (|bpTrap|)) + (|bpPush| + (|bfMDefinition| (|bpPop3|) (|bpPop2|) (|bpPop1|))))))) + +(DEFUN |bpMdef| () + (PROG () (RETURN (AND (|bpName|) (|bpStoreName|) (|bpMDefTail|))))) + +(DEFUN |bpWhere| () + (PROG () + (RETURN + (AND (|bpDefinition|) + (OR (AND (|bpEqKey| 'WHERE) + (OR (|bpDefinitionItem|) (|bpTrap|)) + (|bpPush| (|bfWhere| (|bpPop1|) (|bpPop1|)))) + T))))) + +(DEFUN |bpDefinitionItem| () + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((|bpDDef|) T) + (#0='T (|bpRestore| |a|) + (COND + ((|bpBDefinitionPileItems|) T) + (#0# (|bpRestore| |a|) + (COND + ((|bpPDefinitionItems|) T) + (#0# (|bpRestore| |a|) (|bpWhere|))))))))))) + +(DEFUN |bpDefinitionPileItems| () + (PROG () + (RETURN + (AND (|bpListAndRecover| #'|bpDefinitionItem|) + (|bpPush| (|bfDefSequence| (|bpPop1|))))))) + +(DEFUN |bpBDefinitionPileItems| () + (PROG () (RETURN (|bpPileBracketed| #'|bpDefinitionPileItems|)))) + +(DEFUN |bpSemiColonDefinition| () + (PROG () + (RETURN (|bpSemiListing| #'|bpDefinitionItem| #'|bfDefSequence|)))) + +(DEFUN |bpPDefinitionItems| () + (PROG () (RETURN (|bpParenthesized| #'|bpSemiColonDefinition|)))) + +(DEFUN |bpComma| () + (PROG () + (RETURN (OR (|bpModule|) (|bpImport|) (|bpTuple| #'|bpWhere|))))) + +(DEFUN |bpTuple| (|p|) + (PROG () + (RETURN (|bpListofFun| |p| #'|bpCommaBackSet| #'|bfTuple|)))) + +(DEFUN |bpCommaBackSet| () + (PROG () + (RETURN (AND (|bpEqKey| 'COMMA) (OR (|bpEqKey| 'BACKSET) T))))) + +(DEFUN |bpSemiColon| () + (PROG () (RETURN (|bpSemiListing| #'|bpComma| #'|bfSequence|)))) + +(DEFUN |bpSemiListing| (|p| |f|) + (PROG () (RETURN (|bpListofFun| |p| #'|bpSemiBackSet| |f|)))) + +(DEFUN |bpSemiBackSet| () + (PROG () + (RETURN (AND (|bpEqKey| 'SEMICOLON) (OR (|bpEqKey| 'BACKSET) T))))) + +(DEFUN |bpPDefinition| () + (PROG () (RETURN (|bpIndentParenthesized| #'|bpSemiColon|)))) + +(DEFUN |bpPileItems| () + (PROG () + (RETURN + (AND (|bpListAndRecover| #'|bpSemiColon|) + (|bpPush| (|bfSequence| (|bpPop1|))))))) + +(DEFUN |bpBPileDefinition| () + (PROG () (RETURN (|bpPileBracketed| #'|bpPileItems|)))) + +(DEFUN |bpIteratorTail| () + (PROG () (RETURN (AND (OR (|bpEqKey| 'REPEAT) T) (|bpIterators|))))) + +(DEFUN |bpConstruct| () + (PROG () (RETURN (|bpBracket| #'|bpConstruction|)))) + +(DEFUN |bpConstruction| () + (PROG () + (RETURN + (AND (|bpComma|) + (OR (AND (|bpIteratorTail|) + (|bpPush| (|bfCollect| (|bpPop2|) (|bpPop1|)))) + (|bpPush| (|bfTupleConstruct| (|bpPop1|)))))))) + +(DEFUN |bpDConstruct| () + (PROG () (RETURN (|bpBracket| #'|bpDConstruction|)))) + +(DEFUN |bpDConstruction| () + (PROG () + (RETURN + (AND (|bpComma|) + (OR (AND (|bpIteratorTail|) + (|bpPush| (|bfDCollect| (|bpPop2|) (|bpPop1|)))) + (|bpPush| (|bfDTuple| (|bpPop1|)))))))) + +(DEFUN |bpPattern| () + (PROG () + (RETURN + (OR (|bpBracketConstruct| #'|bpPatternL|) (|bpName|) + (|bpConstTok|))))) + +(DEFUN |bpEqual| () + (PROG () + (RETURN + (AND (|bpEqKey| 'SHOEEQ) + (OR (|bpApplication|) (|bpConstTok|) (|bpTrap|)) + (|bpPush| (|bfEqual| (|bpPop1|))))))) + +(DEFUN |bpRegularPatternItem| () + (PROG () + (RETURN + (OR (|bpEqual|) (|bpConstTok|) (|bpDot|) + (AND (|bpName|) + (OR (AND (|bpEqKey| 'BEC) (OR (|bpPattern|) (|bpTrap|)) + (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|)))) + T)) + (|bpBracketConstruct| #'|bpPatternL|))))) + +(DEFUN |bpRegularPatternItemL| () + (PROG () + (RETURN + (AND (|bpRegularPatternItem|) (|bpPush| (LIST (|bpPop1|))))))) + +(DEFUN |bpRegularList| () + (PROG () + (RETURN + (|bpListof| #'|bpRegularPatternItemL| 'COMMA #'|bfAppend|)))) + +(DEFUN |bpPatternColon| () + (PROG () + (RETURN + (AND (|bpEqKey| 'COLON) (OR (|bpRegularPatternItem|) (|bpTrap|)) + (|bpPush| (LIST (|bfColon| (|bpPop1|)))))))) + +(DEFUN |bpPatternL| () + (PROG () + (RETURN (AND (|bpPatternList|) (|bpPush| (|bfTuple| (|bpPop1|))))))) + +(DEFUN |bpPatternList| () + (PROG () + (RETURN + (COND + ((|bpRegularPatternItemL|) + ((LAMBDA () + (LOOP + (COND + ((NOT (AND (|bpEqKey| 'COMMA) + (OR (|bpRegularPatternItemL|) + (PROGN + (OR (AND (|bpPatternTail|) + (|bpPush| + (APPEND (|bpPop2|) (|bpPop1|)))) + (|bpTrap|)) + NIL)))) + (RETURN NIL)) + ('T (|bpPush| (APPEND (|bpPop2|) (|bpPop1|)))))))) + T) + ('T (|bpPatternTail|)))))) + +(DEFUN |bpPatternTail| () + (PROG () + (RETURN + (AND (|bpPatternColon|) + (OR (AND (|bpEqKey| 'COMMA) + (OR (|bpRegularList|) (|bpTrap|)) + (|bpPush| (APPEND (|bpPop2|) (|bpPop1|)))) + T))))) + +(DEFUN |bpRegularBVItem| () + (PROG () + (RETURN + (OR (|bpBVString|) (|bpConstTok|) + (AND (|bpName|) + (OR (AND (|bpEqKey| 'COLON) + (OR (|bpApplication|) (|bpTrap|)) + (|bpPush| (|bfTagged| (|bpPop2|) (|bpPop1|)))) + (AND (|bpEqKey| 'BEC) (OR (|bpPattern|) (|bpTrap|)) + (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|)))) + (AND (|bpEqKey| 'IS) (OR (|bpPattern|) (|bpTrap|)) + (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|)))) + T)) + (|bpBracketConstruct| #'|bpPatternL|))))) + +(DEFUN |bpBVString| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (AND (EQ (|shoeTokType| |$stok|) 'STRING) + (|bpPush| (LIST 'BVQUOTE (INTERN |$ttok|))) (|bpNext|))))) + +(DEFUN |bpRegularBVItemL| () + (PROG () + (RETURN (AND (|bpRegularBVItem|) (|bpPush| (LIST (|bpPop1|))))))) + +(DEFUN |bpColonName| () + (PROG () + (RETURN + (AND (|bpEqKey| 'COLON) + (OR (|bpName|) (|bpBVString|) (|bpTrap|)))))) + +(DEFUN |bpBoundVariablelist| () + (PROG () + (RETURN + (COND + ((|bpRegularBVItemL|) + ((LAMBDA () + (LOOP + (COND + ((NOT (AND (|bpEqKey| 'COMMA) + (OR (|bpRegularBVItemL|) + (PROGN + (OR (AND (|bpColonName|) + (|bpPush| + (|bfColonAppend| (|bpPop2|) + (|bpPop1|)))) + (|bpTrap|)) + NIL)))) + (RETURN NIL)) + ('T (|bpPush| (APPEND (|bpPop2|) (|bpPop1|)))))))) + T) + ('T + (AND (|bpColonName|) + (|bpPush| (|bfColonAppend| NIL (|bpPop1|))))))))) + +(DEFUN |bpBeginParameterList| () + (PROG () + (DECLARE (SPECIAL |$sawParenthesizedHead|)) + (RETURN (PROGN (SETQ |$sawParenthesizedHead| NIL) T)))) + +(DEFUN |bpEndParameterList| () + (PROG () + (DECLARE (SPECIAL |$sawParenthesizedHead|)) + (RETURN (SETQ |$sawParenthesizedHead| T)))) + +(DEFUN |bpVariable| () + (PROG () + (RETURN + (OR (AND (|bpBeginParameterList|) + (|bpParenthesized| #'|bpBoundVariablelist|) + (|bpPush| (|bfTupleIf| (|bpPop1|))) + (|bpEndParameterList|)) + (|bpBracketConstruct| #'|bpPatternL|) (|bpName|) + (|bpConstTok|))))) + +(DEFUN |bpAssignVariable| () + (PROG () + (RETURN + (OR (|bpBracketConstruct| #'|bpPatternL|) (|bpAssignLHS|))))) + +(DEFUN |bpAssignLHS| () + (PROG () + (RETURN + (AND (|bpName|) + (OR (AND (|bpEqKey| 'COLON) + (OR (|bpApplication|) (|bpTrap|)) + (|bpPush| (|bfLocal| (|bpPop2|) (|bpPop1|)))) + (AND (|bpEqKey| 'DOT) + (|bpList| #'|bpPrimary| 'DOT #'|bfListOf|) + (|bpChecknull|) + (|bpPush| (|bfTuple| (CONS (|bpPop2|) (|bpPop1|))))) + T))))) + +(DEFUN |bpChecknull| () + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpPop1|)) + (COND ((NULL |a|) (|bpTrap|)) ('T (|bpPush| |a|))))))) + +(DEFUN |bpStruct| () + (PROG () + (RETURN + (AND (|bpEqKey| 'STRUCTURE) (OR (|bpName|) (|bpTrap|)) + (OR (|bpEqKey| 'DEF) (|bpTrap|)) (|bpTypeList|) + (|bpPush| (|bfStruct| (|bpPop2|) (|bpPop1|))))))) + +(DEFUN |bpTypeList| () + (PROG () + (RETURN + (OR (|bpPileBracketed| #'|bpTypeItemList|) + (AND (|bpTerm|) (|bpPush| (LIST (|bpPop1|)))))))) + +(DEFUN |bpTypeItemList| () + (PROG () (RETURN (|bpListAndRecover| #'|bpTerm|)))) + +(DEFUN |bpTerm| () + (PROG () + (RETURN + (OR (AND (OR (|bpName|) (|bpTrap|)) + (OR (AND (|bpParenthesized| #'|bpIdList|) + (|bpPush| (|bfNameArgs| (|bpPop2|) (|bpPop1|)))) + (AND (|bpName|) + (|bpPush| (|bfNameArgs| (|bpPop2|) (|bpPop1|)))))) + (|bpPush| (|bfNameOnly| (|bpPop1|))))))) + +(DEFUN |bpIdList| () (PROG () (RETURN (|bpTuple| #'|bpName|)))) + +(DEFUN |bpCase| () + (PROG () + (RETURN + (AND (|bpEqKey| 'CASE) (OR (|bpWhere|) (|bpTrap|)) + (OR (|bpEqKey| 'OF) (|bpMissing| 'OF)) (|bpPiledCaseItems|))))) + +(DEFUN |bpPiledCaseItems| () + (PROG () + (RETURN + (AND (|bpPileBracketed| #'|bpCaseItemList|) + (|bpPush| (|bfCase| (|bpPop2|) (|bpPop1|))))))) + +(DEFUN |bpCaseItemList| () + (PROG () (RETURN (|bpListAndRecover| #'|bpCaseItem|)))) + +(DEFUN |bpCaseItem| () + (PROG () + (RETURN + (AND (OR (|bpTerm|) (|bpTrap|)) (OR (|bpEqKey| 'EXIT) (|bpTrap|)) + (OR (|bpWhere|) (|bpTrap|)) + (|bpPush| (|bfCaseItem| (|bpPop2|) (|bpPop1|))))))) + +@ + +\end{document} diff --git a/src/boot/pile.boot.pamphlet b/src/boot/pile.boot.pamphlet new file mode 100644 index 00000000..eaad129f --- /dev/null +++ b/src/boot/pile.boot.pamphlet @@ -0,0 +1,325 @@ +\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") + +(IMPORT-MODULE "scanner") + +(IN-PACKAGE "BOOTTRAN") + +(DEFUN |shoeFirstTokPosn| (|t|) + (PROG () (RETURN (|shoeTokPosn| (CAAR |t|))))) + +(DEFUN |shoeLastTokPosn| (|t|) + (PROG () (RETURN (|shoeTokPosn| (CADR |t|))))) + +(DEFUN |shoePileColumn| (|t|) + (PROG () (RETURN (CDR (|shoeTokPosn| (CAAR |t|)))))) + +(DEFUN |shoePileInsert| (|s|) + (PROG (|a| |toktype|) + (RETURN + (COND + ((|bStreamNull| |s|) (CONS NIL |s|)) + (#0='T (SETQ |toktype| (|shoeTokType| (CAAAR |s|))) + (COND + ((OR (EQ |toktype| 'LISP) (EQ |toktype| 'LINE)) + (CONS (LIST (CAR |s|)) (CDR |s|))) + (#0# (SETQ |a| (|shoePileTree| (- 1) |s|)) + (CONS (LIST (ELT |a| 2)) (ELT |a| 3))))))))) + +(DEFUN |shoePileTree| (|n| |s|) + (PROG (|hh| |t| |h| |LETTMP#1|) + (RETURN + (COND + ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|)) + (#0='T (SETQ |LETTMP#1| (LIST (CAR |s|) (CDR |s|))) + (SETQ |h| (CAR |LETTMP#1|)) (SETQ |t| (CADR |LETTMP#1|)) + (SETQ |hh| (|shoePileColumn| |h|)) + (COND + ((< |n| |hh|) (|shoePileForests| |h| |hh| |t|)) + (#0# (LIST NIL |n| NIL |s|)))))))) + +(DEFUN |eqshoePileTree| (|n| |s|) + (PROG (|hh| |t| |h| |LETTMP#1|) + (RETURN + (COND + ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|)) + (#0='T (SETQ |LETTMP#1| (LIST (CAR |s|) (CDR |s|))) + (SETQ |h| (CAR |LETTMP#1|)) (SETQ |t| (CADR |LETTMP#1|)) + (SETQ |hh| (|shoePileColumn| |h|)) + (COND + ((EQUAL |hh| |n|) (|shoePileForests| |h| |hh| |t|)) + (#0# (LIST NIL |n| NIL |s|)))))))) + +(DEFUN |shoePileForest| (|n| |s|) + (PROG (|t1| |h1| |t| |h| |hh| |b| |LETTMP#1|) + (RETURN + (PROGN + (SETQ |LETTMP#1| (|shoePileTree| |n| |s|)) + (SETQ |b| (CAR |LETTMP#1|)) + (SETQ |hh| (CADR . #0=(|LETTMP#1|))) + (SETQ |h| (CADDR . #0#)) + (SETQ |t| (CADDDR . #0#)) + (COND + (|b| (SETQ |LETTMP#1| (|shoePileForest1| |hh| |t|)) + (SETQ |h1| (CAR |LETTMP#1|)) + (SETQ |t1| (CADR |LETTMP#1|)) + (LIST (CONS |h| |h1|) |t1|)) + ('T (LIST NIL |s|))))))) + +(DEFUN |shoePileForest1| (|n| |s|) + (PROG (|t1| |h1| |t| |h| |n1| |b| |LETTMP#1|) + (RETURN + (PROGN + (SETQ |LETTMP#1| (|eqshoePileTree| |n| |s|)) + (SETQ |b| (CAR |LETTMP#1|)) + (SETQ |n1| (CADR . #0=(|LETTMP#1|))) + (SETQ |h| (CADDR . #0#)) + (SETQ |t| (CADDDR . #0#)) + (COND + (|b| (SETQ |LETTMP#1| (|shoePileForest1| |n| |t|)) + (SETQ |h1| (CAR |LETTMP#1|)) + (SETQ |t1| (CADR |LETTMP#1|)) + (LIST (CONS |h| |h1|) |t1|)) + ('T (LIST NIL |s|))))))) + +(DEFUN |shoePileForests| (|h| |n| |s|) + (PROG (|t1| |h1| |LETTMP#1|) + (RETURN + (PROGN + (SETQ |LETTMP#1| (|shoePileForest| |n| |s|)) + (SETQ |h1| (CAR |LETTMP#1|)) + (SETQ |t1| (CADR |LETTMP#1|)) + (COND + ((|bStreamNull| |h1|) (LIST T |n| |h| |s|)) + ('T (|shoePileForests| (|shoePileCtree| |h| |h1|) |n| |t1|))))))) + +(DEFUN |shoePileCtree| (|x| |y|) + (PROG () (RETURN (|dqAppend| |x| (|shoePileCforest| |y|))))) + +(DEFUN |shoePileCforest| (|x|) + (PROG (|b| |a|) + (RETURN + (COND + ((NULL |x|) NIL) + ((NULL (CDR |x|)) (CAR |x|)) + (#0='T (SETQ |a| (CAR |x|)) + (SETQ |b| (|shoePileCoagulate| |a| (CDR |x|))) + (COND + ((NULL (CDR |b|)) (CAR |b|)) + (#0# (|shoeEnPile| (|shoeSeparatePiles| |b|))))))))) + +(DEFUN |shoePileCoagulate| (|a| |b|) + (PROG (|e| |d| |c|) + (RETURN + (COND + ((NULL |b|) (LIST |a|)) + (#0='T (SETQ |c| (CAR |b|)) + (COND + ((OR (EQ (|shoeTokPart| (CAAR |c|)) 'THEN) + (EQ (|shoeTokPart| (CAAR |c|)) 'ELSE)) + (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|))) + (#0# (SETQ |d| (CADR |a|)) (SETQ |e| (|shoeTokPart| |d|)) + (COND + ((AND (EQCAR |d| 'KEY) + (OR (GET |e| 'SHOEINF) (EQ |e| 'COMMA) + (EQ |e| 'SEMICOLON))) + (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|))) + (#0# (CONS |a| (|shoePileCoagulate| |c| (CDR |b|)))))))))))) + +(DEFUN |shoeSeparatePiles| (|x|) + (PROG (|semicolon| |a|) + (RETURN + (COND + ((NULL |x|) NIL) + ((NULL (CDR |x|)) (CAR |x|)) + ('T (SETQ |a| (CAR |x|)) + (SETQ |semicolon| + (|dqUnit| + (|shoeTokConstruct| 'KEY 'BACKSET + (|shoeLastTokPosn| |a|)))) + (|dqConcat| + (LIST |a| |semicolon| (|shoeSeparatePiles| (CDR |x|))))))))) + +(DEFUN |shoeEnPile| (|x|) + (PROG () + (RETURN + (|dqConcat| (LIST (|dqUnit| + (|shoeTokConstruct| 'KEY 'SETTAB + (|shoeFirstTokPosn| |x|))) + |x| + (|dqUnit| + (|shoeTokConstruct| 'KEY 'BACKTAB + (|shoeLastTokPosn| |x|)))))))) + +@ + +\end{document} diff --git a/src/boot/scanner.boot.pamphlet b/src/boot/scanner.boot.pamphlet new file mode 100644 index 00000000..b98ed289 --- /dev/null +++ b/src/boot/scanner.boot.pamphlet @@ -0,0 +1,1175 @@ +\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") + +(IMPORT-MODULE "includer") + +(IN-PACKAGE "BOOTTRAN") + +(DEFUN |double| (|x|) (PROG () (RETURN (FLOAT |x| 1.0)))) + +(DEFUN |dqUnit| (|s|) + (PROG (|a|) (RETURN (PROGN (SETQ |a| (LIST |s|)) (CONS |a| |a|))))) + +(DEFUN |dqAppend| (|x| |y|) + (PROG () + (RETURN + (COND + ((NULL |x|) |y|) + ((NULL |y|) |x|) + ('T (RPLACD (CDR |x|) (CAR |y|)) (RPLACD |x| (CDR |y|)) |x|))))) + +(DEFUN |dqConcat| (|ld|) + (PROG () + (RETURN + (COND + ((NULL |ld|) NIL) + ((NULL (CDR |ld|)) (CAR |ld|)) + ('T (|dqAppend| (CAR |ld|) (|dqConcat| (CDR |ld|)))))))) + +(DEFUN |dqToList| (|s|) + (PROG () (RETURN (COND ((NULL |s|) NIL) ('T (CAR |s|)))))) + +(DEFUN |shoeConstructToken| (|ln| |lp| |b| |n|) + (PROG () + (RETURN (CONS (ELT |b| 0) (CONS (ELT |b| 1) (CONS |lp| |n|)))))) + +(DEFUN |shoeTokType| (|x|) (PROG () (RETURN (CAR |x|)))) + +(DEFUN |shoeTokPart| (|x|) (PROG () (RETURN (CADR |x|)))) + +(DEFUN |shoeTokPosn| (|x|) (PROG () (RETURN (CDDR |x|)))) + +(DEFUN |shoeTokConstruct| (|x| |y| |z|) + (PROG () (RETURN (CONS |x| (CONS |y| |z|))))) + +(DEFUN |shoeNextLine| (|s|) + (PROG (|s1| |a|) + (DECLARE (SPECIAL |$sz| |$n| |$ln| |$r| |$f| |$linepos|)) + (RETURN + (COND + ((|bStreamNull| |s|) NIL) + ('T (SETQ |$linepos| |s|) (SETQ |$f| (CAR |s|)) + (SETQ |$r| (CDR |s|)) (SETQ |$ln| (CAR |$f|)) + (SETQ |$n| (STRPOSL " " |$ln| 0 T)) + (SETQ |$sz| (LENGTH |$ln|)) + (COND + ((NULL |$n|) T) + ((EQUAL (QENUM |$ln| |$n|) |shoeTAB|) + (PROGN + (SETQ |a| (MAKE-FULL-CVEC (- 7 (REM |$n| 8)) " ")) + (SETF (ELT |$ln| |$n|) (ELT " " 0)) + (SETQ |$ln| (CONCAT |a| |$ln|)) + (SETQ |s1| (CONS (CONS |$ln| (CDR |$f|)) |$r|)) + (|shoeNextLine| |s1|))) + ('T T))))))) + +(DEFUN |shoeLineToks| (|s|) + (PROG (|$linepos| |$floatok| |$sz| |$n| |$ln| |$r| |$f| |toks| |a| + |dq| |command| |fst|) + (DECLARE (SPECIAL |$floatok| |$f| |$sz| |$linepos| |$ln| |$r| |$n|)) + (RETURN + (PROGN + (SETQ |$f| NIL) + (SETQ |$r| NIL) + (SETQ |$ln| NIL) + (SETQ |$n| NIL) + (SETQ |$sz| NIL) + (SETQ |$floatok| T) + (SETQ |$linepos| |s|) + (COND + ((NULL (|shoeNextLine| |s|)) (CONS NIL NIL)) + ((NULL |$n|) (|shoeLineToks| |$r|)) + (#0='T + (PROGN + (SETQ |fst| (QENUM |$ln| 0)) + (COND + ((EQL |fst| |shoeCLOSEPAREN|) + (COND + ((SETQ |command| (|shoeLine?| |$ln|)) + (PROGN + (SETQ |dq| + (|dqUnit| + (|shoeConstructToken| |$ln| |$linepos| + (|shoeLeafLine| |command|) 0))) + (CONS (LIST |dq|) |$r|))) + ((SETQ |command| (|shoeLisp?| |$ln|)) + (|shoeLispToken| |$r| |command|)) + ((SETQ |command| (|shoePackage?| |$ln|)) + (PROGN + (SETQ |a| (CONCAT "(IN-PACKAGE " |command| ")")) + (SETQ |dq| + (|dqUnit| + (|shoeConstructToken| |$ln| |$linepos| + (|shoeLeafLisp| |a|) 0))) + (CONS (LIST |dq|) |$r|))) + (#0# (|shoeLineToks| |$r|)))) + (#0# + (PROGN + (SETQ |toks| NIL) + ((LAMBDA () + (LOOP + (COND + ((NOT (< |$n| |$sz|)) (RETURN NIL)) + ('T + (SETQ |toks| + (|dqAppend| |toks| (|shoeToken|)))))))) + (COND + ((NULL |toks|) (|shoeLineToks| |$r|)) + (#0# (CONS (LIST |toks|) |$r|))))))))))))) + +(DEFUN |shoeLispToken| (|s| |string|) + (PROG (|dq| |st| |r| |LETTMP#1| |linepos| |ln|) + (DECLARE (SPECIAL |$linepos| |$ln|)) + (RETURN + (PROGN + (SETQ |string| + (COND + ((OR (EQL (LENGTH |string|) 0) + (EQL (QENUM |string| 0) (QENUM ";" 0))) + "") + ('T |string|))) + (SETQ |ln| |$ln|) + (SETQ |linepos| |$linepos|) + (SETQ |LETTMP#1| (|shoeAccumulateLines| |s| |string|)) + (SETQ |r| (CAR |LETTMP#1|)) + (SETQ |st| (CDR |LETTMP#1|)) + (SETQ |dq| + (|dqUnit| + (|shoeConstructToken| |ln| |linepos| + (|shoeLeafLisp| |st|) 0))) + (CONS (LIST |dq|) |r|))))) + +(DEFUN |shoeAccumulateLines| (|s| |string|) + (PROG (|a| |command| |fst|) + (DECLARE (SPECIAL |$ln| |$r| |$n|)) + (RETURN + (COND + ((NULL (|shoeNextLine| |s|)) (CONS |s| |string|)) + ((NULL |$n|) (|shoeAccumulateLines| |$r| |string|)) + ((EQL (LENGTH |$ln|) 0) (|shoeAccumulateLines| |$r| |string|)) + (#0='T + (PROGN + (SETQ |fst| (QENUM |$ln| 0)) + (COND + ((EQL |fst| |shoeCLOSEPAREN|) + (PROGN + (SETQ |command| (|shoeLisp?| |$ln|)) + (COND + ((AND |command| (< 0 (LENGTH |command|))) + (COND + ((EQL (QENUM |command| 0) (QENUM ";" 0)) + (|shoeAccumulateLines| |$r| |string|)) + (#0# + (PROGN + (SETQ |a| (STRPOS ";" |command| 0 NIL)) + (COND + (|a| (|shoeAccumulateLines| |$r| + (CONCAT |string| + (SUBSTRING |command| 0 (- |a| 1))))) + (#0# + (|shoeAccumulateLines| |$r| + (CONCAT |string| |command|)))))))) + (#0# (|shoeAccumulateLines| |$r| |string|))))) + (#0# (CONS |s| |string|))))))))) + +(DEFUN |shoeCloser| (|t|) + (PROG () (RETURN (MEMQ (|shoeKeyWord| |t|) '(CPAREN CBRACK))))) + +(DEFUN |shoeToken| () + (PROG (|b| |ch| |n| |linepos| |c| |ln|) + (DECLARE (SPECIAL |$linepos| |$n| |$ln|)) + (RETURN + (PROGN + (SETQ |ln| |$ln|) + (SETQ |c| (QENUM |$ln| |$n|)) + (SETQ |linepos| |$linepos|) + (SETQ |n| |$n|) + (SETQ |ch| (ELT |$ln| |$n|)) + (SETQ |b| + (COND + ((|shoeStartsComment|) (PROGN (|shoeComment|) NIL)) + ((|shoeStartsNegComment|) + (PROGN (|shoeNegComment|) NIL)) + ((EQUAL |c| |shoeLispESCAPE|) (|shoeLispEscape|)) + ((|shoePunctuation| |c|) (|shoePunct|)) + ((|shoeStartsId| |ch|) (|shoeWord| NIL)) + ((EQUAL |c| |shoeSPACE|) (PROGN (|shoeSpace|) NIL)) + ((EQUAL |c| |shoeSTRINGCHAR|) (|shoeString|)) + ((|shoeDigit| |ch|) (|shoeNumber|)) + ((EQUAL |c| |shoeESCAPE|) (|shoeEscape|)) + ((EQUAL |c| |shoeTAB|) + (PROGN (SETQ |$n| (+ |$n| 1)) NIL)) + (#0='T (|shoeError|)))) + (COND + ((NULL |b|) NIL) + (#0# + (|dqUnit| (|shoeConstructToken| |ln| |linepos| |b| |n|)))))))) + +(DEFUN |shoeLeafId| (|x|) (PROG () (RETURN (LIST 'ID (INTERN |x|))))) + +(DEFUN |shoeLeafKey| (|x|) + (PROG () (RETURN (LIST 'KEY (|shoeKeyWord| |x|))))) + +(DEFUN |shoeLeafInteger| (|x|) + (PROG () (RETURN (LIST 'INTEGER (|shoeIntValue| |x|))))) + +(DEFUN |shoeLeafFloat| (|a| |w| |e|) + (PROG (|c| |b|) + (RETURN + (PROGN + (SETQ |b| (|shoeIntValue| (CONCAT |a| |w|))) + (SETQ |c| + (* (|double| |b|) (EXPT (|double| 10) (- |e| (LENGTH |w|))))) + (LIST 'FLOAT |c|))))) + +(DEFUN |shoeLeafString| (|x|) (PROG () (RETURN (LIST 'STRING |x|)))) + +(DEFUN |shoeLeafLisp| (|x|) (PROG () (RETURN (LIST 'LISP |x|)))) + +(DEFUN |shoeLeafLispExp| (|x|) (PROG () (RETURN (LIST 'LISPEXP |x|)))) + +(DEFUN |shoeLeafLine| (|x|) (PROG () (RETURN (LIST 'LINE |x|)))) + +(DEFUN |shoeLeafComment| (|x|) (PROG () (RETURN (LIST 'COMMENT |x|)))) + +(DEFUN |shoeLeafNegComment| (|x|) + (PROG () (RETURN (LIST 'NEGCOMMENT |x|)))) + +(DEFUN |shoeLeafError| (|x|) (PROG () (RETURN (LIST 'ERROR |x|)))) + +(DEFUN |shoeLeafSpaces| (|x|) (PROG () (RETURN (LIST 'SPACES |x|)))) + +(DEFUN |shoeLispEscape| () + (PROG (|n| |exp| |a|) + (DECLARE (SPECIAL |$ln| |$linepos| |$sz| |$n|)) + (RETURN + (PROGN + (SETQ |$n| (+ |$n| 1)) + (COND + ((NOT (< |$n| |$sz|)) + (|SoftShoeError| (CONS |$linepos| |$n|) "lisp escape error") + (|shoeLeafError| (ELT |$ln| |$n|))) + ('T (SETQ |a| (|shoeReadLispString| |$ln| |$n|)) + (COND + ((NULL |a|) + (PROGN + (|SoftShoeError| (CONS |$linepos| |$n|) + "lisp escape error") + (|shoeLeafError| (ELT |$ln| |$n|)))) + (#0='T + (PROGN + (SETQ |exp| (CAR |a|)) + (SETQ |n| (CADR |a|)) + (COND + ((NULL |n|) + (PROGN (SETQ |$n| |$sz|) (|shoeLeafLispExp| |exp|))) + (#0# + (PROGN (SETQ |$n| |n|) (|shoeLeafLispExp| |exp|))))))))))))) + +(DEFUN |shoeEscape| () + (PROG (|a|) + (DECLARE (SPECIAL |$n|)) + (RETURN + (PROGN + (SETQ |$n| (+ |$n| 1)) + (SETQ |a| (|shoeEsc|)) + (COND (|a| (|shoeWord| T)) ('T NIL)))))) + +(DEFUN |shoeEsc| () + (PROG (|n1|) + (DECLARE (SPECIAL |$ln| |$r| |$sz| |$n|)) + (RETURN + (COND + ((NOT (< |$n| |$sz|)) + (COND + ((|shoeNextLine| |$r|) + ((LAMBDA () + (LOOP + (COND + (|$n| (RETURN NIL)) + (#0='T (|shoeNextLine| |$r|)))))) + (|shoeEsc|) NIL) + (#1='T NIL))) + (#1# (SETQ |n1| (STRPOSL " " |$ln| |$n| T)) + (COND + ((NULL |n1|) (|shoeNextLine| |$r|) + ((LAMBDA () + (LOOP + (COND + (|$n| (RETURN NIL)) + (#0# (|shoeNextLine| |$r|)))))) + (|shoeEsc|) NIL) + (#1# T))))))) + +(DEFUN |shoeStartsComment| () + (PROG (|www|) + (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (RETURN + (COND + ((< |$n| |$sz|) + (COND + ((EQUAL (QENUM |$ln| |$n|) |shoePLUSCOMMENT|) + (SETQ |www| (+ |$n| 1)) + (COND + ((NOT (< |www| |$sz|)) NIL) + (#0='T (EQUAL (QENUM |$ln| |www|) |shoePLUSCOMMENT|)))) + (#0# NIL))) + (#0# NIL))))) + +(DEFUN |shoeStartsNegComment| () + (PROG (|www|) + (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (RETURN + (COND + ((< |$n| |$sz|) + (COND + ((EQUAL (QENUM |$ln| |$n|) |shoeMINUSCOMMENT|) + (SETQ |www| (+ |$n| 1)) + (COND + ((NOT (< |www| |$sz|)) NIL) + (#0='T (EQUAL (QENUM |$ln| |www|) |shoeMINUSCOMMENT|)))) + (#0# NIL))) + (#0# NIL))))) + +(DEFUN |shoeNegComment| () + (PROG (|n|) + (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (RETURN + (PROGN + (SETQ |n| |$n|) + (SETQ |$n| |$sz|) + (|shoeLeafNegComment| (SUBSTRING |$ln| |n| NIL)))))) + +(DEFUN |shoeComment| () + (PROG (|n|) + (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (RETURN + (PROGN + (SETQ |n| |$n|) + (SETQ |$n| |$sz|) + (|shoeLeafComment| (SUBSTRING |$ln| |n| NIL)))))) + +(DEFUN |shoePunct| () + (PROG (|sss|) + (DECLARE (SPECIAL |$n| |$ln|)) + (RETURN + (PROGN + (SETQ |sss| (|shoeMatch| |$ln| |$n|)) + (SETQ |$n| (+ |$n| (LENGTH |sss|))) + (|shoeKeyTr| |sss|))))) + +(DEFUN |shoeKeyTr| (|w|) + (PROG () + (DECLARE (SPECIAL |$floatok|)) + (RETURN + (COND + ((EQ (|shoeKeyWord| |w|) 'DOT) + (COND + (|$floatok| (|shoePossFloat| |w|)) + (#0='T (|shoeLeafKey| |w|)))) + (#0# (SETQ |$floatok| (NULL (|shoeCloser| |w|))) + (|shoeLeafKey| |w|)))))) + +(DEFUN |shoePossFloat| (|w|) + (PROG () + (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (RETURN + (COND + ((OR (NOT (< |$n| |$sz|)) + (NULL (|shoeDigit| (ELT |$ln| |$n|)))) + (|shoeLeafKey| |w|)) + ('T (SETQ |w| (|shoeInteger|)) (|shoeExponent| "0" |w|)))))) + +(DEFUN |shoeSpace| () + (PROG (|n|) + (DECLARE (SPECIAL |$floatok| |$ln| |$n|)) + (RETURN + (PROGN + (SETQ |n| |$n|) + (SETQ |$n| (STRPOSL " " |$ln| |$n| T)) + (SETQ |$floatok| T) + (COND + ((NULL |$n|) (|shoeLeafSpaces| 0) (SETQ |$n| (LENGTH |$ln|))) + ('T (|shoeLeafSpaces| (- |$n| |n|)))))))) + +(DEFUN |shoeString| () + (PROG () + (DECLARE (SPECIAL |$floatok| |$n|)) + (RETURN + (PROGN + (SETQ |$n| (+ |$n| 1)) + (SETQ |$floatok| NIL) + (|shoeLeafString| (|shoeS|)))))) + +(DEFUN |shoeS| () + (PROG (|b| |a| |str| |mn| |escsym| |strsym| |n|) + (DECLARE (SPECIAL |$ln| |$linepos| |$sz| |$n|)) + (RETURN + (COND + ((NOT (< |$n| |$sz|)) + (|SoftShoeError| (CONS |$linepos| |$n|) "quote added") "") + (#0='T (SETQ |n| |$n|) + (SETQ |strsym| (OR (STRPOS "\"" |$ln| |$n| NIL) |$sz|)) + (SETQ |escsym| (OR (STRPOS "_" |$ln| |$n| NIL) |$sz|)) + (SETQ |mn| (MIN |strsym| |escsym|)) + (COND + ((EQUAL |mn| |$sz|) (SETQ |$n| |$sz|) + (|SoftShoeError| (CONS |$linepos| |$n|) "quote added") + (SUBSTRING |$ln| |n| NIL)) + ((EQUAL |mn| |strsym|) (SETQ |$n| (+ |mn| 1)) + (SUBSTRING |$ln| |n| (- |mn| |n|))) + (#0# (SETQ |str| (SUBSTRING |$ln| |n| (- |mn| |n|))) + (SETQ |$n| (+ |mn| 1)) (SETQ |a| (|shoeEsc|)) + (SETQ |b| + (COND + (|a| (SETQ |str| (CONCAT |str| (ELT |$ln| |$n|))) + (SETQ |$n| (+ |$n| 1)) (|shoeS|)) + (#0# (|shoeS|)))) + (CONCAT |str| |b|)))))))) + +(DEFUN |shoeIdEnd| (|line| |n|) + (PROG () + (RETURN + (PROGN + ((LAMBDA () + (LOOP + (COND + ((NOT (AND (< |n| (LENGTH |line|)) + (|shoeIdChar| (ELT |line| |n|)))) + (RETURN NIL)) + ('T (SETQ |n| (+ |n| 1))))))) + |n|)))) + +(DEFUN |shoeDigit| (|x|) (PROG () (RETURN (DIGIT-CHAR-P |x|)))) + +(DEFUN |shoeW| (|b|) + (PROG (|bb| |a| |str| |endid| |l| |n1|) + (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (RETURN + (PROGN + (SETQ |n1| |$n|) + (SETQ |$n| (+ |$n| 1)) + (SETQ |l| |$sz|) + (SETQ |endid| (|shoeIdEnd| |$ln| |$n|)) + (COND + ((OR (EQUAL |endid| |l|) + (NOT (EQUAL (QENUM |$ln| |endid|) |shoeESCAPE|))) + (SETQ |$n| |endid|) + (LIST |b| (SUBSTRING |$ln| |n1| (- |endid| |n1|)))) + (#0='T (SETQ |str| (SUBSTRING |$ln| |n1| (- |endid| |n1|))) + (SETQ |$n| (+ |endid| 1)) (SETQ |a| (|shoeEsc|)) + (SETQ |bb| (COND (|a| (|shoeW| T)) (#0# (LIST |b| "")))) + (LIST (OR (ELT |bb| 0) |b|) (CONCAT |str| (ELT |bb| 1))))))))) + +(DEFUN |shoeWord| (|esp|) + (PROG (|w| |aaa|) + (DECLARE (SPECIAL |$floatok|)) + (RETURN + (PROGN + (SETQ |aaa| (|shoeW| NIL)) + (SETQ |w| (ELT |aaa| 1)) + (SETQ |$floatok| NIL) + (COND + ((OR |esp| (ELT |aaa| 0)) (|shoeLeafId| |w|)) + ((|shoeKeyWordP| |w|) (SETQ |$floatok| T) + (|shoeLeafKey| |w|)) + ('T (|shoeLeafId| |w|))))))) + +(DEFUN |shoeInteger| () (PROG () (RETURN (|shoeInteger1| NIL)))) + +(DEFUN |shoeInteger1| (|zro|) + (PROG (|bb| |a| |str| |l| |n|) + (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (RETURN + (PROGN + (SETQ |n| |$n|) + (SETQ |l| |$sz|) + ((LAMBDA () + (LOOP + (COND + ((NOT (AND (< |$n| |l|) (|shoeDigit| (ELT |$ln| |$n|)))) + (RETURN NIL)) + ('T (SETQ |$n| (+ |$n| 1))))))) + (COND + ((OR (EQUAL |$n| |l|) + (NOT (EQUAL (QENUM |$ln| |$n|) |shoeESCAPE|))) + (COND + ((AND (EQUAL |n| |$n|) |zro|) "0") + (#0='T (SUBSTRING |$ln| |n| (- |$n| |n|))))) + (#0# (SETQ |str| (SUBSTRING |$ln| |n| (- |$n| |n|))) + (SETQ |$n| (+ |$n| 1)) (SETQ |a| (|shoeEsc|)) + (SETQ |bb| (|shoeInteger1| |zro|)) (CONCAT |str| |bb|))))))) + +(DEFUN |shoeIntValue| (|s|) + (PROG (|d| |ival| |ns|) + (RETURN + (PROGN + (SETQ |ns| (LENGTH |s|)) + (SETQ |ival| 0) + ((LAMBDA (|bfVar#1| |i|) + (LOOP + (COND + ((> |i| |bfVar#1|) (RETURN NIL)) + ('T + (PROGN + (SETQ |d| (|shoeOrdToNum| (ELT |s| |i|))) + (SETQ |ival| (+ (* 10 |ival|) |d|))))) + (SETQ |i| (+ |i| 1)))) + (- |ns| 1) 0) + |ival|)))) + +(DEFUN |shoeNumber| () + (PROG (|w| |n| |a|) + (DECLARE (SPECIAL |$ln| |$floatok| |$sz| |$n|)) + (RETURN + (PROGN + (SETQ |a| (|shoeInteger|)) + (COND + ((NOT (< |$n| |$sz|)) (|shoeLeafInteger| |a|)) + ((AND |$floatok| (EQUAL (QENUM |$ln| |$n|) |shoeDOT|)) + (SETQ |n| |$n|) (SETQ |$n| (+ |$n| 1)) + (COND + ((AND (< |$n| |$sz|) (EQUAL (QENUM |$ln| |$n|) |shoeDOT|)) + (SETQ |$n| |n|) (|shoeLeafInteger| |a|)) + (#0='T (SETQ |w| (|shoeInteger1| T)) + (|shoeExponent| |a| |w|)))) + (#0# (|shoeLeafInteger| |a|))))))) + +(DEFUN |shoeExponent| (|a| |w|) + (PROG (|c1| |e| |c| |n|) + (DECLARE (SPECIAL |$ln| |$sz| |$n|)) + (RETURN + (COND + ((NOT (< |$n| |$sz|)) (|shoeLeafFloat| |a| |w| 0)) + (#0='T (SETQ |n| |$n|) (SETQ |c| (QENUM |$ln| |$n|)) + (COND + ((OR (EQUAL |c| |shoeEXPONENT1|) + (EQUAL |c| |shoeEXPONENT2|)) + (SETQ |$n| (+ |$n| 1)) + (COND + ((NOT (< |$n| |$sz|)) (SETQ |$n| |n|) + (|shoeLeafFloat| |a| |w| 0)) + ((|shoeDigit| (ELT |$ln| |$n|)) + (SETQ |e| (|shoeInteger|)) + (SETQ |e| (|shoeIntValue| |e|)) + (|shoeLeafFloat| |a| |w| |e|)) + (#0# (SETQ |c1| (QENUM |$ln| |$n|)) + (COND + ((OR (EQUAL |c1| |shoePLUSCOMMENT|) + (EQUAL |c1| |shoeMINUSCOMMENT|)) + (SETQ |$n| (+ |$n| 1)) + (COND + ((NOT (< |$n| |$sz|)) (SETQ |$n| |n|) + (|shoeLeafFloat| |a| |w| 0)) + ((|shoeDigit| (ELT |$ln| |$n|)) + (SETQ |e| (|shoeInteger|)) + (SETQ |e| (|shoeIntValue| |e|)) + (|shoeLeafFloat| |a| |w| + (COND + ((EQUAL |c1| |shoeMINUSCOMMENT|) (- |e|)) + (#0# |e|)))) + (#0# (SETQ |$n| |n|) (|shoeLeafFloat| |a| |w| 0)))))))) + (#0# (|shoeLeafFloat| |a| |w| 0)))))))) + +(DEFUN |shoeError| () + (PROG (|n|) + (DECLARE (SPECIAL |$ln| |$linepos| |$n|)) + (RETURN + (PROGN + (SETQ |n| |$n|) + (SETQ |$n| (+ |$n| 1)) + (|SoftShoeError| (CONS |$linepos| |n|) + (CONCAT "The character whose number is " + (STRINGIMAGE (QENUM |$ln| |n|)) + " is not a Boot character")) + (|shoeLeafError| (ELT |$ln| |n|)))))) + +(DEFUN |shoeOrdToNum| (|x|) (PROG () (RETURN (DIGIT-CHAR-P |x|)))) + +(DEFUN |shoeKeyWord| (|st|) + (PROG () (RETURN (GETHASH |st| |shoeKeyTable|)))) + +(DEFUN |shoeKeyWordP| (|st|) + (PROG () (RETURN (NULL (NULL (GETHASH |st| |shoeKeyTable|)))))) + +(DEFUN |shoeMatch| (|l| |i|) + (PROG () (RETURN (|shoeSubStringMatch| |l| |shoeDict| |i|)))) + +(DEFUN |shoeSubStringMatch| (|l| |d| |i|) + (PROG (|eql| |ls| |s| |s1| |done| |ll| |u| |h|) + (RETURN + (PROGN + (SETQ |h| (QENUM |l| |i|)) + (SETQ |u| (ELT |d| |h|)) + (SETQ |ll| (SIZE |l|)) + (SETQ |done| NIL) + (SETQ |s1| "") + ((LAMBDA (|bfVar#2| |j|) + (LOOP + (COND + ((OR (> |j| |bfVar#2|) |done|) (RETURN NIL)) + (#0='T + (PROGN + (SETQ |s| (ELT |u| |j|)) + (SETQ |ls| (SIZE |s|)) + (SETQ |done| + (COND + ((< |ll| (+ |ls| |i|)) NIL) + (#1='T (SETQ |eql| T) + ((LAMBDA (|bfVar#3| |k|) + (LOOP + (COND + ((OR (> |k| |bfVar#3|) (NOT |eql|)) + (RETURN NIL)) + (#0# + (SETQ |eql| + (EQL (QENUM |s| |k|) + (QENUM |l| (+ |k| |i|)))))) + (SETQ |k| (+ |k| 1)))) + (- |ls| 1) 1) + (COND (|eql| (SETQ |s1| |s|) T) (#1# NIL)))))))) + (SETQ |j| (+ |j| 1)))) + (- (SIZE |u|) 1) 0) + |s1|)))) + +(DEFUN |shoePunctuation| (|c|) + (PROG () (RETURN (EQL (ELT |shoePun| |c|) 1)))) + +@ + +\end{document} diff --git a/src/boot/tokens.boot.pamphlet b/src/boot/tokens.boot.pamphlet new file mode 100644 index 00000000..4e429a81 --- /dev/null +++ b/src/boot/tokens.boot.pamphlet @@ -0,0 +1,751 @@ +\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"], _ + ['"^=","NE" ], _ + ['"..","SEG" ], _ + ['"#", "LENGTH"], _ + ['"=>","EXIT" ], _ + ['":=", "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" ,">="], _ + ["NE" ,"^="] _ + ]_ + 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"], _ + ["NE", "/="], _ + ["T", "T$"] _ + ] + repeat SETF (GET(CAR i,'SHOERENAME),CDR i) + +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") + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (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 "^=" 'NE) (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)) + ((LAMBDA (|bfVar#1| |st|) + (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|)))) + |shoeKeyWords| NIL) + |KeyTable|)))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (DEFPARAMETER |shoeKeyTable| (|shoeKeyTableCons|))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (DEFPARAMETER |shoeSPACE| (QENUM " " 0))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (DEFPARAMETER |shoeESCAPE| (QENUM "_ " 0))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (DEFPARAMETER |shoeLispESCAPE| (QENUM "! " 0))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (DEFPARAMETER |shoeSTRINGCHAR| (QENUM "\" " 0))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (DEFPARAMETER |shoePLUSCOMMENT| (QENUM "+ " 0))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (DEFPARAMETER |shoeMINUSCOMMENT| (QENUM "- " 0))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (DEFPARAMETER |shoeDOT| (QENUM ". " 0))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (DEFPARAMETER |shoeEXPONENT1| (QENUM "E " 0))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (DEFPARAMETER |shoeEXPONENT2| (QENUM "e " 0))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (DEFPARAMETER |shoeCLOSEPAREN| (QENUM ") " 0))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) (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) + ((LAMBDA () + (LOOP + (COND + ((< (LENGTH (ELT |u| |k|)) |l|) (RETURN NIL)) + (#0='T (SETQ |k| (+ |k| 1))))))) + (SETQ |v| (MAKE-VEC (+ |n| 1))) + ((LAMBDA (|bfVar#2| |i|) + (LOOP + (COND + ((> |i| |bfVar#2|) (RETURN NIL)) + (#0# (VEC-SETELT |v| |i| (ELT |u| |i|)))) + (SETQ |i| (+ |i| 1)))) + (- |k| 1) 0) + (VEC-SETELT |v| |k| |s|) + ((LAMBDA (|bfVar#3| |i|) + (LOOP + (COND + ((> |i| |bfVar#3|) (RETURN NIL)) + (#0# (VEC-SETELT |v| (+ |i| 1) (ELT |u| |i|)))) + (SETQ |i| (+ |i| 1)))) + (- |n| 1) |k|) + (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)) + ((LAMBDA (|i|) + (LOOP + (COND + ((> |i| 255) (RETURN NIL)) + (#0='T (VEC-SETELT |a| |i| |b|))) + (SETQ |i| (+ |i| 1)))) + 0) + |a|)) + ((LAMBDA (|bfVar#4| |s|) + (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|)))) + |l| NIL) + |d|)))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (DEFPARAMETER |shoeDict| (|shoeDictCons|))) + +(DEFUN |shoePunCons| () + (PROG (|a| |listing|) + (RETURN + (PROGN + (SETQ |listing| (HKEYS |shoeKeyTable|)) + (SETQ |a| (MAKE-BVEC 256)) + ((LAMBDA (|i|) + (LOOP + (COND + ((> |i| 255) (RETURN NIL)) + (#0='T (BVEC-SETELT |a| |i| 0))) + (SETQ |i| (+ |i| 1)))) + 0) + ((LAMBDA (|bfVar#5| |k|) + (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|)))) + |listing| NIL) + |a|)))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (DEFPARAMETER |shoePun| (|shoePunCons|))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (PROG () + (RETURN + ((LAMBDA (|bfVar#6| |i|) + (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|)))) + (LIST 'NOT 'LENGTH) NIL)))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (PROG () + (RETURN + ((LAMBDA (|bfVar#7| |i|) + (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|)))) + (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 'NE '^=)) + NIL)))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (PROG () + (RETURN + ((LAMBDA (|bfVar#8| |i|) + (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|)))) + (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)) + NIL)))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (PROG () + (RETURN + ((LAMBDA (|bfVar#9| |i|) + (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|)))) + (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 'NE '/=) (LIST 'T 'T$)) + NIL)))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (PROG () + (RETURN + ((LAMBDA (|bfVar#10| |i|) + (LOOP + (COND + ((OR (ATOM |bfVar#10|) + (PROGN (SETQ |i| (CAR |bfVar#10|)) NIL)) + (RETURN NIL)) + ('T (SETF (GET (CAR |i|) 'SHOESELFUNCTION) (CADR |i|)))) + (SETQ |bfVar#10| (CDR |bfVar#10|)))) + (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)) + NIL)))) + +@ +\eject + +\section*{Acknowledgment} +Gabriel Dos Reis contributed initial documentation of this pamphlet. + +\end{document} diff --git a/src/boot/translator.boot.pamphlet b/src/boot/translator.boot.pamphlet new file mode 100644 index 00000000..384fdbde --- /dev/null +++ b/src/boot/translator.boot.pamphlet @@ -0,0 +1,1935 @@ +\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" + +-- 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) == + $bfClamming:local:=false + 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) == BOOTCLAMLINES(nil,fn, out) + +BOOTCLAMLINES(lines, fn, out) == + $bfClamming:local:=true + 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" + $bfClamming:local:=false + 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" + $bfClamming:local:=false + $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_-NAME _*PACKAGE_* + IN_-PACKAGE '"BOOTTRAN" + $bfClamming:local:=false + infn:=shoeAddbootIfNec fn + outfn:=CONCAT(shoeRemovebootIfNec fn,'".",_*LISP_-SOURCE_-FILETYPE_*) + shoeOpenInputFile(a,infn,shoeClLines(a,infn,[],outfn)) + IN_-PACKAGE b + LOAD outfn + +-- (boot "filename") translates the file "filename.boot" +-- and prints the result at the console + +BO fn== + b:=PACKAGE_-NAME _*PACKAGE_* + IN_-PACKAGE '"BOOTTRAN" + $GenVarCounter:local := 0 + $bfClamming:local := false + infn:=shoeAddbootIfNec fn + shoeOpenInputFile(a,infn,shoeToConsole(a,fn)) + IN_-PACKAGE 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 + $bfClamming:local:=false + 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 + $bfClamming:local:=false + 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) + +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 [shoeEVALANDFILEACTQ ["DEFPARAMETER",l,r]] + case b of + Module(m) => bpPush [shoeCompileTimeEvaluation ["PROVIDE", m]] + Import(m) => bpPush [["IMPORT-MODULE", m]] + TypeAlias(t, args, rhs) => bpPush [["DEFTYPE", t, args, ["QUOTE", rhs]]] + 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)== + $bfClamming:local:=false + $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_-NAME _*PACKAGE_* + IN_-PACKAGE '"BOOTTRAN" + b:=bStreamNull s + IN_-PACKAGE a + b + +PSTTOMC string== + $GenVarCounter:local := 0 + $bfClamming:local:=false + 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 + $bfClamming:local:=false + result := shoeConsoleTrees shoeTransformString string + setCurrentPackage callingPackage + result + + +defaultBootToLispFile file == + CONCAT(shoeRemovebootIfNec file,'".clisp") + +translateBootFile(progname, options, file) == + outFile := getOutputPathname(options, defaultBootToLispFile file) + 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") + +(IMPORT-MODULE "scanner") + +(IMPORT-MODULE "pile") + +(IMPORT-MODULE "parser") + +(IMPORT-MODULE "ast") + +(IN-PACKAGE "BOOTTRAN") + +(DEFUN |setCurrentPackage| (|x|) + (PROG () (RETURN (SETQ *PACKAGE* |x|)))) + +(DEFUN |shoeCOMPILE-FILE| (|lspFileName|) + (PROG () (RETURN (COMPILE-FILE |lspFileName|)))) + +(DEFUN BOOTTOCL (|fn| |out|) + (PROG (|$bfClamming|) + (DECLARE (SPECIAL |$bfClamming|)) + (RETURN + (PROGN (SETQ |$bfClamming| NIL) (BOOTTOCLLINES NIL |fn| |out|))))) + +(DEFUN BOOTCLAM (|fn| |out|) + (PROG () (RETURN (BOOTCLAMLINES NIL |fn| |out|)))) + +(DEFUN BOOTCLAMLINES (|lines| |fn| |out|) + (PROG (|$bfClamming|) + (DECLARE (SPECIAL |$bfClamming|)) + (RETURN + (PROGN + (SETQ |$bfClamming| T) + (BOOTTOCLLINES |lines| |fn| |out|))))) + +(DEFUN BOOTTOCLLINES (|lines| |fn| |outfn|) + (PROG (|result| |infn| |callingPackage|) + (RETURN + (PROGN + (SETQ *READ-DEFAULT-FLOAT-FORMAT* 'DOUBLE-FLOAT) + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |infn| (|shoeAddbootIfNec| |fn|)) + (SETQ |result| + (|shoeOpenInputFile| |a| |infn| + (|shoeClLines| |a| |fn| |lines| |outfn|))) + (|setCurrentPackage| |callingPackage|) + |result|)))) + +(DEFUN |shoeClLines| (|a| |fn| |lines| |outfn|) + (PROG (|$GenVarCounter|) + (DECLARE (SPECIAL |$GenVarCounter|)) + (RETURN + (COND + ((NULL |a|) (|shoeNotFound| |fn|)) + ('T (SETQ |$GenVarCounter| 0) + (|shoeOpenOutputFile| |stream| |outfn| + (PROGN + ((LAMBDA (|bfVar#1| |line|) + (LOOP + (COND + ((OR (ATOM |bfVar#1|) + (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL)) + (RETURN NIL)) + ('T (|shoeFileLine| |line| |stream|))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))) + |lines| NIL) + (|shoeFileTrees| (|shoeTransformStream| |a|) |stream|))) + |outfn|))))) + +(DEFUN BOOTTOCLC (|fn| |out|) + (PROG () (RETURN (BOOTTOCLCLINES NIL |fn| |out|)))) + +(DEFUN BOOTTOCLCLINES (|lines| |fn| |outfn|) + (PROG (|$bfClamming| |result| |infn| |callingPackage|) + (DECLARE (SPECIAL |$bfClamming|)) + (RETURN + (PROGN + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |$bfClamming| NIL) + (SETQ |infn| (|shoeAddbootIfNec| |fn|)) + (SETQ |result| + (|shoeOpenInputFile| |a| |infn| + (|shoeClCLines| |a| |fn| |lines| |outfn|))) + (|setCurrentPackage| |callingPackage|) + |result|)))) + +(DEFUN |shoeClCLines| (|a| |fn| |lines| |outfn|) + (PROG (|$GenVarCounter|) + (DECLARE (SPECIAL |$GenVarCounter|)) + (RETURN + (COND + ((NULL |a|) (|shoeNotFound| |fn|)) + ('T (SETQ |$GenVarCounter| 0) + (|shoeOpenOutputFile| |stream| |outfn| + (PROGN + ((LAMBDA (|bfVar#2| |line|) + (LOOP + (COND + ((OR (ATOM |bfVar#2|) + (PROGN (SETQ |line| (CAR |bfVar#2|)) NIL)) + (RETURN NIL)) + ('T (|shoeFileLine| |line| |stream|))) + (SETQ |bfVar#2| (CDR |bfVar#2|)))) + |lines| NIL) + (|shoeFileTrees| + (|shoeTransformToFile| |stream| + (|shoeInclude| + (|bAddLineNumber| (|bRgen| |a|) (|bIgen| 0)))) + |stream|))) + |outfn|))))) + +(DEFUN BOOTTOMC (|fn|) + (PROG (|$GenVarCounter| |$bfClamming| |result| |infn| + |callingPackage|) + (DECLARE (SPECIAL |$GenVarCounter| |$bfClamming|)) + (RETURN + (PROGN + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |$bfClamming| NIL) + (SETQ |$GenVarCounter| 0) + (SETQ |infn| (|shoeAddbootIfNec| |fn|)) + (SETQ |result| + (|shoeOpenInputFile| |a| |infn| (|shoeMc| |a| |fn|))) + (|setCurrentPackage| |callingPackage|) + |result|)))) + +(DEFUN |shoeMc| (|a| |fn|) + (PROG () + (RETURN + (COND + ((NULL |a|) (|shoeNotFound| |fn|)) + ('T (|shoePCompileTrees| (|shoeTransformStream| |a|)) + (|shoeConsole| (CONCAT |fn| " COMPILED AND LOADED"))))))) + +(DEFUN EVAL-BOOT-FILE (|fn|) + (PROG (|$bfClamming| |outfn| |infn| |b|) + (DECLARE (SPECIAL |$bfClamming|)) + (RETURN + (PROGN + (SETQ |b| (PACKAGE-NAME *PACKAGE*)) + (IN-PACKAGE "BOOTTRAN") + (SETQ |$bfClamming| NIL) + (SETQ |infn| (|shoeAddbootIfNec| |fn|)) + (SETQ |outfn| + (CONCAT (|shoeRemovebootIfNec| |fn|) "." + *LISP-SOURCE-FILETYPE*)) + (|shoeOpenInputFile| |a| |infn| + (|shoeClLines| |a| |infn| NIL |outfn|)) + (IN-PACKAGE |b|) + (LOAD |outfn|))))) + +(DEFUN BO (|fn|) + (PROG (|$bfClamming| |$GenVarCounter| |infn| |b|) + (DECLARE (SPECIAL |$bfClamming| |$GenVarCounter|)) + (RETURN + (PROGN + (SETQ |b| (PACKAGE-NAME *PACKAGE*)) + (IN-PACKAGE "BOOTTRAN") + (SETQ |$GenVarCounter| 0) + (SETQ |$bfClamming| NIL) + (SETQ |infn| (|shoeAddbootIfNec| |fn|)) + (|shoeOpenInputFile| |a| |infn| (|shoeToConsole| |a| |fn|)) + (IN-PACKAGE |b|))))) + +(DEFUN BOCLAM (|fn|) + (PROG (|$bfClamming| |$GenVarCounter| |result| |infn| + |callingPackage|) + (DECLARE (SPECIAL |$bfClamming| |$GenVarCounter|)) + (RETURN + (PROGN + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |$GenVarCounter| 0) + (SETQ |$bfClamming| T) + (SETQ |infn| (|shoeAddbootIfNec| |fn|)) + (SETQ |result| + (|shoeOpenInputFile| |a| |infn| + (|shoeToConsole| |a| |fn|))) + (|setCurrentPackage| |callingPackage|) + |result|)))) + +(DEFUN |shoeToConsole| (|a| |fn|) + (PROG () + (RETURN + (COND + ((NULL |a|) (|shoeNotFound| |fn|)) + ('T + (|shoeConsoleTrees| + (|shoeTransformToConsole| + (|shoeInclude| + (|bAddLineNumber| (|bRgen| |a|) (|bIgen| 0)))))))))) + +(DEFUN STOUT (|string|) (PROG () (RETURN (PSTOUT (LIST |string|))))) + +(DEFUN STEVAL (|string|) + (PROG (|$bfClamming| |$GenVarCounter| |result| |fn| |a| + |callingPackage|) + (DECLARE (SPECIAL |$bfClamming| |$GenVarCounter|)) + (RETURN + (PROGN + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |$GenVarCounter| 0) + (SETQ |$bfClamming| NIL) + (SETQ |a| (|shoeTransformString| (LIST |string|))) + (SETQ |result| + (COND + ((|bStreamPackageNull| |a|) NIL) + ('T + (PROGN + (SETQ |fn| + (|stripm| (CAR |a|) *PACKAGE* + (FIND-PACKAGE "BOOTTRAN"))) + (EVAL |fn|))))) + (|setCurrentPackage| |callingPackage|) + |result|)))) + +(DEFUN STTOMC (|string|) + (PROG (|$bfClamming| |$GenVarCounter| |result| |a| |callingPackage|) + (DECLARE (SPECIAL |$bfClamming| |$GenVarCounter|)) + (RETURN + (PROGN + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |$GenVarCounter| 0) + (SETQ |$bfClamming| NIL) + (SETQ |a| (|shoeTransformString| (LIST |string|))) + (SETQ |result| + (COND + ((|bStreamPackageNull| |a|) NIL) + ('T (|shoePCompile| (CAR |a|))))) + (|setCurrentPackage| |callingPackage|) + |result|)))) + +(DEFUN |shoeCompileTrees| (|s|) + (PROG () + (RETURN + ((LAMBDA () + (LOOP + (COND + ((|bStreamNull| |s|) (RETURN NIL)) + ('T + (PROGN (|shoeCompile| (CAR |s|)) (SETQ |s| (CDR |s|))))))))))) + +(DEFUN |shoeCompile| (|fn|) + (PROG (|body| |bv| |ISTMP#2| |name| |ISTMP#1|) + (RETURN + (COND + ((AND (CONSP |fn|) (EQ (CAR |fn|) 'DEFUN) + (PROGN + (SETQ |ISTMP#1| (CDR |fn|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |name| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (PROGN + (SETQ |bv| (CAR |ISTMP#2|)) + (SETQ |body| (CDR |ISTMP#2|)) + 'T)))))) + (COMPILE |name| (CONS 'LAMBDA (CONS |bv| |body|)))) + ('T (EVAL |fn|)))))) + +(DEFUN |shoeTransform| (|str|) + (PROG () + (RETURN + (|bNext| #'|shoeTreeConstruct| + (|bNext| #'|shoePileInsert| + (|bNext| #'|shoeLineToks| |str|)))))) + +(DEFUN |shoeTransformString| (|s|) + (PROG () + (RETURN + (|shoeTransform| + (|shoeInclude| (|bAddLineNumber| |s| (|bIgen| 0))))))) + +(DEFUN |shoeTransformStream| (|s|) + (PROG () (RETURN (|shoeTransformString| (|bRgen| |s|))))) + +(DEFUN |shoeTransformToConsole| (|str|) + (PROG () + (RETURN + (|bNext| #'|shoeConsoleItem| + (|bNext| #'|shoePileInsert| + (|bNext| #'|shoeLineToks| |str|)))))) + +(DEFUN |shoeTransformToFile| (|fn| |str|) + (PROG () + (RETURN + (|bFileNext| |fn| + (|bNext| #'|shoePileInsert| (|bNext| #'|shoeLineToks| |str|)))))) + +(DEFUN |shoeConsoleItem| (|str|) + (PROG (|dq|) + (RETURN + (PROGN + (SETQ |dq| (CAR |str|)) + (|shoeConsoleLines| (|shoeDQlines| |dq|)) + (CONS (|shoeParseTrees| |dq|) (CDR |str|)))))) + +(DEFUN |bFileNext| (|fn| |s|) + (PROG () (RETURN (|bDelay| #'|bFileNext1| (LIST |fn| |s|))))) + +(DEFUN |bFileNext1| (|fn| |s|) + (PROG (|dq|) + (RETURN + (COND + ((|bStreamNull| |s|) (LIST '|nullstream|)) + ('T + (PROGN + (SETQ |dq| (CAR |s|)) + (|shoeFileLines| (|shoeDQlines| |dq|) |fn|) + (|bAppend| (|shoeParseTrees| |dq|) + (|bFileNext| |fn| (CDR |s|))))))))) + +(DEFUN |shoeParseTrees| (|dq|) + (PROG (|toklist|) + (RETURN + (PROGN + (SETQ |toklist| (|dqToList| |dq|)) + (COND ((NULL |toklist|) NIL) ('T (|shoeOutParse| |toklist|))))))) + +(DEFUN |shoeTreeConstruct| (|str|) + (PROG () (RETURN (CONS (|shoeParseTrees| (CAR |str|)) (CDR |str|))))) + +(DEFUN |shoeDQlines| (|dq|) + (PROG (|b| |a|) + (RETURN + (PROGN + (SETQ |a| (CDAAR (|shoeLastTokPosn| |dq|))) + (SETQ |b| (CDAAR (|shoeFirstTokPosn| |dq|))) + (|streamTake| (+ (- |a| |b|) 1) + (CAR (|shoeFirstTokPosn| |dq|))))))) + +(DEFUN |streamTake| (|n| |s|) + (PROG () + (RETURN + (COND + ((|bStreamNull| |s|) NIL) + ((EQL |n| 0) NIL) + ('T (CONS (CAR |s|) (|streamTake| (- |n| 1) (CDR |s|)))))))) + +(DEFUN |shoeFileLines| (|lines| |fn|) + (PROG () + (RETURN + (PROGN + (|shoeFileLine| " " |fn|) + ((LAMBDA (|bfVar#3| |line|) + (LOOP + (COND + ((OR (ATOM |bfVar#3|) + (PROGN (SETQ |line| (CAR |bfVar#3|)) NIL)) + (RETURN NIL)) + ('T (|shoeFileLine| (|shoeAddComment| |line|) |fn|))) + (SETQ |bfVar#3| (CDR |bfVar#3|)))) + |lines| NIL) + (|shoeFileLine| " " |fn|))))) + +(DEFUN |shoeConsoleLines| (|lines|) + (PROG () + (RETURN + (PROGN + (|shoeConsole| " ") + ((LAMBDA (|bfVar#4| |line|) + (LOOP + (COND + ((OR (ATOM |bfVar#4|) + (PROGN (SETQ |line| (CAR |bfVar#4|)) NIL)) + (RETURN NIL)) + ('T (|shoeConsole| (|shoeAddComment| |line|)))) + (SETQ |bfVar#4| (CDR |bfVar#4|)))) + |lines| NIL) + (|shoeConsole| " "))))) + +(DEFUN |shoeFileLine| (|x| |stream|) + (PROG () (RETURN (PROGN (WRITE-LINE |x| |stream|) |x|)))) + +(DEFUN |shoeFileTrees| (|s| |st|) + (PROG (|a|) + (RETURN + ((LAMBDA () + (LOOP + (COND + ((|bStreamNull| |s|) (RETURN NIL)) + ('T + (PROGN + (SETQ |a| (CAR |s|)) + (COND + ((EQCAR |a| '+LINE) (|shoeFileLine| (CADR |a|) |st|)) + ('T (REALLYPRETTYPRINT |a| |st|) (TERPRI |st|))) + (SETQ |s| (CDR |s|))))))))))) + +(DEFUN |shoePPtoFile| (|x| |stream|) + (PROG () (RETURN (PROGN (SHOENOTPRETTYPRINT |x| |stream|) |x|)))) + +(DEFUN |shoeConsoleTrees| (|s|) + (PROG (|fn|) + (RETURN + ((LAMBDA () + (LOOP + (COND + ((|bStreamPackageNull| |s|) (RETURN NIL)) + ('T + (PROGN + (SETQ |fn| + (|stripm| (CAR |s|) *PACKAGE* + (FIND-PACKAGE "BOOTTRAN"))) + (REALLYPRETTYPRINT |fn|) + (SETQ |s| (CDR |s|))))))))))) + +(DEFUN |shoeAddComment| (|l|) + (PROG () (RETURN (CONCAT "; " (CAR |l|))))) + +(DEFUN |shoeOutParse| (|stream|) + (PROG (|$bpParenCount| |$bpCount| |$returns| |$typings| |$wheredefs| + |$op| |$ttok| |$stok| |$stack| |$inputStream| |found|) + (DECLARE (SPECIAL |$bpParenCount| |$bpCount| |$returns| |$typings| + |$wheredefs| |$op| |$ttok| |$stok| |$stack| + |$inputStream|)) + (RETURN + (PROGN + (SETQ |$inputStream| |stream|) + (SETQ |$stack| NIL) + (SETQ |$stok| NIL) + (SETQ |$ttok| NIL) + (SETQ |$op| NIL) + (SETQ |$wheredefs| NIL) + (SETQ |$typings| NIL) + (SETQ |$returns| NIL) + (SETQ |$bpCount| 0) + (SETQ |$bpParenCount| 0) + (|bpFirstTok|) + (SETQ |found| (CATCH 'TRAPPOINT (|bpOutItem|))) + (COND + ((EQ |found| 'TRAPPED) NIL) + ((NULL (|bStreamNull| |$inputStream|)) (|bpGeneralErrorHere|) + NIL) + ((NULL |$stack|) (|bpGeneralErrorHere|) NIL) + ('T (CAR |$stack|))))))) + +(DEFUN |bpOutItem| () + (PROG (|bfVar#6| |bfVar#5| |r| |ISTMP#2| |l| |ISTMP#1| |b|) + (RETURN + (PROGN + (OR (|bpComma|) (|bpTrap|)) + (SETQ |b| (|bpPop1|)) + (COND + ((EQCAR |b| 'TUPLE) (|bpPush| (CDR |b|))) + ((EQCAR |b| '+LINE) (|bpPush| (LIST |b|))) + ((AND (CONSP |b|) (EQ (CAR |b|) 'L%T) + (PROGN + (SETQ |ISTMP#1| (CDR |b|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |l| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |r| (CAR |ISTMP#2|)) 'T))))) + (IDENTP |l|)) + (|bpPush| + (LIST (|shoeEVALANDFILEACTQ| + (LIST 'DEFPARAMETER |l| |r|))))) + ('T + (PROGN + (SETQ |bfVar#5| |b|) + (SETQ |bfVar#6| (CDR |bfVar#5|)) + (CASE (CAR |bfVar#5|) + (|Module| + (LET ((|m| (CAR |bfVar#6|))) + (|bpPush| + (LIST (|shoeCompileTimeEvaluation| + (LIST 'PROVIDE |m|)))))) + (|Import| + (LET ((|m| (CAR |bfVar#6|))) + (|bpPush| + (LIST (LIST 'IMPORT-MODULE |m|))))) + (|TypeAlias| + (LET ((|t| (CAR |bfVar#6|)) + (|args| (CADR |bfVar#6|)) + (|rhs| (CADDR |bfVar#6|))) + (|bpPush| + (LIST (LIST 'DEFTYPE |t| |args| + (LIST 'QUOTE |rhs|)))))) + (T (PROGN + (SETQ |b| + (|shoeCompTran| + (LIST 'LAMBDA (LIST '|x|) |b|))) + (|bpPush| + (LIST (|shoeEVALANDFILEACTQ| (CADDR |b|)))))))))))))) + +(DEFUN |shoeAddbootIfNec| (|s|) + (PROG () (RETURN (|shoeAddStringIfNec| ".boot" |s|)))) + +(DEFUN |shoeRemovebootIfNec| (|s|) + (PROG () (RETURN (|shoeRemoveStringIfNec| ".boot" |s|)))) + +(DEFUN |shoeAddStringIfNec| (|str| |s|) + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (STRPOS |str| |s| 0 NIL)) + (COND ((NULL |a|) (CONCAT |s| |str|)) ('T |s|)))))) + +(DEFUN |shoeRemoveStringIfNec| (|str| |s|) + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (STRPOS |str| |s| 0 NIL)) + (COND ((NULL |a|) |s|) ('T (SUBSTRING |s| 0 |a|))))))) + +(DEFUN DEFUSE (|fn|) + (PROG (|infn|) + (RETURN + (PROGN + (SETQ |infn| (CONCAT |fn| ".boot")) + (|shoeOpenInputFile| |a| |infn| (|shoeDfu| |a| |fn|)))))) + +(DEFUN |shoeDfu| (|a| |fn|) + (PROG (|$bfClamming| |$GenVarCounter| |$bootDefinedTwice| |$bootUsed| + |$bootDefined| |$lispWordTable| |out|) + (DECLARE (SPECIAL |$bfClamming| |$GenVarCounter| + |$bootDefinedTwice| |$bootUsed| |$bootDefined| + |$lispWordTable|)) + (RETURN + (COND + ((NULL |a|) (|shoeNotFound| |fn|)) + ('T (SETQ |$lispWordTable| (MAKE-HASHTABLE 'EQ)) + (DO-SYMBOLS (|i| (FIND-PACKAGE 'LISP)) + (HPUT |$lispWordTable| |i| T)) + (SETQ |$bootDefined| (MAKE-HASHTABLE 'EQ)) + (SETQ |$bootUsed| (MAKE-HASHTABLE 'EQ)) + (SETQ |$bootDefinedTwice| NIL) (SETQ |$GenVarCounter| 0) + (SETQ |$bfClamming| NIL) + (|shoeDefUse| (|shoeTransformStream| |a|)) + (SETQ |out| (CONCAT |fn| ".defuse")) + (|shoeOpenOutputFile| |stream| |out| (|shoeReport| |stream|)) + |out|))))) + +(DEFUN |shoeReport| (|stream|) + (PROG (|b| |a|) + (DECLARE (SPECIAL |$bootDefinedTwice| |$bootDefined| |$bootUsed|)) + (RETURN + (PROGN + (|shoeFileLine| "DEFINED and not USED" |stream|) + (SETQ |a| + ((LAMBDA (|bfVar#8| |bfVar#7| |i|) + (LOOP + (COND + ((OR (ATOM |bfVar#7|) + (PROGN (SETQ |i| (CAR |bfVar#7|)) NIL)) + (RETURN (NREVERSE |bfVar#8|))) + (#0='T + (AND (NULL (GETHASH |i| |$bootUsed|)) + (SETQ |bfVar#8| (CONS |i| |bfVar#8|))))) + (SETQ |bfVar#7| (CDR |bfVar#7|)))) + NIL (HKEYS |$bootDefined|) NIL)) + (|bootOut| (SSORT |a|) |stream|) + (|shoeFileLine| " " |stream|) + (|shoeFileLine| "DEFINED TWICE" |stream|) + (|bootOut| (SSORT |$bootDefinedTwice|) |stream|) + (|shoeFileLine| " " |stream|) + (|shoeFileLine| "USED and not DEFINED" |stream|) + (SETQ |a| + ((LAMBDA (|bfVar#10| |bfVar#9| |i|) + (LOOP + (COND + ((OR (ATOM |bfVar#9|) + (PROGN (SETQ |i| (CAR |bfVar#9|)) NIL)) + (RETURN (NREVERSE |bfVar#10|))) + (#0# + (AND (NULL (GETHASH |i| |$bootDefined|)) + (SETQ |bfVar#10| (CONS |i| |bfVar#10|))))) + (SETQ |bfVar#9| (CDR |bfVar#9|)))) + NIL (HKEYS |$bootUsed|) NIL)) + ((LAMBDA (|bfVar#11| |i|) + (LOOP + (COND + ((OR (ATOM |bfVar#11|) + (PROGN (SETQ |i| (CAR |bfVar#11|)) NIL)) + (RETURN NIL)) + (#0# + (PROGN + (SETQ |b| (CONCAT (PNAME |i|) " is used in ")) + (|bootOutLines| (SSORT (GETHASH |i| |$bootUsed|)) + |stream| |b|)))) + (SETQ |bfVar#11| (CDR |bfVar#11|)))) + (SSORT |a|) NIL))))) + +(DEFUN |shoeDefUse| (|s|) + (PROG () + (RETURN + ((LAMBDA () + (LOOP + (COND + ((|bStreamPackageNull| |s|) (RETURN NIL)) + ('T (PROGN (|defuse| NIL (CAR |s|)) (SETQ |s| (CDR |s|))))))))))) + +(DEFUN |defuse| (|e| |x|) + (PROG (|$used| |niens| |nee| |LETTMP#1| |exp| |ISTMP#5| |id| + |ISTMP#4| |ISTMP#3| |body| |bv| |ISTMP#2| |name| + |ISTMP#1|) + (DECLARE (SPECIAL |$used| |$bootUsed| |$bootDefinedTwice| + |$bootDefined|)) + (RETURN + (PROGN + (SETQ |x| (|stripm| |x| *PACKAGE* (FIND-PACKAGE "BOOTTRAN"))) + (SETQ |$used| NIL) + (SETQ |LETTMP#1| + (COND + ((AND (CONSP |x|) (EQ (CAR |x|) 'DEFUN) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |name| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (PROGN + (SETQ |bv| (CAR |ISTMP#2|)) + (SETQ |body| (CDR |ISTMP#2|)) + #0='T)))))) + (LIST |name| (CONS 'LAMBDA (CONS |bv| |body|)))) + ((AND (CONSP |x|) (EQ (CAR |x|) 'DEFMACRO) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |name| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (PROGN + (SETQ |bv| (CAR |ISTMP#2|)) + (SETQ |body| (CDR |ISTMP#2|)) + #0#)))))) + (LIST |name| (CONS 'LAMBDA (CONS |bv| |body|)))) + ((AND (CONSP |x|) (EQ (CAR |x|) 'EVAL-WHEN) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CDR |ISTMP#2|) NIL) + (PROGN + (SETQ |ISTMP#3| (CAR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (EQ (CAR |ISTMP#3|) 'SETQ) + (PROGN + (SETQ |ISTMP#4| + (CDR |ISTMP#3|)) + (AND (CONSP |ISTMP#4|) + (PROGN + (SETQ |id| (CAR |ISTMP#4|)) + (SETQ |ISTMP#5| + (CDR |ISTMP#4|)) + (AND (CONSP |ISTMP#5|) + (EQ (CDR |ISTMP#5|) NIL) + (PROGN + (SETQ |exp| + (CAR |ISTMP#5|)) + #0#)))))))))))) + (LIST |id| |exp|)) + ((AND (CONSP |x|) (EQ (CAR |x|) 'SETQ) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |id| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CDR |ISTMP#2|) NIL) + (PROGN + (SETQ |exp| (CAR |ISTMP#2|)) + #0#)))))) + (LIST |id| |exp|)) + (#1='T (LIST 'TOP-LEVEL |x|)))) + (SETQ |nee| (CAR |LETTMP#1|)) + (SETQ |niens| (CADR |LETTMP#1|)) + (COND + ((GETHASH |nee| |$bootDefined|) + (SETQ |$bootDefinedTwice| + (COND + ((EQ |nee| 'TOP-LEVEL) |$bootDefinedTwice|) + (#1# (CONS |nee| |$bootDefinedTwice|))))) + ('T (HPUT |$bootDefined| |nee| T))) + (|defuse1| |e| |niens|) + ((LAMBDA (|bfVar#12| |i|) + (LOOP + (COND + ((OR (ATOM |bfVar#12|) + (PROGN (SETQ |i| (CAR |bfVar#12|)) NIL)) + (RETURN NIL)) + ('T + (HPUT |$bootUsed| |i| + (CONS |nee| (GETHASH |i| |$bootUsed|))))) + (SETQ |bfVar#12| (CDR |bfVar#12|)))) + |$used| NIL))))) + +(DEFUN |defuse1| (|e| |y|) + (PROG (|ndol| |dol| |LETTMP#1| |b| |a| |ISTMP#1|) + (DECLARE (SPECIAL |$bootDefined| |$used|)) + (RETURN + (COND + ((ATOM |y|) + (COND + ((IDENTP |y|) + (SETQ |$used| + (COND + ((MEMQ |y| |e|) |$used|) + ((MEMQ |y| |$used|) |$used|) + ((|defusebuiltin| |y|) |$used|) + (#0='T (UNION (LIST |y|) |$used|))))) + (#0# NIL))) + ((AND (CONSP |y|) (EQ (CAR |y|) 'LAMBDA) + (PROGN + (SETQ |ISTMP#1| (CDR |y|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |a| (CAR |ISTMP#1|)) + (SETQ |b| (CDR |ISTMP#1|)) + #1='T)))) + (|defuse1| (APPEND (|unfluidlist| |a|) |e|) |b|)) + ((AND (CONSP |y|) (EQ (CAR |y|) 'PROG) + (PROGN + (SETQ |ISTMP#1| (CDR |y|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |a| (CAR |ISTMP#1|)) + (SETQ |b| (CDR |ISTMP#1|)) + #1#)))) + (PROGN + (SETQ |LETTMP#1| (|defSeparate| |a|)) + (SETQ |dol| (CAR |LETTMP#1|)) + (SETQ |ndol| (CADR |LETTMP#1|)) + ((LAMBDA (|bfVar#13| |i|) + (LOOP + (COND + ((OR (ATOM |bfVar#13|) + (PROGN (SETQ |i| (CAR |bfVar#13|)) NIL)) + (RETURN NIL)) + (#2='T (HPUT |$bootDefined| |i| T))) + (SETQ |bfVar#13| (CDR |bfVar#13|)))) + |dol| NIL) + (|defuse1| (APPEND |ndol| |e|) |b|))) + ((AND (CONSP |y|) (EQ (CAR |y|) 'QUOTE) + (PROGN (SETQ |a| (CDR |y|)) #1#)) + NIL) + ((AND (CONSP |y|) (EQ (CAR |y|) '+LINE) + (PROGN (SETQ |a| (CDR |y|)) #1#)) + NIL) + (#0# + ((LAMBDA (|bfVar#14| |i|) + (LOOP + (COND + ((OR (ATOM |bfVar#14|) + (PROGN (SETQ |i| (CAR |bfVar#14|)) NIL)) + (RETURN NIL)) + (#2# (|defuse1| |e| |i|))) + (SETQ |bfVar#14| (CDR |bfVar#14|)))) + |y| NIL)))))) + +(DEFUN |defSeparate| (|x|) + (PROG (|x2| |x1| |LETTMP#1| |f|) + (RETURN + (COND + ((NULL |x|) (LIST NIL NIL)) + (#0='T (SETQ |f| (CAR |x|)) + (SETQ |LETTMP#1| (|defSeparate| (CDR |x|))) + (SETQ |x1| (CAR |LETTMP#1|)) (SETQ |x2| (CADR |LETTMP#1|)) + (COND + ((|bfBeginsDollar| |f|) (LIST (CONS |f| |x1|) |x2|)) + (#0# (LIST |x1| (CONS |f| |x2|))))))))) + +(DEFUN |unfluidlist| (|x|) + (PROG (|y| |ISTMP#1|) + (RETURN + (COND + ((NULL |x|) NIL) + ((ATOM |x|) (LIST |x|)) + ((AND (CONSP |x|) (EQ (CAR |x|) '&REST) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN (SETQ |y| (CAR |ISTMP#1|)) 'T)))) + (LIST |y|)) + ('T (CONS (CAR |x|) (|unfluidlist| (CDR |x|)))))))) + +(DEFUN |defusebuiltin| (|x|) + (PROG () + (DECLARE (SPECIAL |$lispWordTable|)) + (RETURN (GETHASH |x| |$lispWordTable|)))) + +(DEFUN |bootOut| (|l| |outfn|) + (PROG () + (RETURN + ((LAMBDA (|bfVar#15| |i|) + (LOOP + (COND + ((OR (ATOM |bfVar#15|) + (PROGN (SETQ |i| (CAR |bfVar#15|)) NIL)) + (RETURN NIL)) + ('T (|shoeFileLine| (CONCAT " " (PNAME |i|)) |outfn|))) + (SETQ |bfVar#15| (CDR |bfVar#15|)))) + |l| NIL)))) + +(DEFUN CLESSP (|s1| |s2|) + (PROG () (RETURN (NULL (SHOEGREATERP |s1| |s2|))))) + +(DEFUN SSORT (|l|) (PROG () (RETURN (SORT |l| #'CLESSP)))) + +(DEFUN |bootOutLines| (|l| |outfn| |s|) + (PROG (|a|) + (RETURN + (COND + ((NULL |l|) (|shoeFileLine| |s| |outfn|)) + (#0='T (SETQ |a| (PNAME (CAR |l|))) + (COND + ((< 70 (+ (LENGTH |s|) (LENGTH |a|))) + (|shoeFileLine| |s| |outfn|) + (|bootOutLines| |l| |outfn| " ")) + (#0# + (|bootOutLines| (CDR |l|) |outfn| (CONCAT |s| " " |a|))))))))) + +(DEFUN XREF (|fn|) + (PROG (|infn|) + (RETURN + (PROGN + (SETQ |infn| (CONCAT |fn| ".boot")) + (|shoeOpenInputFile| |a| |infn| (|shoeXref| |a| |fn|)))))) + +(DEFUN |shoeXref| (|a| |fn|) + (PROG (|$bfClamming| |$GenVarCounter| |$bootUsed| |$bootDefined| + |$lispWordTable| |out|) + (DECLARE (SPECIAL |$bfClamming| |$GenVarCounter| |$bootUsed| + |$bootDefined| |$lispWordTable|)) + (RETURN + (COND + ((NULL |a|) (|shoeNotFound| |fn|)) + ('T (SETQ |$lispWordTable| (MAKE-HASHTABLE 'EQ)) + (DO-SYMBOLS (|i| (FIND-PACKAGE 'LISP)) + (HPUT |$lispWordTable| |i| T)) + (SETQ |$bootDefined| (MAKE-HASHTABLE 'EQ)) + (SETQ |$bootUsed| (MAKE-HASHTABLE 'EQ)) + (SETQ |$GenVarCounter| 0) (SETQ |$bfClamming| NIL) + (|shoeDefUse| (|shoeTransformStream| |a|)) + (SETQ |out| (CONCAT |fn| ".xref")) + (|shoeOpenOutputFile| |stream| |out| (|shoeXReport| |stream|)) + |out|))))) + +(DEFUN |shoeXReport| (|stream|) + (PROG (|a| |c|) + (DECLARE (SPECIAL |$bootUsed|)) + (RETURN + (PROGN + (|shoeFileLine| "USED and where DEFINED" |stream|) + (SETQ |c| (SSORT (HKEYS |$bootUsed|))) + ((LAMBDA (|bfVar#16| |i|) + (LOOP + (COND + ((OR (ATOM |bfVar#16|) + (PROGN (SETQ |i| (CAR |bfVar#16|)) NIL)) + (RETURN NIL)) + ('T + (PROGN + (SETQ |a| (CONCAT (PNAME |i|) " is used in ")) + (|bootOutLines| (SSORT (GETHASH |i| |$bootUsed|)) + |stream| |a|)))) + (SETQ |bfVar#16| (CDR |bfVar#16|)))) + |c| NIL))))) + +(DEFUN FBO (|name| |fn|) + (PROG () (RETURN (|shoeGeneralFC| #'BO |name| |fn|)))) + +(DEFUN FEV (|name| |fn|) + (PROG () (RETURN (|shoeGeneralFC| #'EVAL-BOOT-FILE |name| |fn|)))) + +(DEFUN |shoeGeneralFC| (|f| |name| |fn|) + (PROG (|$GenVarCounter| |$bfClamming| |filename| |a| |infn|) + (DECLARE (SPECIAL |$GenVarCounter| |$bfClamming|)) + (RETURN + (PROGN + (SETQ |$bfClamming| NIL) + (SETQ |$GenVarCounter| 0) + (SETQ |infn| (|shoeAddbootIfNec| |fn|)) + (SETQ |a| + (|shoeOpenInputFile| |a| |infn| + (|shoeFindName2| |fn| |name| |a|))) + (SETQ |filename| + (COND + ((< 8 (LENGTH |name|)) (SUBSTRING |name| 0 8)) + ('T |name|))) + (COND + (|a| (FUNCALL |f| (CONCAT "/tmp/" |filename|))) + ('T NIL)))))) + +(DEFUN |shoeFindName2| (|fn| |name| |a|) + (PROG (|filename| |lines|) + (RETURN + (PROGN + (SETQ |lines| (|shoeFindLines| |fn| |name| |a|)) + (COND + (|lines| (PROGN + (SETQ |filename| + (COND + ((< 8 (LENGTH |name|)) + (SUBSTRING |name| 0 8)) + ('T |name|))) + (SETQ |filename| + (CONCAT "/tmp/" |filename| ".boot")) + (|shoeOpenOutputFile| |stream| |filename| + ((LAMBDA (|bfVar#17| |line|) + (LOOP + (COND + ((OR (ATOM |bfVar#17|) + (PROGN + (SETQ |line| (CAR |bfVar#17|)) + NIL)) + (RETURN NIL)) + ('T (|shoeFileLine| |line| |stream|))) + (SETQ |bfVar#17| (CDR |bfVar#17|)))) + |lines| NIL)) + T)) + ('T NIL)))))) + +(DEFUN |shoeTransform2| (|str|) + (PROG () + (RETURN + (|bNext| #'|shoeItem| + (|streamTake| 1 + (|bNext| #'|shoePileInsert| + (|bNext| #'|shoeLineToks| |str|))))))) + +(DEFUN |shoeItem| (|str|) + (PROG (|dq|) + (RETURN + (PROGN + (SETQ |dq| (CAR |str|)) + (CONS (LIST ((LAMBDA (|bfVar#19| |bfVar#18| |line|) + (LOOP + (COND + ((OR (ATOM |bfVar#18|) + (PROGN + (SETQ |line| (CAR |bfVar#18|)) + NIL)) + (RETURN (NREVERSE |bfVar#19|))) + ('T + (SETQ |bfVar#19| + (CONS (CAR |line|) |bfVar#19|)))) + (SETQ |bfVar#18| (CDR |bfVar#18|)))) + NIL (|shoeDQlines| |dq|) NIL)) + (CDR |str|)))))) + +(DEFUN |stripm| (|x| |pk| |bt|) + (PROG () + (RETURN + (COND + ((ATOM |x|) + (COND + ((IDENTP |x|) + (COND + ((EQUAL (SYMBOL-PACKAGE |x|) |bt|) + (INTERN (PNAME |x|) |pk|)) + (#0='T |x|))) + (#0# |x|))) + (#0# + (CONS (|stripm| (CAR |x|) |pk| |bt|) + (|stripm| (CDR |x|) |pk| |bt|))))))) + +(DEFUN |shoePCompile| (|fn|) + (PROG (|body| |bv| |ISTMP#2| |name| |ISTMP#1|) + (RETURN + (PROGN + (SETQ |fn| (|stripm| |fn| *PACKAGE* (FIND-PACKAGE "BOOTTRAN"))) + (COND + ((AND (CONSP |fn|) (EQ (CAR |fn|) 'DEFUN) + (PROGN + (SETQ |ISTMP#1| (CDR |fn|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |name| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (PROGN + (SETQ |bv| (CAR |ISTMP#2|)) + (SETQ |body| (CDR |ISTMP#2|)) + 'T)))))) + (COMPILE |name| (CONS 'LAMBDA (CONS |bv| |body|)))) + ('T (EVAL |fn|))))))) + +(DEFUN FC (|name| |fn|) + (PROG (|$GenVarCounter| |$bfClamming| |infn|) + (DECLARE (SPECIAL |$GenVarCounter| |$bfClamming|)) + (RETURN + (PROGN + (SETQ |$bfClamming| NIL) + (SETQ |$GenVarCounter| 0) + (SETQ |infn| (|shoeAddbootIfNec| |fn|)) + (|shoeOpenInputFile| |a| |infn| + (|shoeFindName| |fn| |name| |a|)))))) + +(DEFUN |shoeFindName| (|fn| |name| |a|) + (PROG (|lines|) + (RETURN + (PROGN + (SETQ |lines| (|shoeFindLines| |fn| |name| |a|)) + (|shoePCompileTrees| (|shoeTransformString| |lines|)))))) + +(DEFUN |shoePCompileTrees| (|s|) + (PROG () + (RETURN + ((LAMBDA () + (LOOP + (COND + ((|bStreamPackageNull| |s|) (RETURN NIL)) + ('T + (PROGN + (REALLYPRETTYPRINT (|shoePCompile| (CAR |s|))) + (SETQ |s| (CDR |s|))))))))))) + +(DEFUN |bStreamPackageNull| (|s|) + (PROG (|b| |a|) + (RETURN + (PROGN + (SETQ |a| (PACKAGE-NAME *PACKAGE*)) + (IN-PACKAGE "BOOTTRAN") + (SETQ |b| (|bStreamNull| |s|)) + (IN-PACKAGE |a|) + |b|)))) + +(DEFUN PSTTOMC (|string|) + (PROG (|$bfClamming| |$GenVarCounter|) + (DECLARE (SPECIAL |$bfClamming| |$GenVarCounter|)) + (RETURN + (PROGN + (SETQ |$GenVarCounter| 0) + (SETQ |$bfClamming| NIL) + (|shoePCompileTrees| (|shoeTransformString| |string|)))))) + +(DEFUN BOOTLOOP () + (PROG (|stream| |b| |a|) + (RETURN + (PROGN + (SETQ |a| (READ-LINE)) + (COND + ((EQL (LENGTH |a|) 0) + (PROGN + (WRITE-LINE "Boot Loop; to exit type ] ") + (BOOTLOOP))) + (#0='T + (PROGN + (SETQ |b| (|shoePrefix?| ")console" |a|)) + (COND + (|b| (PROGN + (SETQ |stream| *TERMINAL-IO*) + (PSTTOMC (|bRgen| |stream|)) + (BOOTLOOP))) + ((EQUAL (ELT |a| 0) (ELT "]" 0)) NIL) + (#0# (PROGN (PSTTOMC (LIST |a|)) (BOOTLOOP))))))))))) + +(DEFUN BOOTPO () + (PROG (|stream| |b| |a|) + (RETURN + (PROGN + (SETQ |a| (READ-LINE)) + (COND + ((EQL (LENGTH |a|) 0) + (PROGN (WRITE-LINE "Boot Loop; to exit type ] ") (BOOTPO))) + (#0='T + (PROGN + (SETQ |b| (|shoePrefix?| ")console" |a|)) + (COND + (|b| (PROGN + (SETQ |stream| *TERMINAL-IO*) + (PSTOUT (|bRgen| |stream|)) + (BOOTPO))) + ((EQUAL (ELT |a| 0) (ELT "]" 0)) NIL) + (#0# (PROGN (PSTOUT (LIST |a|)) (BOOTPO))))))))))) + +(DEFUN PSTOUT (|string|) + (PROG (|$bfClamming| |$GenVarCounter| |result| |callingPackage|) + (DECLARE (SPECIAL |$bfClamming| |$GenVarCounter|)) + (RETURN + (PROGN + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |$GenVarCounter| 0) + (SETQ |$bfClamming| NIL) + (SETQ |result| + (|shoeConsoleTrees| (|shoeTransformString| |string|))) + (|setCurrentPackage| |callingPackage|) + |result|)))) + +(DEFUN |defaultBootToLispFile| (|file|) + (PROG () (RETURN (CONCAT (|shoeRemovebootIfNec| |file|) ".clisp")))) + +(DEFUN |translateBootFile| (|progname| |options| |file|) + (PROG (|outFile|) + (RETURN + (PROGN + (SETQ |outFile| + (|getOutputPathname| |options| + (|defaultBootToLispFile| |file|))) + (BOOTTOCL |file| (ENOUGH-NAMESTRING |outFile|)))))) + +(DEFUN |compileBootHandler| (|progname| |options| |file|) + (PROG (|objFile| |intFile|) + (RETURN + (PROGN + (SETQ |intFile| + (BOOTTOCL |file| (|defaultBootToLispFile| |file|))) + (COND + (|intFile| + (PROGN + (SETQ |objFile| + (|compileLispHandler| |progname| |options| + |intFile|)) + (DELETE-FILE |intFile|) + |objFile|)) + ('T NIL)))))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (PROG () + (RETURN + (|associateRequestWithFileType| (|Option| "translate") "boot" + #'|translateBootFile|)))) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (PROG () + (RETURN + (|associateRequestWithFileType| (|Option| "compile") "boot" + #'|compileBootHandler|)))) + +@ + +\end{document} |