From 5e19307d17fae9928e92ecc96af9ec56842b13b3 Mon Sep 17 00:00:00 2001 From: Peter Vanusanik Date: Thu, 2 Mar 2023 16:45:30 +0100 Subject: [PATCH] #59 --- CHANGELOG.md | 5 + build.gradle.kts | 2 +- .../slt/plugin/lisp/impl/LispListImpl.java | 26 +- .../slt/plugin/lisp/psi/LispList.java | 12 +- .../slt/plugin/lisp/psi/LispVisitor.java | 2 +- .../slt/plugin/SltStructureAwareNavbar.java | 50 +- .../com/en_circle/slt/plugin/lisp/Lisp.bnf | 7 +- .../lisp/lisp/components/LispArguments.java | 7 + .../lisp/components/LispFunctionCall.java | 7 + .../plugin/lisp/psi/impl/LispPsiImplUtil.java | 31 + .../structure/LispStructureViewElement.java | 24 +- .../structure/LispStructureViewModel.java | 5 +- src/main/lisp/libs/eclector/.gitignore | 11 + src/main/lisp/libs/eclector/LICENSE | 12 + src/main/lisp/libs/eclector/README.md | 111 ++ .../libs/eclector/code/base/conditions.lisp | 80 + .../eclector/code/base/generic-functions.lisp | 13 + .../eclector/code/base/messages-english.lisp | 23 + .../lisp/libs/eclector/code/base/package.lisp | 52 + .../libs/eclector/code/base/read-char.lisp | 44 + .../libs/eclector/code/base/utilities.lisp | 18 + .../libs/eclector/code/base/variables.lisp | 3 + .../code/concrete-syntax-tree/package.lisp | 18 + .../code/concrete-syntax-tree/read.lisp | 76 + .../eclector/code/parse-result/client.lisp | 19 + .../code/parse-result/deprecation.lisp | 6 + .../code/parse-result/generic-functions.lisp | 26 + .../eclector/code/parse-result/package.lisp | 29 + .../libs/eclector/code/parse-result/read.lisp | 126 ++ .../code/reader/additional-conditions.lisp | 439 +++++ .../lisp/libs/eclector/code/reader/fixup.lisp | 42 + .../code/reader/generic-functions.lisp | 99 ++ .../lisp/libs/eclector/code/reader/init.lisp | 79 + .../eclector/code/reader/macro-functions.lisp | 1415 +++++++++++++++++ .../code/reader/messages-english.lisp | 573 +++++++ .../eclector/code/reader/more-variables.lisp | 38 + .../libs/eclector/code/reader/package.lisp | 259 +++ .../code/reader/quasiquote-macro.lisp | 72 + .../eclector/code/reader/read-common.lisp | 112 ++ .../lisp/libs/eclector/code/reader/read.lisp | 162 ++ .../libs/eclector/code/reader/tokens.lisp | 627 ++++++++ .../libs/eclector/code/reader/utilities.lisp | 236 +++ .../libs/eclector/code/reader/variables.lisp | 20 + .../eclector/code/readtable/conditions.lisp | 28 + .../code/readtable/generic-functions.lisp | 77 + .../code/readtable/messages-english.lisp | 34 + .../libs/eclector/code/readtable/package.lisp | 31 + .../readtable/simple/messages-english.lisp | 11 + .../code/readtable/simple/methods.lisp | 152 ++ .../code/readtable/simple/package.lisp | 12 + .../code/readtable/simple/readtable.lisp | 14 + .../eclector/code/readtable/variables.lisp | 12 + .../eclector-concrete-syntax-tree.asd | 34 + src/main/lisp/libs/eclector/eclector.asd | 143 ++ src/main/lisp/libs/eclector/version.sexp | 1 + src/main/resources/META-INF/plugin.xml | 11 +- 56 files changed, 5533 insertions(+), 45 deletions(-) create mode 100644 src/main/java/com/en_circle/slt/plugin/lisp/lisp/components/LispArguments.java create mode 100644 src/main/java/com/en_circle/slt/plugin/lisp/lisp/components/LispFunctionCall.java create mode 100644 src/main/lisp/libs/eclector/.gitignore create mode 100644 src/main/lisp/libs/eclector/LICENSE create mode 100644 src/main/lisp/libs/eclector/README.md create mode 100644 src/main/lisp/libs/eclector/code/base/conditions.lisp create mode 100644 src/main/lisp/libs/eclector/code/base/generic-functions.lisp create mode 100644 src/main/lisp/libs/eclector/code/base/messages-english.lisp create mode 100644 src/main/lisp/libs/eclector/code/base/package.lisp create mode 100644 src/main/lisp/libs/eclector/code/base/read-char.lisp create mode 100644 src/main/lisp/libs/eclector/code/base/utilities.lisp create mode 100644 src/main/lisp/libs/eclector/code/base/variables.lisp create mode 100644 src/main/lisp/libs/eclector/code/concrete-syntax-tree/package.lisp create mode 100644 src/main/lisp/libs/eclector/code/concrete-syntax-tree/read.lisp create mode 100644 src/main/lisp/libs/eclector/code/parse-result/client.lisp create mode 100644 src/main/lisp/libs/eclector/code/parse-result/deprecation.lisp create mode 100644 src/main/lisp/libs/eclector/code/parse-result/generic-functions.lisp create mode 100644 src/main/lisp/libs/eclector/code/parse-result/package.lisp create mode 100644 src/main/lisp/libs/eclector/code/parse-result/read.lisp create mode 100644 src/main/lisp/libs/eclector/code/reader/additional-conditions.lisp create mode 100644 src/main/lisp/libs/eclector/code/reader/fixup.lisp create mode 100644 src/main/lisp/libs/eclector/code/reader/generic-functions.lisp create mode 100644 src/main/lisp/libs/eclector/code/reader/init.lisp create mode 100644 src/main/lisp/libs/eclector/code/reader/macro-functions.lisp create mode 100644 src/main/lisp/libs/eclector/code/reader/messages-english.lisp create mode 100644 src/main/lisp/libs/eclector/code/reader/more-variables.lisp create mode 100644 src/main/lisp/libs/eclector/code/reader/package.lisp create mode 100644 src/main/lisp/libs/eclector/code/reader/quasiquote-macro.lisp create mode 100644 src/main/lisp/libs/eclector/code/reader/read-common.lisp create mode 100644 src/main/lisp/libs/eclector/code/reader/read.lisp create mode 100644 src/main/lisp/libs/eclector/code/reader/tokens.lisp create mode 100644 src/main/lisp/libs/eclector/code/reader/utilities.lisp create mode 100644 src/main/lisp/libs/eclector/code/reader/variables.lisp create mode 100644 src/main/lisp/libs/eclector/code/readtable/conditions.lisp create mode 100644 src/main/lisp/libs/eclector/code/readtable/generic-functions.lisp create mode 100644 src/main/lisp/libs/eclector/code/readtable/messages-english.lisp create mode 100644 src/main/lisp/libs/eclector/code/readtable/package.lisp create mode 100644 src/main/lisp/libs/eclector/code/readtable/simple/messages-english.lisp create mode 100644 src/main/lisp/libs/eclector/code/readtable/simple/methods.lisp create mode 100644 src/main/lisp/libs/eclector/code/readtable/simple/package.lisp create mode 100644 src/main/lisp/libs/eclector/code/readtable/simple/readtable.lisp create mode 100644 src/main/lisp/libs/eclector/code/readtable/variables.lisp create mode 100644 src/main/lisp/libs/eclector/eclector-concrete-syntax-tree.asd create mode 100644 src/main/lisp/libs/eclector/eclector.asd create mode 100644 src/main/lisp/libs/eclector/version.sexp diff --git a/CHANGELOG.md b/CHANGELOG.md index 9588c9d..6292f3b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +## 0.5.0 + +### Changes + + ## 0.4.1 230218 ### Fixes diff --git a/build.gradle.kts b/build.gradle.kts index 0fb6778..165e08a 100644 --- a/build.gradle.kts +++ b/build.gradle.kts @@ -4,7 +4,7 @@ plugins { } group = "com.en_circle.slt" -version = "0.4.1-rev1" +version = "0.5.0" repositories { mavenCentral() diff --git a/src/main/gen/com/en_circle/slt/plugin/lisp/impl/LispListImpl.java b/src/main/gen/com/en_circle/slt/plugin/lisp/impl/LispListImpl.java index 196a477..1c8e892 100644 --- a/src/main/gen/com/en_circle/slt/plugin/lisp/impl/LispListImpl.java +++ b/src/main/gen/com/en_circle/slt/plugin/lisp/impl/LispListImpl.java @@ -1,16 +1,18 @@ // This is a generated file. Not intended for manual editing. package com.en_circle.slt.plugin.lisp.impl; -import java.util.List; -import org.jetbrains.annotations.*; +import com.en_circle.slt.plugin.lisp.psi.LispList; +import com.en_circle.slt.plugin.lisp.psi.LispSexpr; +import com.en_circle.slt.plugin.lisp.psi.LispVisitor; +import com.en_circle.slt.plugin.lisp.psi.impl.LispPsiImplUtil; +import com.intellij.extapi.psi.ASTWrapperPsiElement; import com.intellij.lang.ASTNode; -import com.intellij.psi.PsiElement; +import com.intellij.navigation.ItemPresentation; import com.intellij.psi.PsiElementVisitor; import com.intellij.psi.util.PsiTreeUtil; -import static com.en_circle.slt.plugin.lisp.psi.LispTypes.*; -import com.intellij.extapi.psi.ASTWrapperPsiElement; -import com.en_circle.slt.plugin.lisp.psi.*; -import com.en_circle.slt.plugin.lisp.psi.impl.LispPsiImplUtil; +import org.jetbrains.annotations.NotNull; + +import java.util.List; public class LispListImpl extends ASTWrapperPsiElement implements LispList { @@ -34,4 +36,14 @@ public List getSexprList() { return PsiTreeUtil.getChildrenOfTypeAsList(this, LispSexpr.class); } + @Override + public String getName() { + return LispPsiImplUtil.getName(this); + } + + @Override + public ItemPresentation getPresentation() { + return LispPsiImplUtil.getPresentation(this); + } + } diff --git a/src/main/gen/com/en_circle/slt/plugin/lisp/psi/LispList.java b/src/main/gen/com/en_circle/slt/plugin/lisp/psi/LispList.java index 10e22ff..0d4af46 100644 --- a/src/main/gen/com/en_circle/slt/plugin/lisp/psi/LispList.java +++ b/src/main/gen/com/en_circle/slt/plugin/lisp/psi/LispList.java @@ -1,13 +1,19 @@ // This is a generated file. Not intended for manual editing. package com.en_circle.slt.plugin.lisp.psi; +import com.intellij.navigation.ItemPresentation; +import com.intellij.psi.NavigatablePsiElement; +import org.jetbrains.annotations.NotNull; + import java.util.List; -import org.jetbrains.annotations.*; -import com.intellij.psi.PsiElement; -public interface LispList extends PsiElement { +public interface LispList extends NavigatablePsiElement { @NotNull List getSexprList(); + String getName(); + + ItemPresentation getPresentation(); + } diff --git a/src/main/gen/com/en_circle/slt/plugin/lisp/psi/LispVisitor.java b/src/main/gen/com/en_circle/slt/plugin/lisp/psi/LispVisitor.java index 08b96fe..609166d 100644 --- a/src/main/gen/com/en_circle/slt/plugin/lisp/psi/LispVisitor.java +++ b/src/main/gen/com/en_circle/slt/plugin/lisp/psi/LispVisitor.java @@ -45,7 +45,7 @@ public void visitInteger(@NotNull LispInteger o) { } public void visitList(@NotNull LispList o) { - visitPsiElement(o); + visitNavigatablePsiElement(o); } public void visitNumber(@NotNull LispNumber o) { diff --git a/src/main/java/com/en_circle/slt/plugin/SltStructureAwareNavbar.java b/src/main/java/com/en_circle/slt/plugin/SltStructureAwareNavbar.java index 3679d28..45ac781 100644 --- a/src/main/java/com/en_circle/slt/plugin/SltStructureAwareNavbar.java +++ b/src/main/java/com/en_circle/slt/plugin/SltStructureAwareNavbar.java @@ -8,6 +8,8 @@ import com.en_circle.slt.plugin.lisp.psi.LispToplevel; import com.intellij.ide.navigationToolbar.StructureAwareNavBarModelExtension; import com.intellij.lang.Language; +import com.intellij.psi.PsiElement; +import com.intellij.psi.util.PsiTreeUtil; import org.jetbrains.annotations.NotNull; import org.jetbrains.annotations.Nullable; @@ -26,19 +28,14 @@ protected Language getLanguage() { if (object instanceof LispFile) { return SltIconProvider.getFileIcon(); } - if (object instanceof LispToplevel toplevel) { - LispSexpressionInfo info = LispParserUtil.determineTopLevelType(toplevel.getSexpr()); - if (info.getType() != SexpressionType.EXPRESSION) { - return info.getIcon(); - } - return SltIconProvider.getFileIcon(); + LispSexpressionInfo topLevelInfo = getTopLevelForObject(object); + if (topLevelInfo != null) { + return topLevelInfo.getIcon(); } - if (object instanceof LispSexpr sexpr) { - LispSexpressionInfo info = LispParserUtil.determineTopLevelType(sexpr); - if (info.getType() != SexpressionType.EXPRESSION) { - return info.getIcon(); + if (object instanceof PsiElement psiElement) { + if (psiElement.getContainingFile() instanceof LispFile) { + return SltIconProvider.getFileIcon(); } - return SltIconProvider.getFileIcon(); } return null; } @@ -48,20 +45,33 @@ protected Language getLanguage() { if (object instanceof LispFile file) { return file.getName(); } - if (object instanceof LispToplevel toplevel) { - LispSexpressionInfo info = LispParserUtil.determineTopLevelType(toplevel.getSexpr()); - if (info.getType() != SexpressionType.EXPRESSION) { - return info.getLongForm(); + LispSexpressionInfo topLevelInfo = getTopLevelForObject(object); + if (topLevelInfo != null) { + return topLevelInfo.getLongForm(); + } + if (object instanceof PsiElement psiElement) { + if (psiElement.getContainingFile() instanceof LispFile file) { + return file.getName(); } - return toplevel.getContainingFile().getName(); + } + return null; + } + + private LispSexpressionInfo getTopLevelForObject(Object object) { + if (object instanceof LispToplevel toplevel) { + return LispParserUtil.determineTopLevelType(toplevel.getSexpr()); } if (object instanceof LispSexpr sexpr) { - LispSexpressionInfo info = LispParserUtil.determineTopLevelType(sexpr); - if (info.getType() != SexpressionType.EXPRESSION) { - return info.getLongForm(); + LispSexpressionInfo info = LispParserUtil.determineTopLevelType(sexpr); + if (info != null && info.getType() != SexpressionType.EXPRESSION) { + return info; } - return sexpr.getContainingFile().getName(); + } + if (object instanceof PsiElement psiElement) { + LispSexpr sexpr = PsiTreeUtil.getParentOfType(psiElement, LispSexpr.class); + return getTopLevelForObject(sexpr); } return null; } + } diff --git a/src/main/java/com/en_circle/slt/plugin/lisp/Lisp.bnf b/src/main/java/com/en_circle/slt/plugin/lisp/Lisp.bnf index 8107a8d..ffe77df 100644 --- a/src/main/java/com/en_circle/slt/plugin/lisp/Lisp.bnf +++ b/src/main/java/com/en_circle/slt/plugin/lisp/Lisp.bnf @@ -50,7 +50,12 @@ array ::= ARRAY_START list structure ::= STRUCTURE_TOKEN list -list ::= LPAREN sexpr* RPAREN { pin = 2 recoverWhile=list_recovery } +list ::= LPAREN sexpr* RPAREN { + pin = 2 + recoverWhile=list_recovery + implements="com.intellij.psi.NavigatablePsiElement" + methods=[getName getPresentation] +} private list_recovery ::= !(sexpr | RPAREN) string ::= STRING_TOKEN { diff --git a/src/main/java/com/en_circle/slt/plugin/lisp/lisp/components/LispArguments.java b/src/main/java/com/en_circle/slt/plugin/lisp/lisp/components/LispArguments.java new file mode 100644 index 0000000..3a3d9f4 --- /dev/null +++ b/src/main/java/com/en_circle/slt/plugin/lisp/lisp/components/LispArguments.java @@ -0,0 +1,7 @@ +package com.en_circle.slt.plugin.lisp.lisp.components; + +public class LispArguments { + + + +} diff --git a/src/main/java/com/en_circle/slt/plugin/lisp/lisp/components/LispFunctionCall.java b/src/main/java/com/en_circle/slt/plugin/lisp/lisp/components/LispFunctionCall.java new file mode 100644 index 0000000..5c964c1 --- /dev/null +++ b/src/main/java/com/en_circle/slt/plugin/lisp/lisp/components/LispFunctionCall.java @@ -0,0 +1,7 @@ +package com.en_circle.slt.plugin.lisp.lisp.components; + +public class LispFunctionCall { + + + +} diff --git a/src/main/java/com/en_circle/slt/plugin/lisp/psi/impl/LispPsiImplUtil.java b/src/main/java/com/en_circle/slt/plugin/lisp/psi/impl/LispPsiImplUtil.java index ab88855..93dd5d3 100644 --- a/src/main/java/com/en_circle/slt/plugin/lisp/psi/impl/LispPsiImplUtil.java +++ b/src/main/java/com/en_circle/slt/plugin/lisp/psi/impl/LispPsiImplUtil.java @@ -3,6 +3,7 @@ import com.en_circle.slt.plugin.SltCommonLispFileType; import com.en_circle.slt.plugin.lisp.LispParserUtil; import com.en_circle.slt.plugin.lisp.LispParserUtil.LispSexpressionInfo; +import com.en_circle.slt.plugin.lisp.LispParserUtil.SexpressionType; import com.en_circle.slt.plugin.lisp.LispSymbolPresentation; import com.en_circle.slt.plugin.lisp.psi.*; import com.intellij.lang.ASTNode; @@ -70,6 +71,16 @@ public static String getName(LispToplevel element) { return LispParserUtil.determineTopLevelType(element.getSexpr()).getShortForm(); } + public static String getName(LispList element) { + if (element.getParent() instanceof LispDatum && element.getParent().getParent() instanceof LispSexpr) { + LispSexpressionInfo type = LispParserUtil.determineTopLevelType((LispSexpr) element.getParent().getParent()); + if (type.getType() != SexpressionType.EXPRESSION) + return type.getShortForm(); + return null; + } + return null; + } + public static PsiElement setName(LispComment element, String newName) { ASTNode commentLineNode = element.getNode().findChildByType(LispTypes.LINE_COMMENT); if (commentLineNode != null) { @@ -159,4 +170,24 @@ public static ItemPresentation getPresentation(LispToplevel toplevel) { }; } + public static ItemPresentation getPresentation(LispList list) { + if (list.getParent() instanceof LispDatum && list.getParent().getParent() instanceof LispSexpr) { + LispSexpressionInfo type = LispParserUtil.determineTopLevelType((LispSexpr) list.getParent().getParent()); + if (type.getType() != SexpressionType.EXPRESSION) { + return new ItemPresentation() { + @Override + public @NlsSafe @Nullable String getPresentableText() { + return type.getShortForm(); + } + + @Override + public @Nullable Icon getIcon(boolean unused) { + return type.getIcon(); + } + }; + } + } + return null; + } + } \ No newline at end of file diff --git a/src/main/java/com/en_circle/slt/plugin/structure/LispStructureViewElement.java b/src/main/java/com/en_circle/slt/plugin/structure/LispStructureViewElement.java index e3c8f55..c587ea3 100644 --- a/src/main/java/com/en_circle/slt/plugin/structure/LispStructureViewElement.java +++ b/src/main/java/com/en_circle/slt/plugin/structure/LispStructureViewElement.java @@ -5,6 +5,8 @@ import com.en_circle.slt.plugin.lisp.LispParserUtil.LispSexpressionInfo; import com.en_circle.slt.plugin.lisp.LispParserUtil.SexpressionType; import com.en_circle.slt.plugin.lisp.psi.LispFile; +import com.en_circle.slt.plugin.lisp.psi.LispList; +import com.en_circle.slt.plugin.lisp.psi.LispSexpr; import com.en_circle.slt.plugin.lisp.psi.LispToplevel; import com.intellij.ide.structureView.StructureViewTreeElement; import com.intellij.ide.util.treeView.smartTree.SortableTreeElement; @@ -80,10 +82,24 @@ public Object getValue() { LispSexpressionInfo sexpressionInfo = LispParserUtil.determineTopLevelType(toplevel.getSexpr()); if (sexpressionInfo.getType() != SexpressionType.EXPRESSION) { elementList.add(new LispStructureViewElement(toplevel, sexpressionInfo)); + } else { + LispSexpr sexpr = toplevel.getSexpr(); + if (sexpr.getDatum() != null) { + if (sexpr.getDatum().getList() != null) { + for (LispSexpr element : sexpr.getDatum().getList().getSexprList()) { + if (element.getDatum() != null && element.getDatum().getList() != null) { + LispList sublist = element.getDatum().getList(); + LispSexpressionInfo subInfo = LispParserUtil.determineTopLevelType(element); + if (subInfo.getType() != SexpressionType.EXPRESSION) { + elementList.add(new LispStructureViewElement(sublist, subInfo)); + } + } + } + } + } } } } - return elementList.toArray(new TreeElement[0]); } return EMPTY_ARRAY; @@ -103,4 +119,10 @@ public boolean canNavigate() { public boolean canNavigateToSource() { return psiElement.canNavigateToSource(); } + + public boolean isDefinition() { + if (psiElement instanceof LispFile) + return true; + return false; + } } diff --git a/src/main/java/com/en_circle/slt/plugin/structure/LispStructureViewModel.java b/src/main/java/com/en_circle/slt/plugin/structure/LispStructureViewModel.java index 31483a8..39dbff6 100644 --- a/src/main/java/com/en_circle/slt/plugin/structure/LispStructureViewModel.java +++ b/src/main/java/com/en_circle/slt/plugin/structure/LispStructureViewModel.java @@ -1,5 +1,6 @@ package com.en_circle.slt.plugin.structure; +import com.en_circle.slt.plugin.lisp.psi.LispList; import com.en_circle.slt.plugin.lisp.psi.LispToplevel; import com.intellij.ide.structureView.StructureViewModel; import com.intellij.ide.structureView.StructureViewModelBase; @@ -23,7 +24,7 @@ public LispStructureViewModel(PsiFile psiFile, Editor editor) { @Override public boolean isAlwaysLeaf(StructureViewTreeElement element) { - return element.getValue() instanceof LispToplevel; + return !((LispStructureViewElement) element).isDefinition(); } @Override @@ -33,6 +34,6 @@ public boolean isAlwaysShowsPlus(StructureViewTreeElement element) { @Override protected Class @NotNull [] getSuitableClasses() { - return new Class[]{ LispToplevel.class }; + return new Class[]{ LispToplevel.class, LispList.class }; } } diff --git a/src/main/lisp/libs/eclector/.gitignore b/src/main/lisp/libs/eclector/.gitignore new file mode 100644 index 0000000..5ea87d0 --- /dev/null +++ b/src/main/lisp/libs/eclector/.gitignore @@ -0,0 +1,11 @@ +*.aux +*.bbl +*.blg +*.cb +*.cb2 +*.idx +*.ilg +*.ind +*.log +*.pdf +*.toc diff --git a/src/main/lisp/libs/eclector/LICENSE b/src/main/lisp/libs/eclector/LICENSE new file mode 100644 index 0000000..f84d16e --- /dev/null +++ b/src/main/lisp/libs/eclector/LICENSE @@ -0,0 +1,12 @@ +Copyright (c) 2010 - 2018 Robert Strandh (robert.strandh@gmail.com) +Copyright (c) 2018 - 2020 Jan Moringen + +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/src/main/lisp/libs/eclector/README.md b/src/main/lisp/libs/eclector/README.md new file mode 100644 index 0000000..532c151 --- /dev/null +++ b/src/main/lisp/libs/eclector/README.md @@ -0,0 +1,111 @@ +# Eclector: A portable and extensible Common Lisp Reader + +## Introduction + +The `eclector` system provides a portable implementation of a reader +following the Common Lisp specification. + +**``eclector`` is under active development. Its ASDF system structure, +package structure, exported symbols and protocols may change at any +time but are becoming less and less likely to do so in incompatible +ways.** + +This document only gives a very brief overview and highlights some +features. Proper documentation can be found in the `documentation` +directory. + +## Usage Overview and Highlights + +### Basics + +In the simplest case, the eclector reader can be used like any Common +Lisp reader: + +* ```lisp + (with-input-from-string (stream "(1 2 3)") + (eclector.reader:read stream)) + ; => (1 2 3) + ``` + +* ```lisp + (eclector.reader:read-from-string "#C(1 1)") + ; => #C(1 1) 7 + ``` + +### Error Recovery + +In contrast to many other reader implementations, eclector can recover +from most errors in the input supplied to it and continue +reading. This capability is realized as a restart named +`eclector.reader:recover` which is established whenever an error is +signaled for which a recovery strategy is available. + +For example, the following code + +```lisp +(handler-bind ((error (lambda (condition) + (let ((restart (find-restart 'eclector.reader:recover))) + (format t "Recovering from error:~%~2@T~A~%using~%~2@T~A~%" + condition restart)) + (eclector.reader:recover)))) + (eclector.reader:read-from-string "`(::foo ,")) +``` + +produces this: + +``` +Recovering from error: + A symbol token must not start with two package markers as in ::name. +using + Treat the character as if it had been escaped. +Recovering from error: + While reading unquote, expected an object when input ended. +using + Use NIL in place of the missing object. +Recovering from error: + While reading list, expected the character ) when input ended. +using + Return a list of the already read elements. +; => (ECLECTOR.READER:QUASIQUOTE (:FOO (ECLECTOR.READER:UNQUOTE NIL))) 9 +``` + +indicating that eclector recovered from multiple errors and consumed +all input. Of course, the returned expression is likely unsuitable for +evaluation, but recovery is useful for detecting multiple errors in +one go and performing further processing such as static analysis. + +### Custom Parse Results + +Using features provided in the `eclector.parse-result` package, +the reader can produce parse results controlled by the client, +optionally including source tracking and representation of skipped +input (due to e.g. comments and reader conditionals): + +```lisp +(defclass my-client (eclector.parse-result:parse-result-client) + ()) + +(defmethod eclector.parse-result:make-expression-result + ((client my-client) (result t) (children t) (source t)) + (list :result result :source source :children children)) + +(defmethod eclector.parse-result:make-skipped-input-result + ((client my-client) (stream t) (reason t) (source t)) + (list :reason reason :source source)) + +(with-input-from-string (stream "(1 #|comment|# \"string\")") + (eclector.parse-result:read (make-instance 'my-client) stream)) +``` + +### Concrete Syntax Trees + +The `eclector.concrete-syntax-tree` system provides a variant of the +`eclector` reader that produces instances of the concrete syntax tree +classes provided by the [concrete syntax tree library]: + +```lisp +(eclector.concrete-syntax-tree:read-from-string "(1 2 3)") +; => # 7 NIL +``` + +[concrete syntax tree library]: https://github.com/s-expressionists/Concrete-Syntax-Tree diff --git a/src/main/lisp/libs/eclector/code/base/conditions.lisp b/src/main/lisp/libs/eclector/code/base/conditions.lisp new file mode 100644 index 0000000..9f9aff3 --- /dev/null +++ b/src/main/lisp/libs/eclector/code/base/conditions.lisp @@ -0,0 +1,80 @@ +(cl:in-package #:eclector.base) + +(defun %reader-error (stream datum + &rest arguments + &key (stream-position (eclector.base:source-position + *client* stream)) + (position-offset 0) + &allow-other-keys) + (apply #'error datum :stream stream + :stream-position stream-position + :position-offset position-offset + (alexandria:remove-from-plist + arguments :stream-position :position-offset))) + +(defgeneric recovery-description (strategy &key language) + (:method ((strategy t) &key (language (acclimation:language + acclimation:*locale*))) + (recovery-description-using-language strategy language))) + +(defgeneric recovery-description-using-language (strategy language)) + +(defun format-recovery-report (stream strategy &rest args) + (labels ((resolve (strategy &rest args) + (etypecase strategy + (cons (apply #'resolve (append strategy args))) + (symbol (apply #'resolve (recovery-description strategy) args)) + (string (apply #'format stream strategy args)) + (function (apply strategy stream args))))) + (apply #'resolve strategy args))) + +(defun %recoverable-reader-error (stream datum &rest arguments + &key report &allow-other-keys) + (restart-case + (apply #'%reader-error stream datum + (alexandria:remove-from-plist arguments :report)) + (recover () + :report (lambda (stream) + (format-recovery-report stream report)) + (values)))) + +(defun recover (&optional condition) + (alexandria:when-let ((restart (find-restart 'recover condition))) + (invoke-restart restart))) + +(define-condition stream-position-condition (condition) + ((%stream-position :initarg :stream-position + :reader stream-position + :documentation + #.(format nil + "Approximate position in an input stream with ~ + which the condition is associated. The ~ + representation is controlled by the client by ~ + adding methods on the generic function ~ + STREAM-POSITION.")) + (%position-offset :initarg :position-offset + :type integer + :reader position-offset + :initform 0 + :documentation + #.(format nil + "Offset from the approximate position to produce ~ + the exact position. Always an integer and not ~ + controlled by the client.")))) + +(define-condition stream-position-reader-error (acclimation:condition + stream-position-condition + reader-error) + ()) + +;;; Adds a stream position to CL:END-OF-FILE. +(define-condition end-of-file (acclimation:condition + stream-position-condition + cl:end-of-file) + ()) + +(define-condition incomplete-construct (stream-position-reader-error) + ()) + +(define-condition missing-delimiter (end-of-file incomplete-construct) + ((%delimiter :initarg :delimiter :reader delimiter))) diff --git a/src/main/lisp/libs/eclector/code/base/generic-functions.lisp b/src/main/lisp/libs/eclector/code/base/generic-functions.lisp new file mode 100644 index 0000000..49d8288 --- /dev/null +++ b/src/main/lisp/libs/eclector/code/base/generic-functions.lisp @@ -0,0 +1,13 @@ +(cl:in-package #:eclector.base) + +;;; Source location protocol + +(defgeneric source-position (client stream) + (:method (client stream) + (declare (ignore client)) + (file-position stream))) + +(defgeneric make-source-range (client start end) + (:method (client start end) + (declare (ignore client)) + (cons start end))) diff --git a/src/main/lisp/libs/eclector/code/base/messages-english.lisp b/src/main/lisp/libs/eclector/code/base/messages-english.lisp new file mode 100644 index 0000000..e9a94c0 --- /dev/null +++ b/src/main/lisp/libs/eclector/code/base/messages-english.lisp @@ -0,0 +1,23 @@ +(cl:in-package #:eclector.base) + +;;; Utilities + +(defun describe-character-english (stream character &optional colon at-sign) + (declare (ignore colon at-sign)) + (format stream "character ~:[named ~A~*~;~*~C~]" + (and (not (char= character #\Space)) (graphic-char-p character)) + (char-name character) character)) + +;;; Condition reports + +(macrolet + ((define-reporter (((condition-var condition-specializer) stream-var) + &body body) + `(defmethod acclimation:report-condition + ((,condition-var ,condition-specializer) + ,stream-var + (language acclimation:english)) + ,@body))) + + (define-reporter ((condition end-of-file) stream) + (format stream "~@"))) diff --git a/src/main/lisp/libs/eclector/code/base/package.lisp b/src/main/lisp/libs/eclector/code/base/package.lisp new file mode 100644 index 0000000..6df2268 --- /dev/null +++ b/src/main/lisp/libs/eclector/code/base/package.lisp @@ -0,0 +1,52 @@ +(cl:defpackage #:eclector.base + (:use + #:common-lisp) + + (:shadow + . #1=(#:end-of-file + + #:read-char)) + + (:export + . #1#) + + ;;Exported for eclector.*, not public use. + #+sbcl + (:export + #:&optional-and-&key-style-warning) + + ;; Conditions (with accessors) + (:export + #:stream-position-reader-error + #:stream-position + #:position-offset + + #:end-of-file + + #:incomplete-construct + + #:missing-delimiter + #:delimiter) + + ;; Recover restart + (:export + #:recover) ; function and restart name + + ;; Source location protocol + (:export + #:source-position + #:make-source-range) + + ;; Exported for eclector.reader, not public use. + (:export + #:*client* + + #:%reader-error + #:%recoverable-reader-error + + #:recovery-description + #:recovery-description-using-language + #:format-recovery-report + + #:read-char-or-error + #:read-char-or-recoverable-error)) diff --git a/src/main/lisp/libs/eclector/code/base/read-char.lisp b/src/main/lisp/libs/eclector/code/base/read-char.lisp new file mode 100644 index 0000000..97610f7 --- /dev/null +++ b/src/main/lisp/libs/eclector/code/base/read-char.lisp @@ -0,0 +1,44 @@ +(cl:in-package #:eclector.base) + +;;; We have our own READ-CHAR function so we can signal our own +;;; END-OF-FILE condition which stores the position in the input +;;; stream in a portable way. Since READ-CHAR is relatively critical +;;; for performance, we use a compiler macro to transform our +;;; READ-CHAR to CL:READ-CHAR when we can statically determine that +;;; END-OF-FILE will not be signaled. + +(defun read-char (&optional (input-stream *standard-input*) + (eof-error-p t) + eof-value + recursive-p) + (if eof-error-p + (let ((result (cl:read-char input-stream + nil '#1=#.(gensym "EOF") recursive-p))) + (if (eq result '#1#) + (%reader-error input-stream 'end-of-file) + result)) + (cl:read-char input-stream nil eof-value recursive-p))) + +(define-compiler-macro read-char + (&whole whole &optional (input-stream '*standard-input*) + (eof-error-p nil eof-error-p-supplied-p) + eof-value recursive-p) + (if (and eof-error-p-supplied-p + (constantp eof-error-p) (not (eval eof-error-p))) + `(cl:read-char ,input-stream nil ,eof-value ,recursive-p) + whole)) + +(defun read-char-or-error (input-stream datum &rest arguments) + (let ((result (cl:read-char input-stream nil '#1=#.(gensym "EOF") t))) + (if (eq result '#1#) + (apply #'%reader-error input-stream datum arguments) + result))) + +(defun read-char-or-recoverable-error (input-stream recover-value + datum &rest arguments) + (let ((result (cl:read-char input-stream nil '#1=#.(gensym "EOF") t))) + (if (eq result '#1#) + (progn + (apply #'%recoverable-reader-error input-stream datum arguments) + recover-value) + result))) diff --git a/src/main/lisp/libs/eclector/code/base/utilities.lisp b/src/main/lisp/libs/eclector/code/base/utilities.lisp new file mode 100644 index 0000000..de47d50 --- /dev/null +++ b/src/main/lisp/libs/eclector/code/base/utilities.lisp @@ -0,0 +1,18 @@ +(cl:in-package #:eclector.base) + +#+sbcl +(defun &optional-and-&key-style-warning-p (condition) + (and (typep condition 'simple-condition) + (eql 0 (search "&OPTIONAL and &KEY found in the same lambda list" + ;; We do this seemingly overcomplicated maneuver + ;; instead of checking the format control slot + ;; directly because the contents of that slot + ;; may not be a string. + (with-standard-io-syntax + (let ((*print-right-margin* most-positive-fixnum)) + (apply #'format nil (simple-condition-format-control condition) + (simple-condition-format-arguments condition)))))))) + +#+sbcl +(deftype &optional-and-&key-style-warning () + '(satisfies &optional-and-&key-style-warning-p)) diff --git a/src/main/lisp/libs/eclector/code/base/variables.lisp b/src/main/lisp/libs/eclector/code/base/variables.lisp new file mode 100644 index 0000000..4d1f1e9 --- /dev/null +++ b/src/main/lisp/libs/eclector/code/base/variables.lisp @@ -0,0 +1,3 @@ +(cl:in-package #:eclector.base) + +(defparameter *client* nil) diff --git a/src/main/lisp/libs/eclector/code/concrete-syntax-tree/package.lisp b/src/main/lisp/libs/eclector/code/concrete-syntax-tree/package.lisp new file mode 100644 index 0000000..442c528 --- /dev/null +++ b/src/main/lisp/libs/eclector/code/concrete-syntax-tree/package.lisp @@ -0,0 +1,18 @@ +(cl:defpackage #:eclector.concrete-syntax-tree + (:use + #:common-lisp) + + (:shadow + #:read + #:read-preserving-whitespace + #:read-from-string) + + ;; Read protocol + (:export + #:read + #:read-preserving-whitespace + #:read-from-string) + + ;; Client class (can be used as a superclass) + (:export + #:cst-client)) diff --git a/src/main/lisp/libs/eclector/code/concrete-syntax-tree/read.lisp b/src/main/lisp/libs/eclector/code/concrete-syntax-tree/read.lisp new file mode 100644 index 0000000..e5f2e2f --- /dev/null +++ b/src/main/lisp/libs/eclector/code/concrete-syntax-tree/read.lisp @@ -0,0 +1,76 @@ +(cl:in-package #:eclector.concrete-syntax-tree) + +(defclass cst-client (eclector.parse-result:parse-result-client) + ()) + +(defmethod eclector.parse-result:make-expression-result + ((client cst-client) expression children source) + (labels ((make-atom-cst (expression &optional source) + (make-instance 'cst:atom-cst + :raw expression + :source source)) + + (make-list-cst (expression children source) + (loop for expression in (loop with reversed = '() + for sub-expression on expression + do (push sub-expression reversed) + finally (return reversed)) + for child in (reverse children) + for previous = (make-instance 'cst:atom-cst :raw nil) then node + for node = (make-instance 'cst:cons-cst :raw expression + :first child + :rest previous) + finally (return (reinitialize-instance node :source source))))) + (cond + ((atom expression) + (make-atom-cst expression source)) + ;; List structure with corresponding elements. + ((and (eql (ignore-errors (list-length expression)) + (length children)) + (every (lambda (sub-expression child) + (eql sub-expression (cst:raw child))) + expression children)) + (make-list-cst expression children source)) + ;; Structure mismatch, try heuristic reconstruction. + (t + ;; We don't use + ;; + ;; (cst:reconstruct expression children client) + ;; + ;; because we want SOURCE for the outer CONS-CST but not any of + ;; its children. + (destructuring-bind (car . cdr) expression + (make-instance 'cst:cons-cst + :raw expression + :first (cst:reconstruct car children client) + :rest (cst:reconstruct cdr children client) + :source source)))))) + +(defvar *cst-client* (make-instance 'cst-client)) + +(defun read (&optional (input-stream *standard-input*) + (eof-error-p t) + (eof-value nil)) + (eclector.parse-result:read + (or eclector.reader:*client* *cst-client*) + input-stream eof-error-p eof-value)) + +(defun read-preserving-whitespace (&optional (input-stream *standard-input*) + (eof-error-p t) + (eof-value nil)) + (eclector.parse-result:read-preserving-whitespace + (or eclector.reader:*client* *cst-client*) + input-stream eof-error-p eof-value)) + +(locally (declare #+sbcl (sb-ext:muffle-conditions eclector.base:&optional-and-&key-style-warning)) + (defun read-from-string (string &optional + (eof-error-p t) + (eof-value nil) + &key + (start 0) + (end nil) + (preserve-whitespace nil)) + (eclector.parse-result:read-from-string + (or eclector.reader:*client* *cst-client*) + string eof-error-p eof-value :start start :end end + :preserve-whitespace preserve-whitespace))) diff --git a/src/main/lisp/libs/eclector/code/parse-result/client.lisp b/src/main/lisp/libs/eclector/code/parse-result/client.lisp new file mode 100644 index 0000000..41e4d46 --- /dev/null +++ b/src/main/lisp/libs/eclector/code/parse-result/client.lisp @@ -0,0 +1,19 @@ +(cl:in-package #:eclector.parse-result) + +(defclass parse-result-client () + ()) + +;;; The following two methods are for backwards compatibility: +;;; Eclector code always calls the generic functions defined in the +;;; base module. The following two methods delegate such calls to +;;; client-defined methods on generic functions defined in the +;;; parse-result module. If there are no such client-defined methods, +;;; the default methods defined in the parse-result module delegate +;;; back to the default methods defined in the base module. +;;; +;;; This mechanism will be removed after a grace period. +(defmethod eclector.base:source-position ((client parse-result-client) stream) + (source-position client stream)) + +(defmethod eclector.base:make-source-range ((client parse-result-client) start end) + (make-source-range client start end)) diff --git a/src/main/lisp/libs/eclector/code/parse-result/deprecation.lisp b/src/main/lisp/libs/eclector/code/parse-result/deprecation.lisp new file mode 100644 index 0000000..ebb1661 --- /dev/null +++ b/src/main/lisp/libs/eclector/code/parse-result/deprecation.lisp @@ -0,0 +1,6 @@ +(cl:in-package #:eclector.parse-result) + +(declaim (sb-ext:deprecated + :early ("Eclector" "0.7") + (function source-position :replacement eclector.base:source-position) + (function make-source-range :replacement eclector.base:make-source-range))) diff --git a/src/main/lisp/libs/eclector/code/parse-result/generic-functions.lisp b/src/main/lisp/libs/eclector/code/parse-result/generic-functions.lisp new file mode 100644 index 0000000..d1b042f --- /dev/null +++ b/src/main/lisp/libs/eclector/code/parse-result/generic-functions.lisp @@ -0,0 +1,26 @@ +(cl:in-package #:eclector.parse-result) + +;;; Source location protocol (has moved to base module) +;;; +;;; The default methods delegate to the default methods defined in the +;;; base module. +;;; +;;; This protocol will be removed from this module after a grace +;;; period. + +(defgeneric source-position (client stream) + (:method (client stream) + (eclector.base:source-position nil stream))) + +(defgeneric make-source-range (client start end) + (:method (client start end) + (eclector.base:make-source-range nil start end))) + +;;; Parse result protocol + +(defgeneric make-expression-result (client result children source)) + +(defgeneric make-skipped-input-result (client stream reason source) + (:method (client stream reason source) + (declare (ignore client stream reason source)) + nil)) diff --git a/src/main/lisp/libs/eclector/code/parse-result/package.lisp b/src/main/lisp/libs/eclector/code/parse-result/package.lisp new file mode 100644 index 0000000..b749323 --- /dev/null +++ b/src/main/lisp/libs/eclector/code/parse-result/package.lisp @@ -0,0 +1,29 @@ +(cl:defpackage #:eclector.parse-result + (:use + #:common-lisp + #:alexandria) + + (:shadow + #:read + #:read-preserving-whitespace + #:read-from-string) + + ;; Source location protocol (deprecated, moved to base module) + (:export + #:source-position + #:make-source-range) + + ;; Parse result protocol + (:export + #:make-expression-result + #:make-skipped-input-result) + + ;; Read protocol + (:export + #:read + #:read-preserving-whitespace + #:read-from-string) + + ;; Client protocol class (can be used as a superclass) + (:export + #:parse-result-client)) diff --git a/src/main/lisp/libs/eclector/code/parse-result/read.lisp b/src/main/lisp/libs/eclector/code/parse-result/read.lisp new file mode 100644 index 0000000..01ef34d --- /dev/null +++ b/src/main/lisp/libs/eclector/code/parse-result/read.lisp @@ -0,0 +1,126 @@ +(cl:in-package #:eclector.parse-result) + +;;; A list of sub-lists the form +;;; +;;; (CHILDREN-OF-CURRENT-NODE CHILDREN-OF-PARENT ...) +;;; +(defvar *stack*) + +(defvar *start*) + +(defmethod eclector.reader:note-skipped-input + ((client parse-result-client) input-stream reason) + (let* ((start *start*) + (end (eclector.base:source-position client input-stream)) + (range (eclector.base:make-source-range client start end)) + (parse-result (make-skipped-input-result + client input-stream reason range))) + (when parse-result + (push parse-result (second *stack*))))) + +;;; Establishing context + +(defmethod eclector.reader:call-as-top-level-read :around + ((client parse-result-client) thunk input-stream + eof-error-p eof-value preserve-whitespace-p) + (declare (ignore thunk input-stream preserve-whitespace-p)) + ;; We bind *CLIENT* here (instead of in, say, READ-AUX) to allow + ;; (call-as-top-level-read + ;; client (lambda () ... (read-maybe-nothing client ...) ...) ...) + ;; to work without the user code explicitly binding the variable. + (let* ((eclector.base:*client* client) + (stack (list '())) + (*stack* stack) + (values (multiple-value-list (call-next-method))) + (value (first values)) + (results (if (and (null eof-error-p) (eq value eof-value)) + (first stack) + (rest (first stack)))) + (orphan-results (reverse results))) + (if (null orphan-results) + (values-list values) + (multiple-value-call #'values (values-list values) orphan-results)))) + +(defmethod eclector.reader:read-common + ((client parse-result-client) input-stream eof-error-p eof-value) + (loop for (value what parse-result) + = (multiple-value-list + (eclector.reader:read-maybe-nothing + client input-stream eof-error-p eof-value)) + do (ecase what + (:eof + (return (values value nil))) + ((:suppress :object) + (return (values value parse-result))) + ((:whitespace :skip))))) + +(defmethod eclector.reader:read-maybe-nothing + ((client parse-result-client) input-stream eof-error-p eof-value) + (declare (ignore eof-error-p eof-value)) + (let* ((stack (list* '() *stack*)) + (start (eclector.base:source-position client input-stream))) + (multiple-value-bind (value what) + (let ((*stack* stack) + ;; *START* is used in NOTE-SKIPPED-INPUT to describe + ;; skipped input (comments, reader macros, + ;; *READ-SUPPRESS*). + (*start* start)) + (call-next-method)) + (case what + (:object + (let* ((children (reverse (first stack))) + (end (eclector.base:source-position client input-stream)) + (source (eclector.base:make-source-range client start end)) + (parse-result (make-expression-result + client value children source))) + (push parse-result (second stack)) + (values value what parse-result))) + ((:eof :whitespace) + (values value what)) + (t + (values value what (first (second stack)))))))) + +;;; Entry points + +(defun read-aux (client input-stream eof-error-p eof-value preserve-whitespace-p) + (multiple-value-bind (result parse-result orphan-results) + (flet ((read-common () + (eclector.reader:read-common + client input-stream eof-error-p eof-value))) + (declare (dynamic-extent #'read-common)) + (eclector.reader:call-as-top-level-read + client #'read-common input-stream + eof-error-p eof-value preserve-whitespace-p)) + ;; If we come here, that means that either the call to READ-AUX + ;; succeeded without encountering end-of-file, or that EOF-ERROR-P + ;; is false, end-of-file was encountered, and EOF-VALUE was + ;; returned. In the latter case, we want READ to return + ;; EOF-VALUE. + (values (if (and (null eof-error-p) (eq eof-value result)) + eof-value + parse-result) + orphan-results))) + +(defun read (client &optional (input-stream *standard-input*) + (eof-error-p t) + (eof-value nil)) + (read-aux client input-stream eof-error-p eof-value nil)) + +(defun read-preserving-whitespace (client &optional + (input-stream *standard-input*) + (eof-error-p t) + (eof-value nil)) + (read-aux client input-stream eof-error-p eof-value t)) + +(locally (declare #+sbcl (sb-ext:muffle-conditions eclector.base:&optional-and-&key-style-warning)) + (defun read-from-string (client string &optional (eof-error-p t) + (eof-value nil) + &key (start 0) + (end nil) + (preserve-whitespace nil)) + (let ((index)) + (multiple-value-bind (result orphan-results) + (with-input-from-string (stream string :start start :end end + :index index) + (read-aux client stream eof-error-p eof-value preserve-whitespace)) + (values result index orphan-results))))) diff --git a/src/main/lisp/libs/eclector/code/reader/additional-conditions.lisp b/src/main/lisp/libs/eclector/code/reader/additional-conditions.lisp new file mode 100644 index 0000000..b20f73f --- /dev/null +++ b/src/main/lisp/libs/eclector/code/reader/additional-conditions.lisp @@ -0,0 +1,439 @@ +(cl:in-package #:eclector.reader) + +;;; Type error + +(define-condition read-object-type-error (stream-position-reader-error + type-error) + ()) + +;;; General escape errors + +(define-condition unterminated-single-escape (end-of-file + incomplete-construct) + ((%escape-char :initarg :escape-char :reader escape-char))) + +(define-condition unterminated-multiple-escape (missing-delimiter) + ()) + +;;; Conditions related to symbols +;;; +;;; See HyperSpec section 2.3.5 (Valid Patterns for Tokens). + +(define-condition package-does-not-exist (stream-position-reader-error) + ((%package-name :initarg :package-name :reader desired-package-name))) + +(define-condition symbol-access-error (stream-position-reader-error) + ((%symbol-name :initarg :symbol-name :reader desired-symbol-name) + (%package :initarg :package :reader desired-symbol-package))) + +(define-condition symbol-does-not-exist (symbol-access-error) + ()) + +(define-condition symbol-is-not-external (symbol-access-error) + ()) + +(define-condition symbol-syntax-error (stream-position-reader-error) + ((%token :initarg :token :reader token))) + +(define-condition invalid-constituent-character (symbol-syntax-error) + ()) + +(define-condition unterminated-single-escape-in-symbol (symbol-syntax-error + unterminated-single-escape) + ()) + +(define-condition unterminated-multiple-escape-in-symbol (symbol-syntax-error + unterminated-multiple-escape) + ()) + +(define-condition symbol-name-must-not-be-only-package-markers (symbol-syntax-error) + ()) + +(define-condition symbol-name-must-not-end-with-package-marker (symbol-syntax-error) + ()) + +(define-condition two-package-markers-must-be-adjacent (symbol-syntax-error) + ()) + +(define-condition two-package-markers-must-not-be-first (symbol-syntax-error) + ()) + +(define-condition symbol-can-have-at-most-two-package-markers (symbol-syntax-error) + ()) + +(define-condition uninterned-symbol-must-not-contain-package-marker (symbol-syntax-error) + ()) + +;;; General reader macro conditions + +(define-condition sharpsign-invalid (stream-position-reader-error) + ((%character-found :initarg :character-found :reader character-found))) + +(define-condition numeric-parameter-supplied-but-ignored (stream-position-reader-error) + ((%parameter :initarg :parameter :reader parameter) + (%macro-name :initarg :macro-name :reader macro-name))) + +(defun numeric-parameter-ignored (stream macro-name parameter) + (unless *read-suppress* + (%recoverable-reader-error + stream 'numeric-parameter-supplied-but-ignored + :position-offset -2 + :parameter parameter :macro-name macro-name :report 'ignore-parameter))) + +(define-condition numeric-parameter-not-supplied-but-required (stream-position-reader-error) + ((%macro-name :initarg :macro-name :reader macro-name))) + +(defun numeric-parameter-not-supplied (stream macro-name) + (unless *read-suppress* + (%recoverable-reader-error + stream 'numeric-parameter-not-supplied-but-required + :position-offset -1 + :macro-name macro-name :report 'use-replacement-parameter))) + +;;; Conditions related to single quote + +(define-condition end-of-input-after-quote (end-of-file incomplete-construct) + ()) + +(define-condition object-must-follow-quote (incomplete-construct) + ()) + +;;; Conditions related to strings + +(define-condition unterminated-string (missing-delimiter) + ()) + +(define-condition unterminated-single-escape-in-string (unterminated-single-escape) + ()) + +;;; Conditions related to quasiquotation + +(defgeneric context-name (context language)) + +(define-condition backquote-error (stream-position-reader-error) + ()) + +(define-condition backquote-context-error (backquote-error) + ((%context :initarg :context :reader context))) + +(define-condition backquote-in-invalid-context (backquote-context-error) + ()) + +(define-condition object-must-follow-backquote (incomplete-construct + backquote-error) + ()) + +(define-condition end-of-input-after-backquote (end-of-file + incomplete-construct + backquote-error) + ()) + +(define-condition unquote-condition () + ((%splicing-p :initarg :splicing-p :reader splicing-p))) + +(define-condition unquote-error (backquote-error unquote-condition) + ()) + +(define-condition invalid-context-for-unquote (unquote-error) + ()) + +(define-condition unquote-not-inside-backquote (invalid-context-for-unquote) + ()) + +(define-condition unquote-in-invalid-context (invalid-context-for-unquote + backquote-context-error) + ()) + +(define-condition end-of-input-after-unquote (end-of-file + incomplete-construct + unquote-condition) + ()) + +(define-condition object-must-follow-unquote (unquote-error + incomplete-construct) + ()) + +(define-condition unquote-splicing-in-dotted-list (unquote-error) + () + (:default-initargs + :splicing-p t)) + +(define-condition unquote-splicing-at-top (unquote-error) + () + (:default-initargs + :splicing-p t)) + +;;; Conditions related to lists + +(define-condition unterminated-list (missing-delimiter) + ()) + +(define-condition too-many-dots (stream-position-reader-error) + ()) + +(define-condition invalid-context-for-consing-dot (stream-position-reader-error) + ()) + +(define-condition end-of-input-after-consing-dot (end-of-file + incomplete-construct) + ()) + +(define-condition object-must-follow-consing-dot (incomplete-construct) + ()) + +(define-condition multiple-objects-following-consing-dot (stream-position-reader-error) + ()) + +(define-condition invalid-context-for-right-parenthesis (stream-position-reader-error) + ((%expected-character :initarg :expected-character + :reader expected-character + :initform nil) + (%found-character :initarg :found-character + :reader found-character))) + +;;; Conditions related to SHARPSIGN-DOT + +(define-condition end-of-input-after-sharpsign-single-quote (end-of-file + incomplete-construct) + ()) + +(define-condition object-must-follow-sharpsign-single-quote (incomplete-construct) + ()) + +;;; Conditions related to read-time evaluation + +(define-condition end-of-input-after-sharpsign-dot (end-of-file + incomplete-construct) + ()) + +(define-condition object-must-follow-sharpsign-dot (incomplete-construct) + ()) + +(define-condition read-time-evaluation-inhibited (stream-position-reader-error) + ()) + +(define-condition read-time-evaluation-error (stream-position-reader-error) + ((%expression :initarg :expression :reader expression) + (%original-condition :initarg :original-condition :reader original-condition))) + +;;; Conditions related to characters + +(define-condition end-of-input-after-backslash (end-of-file + incomplete-construct) + ()) + +(define-condition unterminated-single-escape-in-character-name + (unterminated-single-escape) + ()) + +(define-condition unterminated-multiple-escape-in-character-name + (unterminated-multiple-escape) + ()) + +(define-condition unknown-character-name (stream-position-reader-error) + ((%name :initarg :name :reader name))) + +;;; Conditions related to rational numbers + +(define-condition digit-condition (condition) + ((%base :initarg :base :reader base))) + +(define-condition end-of-input-before-digit (end-of-file + incomplete-construct + digit-condition) + ()) + +(define-condition digit-expected (stream-position-reader-error + digit-condition) + ((%character-found :initarg :character-found :reader character-found))) + +(define-condition zero-denominator (stream-position-reader-error) + ()) + +(define-condition invalid-radix (stream-position-reader-error) + ((%radix :initarg :radix :reader radix))) + +(define-condition invalid-default-float-format (stream-position-reader-error) + ((%exponent-marker :initarg :exponent-marker :reader exponent-marker) + (%float-format :initarg :float-format :reader float-format))) + +;;; Conditions related to block comments + +(define-condition unterminated-block-comment (missing-delimiter) + ()) + +;;; Conditions related to arrays + +(define-condition end-of-input-after-sharpsign-a (end-of-file + incomplete-construct) + ()) + +(define-condition object-must-follow-sharpsign-a (incomplete-construct) + ()) + +(define-condition unterminated-vector (missing-delimiter) + ()) + +(define-condition array-initialization-error (stream-position-reader-error) + ((%array-type :initarg :array-type :reader array-type))) + +(define-condition too-many-elements (array-initialization-error) + ((%expected-number :initarg :expected-number :reader expected-number) + (%number-found :initarg :number-found :reader number-found))) + +(define-condition no-elements-found (array-initialization-error) + ((%expected-number :initarg :expected-number :reader expected-number))) + +(define-condition incorrect-initialization-length (array-initialization-error) + ((%axis :initarg :axis :reader axis) + (%expected-length :initarg :expected-length :reader expected-length) + (%datum :initarg :datum :reader datum))) + +;;; Sharpsign C conditions + +(define-condition end-of-input-after-sharpsign-c (end-of-file + incomplete-construct) + ()) + +(define-condition complex-parts-must-follow-sharpsign-c (incomplete-construct) + ()) + +(define-condition non-list-following-sharpsign-c (stream-position-reader-error) + ()) + +(define-condition complex-part-condition () + ((%which :initarg :which :reader which))) + +(define-condition end-of-input-before-complex-part (end-of-file + incomplete-construct + complex-part-condition) + ()) + +(define-condition complex-part-expected (stream-position-reader-error + complex-part-condition) + ()) + +(define-condition too-many-complex-parts (stream-position-reader-error) + ()) + +;;; Sharpsign S conditions + +(define-condition end-of-input-after-sharpsign-s (stream-position-reader-error) + ()) + +(define-condition structure-constructor-must-follow-sharpsign-s (stream-position-reader-error) + ()) + +(define-condition non-list-following-sharpsign-s (stream-position-reader-error) + ()) + +(define-condition end-of-input-before-structure-type-name (end-of-file + incomplete-construct) + ()) + +(define-condition no-structure-type-name-found (incomplete-construct) + ()) + +(define-condition structure-type-name-is-not-a-symbol (read-object-type-error) + () + (:default-initargs + :expected-type 'symbol)) + +(define-condition end-of-input-before-slot-name (end-of-file + incomplete-construct) + ()) + +(define-condition slot-name-is-not-a-string-designator (read-object-type-error) + () + (:default-initargs + :expected-type 'symbol)) + +(define-condition slot-value-condition (condition) + ((%slot-name :initarg :slot-name + :reader slot-name))) + +(define-condition end-of-input-before-slot-value (slot-value-condition + end-of-file + incomplete-construct) + ()) + +(define-condition no-slot-value-found (slot-value-condition + incomplete-construct) + ()) + +;;; Conditions related to pathname literals + +(define-condition end-of-input-after-sharpsign-p (end-of-file + incomplete-construct) + ()) + +(define-condition namestring-must-follow-sharpsign-p (incomplete-construct) + ()) + +(define-condition non-string-following-sharpsign-p (read-object-type-error) + ()) + +;;; Conditions related to feature expressions +;;; +;;; Can be evaluated without a stream context. Therefore each +;;; condition has a stream- and a non-stream-variant. + +(define-condition reader-conditional-condition (condition) + ((%context :initarg :context :reader context))) + +(define-condition end-of-input-after-sharpsign-plus-minus + (reader-conditional-condition + end-of-file + incomplete-construct) + ()) + +(define-condition feature-expression-must-follow-sharpsign-plus-minus + (reader-conditional-condition + incomplete-construct) + ()) + +(define-condition feature-expression-type-error (acclimation:condition type-error) + ()) + +(define-condition feature-expression-type-error/reader + (feature-expression-type-error stream-position-reader-error) + ()) + +(define-condition single-feature-expected (acclimation:condition error) + ((%features :initarg :features :reader features))) + +(define-condition single-feature-expected/reader + (single-feature-expected stream-position-reader-error) + ()) + +(define-condition end-of-input-after-feature-expression + (reader-conditional-condition + end-of-file + incomplete-construct) + ()) + +(define-condition object-must-follow-feature-expression + (reader-conditional-condition + incomplete-construct) + ()) + +;;; SHARPSIGN-{EQUALS,SHARPSIGN} conditions + +(define-condition end-of-input-after-sharpsign-equals (end-of-file + incomplete-construct) + ()) + +(define-condition object-must-follow-sharpsign-equals (incomplete-construct) + ()) + +(define-condition reference-error (stream-position-reader-error) + ((%label :initarg :label :reader label))) + +(define-condition sharpsign-equals-label-defined-more-than-once (reference-error) + ()) + +(define-condition sharpsign-equals-only-refers-to-self (reference-error) + ()) + +(define-condition sharpsign-sharpsign-undefined-label (reference-error) + ()) diff --git a/src/main/lisp/libs/eclector/code/reader/fixup.lisp b/src/main/lisp/libs/eclector/code/reader/fixup.lisp new file mode 100644 index 0000000..7af6b22 --- /dev/null +++ b/src/main/lisp/libs/eclector/code/reader/fixup.lisp @@ -0,0 +1,42 @@ +(cl:in-package #:eclector.reader) + +(defmethod fixup :around (client object seen-objects mapping) + (declare (ignore client mapping)) + (unless (gethash object seen-objects) + (setf (gethash object seen-objects) t) + (call-next-method))) + +(defmethod fixup (client object seen-objects mapping) + (declare (ignore client object seen-objects mapping)) + nil) + +(macrolet ((fixup-place (place) + `(let ((current-value ,place)) + (multiple-value-bind (value found-p) + (gethash current-value mapping) + (if found-p + (setf ,place value) + (fixup client current-value seen-objects mapping)))))) + + (defmethod fixup (client (object cons) seen-objects mapping) + (fixup-place (car object)) + (fixup-place (cdr object))) + + (defmethod fixup (client (object array) seen-objects mapping) + (loop for i from 0 below (array-total-size object) + do (fixup-place (row-major-aref object i)))) + + (defmethod fixup (client (object standard-object) seen-objects mapping) + (loop for slot-definition in (closer-mop:class-slots (class-of object)) + for name = (closer-mop:slot-definition-name slot-definition) + when (slot-boundp object name) + do (fixup-place (slot-value object name)))) + + (defmethod fixup (client (object hash-table) seen-objects mapping) + (maphash (lambda (key val) + (multiple-value-bind (value found-p) + (gethash val mapping) + (if found-p + (setf (gethash key object) value) + (fixup client value seen-objects mapping)))) + object))) diff --git a/src/main/lisp/libs/eclector/code/reader/generic-functions.lisp b/src/main/lisp/libs/eclector/code/reader/generic-functions.lisp new file mode 100644 index 0000000..52028e1 --- /dev/null +++ b/src/main/lisp/libs/eclector/code/reader/generic-functions.lisp @@ -0,0 +1,99 @@ +(cl:in-package #:eclector.reader) + +;;; Establishing context + +(defgeneric call-as-top-level-read (client thunk input-stream + eof-error-p eof-value preserve-whitespace-p)) + +(defgeneric read-common (client input-stream eof-error-p eof-value)) + +(defgeneric read-maybe-nothing (client input-stream eof-error-p eof-value)) + +(defgeneric note-skipped-input (client input-stream reason) + (:method ((client t) (input-stream t) (reason t)) + (declare (ignore client input-stream reason)))) + +;;; Reading tokens + +(defgeneric read-token (client input-stream eof-error-p eof-value)) + +(defgeneric interpret-token (client input-stream token escape-ranges)) + +(defgeneric check-symbol-token (client input-stream + token escape-ranges + position-package-marker-1 + position-package-marker-2)) + +(defgeneric interpret-symbol-token (client input-stream + token + position-package-marker-1 + position-package-marker-2)) + +(defgeneric interpret-symbol (client input-stream + package-indicator symbol-name internp)) + +;;; Calling reader macros and behavior of standard reader macros + +(defgeneric call-reader-macro (client input-stream char readtable) + (:method ((client t) (input-stream t) (char t) (readtable t)) + (let ((function (eclector.readtable:get-macro-character readtable char))) + (funcall function input-stream char)))) + +(defgeneric find-character (client designator) + (:method ((client t) (designator character)) + designator) + (:method ((client t) (designator string)) + (find-standard-character designator))) + +(defgeneric make-structure-instance (client name initargs)) + +(defgeneric call-with-current-package (client thunk package-designator) + (:method ((client t) (thunk t) (package-designator t)) + (let ((*package* (find-package package-designator))) + (funcall thunk)))) + +(defgeneric evaluate-expression (client expression) + (:method ((client t) (expression t)) + (declare (ignore client)) + (eval expression))) + +(defgeneric check-feature-expression (client feature-expression) + (:method ((client t) (feature-expression t)) + (declare (ignore client)) + (check-standard-feature-expression feature-expression))) + +(defgeneric evaluate-feature-expression (client feature-expression) + (:method ((client t) (feature-expression t)) + (evaluate-standard-feature-expression + feature-expression + :check (alexandria:curry #'check-feature-expression client) + :recurse (alexandria:curry #'evaluate-feature-expression client)))) + +(defgeneric fixup (client object seen-objects mapping)) + +;;; Creating s-expressions + +(defgeneric wrap-in-quote (client material) + (:method (client material) + (declare (ignore client)) + (list 'quote material))) + +(defgeneric wrap-in-quasiquote (client form) + (:method (client form) + (declare (ignore client)) + (list 'quasiquote form))) + +(defgeneric wrap-in-unquote (client form) + (:method (client form) + (declare (ignore client)) + (list 'unquote form))) + +(defgeneric wrap-in-unquote-splicing (client form) + (:method (client form) + (declare (ignore client)) + (list 'unquote-splicing form))) + +(defgeneric wrap-in-function (client name) + (:method (client name) + (declare (ignore client)) + (list 'function name))) diff --git a/src/main/lisp/libs/eclector/code/reader/init.lisp b/src/main/lisp/libs/eclector/code/reader/init.lisp new file mode 100644 index 0000000..b164626 --- /dev/null +++ b/src/main/lisp/libs/eclector/code/reader/init.lisp @@ -0,0 +1,79 @@ +(cl:in-package #:eclector.reader) + +(defun set-standard-syntax-types (readtable) + (flet (((setf syntax) (syntax-type char) + (setf (eclector.readtable:syntax-type readtable char) + syntax-type))) + (setf (syntax #\Space) :whitespace + (syntax #\Tab) :whitespace + (syntax #\Linefeed) :whitespace + (syntax #\Return) :whitespace + (syntax #\Page) :whitespace + (syntax #\\) :single-escape + (syntax #\|) :multiple-escape))) + +(defun set-standard-macro-characters (readtable) + (loop for (char reader-macro) in '((#\( left-parenthesis) + (#\) right-parenthesis) + (#\' single-quote) + (#\" double-quote) + (#\; semicolon) + (#\` backquote) + (#\, comma)) + do (eclector.readtable:set-macro-character + readtable char reader-macro))) + +(defun set-standard-dispatch-macro-characters (readtable) + (eclector.readtable:make-dispatch-macro-character + readtable #\# t) + + ;; See HyperSpec section 2.4.8, Figure 2-19. + ;; + ;; Entries marked as "undefined" remain, well, + ;; undefined. ECLECTOR.READTABLE:GET-DISPATCH-MACRO-CHARACTER + ;; signals an appropriate error for those cases. + (loop for (dispatch-char sub-char reader-macro) + in '((#\# #\Backspace sharpsign-invalid) + (#\# #\Tab sharpsign-invalid) + (#\# #\Newline sharpsign-invalid) + (#\# #\Linefeed sharpsign-invalid) + (#\# #\Page sharpsign-invalid) + (#\# #\Return sharpsign-invalid) + (#\# #\Space sharpsign-invalid) + + (#\# #\< sharpsign-invalid) + (#\# #\) sharpsign-invalid) + + (#\# #\' sharpsign-single-quote) + (#\# #\( sharpsign-left-parenthesis) + (#\# #\. sharpsign-dot) + (#\# #\\ sharpsign-backslash) + (#\# #\b sharpsign-b) + (#\# #\x sharpsign-x) + (#\# #\o sharpsign-o) + (#\# #\r sharpsign-r) + (#\# #\* sharpsign-asterisk) + (#\# #\| sharpsign-vertical-bar) + (#\# #\a sharpsign-a) + (#\# #\: sharpsign-colon) + (#\# #\c sharpsign-c) + (#\# #\s sharpsign-s) + (#\# #\p sharpsign-p) + (#\# #\+ sharpsign-plus) + (#\# #\- sharpsign-minus) + (#\# #\= sharpsign-equals) + (#\# #\# sharpsign-sharpsign)) + do (eclector.readtable:set-dispatch-macro-character + readtable dispatch-char sub-char reader-macro))) + +(defun set-standard-syntax-and-macros (readtable) + (set-standard-syntax-types readtable) + (set-standard-macro-characters readtable) + (set-standard-dispatch-macro-characters readtable)) + +(defparameter *standard-readtable* + (let ((readtable (make-instance 'eclector.readtable.simple:readtable))) + (set-standard-syntax-and-macros readtable) + readtable)) + +(setf *readtable* (eclector.readtable:copy-readtable *standard-readtable*)) diff --git a/src/main/lisp/libs/eclector/code/reader/macro-functions.lisp b/src/main/lisp/libs/eclector/code/reader/macro-functions.lisp new file mode 100644 index 0000000..cb4e07e --- /dev/null +++ b/src/main/lisp/libs/eclector/code/reader/macro-functions.lisp @@ -0,0 +1,1415 @@ +(cl:in-package #:eclector.reader) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Macro WITH-FORBIDDEN-QUASIQUOTATION. +;;; +;;; This macro controls whether quasiquote and/or unquote should be +;;; allowed in a given context. + +(defmacro with-forbidden-quasiquotation + ((context &optional (quasiquote-forbidden-p t) + (unquote-forbidden-p t)) + &body body) + (alexandria:with-unique-names (context*) + (let ((context-used-p nil)) + (flet ((make-binding (variable value-form) + (cond ((constantp value-form) + (case (eval value-form) + (:keep + '()) + ((nil) + `((,variable nil))) + (t + (setf context-used-p t) + `((,variable ,context*))))) + (t + (setf context-used-p t) + `((,variable (case ,value-form + (:keep ,variable) + ((nil) nil) + (t ,context*)))))))) + `(let* ((,context* ,context) + ,@(make-binding '*quasiquote-forbidden* quasiquote-forbidden-p) + ,@(make-binding '*unquote-forbidden* unquote-forbidden-p)) + ,@(unless context-used-p + `((declare (ignore ,context*)))) + ,@body))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Reader macro for semicolon. +;;; +;;; We read characters until end-of-file or until we have read a +;;; newline character. Since reading a comment does not generate an +;;; object, the semicolon reader must indicate that fact by returning +;;; zero values. + +(defun semicolon (stream char) + (declare (ignore char)) + (loop with state = :semicolon + for char = (read-char stream nil nil t) + until (or (null char) (eql char #\Newline)) + if (and (eq state :semicolon) (char= char #\;)) + count 1 into semicolons + else + do (setf state nil) + finally (setf *skip-reason* (cons :line-comment (1+ semicolons)))) + (values)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Reader macro for single quote. +;;; +;;; They HyperSpec says that the reader signals an error if +;;; end-of-file is encountered before an object has been entirely +;;; parsed, independently of whether EOF-ERROR-P is true or not. For +;;; that reason, we call the reader recursively with the value of +;;; EOF-ERROR-P being T. + +(defun single-quote (stream char) + (declare (ignore char)) + (let ((material (handler-case + (read stream t nil t) + ((and end-of-file (not incomplete-construct)) (condition) + (%recoverable-reader-error + stream 'end-of-input-after-quote + :stream-position (stream-position condition) + :report 'inject-nil) + nil) + (end-of-list (condition) + (%recoverable-reader-error + stream 'object-must-follow-quote + :position-offset -1 :report 'inject-nil) + (unread-char (%character condition) stream) + nil)))) + (wrap-in-quote *client* material))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Reader macro for double quote. +;;; +;;; We identify a single escape character by its syntax type, so that +;;; if a user wants a different escape chacacter, we can handle that. +;;; +;;; Furthermore, They HyperSpec says that the reader signals an error +;;; if end-of-file is encountered before an object has been entirely +;;; parsed, independently of whether EOF-ERROR-P is true or not. For +;;; that reason, we call READ-CHAR with the value of EOF-ERROR-P being +;;; T. +;;; +;;; We accumulate characters in an adjustable vector. However, the +;;; HyperSpec says that we must return a SIMPLE-STRING. For that +;;; reason, we call COPY-SEQ in the end. COPY-SEQ is guaranteed to +;;; return a simple vector. + +(defun double-quote (stream char) + (let ((result (make-array 100 :element-type 'character + :adjustable t + :fill-pointer 0))) + (loop with readtable = *readtable* + for char2 = (read-char-or-recoverable-error + stream char 'unterminated-string + :delimiter char :report 'use-partial-string) + until (eql char2 char) + when (eq (eclector.readtable:syntax-type readtable char2) :single-escape) + do (setf char2 (read-char-or-recoverable-error + stream nil 'unterminated-single-escape-in-string + :position-offset -1 + :escape-char char2 :report 'use-partial-string)) + when char2 + do (vector-push-extend char2 result) + finally (return (copy-seq result))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Reader macros for backquote and comma. +;;; +;;; +;;; The control structure we use for backquote requires some +;;; explanation. +;;; +;;; The HyperSpec says (see section 2.4.6) that backquote and comma +;;; are allowed only inside lists and vectors. Since READ can be +;;; called recursively from other functions as well (such as the +;;; reader for arrays, or user-defined readers), we somehow need to +;;; track whether backquote and comma are allowed in the current +;;; context. +;;; +;;; We could (and previously did) forbid backquote and comma except +;;; inside lists and vectors, but in practice, clients expect control +;;; over this behavior in order to implement reader macros such as +;;; +;;; #L`(,!1 ,!1) => (lambda (g1) `(,g1 ,g1)) +;;; `#{,key ,value} => (let ((g1 (make-hash-table ...))) ...) +;;; +;;; We use the flags *QUASIQUOTE-FORBIDDEN-P* and +;;; *UNQUOTE-FORBIDDEN-P* to control whether backquote and comma are +;;; allowed. Initially, both variables are bound to T, allowing +;;; backquote and comma (*QUASIQUOTE-DEPTH* ensures that backquote and +;;; comma are nested properly). Reader macros such as #C, #A, +;;; etc. bind the variables to a true value that also indicates the +;;; context (usually the symbol naming the reader macro function). +;;; The only way these variables can be re-bound to NIL (in the +;;; standard readtable) is the SHARPSIGN-DOT reader macro. +;;; +;;; +;;; Representation of quasiquoted forms +;;; +;;; The HyperSpec explicitly encourages us (see section 2.4.6.1) to +;;; follow the example of Scheme for representing backquote +;;; expression. We see no reason for choosing a different +;;; representation, so we use (QUASIQUOTE
), (UNQUOTE ), +;;; and (UNQUOTE-SPLICING ). Then we define QUASIQUOTE as a +;;; macro that expands to a CL form that will build the final data +;;; structure. + +(defun backquote (stream char) + (declare (ignore char)) + (alexandria:when-let ((context *quasiquote-forbidden*)) + (unless *read-suppress* + (%recoverable-reader-error + stream 'backquote-in-invalid-context + :position-offset -1 :context context :report 'ignore-quasiquote) + (return-from backquote + (let ((*backquote-depth* 0)) + (read stream t nil t))))) + (let ((material (let ((*backquote-depth* (1+ *backquote-depth*)) + (*unquote-forbidden* nil)) + (handler-case + (read stream t nil t) + ((and end-of-file (not incomplete-construct)) (condition) + (%recoverable-reader-error + stream 'end-of-input-after-backquote + :stream-position (stream-position condition) + :report 'inject-nil) + nil) + (end-of-list (condition) + (%recoverable-reader-error + stream 'object-must-follow-backquote + :position-offset -1 :report 'inject-nil) + (unread-char (%character condition) stream) + nil))))) + (wrap-in-quasiquote *client* material))) + +(defun comma (stream char) + (declare (ignore char)) + (let* ((depth *backquote-depth*) + (char2 (read-char stream nil nil t)) + (splicing-p (case char2 + ((#\@ #\.) t) + ((nil) nil) ; end-of-input, but we may recover + (t (unread-char char2 stream))))) + (flet ((read-material () + (handler-case + (read stream t nil t) + ((and end-of-file (not incomplete-construct)) (condition) + (%recoverable-reader-error + stream 'end-of-input-after-unquote + :stream-position (stream-position condition) + :splicing-p splicing-p :report 'inject-nil) + nil) + (end-of-list (condition) + (%recoverable-reader-error + stream 'object-must-follow-unquote + :position-offset -1 + :splicing-p splicing-p :report 'inject-nil) + (unread-char (%character condition) stream) + nil)))) + (unless (plusp depth) + (%recoverable-reader-error + stream 'unquote-not-inside-backquote + :position-offset (if splicing-p -2 -1) + :splicing-p splicing-p :report 'ignore-unquote) + (return-from comma (read-material))) + (alexandria:when-let ((context *unquote-forbidden*)) + (unless *read-suppress* + (%recoverable-reader-error + stream 'unquote-in-invalid-context + :position-offset (if splicing-p -2 -1) + :splicing-p splicing-p :context context :report 'ignore-unquote) + (return-from comma (read-material)))) + (let* ((*backquote-depth* (1- depth)) + (form (read-material))) + (if splicing-p + (wrap-in-unquote-splicing *client* form) + (wrap-in-unquote *client* form)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Reader macros for left-parenthesis and right-parenthesis. +;;; +;;; The HyperSpec says that right-parenthesis is a macro character. +;;; In the reader macro for left-parenthesis, we can not just read +;;; until we find a right parenthesis, because it is possible that +;;; some other character has been assigned the same meaning, and we +;;; need to handle that situation too. +;;; +;;; Another problem we need to solve is that of the CONSING-DOT. The +;;; HyperSpec says that it is a token. For that reason, we can not +;;; just read characters and look for a single period, because it is +;;; possible that the single dot has a different syntax type in this +;;; particular readtable. Furthermore, we must handle error +;;; situations such as an attempt to use more than one dot in a list, +;;; or having zero or strictly more than one expression following a +;;; dot. +;;; +;;; We solve these problems as follows: the reader macro for a right +;;; parenthesis calls SIGNAL with a particular condition (of type +;;; END-OF-LIST). In situations where the right parenthesis is +;;; allowed, there will be a handler for this condition type. +;;; Therefore, in that situation, the call to SIGNAL will not return. +;;; If the call to SIGNAL returns, we signal and ERROR, because then +;;; the right parenthesis was read in a context where it is not +;;; allowed. +;;; +;;; The reader macro for left parenthesis manages two local variables, +;;; REVERSED-RESULT and TAIL. The variable REVERSED-RESULT is used to +;;; accumulate elements of the list (preceding a possible consing dot) +;;; being read, in reverse order. A handler for END-OF-LIST is +;;; established around the recursive calls to READ inside the reader +;;; macro function. When this handler is invoked, it calls NRECONC to +;;; reverse the value of REVERSED-RESULT and attach the value of TAIL +;;; to the end. Normally, the value of TAIL is NIL, so the handler +;;; will create and return a proper list containing the accumulated +;;; elements. +;;; +;;; We use a special variable name *CONSING-DOT-ALLOWED-P* to +;;; determine the contexts in which a consing dot is allowed. +;;; Whenever the token parser detects a consing dot, it examines this +;;; variable, and if it is true it returns the unique CONSING-DOT +;;; token, and if it is false, signals an error. Initially, this +;;; variable has the value FALSE. Whenever the reader macro for left +;;; parenthesis is called, it binds this variable to TRUE. When a +;;; recursive call to READ returns with the consing dot as a value, +;;; the reader macro for left parenthesis does three things. First it +;;; SETS (as opposed to BINDS) *CONSING-DOT-ALLOWED-P* to FALSE, so +;;; that if a second consing dot should occur, then the token reader +;;; signals an error. Second, it establishes a nested handler for +;;; END-OF-LIST, so that if a right parenthesis should occur +;;; immediately after the consing dot, then an error is signaled. +;;; With this handler established, READ is called. If it returns +;;; normally, then the return value becomes the value of the variable +;;; TAIL. Third, it calls READ again without any nested handler +;;; established. This call had better result in a right parenthesis, +;;; so that END-OF-LIST is signaled, which is caught by the outermost +;;; handler and the correct list is built and returned. If this call +;;; should return normally, we have a problem, because this means that +;;; there was a second subform after the consing dot in the list, so +;;; we signal an ERROR. + +(defun left-parenthesis (stream char) + (declare (ignore char)) + (%read-delimited-list stream #\))) + +(defun right-parenthesis (stream char) + ;; If the call to SIGNAL returns, then there is no handler for this + ;; condition, which means that the right parenthesis was found in a + ;; context where it is not allowed. + (signal-end-of-list char) + (%recoverable-reader-error + stream 'invalid-context-for-right-parenthesis + :position-offset -1 + :found-character char :report 'ignore-trailing-right-paren)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Reader macro for sharpsign single quote. + +(defun %sharpsign-single-quote (stream char parameter allow-unquote) + (declare (ignore char)) + (unless (null parameter) + (numeric-parameter-ignored stream 'sharpsign-single-quote parameter)) + (let ((name (with-forbidden-quasiquotation + ('sharpsign-single-quote :keep (if allow-unquote :keep t)) + (handler-case + (read stream t nil t) + ((and end-of-file (not incomplete-construct)) (condition) + (%recoverable-reader-error + stream 'end-of-input-after-sharpsign-single-quote + :stream-position (stream-position condition) + :report 'inject-nil) + nil) + (end-of-list (condition) + (%recoverable-reader-error + stream 'object-must-follow-sharpsign-single-quote + :position-offset -1 :report 'inject-nil) + (unread-char (%character condition) stream) + nil))))) + (cond (*read-suppress* + nil) + ((null name) + nil) + (t + (wrap-in-function *client* name))))) + +;;; This variation of SHARPSIGN-SINGLE-QUOTE allows unquote within #', +;;; that is `#',(foo) is read as +;;; +;;; (quasiquote (function (unquote (foo)))) +;;; +;;; . It is not clear that this behavior is supported by +;;; specification, but it is widely relied upon and thus the default +;;; behavior. +(defun sharpsign-single-quote (stream char parameter) + (%sharpsign-single-quote stream char parameter t)) + +;;; This variation of SHARPSIGN-SINGLE-QUOTE does not allow unquote +;;; within #'. +(defun strict-sharpsign-single-quote (stream char parameter) + (%sharpsign-single-quote stream char parameter nil)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Reader macro for sharpsign left parenthesis. + +(defun sharpsign-left-parenthesis (stream char parameter) + (declare (ignore char)) + (flet ((next-element () + (handler-case + (values (read stream t nil t) t) + (end-of-list () + (values nil nil)) + ((and end-of-file (not incomplete-construct)) (condition) + (%recoverable-reader-error + stream 'unterminated-vector + :stream-position (stream-position condition) + :delimiter #\) :report 'use-partial-vector) + (values nil nil))))) + (cond (*read-suppress* + (loop for elementp = (nth-value 1 (next-element)) + while elementp)) + ((null parameter) + (loop with result = (make-array 10 :adjustable t :fill-pointer 0) + for (element elementp) = (multiple-value-list (next-element)) + while elementp + do (vector-push-extend element result) + finally (return (coerce result 'simple-vector)))) + (t + (loop with result = (make-array parameter) + with excess-position = nil + for index from 0 + for (element elementp) = (multiple-value-list + (next-element)) + while elementp + if (< index parameter) + do (setf (aref result index) element) + else + do (setf excess-position (eclector.base:source-position + *client* stream)) + finally (cond ((and (zerop index) (plusp parameter)) + (%recoverable-reader-error + stream 'no-elements-found + :position-offset -1 + :array-type 'vector :expected-number parameter + :report 'use-empty-vector) + (setf result (make-array 0) + index parameter)) + ((> index parameter) + (%recoverable-reader-error + stream 'too-many-elements + :stream-position excess-position ; inaccurate + :position-offset -1 + :array-type 'vector + :expected-number parameter + :number-found index + :report 'ignore-excess-elements))) + (return + (if (< index parameter) + (fill result (aref result (1- index)) + :start index) + result))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Reader macro for sharpsign dot. + +(defun sharpsign-dot (stream char parameter) + (declare (ignore char)) + (unless (null parameter) + (numeric-parameter-ignored stream 'sharpsign-dot parameter)) + (cond ((not *read-eval*) + (%reader-error stream 'read-time-evaluation-inhibited)) + (*read-suppress* + (read stream t nil t)) + (t + (let ((expression (with-forbidden-quasiquotation (nil nil nil) + (let ((*list-reader* nil)) + (handler-case + (read stream t nil t) + ((and end-of-file (not incomplete-construct)) (condition) + (%recoverable-reader-error + stream 'end-of-input-after-sharpsign-dot + :stream-position (stream-position condition) + :report 'inject-nil) + nil) + (end-of-list (condition) + (%recoverable-reader-error + stream 'object-must-follow-sharpsign-dot + :position-offset -1 :report 'inject-nil) + (unread-char (%character condition) stream) + nil)))))) + (handler-case + (evaluate-expression *client* expression) + (error (condition) + (%recoverable-reader-error + stream 'read-time-evaluation-error + :expression expression :original-condition condition + :report 'inject-nil) + nil)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Reader macro for sharpsign backslash. + +;;; Mandatory character names according to 13.1.7 Character Names. +(defparameter *character-names* + (alexandria:alist-hash-table '(("NEWLINE" . #.(code-char 10)) + ("SPACE" . #.(code-char 32)) + ("RUBOUT" . #.(code-char 127)) + ("PAGE" . #.(code-char 12)) + ("TAB" . #.(code-char 9)) + ("BACKSPACE" . #.(code-char 8)) + ("RETURN" . #.(code-char 13)) + ("LINEFEED" . #.(code-char 10))) + :test 'equalp)) + +(defun find-standard-character (name) + (gethash name *character-names*)) + +(defun sharpsign-backslash (stream char parameter) + (declare (ignore char)) + (unless (null parameter) + (numeric-parameter-ignored stream 'sharpsign-backslash parameter)) + (let ((char1 (read-char-or-recoverable-error + stream nil 'end-of-input-after-backslash + :report '(use-replacement-character #1=#\?)))) + (when (null char1) ; can happen when recovering + (return-from sharpsign-backslash #1#)) + (with-token-info (push-char () finalize :lazy t) + (labels ((handle-char (char escapep) + (declare (ignore escapep)) + (when (not (null char1)) + (push-char char1) + (setf char1 nil)) + (push-char char)) + (unterminated-single-escape (escape-char) + (%recoverable-reader-error + stream 'unterminated-single-escape-in-character-name + :escape-char escape-char :report 'use-partial-character-name)) + (unterminated-multiple-escape (delimiter) + (%recoverable-reader-error + stream 'unterminated-multiple-escape-in-character-name + :delimiter delimiter :report 'use-partial-character-name)) + (lookup (name) + (let ((character (find-character *client* name))) + (cond ((null character) + (%recoverable-reader-error + stream 'unknown-character-name + :position-offset (- (if (characterp name) + 1 + (length name))) + :name name + :report '(use-replacement-character #2=#\?)) + #2#) + (t + character)))) + (terminate-character () + (return-from sharpsign-backslash + (cond (*read-suppress* nil) + ((not (null char1)) ; no additional characters pushed (same as (null token)) + (lookup char1)) + (t + (lookup (finalize))))))) + (token-state-machine + stream *readtable* handle-char nil nil + unterminated-single-escape unterminated-multiple-escape + terminate-character))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Reader macro for sharpsign B, X, O and R. + +(defun read-rational (stream base) + (let ((readtable *readtable*) + (read-suppress *read-suppress*)) + (labels ((next-char (eof-error-p) + (let ((char (read-char stream nil nil t))) + (cond ((not (null char)) + (values char (eclector.readtable:syntax-type + readtable char))) + ((and eof-error-p (not read-suppress)) + (%recoverable-reader-error + stream 'end-of-input-before-digit + :base base :report 'replace-invalid-digit) + (values #\1 :constituent)) + (t + (values nil nil))))) + (digit-expected (char type recover-value) + (%recoverable-reader-error + stream 'digit-expected + :position-offset -1 + :character-found char :base base + :report 'replace-invalid-digit) + (unless (eq type :constituent) + (unread-char char stream)) + recover-value) + (ensure-digit (char type) + (let ((value (digit-char-p char base))) + (if (null value) + (digit-expected char type 1) + value))) + (maybe-sign () + (multiple-value-bind (char type) (next-char t) + (cond (read-suppress + (values 1 0)) + ((not (eq type :constituent)) + (digit-expected char type nil)) + ((char= char #\-) + (values -1 0)) + (t + (values 1 (ensure-digit char type)))))) + (integer (empty-allowed /-allowed initial-value) + (let ((value initial-value)) + (tagbody + (when empty-allowed (go rest)) ; also when READ-SUPPRESS + (multiple-value-bind (char type) (next-char t) + (case type + (:constituent + (setf value (ensure-digit char type))) + (t + (digit-expected char type nil) + (return-from integer value)))) + rest + (multiple-value-bind (char type) (next-char nil) + (ecase type + ((nil) + (return-from integer value)) + (:whitespace + (unread-char char stream) + (return-from integer value)) + (:terminating-macro + (unread-char char stream) + (return-from integer value)) + ((:non-terminating-macro + :single-escape :multiple-escape) + (cond (read-suppress + (go rest)) + (t + (digit-expected char type nil) + (return-from integer value)))) + (:constituent + (cond (read-suppress + (go rest)) + ((and /-allowed (eql char #\/)) + (return-from integer (values value t))) + (t + (setf value (+ (* base (or value 0)) + (ensure-digit char type))) + (go rest))))))))) + (read-denominator () + (let ((value (integer nil nil nil))) + (cond ((eql value 0) + (%recoverable-reader-error + stream 'zero-denominator + :position-offset -1 :report 'replace-invalid-digit) + nil) + (t + value))))) + (multiple-value-bind (sign numerator) (maybe-sign) + (if (null sign) + 0 + (multiple-value-bind (numerator slashp) + (integer (= sign 1) t numerator) + (unless read-suppress ; When READ-SUPPRESS, / has been consumed + (let ((denominator (when slashp (read-denominator)))) + (* sign (if denominator + (/ numerator denominator) + numerator)))))))))) + +(defun sharpsign-b (stream char parameter) + (declare (ignore char)) + (unless (null parameter) + (numeric-parameter-ignored stream 'sharpsign-b parameter)) + (read-rational stream 2.)) + +(defun sharpsign-x (stream char parameter) + (declare (ignore char)) + (unless (null parameter) + (numeric-parameter-ignored stream 'sharpsign-x parameter)) + (read-rational stream 16.)) + +(defun sharpsign-o (stream char parameter) + (declare (ignore char)) + (unless (null parameter) + (numeric-parameter-ignored stream 'sharpsign-o parameter)) + (read-rational stream 8.)) + +(defun sharpsign-r (stream char parameter) + (declare (ignore char)) + (let ((radix (cond ((not parameter) + (numeric-parameter-not-supplied stream 'sharpsign-r) + 36) + ((not (<= 2 parameter 36)) + (unless *read-suppress* + (%recoverable-reader-error + stream 'invalid-radix + :position-offset (- (+ (parameter-length parameter) 1)) + :radix parameter :report 'use-replacement-radix)) + 36) + (t + parameter)))) + (read-rational stream radix))) + +(defun sharpsign-asterisk (stream char parameter) + (declare (ignore char)) + (let ((read-suppress *read-suppress*) + (readtable *readtable*)) + (flet ((next-bit () + (let ((char (read-char stream nil nil t))) + (multiple-value-bind (syntax-type value) + (unless (null char) + (values (eclector.readtable:syntax-type + readtable char) + (digit-char-p char 2))) + (when (eq syntax-type :terminating-macro) + (unread-char char stream)) + (cond ((member syntax-type '(nil :whitespace :terminating-macro)) + nil) + (read-suppress + t) + ((null value) + (%recoverable-reader-error + stream 'digit-expected + :position-offset -1 + :character-found char :base 2. + :report 'replace-invalid-digit) + 0) + (t + value)))))) + (cond (read-suppress + (loop for value = (next-bit) while value)) + ((null parameter) + (loop with bits = (make-array 10 :element-type 'bit + :adjustable t :fill-pointer 0) + for value = (next-bit) + while value + do (vector-push-extend value bits) + finally (return (coerce bits 'simple-bit-vector)))) + (t + (loop with result = (make-array parameter :element-type 'bit) + for index from 0 + for value = (next-bit) + while value + when (< index parameter) + do (setf (sbit result index) value) + finally (cond ((and (zerop index) (plusp parameter)) + (%recoverable-reader-error + stream 'no-elements-found + :array-type 'bit-vector + :expected-number parameter + :report 'use-empty-vector) + (setf result (make-array 0 :element-type 'bit) + index parameter)) + ((> index parameter) + (%recoverable-reader-error + stream 'too-many-elements + :position-offset (- (- index parameter)) + :array-type 'bit-vector + :expected-number parameter + :number-found index + :report 'ignore-excess-elements))) + (return + (if (< index parameter) + (fill result (sbit result (1- index)) + :start index) + result)))))))) + +(defun sharpsign-vertical-bar (stream sub-char parameter) + (unless (null parameter) + (numeric-parameter-ignored stream 'sharpsign-vertical-bar parameter)) + (handler-case + (loop for char = (read-char stream t nil t) + do (cond ((eql char #\#) + (let ((char2 (read-char stream t nil t))) + (if (eql char2 sub-char) + (sharpsign-vertical-bar stream sub-char nil) + (unread-char char2 stream)))) + ((eql char sub-char) + (let ((char2 (read-char stream t nil t))) + (if (eql char2 #\#) + (progn + (setf *skip-reason* :block-comment) + (return-from sharpsign-vertical-bar (values))) + (unread-char char2 stream)))) + (t + nil))) + ((and end-of-file (not incomplete-construct)) (condition) + (%recoverable-reader-error + stream 'unterminated-block-comment + :stream-position (stream-position condition) + :delimiter sub-char :report 'ignore-missing-delimiter)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Reader macro for sharpsign A. + +(labels ((check-sequence (stream object) + (when (not (typep object 'alexandria:proper-sequence)) + (%recoverable-reader-error + stream 'read-object-type-error + :position-offset -1 ; inaccurate + :expected-type 'sequence :datum object + :report 'use-empty-array) + (invoke-restart '%make-empty)) + nil) + (make-empty-dimensions (rank) + (make-list rank :initial-element 0)) + (determine-dimensions (stream rank initial-contents) + (labels ((rec (rank initial-contents) + (cond ((zerop rank) + '()) + ((check-sequence stream initial-contents)) + (t + (let ((length (length initial-contents))) + (if (zerop length) + (make-empty-dimensions rank) + (list* length + (rec (1- rank) + (elt initial-contents 0))))))))) + (rec rank initial-contents))) + + (check-dimensions (stream dimensions initial-contents) + (labels ((rec (first rest axis initial-contents) + (cond ((not first)) + ((check-sequence stream initial-contents)) + ((not (eql (length initial-contents) (or first 0))) + (%recoverable-reader-error + stream 'incorrect-initialization-length + :array-type 'array :axis axis + :expected-length first :datum initial-contents + :report 'use-empty-array) + (invoke-restart '%make-empty)) + (t + (every (lambda (subseq) + (rec (first rest) (rest rest) + (1+ axis) subseq)) + initial-contents))))) + (rec (first dimensions) (rest dimensions) 0 initial-contents))) + (read-init (stream) + (with-forbidden-quasiquotation ('sharpsign-a :keep) + (handler-case + (read stream t nil t) + ((and end-of-file (not incomplete-construct)) (condition) + (%recoverable-reader-error + stream 'end-of-input-after-sharpsign-a + :stream-position (stream-position condition) + :report 'use-empty-array) + (invoke-restart '%make-empty)) + (end-of-list (condition) + (%recoverable-reader-error + stream 'object-must-follow-sharpsign-a + :position-offset -1 :report 'use-empty-array) + (unread-char (%character condition) stream) + (invoke-restart '%make-empty)))))) + + (defun sharpsign-a (stream char parameter) + (declare (ignore char)) + (when *read-suppress* + (return-from sharpsign-a (read stream t nil t))) + + (let ((rank (cond ((null parameter) + (numeric-parameter-not-supplied stream 'sharpsign-a) + 0) + (t + parameter)))) + (multiple-value-bind (dimensions init) + (restart-case + (let* ((init (read-init stream)) + (dimensions (determine-dimensions + stream rank init))) + (check-dimensions stream dimensions init) + (values dimensions init)) + (%make-empty () + (values (make-empty-dimensions rank) '()))) + (make-array dimensions :initial-contents init))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Reader macro for sharpsign colon. + +(defun symbol-from-token (stream token token-escapes package-marker) + (when *read-suppress* + (return-from symbol-from-token nil)) + (when package-marker + (%recoverable-reader-error + stream 'uninterned-symbol-must-not-contain-package-marker + :stream-position (if (eq package-marker t) + nil + package-marker) + :token token :report 'treat-as-escaped)) + (convert-according-to-readtable-case token token-escapes) + (interpret-symbol *client* stream nil (copy-seq token) nil)) + +(defun sharpsign-colon (stream char parameter) + (declare (ignore char)) + (unless (null parameter) + (numeric-parameter-ignored stream 'sharpsign-colon parameter)) + (with-token-info (push-char (start-escape end-escape) finalize) + (let ((package-marker nil)) + (labels ((handle-char (char escapep) + (when (and (not escapep) + (char= char #\:) + (not package-marker)) + (setf package-marker (or (ignore-errors (file-position stream)) + t))) + (push-char char)) + (unterminated-single-escape (escape-char) + (%recoverable-reader-error + stream 'unterminated-single-escape-in-symbol + :escape-char escape-char :report 'use-partial-symbol)) + (unterminated-multiple-escape (delimiter) + (%recoverable-reader-error + stream 'unterminated-multiple-escape-in-symbol + :delimiter delimiter :report 'use-partial-symbol)) + (return-symbol () + (return-from sharpsign-colon + (multiple-value-bind (token escape-ranges) (finalize) + (symbol-from-token stream token escape-ranges package-marker))))) + (token-state-machine + stream *readtable* handle-char start-escape end-escape + unterminated-single-escape unterminated-multiple-escape + return-symbol))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Reader macro for sharpsign C. + +(defun %sharpsign-c (stream char parameter allow-non-list) + (declare (ignore char)) + (unless (null parameter) + (numeric-parameter-ignored stream 'sharpsign-c parameter)) + (when *read-suppress* + (read stream t nil t) + (return-from %sharpsign-c nil)) + ;; When we get here, we have to read a list of the form + ;; (REAL-PART-REAL-NUMBER-LITERAL IMAGINARY-PART-REAL-NUMBER) that + ;; is, a list of exactly two elements of type REAL. + ;; + ;; We call %READ-LIST-ELEMENTS which calls the local function PART + ;; for each list element as well as the events such as the end of + ;; the list or the end of input. The variable PART keeps track of + ;; the currently expected part which can be :REAL, :IMAGINARY, :END + ;; or :PAST-END (the latter only comes into play when reading more + ;; than two list elements due to error recovery). + (let ((listp nil) + (part :real) + (real 1) (imaginary 1)) + (labels ((check-value (value) + (typecase value + ((eql #1=#.(gensym "END-OF-LIST")) + (%recoverable-reader-error + stream 'complex-part-expected + :position-offset -1 + :which part :report 'use-partial-complex) + 1) + ((eql #2=#.(gensym "END-OF-INPUT")) + (%recoverable-reader-error + stream 'end-of-input-before-complex-part + :which part :report 'use-partial-complex) + 1) + (real + value) + (t + (%recoverable-reader-error stream 'read-object-type-error + :datum value :expected-type 'real + :report 'use-replacement-part) + 1))) + (part (kind value) + (declare (ignore kind)) + (case part + (:real + (setf real (check-value value) + part :imaginary) + t) + (:imaginary + (setf imaginary (check-value value) + part :end) + t) + ((:end :past-end) + (case value + (#1# t) + (#2# nil) + (t + (when (eq part :end) + (%recoverable-reader-error + stream 'too-many-complex-parts + :position-offset -1 + :report 'ignore-excess-parts) + (setf part :past-end)) + t))))) + (read-parts (stream char) + ;; If this is called, the input started with "#C(" (or, + ;; generally, "#C" followed by any input resulting in a + ;; LEFT-PARENTHESIS call). We record that fact (for + ;; error reporting) by setting LISTP. We reset + ;; *LIST-READER* so lists appearing in the complex + ;; parts are processed normally instead of with + ;; READ-PARTS. + (setf listp t) + (let ((*list-reader* nil)) + (%read-list-elements stream #'part '#1# '#2# char nil)) + nil)) ; unused, but must not return (values) + (handler-case + ;; Depending on ALLOW-NON-LIST, we call either READ or + ;; %READ-MAYBE-NOTHING. Calling %READ-MAYBE-NOTHING will: + ;; - not skip whitespace or comments (the spec is not clear + ;; about whether #C(...) is valid syntax) + ;; - invoke reader macros, in particular LEFT-PARENTHESIS to + ;; initiate reading a list + ;; - not behave like a full READ call in terms of e.g. parse + ;; result construction so (1 2) will not appear as a list + ;; result with two atom result children. + ;; We bind *LIST-READER* to use READ-PARTS for reading lists. + (with-forbidden-quasiquotation ('sharpsign-c) + (let ((*list-reader* #'read-parts)) + (values (if allow-non-list + (read stream t nil t) + (%read-maybe-nothing *client* stream t nil))))) + ((and end-of-file (not incomplete-construct)) (condition) + (%recoverable-reader-error + stream 'end-of-input-after-sharpsign-c + :stream-position (stream-position condition) + :report 'use-replacement-part)) + (end-of-list (condition) ; (... #C) + (%recoverable-reader-error + stream 'complex-parts-must-follow-sharpsign-c + :position-offset -1 :report 'use-partial-complex) + (unread-char (%character condition) stream)) + (:no-error (object) + ;; If we got here, we managed to read an object. + (cond (listp) + ((or (not allow-non-list) (not (typep object 'cons))) + (%recoverable-reader-error + stream 'non-list-following-sharpsign-c + :position-offset -1 ; inaccurate + :report 'use-replacement-part)) + ((typep object #3='(cons real (cons real null))) + (setf real (first object) + imaginary (second object))) + (t + (%recoverable-reader-error + stream 'read-object-type-error + :position-offset -1 ; inaccurate + :datum object :expected-type #3# + :report 'use-replacement-part))))) + (complex real imaginary)))) + +(defun sharpsign-c (stream char parameter) + (%sharpsign-c stream char parameter t)) + +(defun strict-sharpsign-c (stream char parameter) + (%sharpsign-c stream char parameter nil)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Reader macro for sharpsign S. +;;; +;;; In contrast to 2.4.8.11 Sharpsign C which says "#C reads a +;;; following object …" thus allowing whitespace preceding the object, +;;; 2.4.8.13 Sharpsign S spells out the syntax as "#s(…)". However, +;;; since a strict reading of this would also preclude "#S(…)" we +;;; assume that the intention is to allow whitespace after "#s". + +(defun sharpsign-s (stream char parameter) + (declare (ignore char)) + (unless (null parameter) + (numeric-parameter-ignored stream 'sharpsign-s parameter)) + (when *read-suppress* + (read stream t nil t) + (return-from sharpsign-s nil)) + ;; When we get here, we have to read a list of the form + ;; (STRUCTURE-TYPE-NAME SLOT-NAME SLOT-VALUE …). We call + ;; %READ-LIST-ELEMENTS which calls the local function ELEMENT for + ;; each list element as well as events such as the end of the list + ;; or the end of input. The variable ELEMENT keeps track of the + ;; currently expected ELEMENT which can be :TYPE, :SLOT-NAME, or + ;; :SLOT-VALUE. + (let ((old-quasiquote-forbidden *quasiquote-forbidden*) + (listp nil) + (element :type) + (type) + (slot-name) + (initargs '())) + (labels ((element (kind value) + (declare (ignore kind)) + (case element + (:type + (typecase value + ((eql #1=#.(gensym "END-OF-LIST")) + (%recoverable-reader-error + stream 'no-structure-type-name-found + :position-offset -1 :report 'inject-nil)) + ((eql #2=#.(gensym "END-OF-INPUT")) + (%recoverable-reader-error + stream 'end-of-input-before-structure-type-name + :report 'inject-nil)) + (symbol + (setf type value)) + (t + (%recoverable-reader-error + stream 'structure-type-name-is-not-a-symbol + :position-offset -1 :datum value :report 'inject-nil))) + (setf *quasiquote-forbidden* 'sharpsign-s-slot-name + *unquote-forbidden* 'sharpsign-s-slot-name + element :name)) + (:name + (typecase value + ((eql #1#)) + ((eql #2#) + (%recoverable-reader-error + stream 'end-of-input-before-slot-name + :report 'use-partial-initargs)) + (alexandria:string-designator + (setf slot-name value)) + (t + (%recoverable-reader-error + stream 'slot-name-is-not-a-string-designator + :position-offset -1 :datum value :report 'skip-slot) + (setf slot-name value))) + (setf *quasiquote-forbidden* old-quasiquote-forbidden + *unquote-forbidden* 'sharpsign-s-slot-value + element :object)) + (:object + (typecase value + ((eql #1#) + (%recoverable-reader-error + stream 'no-slot-value-found + :position-offset -1 + :slot-name slot-name :report 'skip-slot)) + ((eql #2#) + (%recoverable-reader-error + stream 'end-of-input-before-slot-value + :slot-name slot-name :report 'skip-slot)) + (t + (push slot-name initargs) + (push value initargs))) + (setf *quasiquote-forbidden* 'sharpsign-s-slot-name + *unquote-forbidden* 'sharpsign-s-slot-name + element :name)))) + (read-constructor (stream char) + ;; If this is called, the input started with "#S(" (or, + ;; generally, "#S" followed by any input resulting in a + ;; LEFT-PARENTHESIS call). We record that fact (for + ;; error reporting) by setting LISTP. We reset + ;; *LIST-READER* so lists appearing in the constructor + ;; parts are processed normally instead of with + ;; READ-CONSTRUCTOR. + (setf listp t) + (setf *quasiquote-forbidden* 'sharpsign-s-type + *unquote-forbidden* 'sharpsign-s-type) + (let ((*list-reader* nil)) + (%read-list-elements stream #'element '#1# '#2# char nil)))) + (handler-case + ;; Instead of READ we call %READ-MAYBE-NOTHING which will + ;; - not skip whitespace or comments (the spec is not clear + ;; about whether #S(...) is valid syntax) + ;; - invoke reader macros, in particular LEFT-PARENTHESIS to + ;; initiate reading a list + ;; - not behave like a full READ call in terms of e.g. parse + ;; result construction so (foo :bar 2) will not appear as + ;; a list result with three atom result children. + ;; We bind *LIST-READER* to use READ-CONSTRUCTOR for reading lists. + (with-forbidden-quasiquotation ('sharpsign-s) + (let ((*list-reader* #'read-constructor)) + (%read-maybe-nothing *client* stream t nil))) + ((and end-of-file (not incomplete-construct)) (condition) + (%recoverable-reader-error + stream 'end-of-input-after-sharpsign-s + :stream-position (stream-position condition) + :report 'inject-nil)) + (end-of-list (condition) + (%recoverable-reader-error + stream 'structure-constructor-must-follow-sharpsign-s + :position-offset -1 :report 'inject-nil) + (unread-char (%character condition) stream)) + (:no-error (&rest values) + (declare (ignore values)) + (unless listp + (%recoverable-reader-error + stream 'non-list-following-sharpsign-s + :position-offset -1 :report 'inject-nil)))) + (if (not (null type)) + (make-structure-instance *client* type (nreverse initargs)) + nil)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Reader macro for sharpsign P. + +(defun sharpsign-p (stream char parameter) + (declare (ignore char)) + (unless (null parameter) + (numeric-parameter-ignored stream 'sharpsign-p parameter)) + (when *read-suppress* + (read stream t nil t) + (return-from sharpsign-p nil)) + (let ((expression + (with-forbidden-quasiquotation ('sharpsign-p) + (handler-case + (read stream t nil t) + ((and end-of-file (not incomplete-construct)) (condition) + (%recoverable-reader-error + stream 'end-of-input-after-sharpsign-p + :stream-position (stream-position condition) + :report 'replace-namestring) + ".") + (end-of-list (condition) + (%recoverable-reader-error + stream 'namestring-must-follow-sharpsign-p + :position-offset -1 :report 'replace-namestring) + (unread-char (%character condition) stream) + "."))))) + (cond ((stringp expression) + (values (parse-namestring expression))) + (t + (%recoverable-reader-error + stream 'non-string-following-sharpsign-p + :position-offset -1 + :expected-type 'string :datum expression + :report 'replace-namestring) + #P".")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Reader macros for sharpsign + and sharpsign -. + +;;; This variable is bound to the current input stream in +;;; SHARPSIGN-PLUS-MINUS to make the stream available for error +;;; reporting in CHECK-STANDARD-FEATURE-EXPRESSION. +(defvar *input-stream*) + +(deftype feature-expression-operator () + '(member :not :or :and)) + +(defun check-standard-feature-expression (feature-expression) + (flet ((lose (stream-condition no-stream-condition &rest arguments) + (alexandria:if-let ((stream *input-stream*)) + (apply #'%reader-error stream stream-condition + :position-offset -1 arguments) + (apply #'error no-stream-condition arguments)))) + (unless (or (symbolp feature-expression) + (alexandria:proper-list-p feature-expression)) + (lose 'feature-expression-type-error/reader + 'feature-expression-type-error + :datum feature-expression + :expected-type '(or symbol cons))) + (when (consp feature-expression) + (destructuring-bind (operator &rest operands) feature-expression + (unless (typep operator 'feature-expression-operator) + (lose 'feature-expression-type-error/reader + 'feature-expression-type-error + :datum operator + :expected-type 'feature-expression-operator)) + (when (and (eq operator :not) + (not (alexandria:length= 1 operands))) + (lose 'single-feature-expected/reader 'single-feature-expected + :features (cdr feature-expression))))))) + +(defun evaluate-standard-feature-expression + (feature-expression + &key + (check 'check-standard-feature-expression) + (recurse 'evaluate-standard-feature-expression)) + (funcall check feature-expression) + (typecase feature-expression + (symbol + (member feature-expression *features* :test #'eq)) + ((cons (eql :not)) + (not (funcall recurse (second feature-expression)))) + ((cons (eql :or)) + (some recurse (rest feature-expression))) + ((cons (eql :and)) + (every recurse (rest feature-expression))))) + +(defun sharpsign-plus-minus (stream char parameter invertp) + (declare (ignore char)) + (unless (null parameter) + (numeric-parameter-ignored stream 'sharpsign-plus-minus parameter)) + (let ((context (if invertp + :sharpsign-minus + :sharpsign-plus))) + (flet ((read-expression (end-of-file-condition end-of-list-condition + fallback-value) + (handler-case + (read stream t nil t) + ((and end-of-file (not incomplete-construct)) (condition) + (%recoverable-reader-error + stream end-of-file-condition + :stream-position (stream-position condition) + :context context :report 'inject-nil) + fallback-value) + (end-of-list (condition) + (%recoverable-reader-error + stream end-of-list-condition + :position-offset -1 :context context :report 'inject-nil) + (unread-char (%character condition) stream) + fallback-value)))) + (let* ((client *client*) + (feature-expression + (call-with-current-package + client (lambda () + (let ((*read-suppress* nil)) + (with-forbidden-quasiquotation (context) + (read-expression + 'end-of-input-after-sharpsign-plus-minus + 'feature-expression-must-follow-sharpsign-plus-minus + '(:and))))) + '#:keyword))) + (if (alexandria:xor + (with-simple-restart + (recover (recovery-description 'treat-as-false)) + (let ((*input-stream* stream)) + (evaluate-feature-expression client feature-expression))) + invertp) + (read-expression 'end-of-input-after-feature-expression + 'object-must-follow-feature-expression + nil) + (progn + (setf *skip-reason* (cons context feature-expression)) + (let ((*read-suppress* t)) + (read-expression 'end-of-input-after-feature-expression + 'object-must-follow-feature-expression + nil)) + (values))))))) + +(defun sharpsign-plus (stream char parameter) + (sharpsign-plus-minus stream char parameter nil)) + +(defun sharpsign-minus (stream char parameter) + (sharpsign-plus-minus stream char parameter t)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Reader macros for sharpsign equals and sharpsign sharpsign. +;;; +;;; When the SHARPSIGN-EQUALS reader macro encounters #N=EXPRESSION, +;;; it associates a marker object with N in the hash-table bound to +;;; *LABELS*. The marker object is of the form +;;; +;;; ((FINALP) . FINAL-OBJECT) +;;; +;;; where FINALP and FINAL-OBJECT are initially NIL. The cons cell +;;; (FINALP) is called the temporary object of the marker object. +;;; +;;; If #N# is encountered, the marker for N is looked up in *LABELS* +;;; and FINALP is examined. If FINALP is true, FINAL-OBJECT can be +;;; returned as the result of reading #N#. However, if FINALP is false +;;; (this can happen while READing EXPRESSION if #N=EXPRESSION is +;;; circular), the temporary object is returned as the result of +;;; reading #N# and a deferred fixup step will be necessary. This +;;; fixup happens in READ-AUX. +;;; +;;; After reading EXPRESSION, the resulting object is stored in the +;;; cdr as FINAL-OBJECT and FINALP within the temporary object is set +;;; to true. Subsequent #N# encounters can directly return +;;; FINAL-OBJECT as described above. + +(declaim (inline make-fixup-marker + fixup-marker-temporary + fixup-marker-final-p (setf fixup-marker-final-p) + fixup-marker-final (setf fixup-marker-final))) + +(defun make-fixup-marker () + (let ((temporary (list nil))) + (cons temporary nil))) + +(defun fixup-marker-temporary (marker) + (car marker)) + +(defun fixup-marker-final-p (marker) + (car (fixup-marker-temporary marker))) + +(defun (setf fixup-marker-final-p) (new-value marker) + (setf (car (fixup-marker-temporary marker)) new-value)) + +(defun fixup-marker-final (marker) + (cdr marker)) + +(defun (setf fixup-marker-final) (new-value marker) + (setf (cdr marker) new-value)) + +(defun sharpsign-equals (stream char parameter) + (declare (ignore char)) + (flet ((read-object () + (handler-case + (read stream t nil t) + ((and end-of-file (not incomplete-construct)) (condition) + (%recoverable-reader-error + stream 'end-of-input-after-sharpsign-equals + :stream-position (stream-position condition) + :report 'inject-nil) + nil) + (end-of-list (condition) + (%recoverable-reader-error + stream 'object-must-follow-sharpsign-equals + :position-offset -1 :report 'inject-nil) + (unread-char (%character condition) stream) + nil)))) + (when *read-suppress* + (return-from sharpsign-equals (read-object))) + (when (null parameter) + (numeric-parameter-not-supplied stream 'sharpsign-equals) + (return-from sharpsign-equals (read-object))) + (let ((labels *labels*)) + (when (nth-value 1 (gethash parameter labels)) + (%recoverable-reader-error + stream 'sharpsign-equals-label-defined-more-than-once + :position-offset (- (+ 1 (parameter-length parameter) 1)) + :label parameter :report 'ignore-label) + (return-from sharpsign-equals (read-object))) + (let ((marker (make-fixup-marker))) + (setf (gethash parameter labels) marker) + (let ((result (read-object))) + (when (eq result (fixup-marker-temporary marker)) + (%recoverable-reader-error + stream 'sharpsign-equals-only-refers-to-self + :position-offset -1 :label parameter :report 'inject-nil) + (remhash parameter labels) + (return-from sharpsign-equals nil)) + (setf (fixup-marker-final marker) result + (fixup-marker-final-p marker) t) + result))))) + +(defun sharpsign-sharpsign (stream char parameter) + (declare (ignore char)) + (when *read-suppress* + (return-from sharpsign-sharpsign nil)) + (when (null parameter) + (numeric-parameter-not-supplied stream 'sharpsign-equals) + (return-from sharpsign-sharpsign nil)) + (multiple-value-bind (marker definedp) (gethash parameter *labels*) + (cond ((not definedp) + (%recoverable-reader-error + stream 'sharpsign-sharpsign-undefined-label + :position-offset (- (+ 1 (parameter-length parameter) 1)) + :label parameter :report 'inject-nil) + nil) + ;; If the final object has already been supplied, use it. + ((fixup-marker-final-p marker) + (fixup-marker-final marker)) + ;; Else, we must use the temporary object and it will be + ;; fixed up later. + (t + (fixup-marker-temporary marker))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Reader macros for sharpsign < and sharpsign ) + +(defun sharpsign-invalid (stream char parameter) + (declare (ignore parameter)) + (%recoverable-reader-error + stream 'sharpsign-invalid + :position-offset -1 :character-found char :report 'inject-nil) + nil) diff --git a/src/main/lisp/libs/eclector/code/reader/messages-english.lisp b/src/main/lisp/libs/eclector/code/reader/messages-english.lisp new file mode 100644 index 0000000..cb609a3 --- /dev/null +++ b/src/main/lisp/libs/eclector/code/reader/messages-english.lisp @@ -0,0 +1,573 @@ +(cl:in-package #:eclector.reader) + +;;; Recovery strategy descriptions + +(macrolet ((define-description (strategy description) + `(defmethod recovery-description-using-language + ((strategy (eql ',strategy)) (language acclimation:english)) + ,description))) + (define-description skip-token "Skip the invalid token.") + + (define-description use-partial-symbol "Return a symbol named by the already read characters.") + (define-description replace-invalid-character "Replace the invalid character with a valid one.") + (define-description treat-as-escaped "Treat the character as if it had been escaped.") + (define-description use-uninterned-symbol (lambda (stream package-name symbol-name) + (format stream "Use an uninterned symbol named \"~A\" and ~ + ignore the non-existent \"~A\" package." + symbol-name package-name))) + (define-description use-replacement-package (lambda (stream package-name) + (format stream "Specify a package to use in place of the ~ + non-existent \"~A\" package." + package-name))) + (define-description use-replacement-symbol (lambda (stream package symbol-name) + (format stream "Specify a symbol to use in place of the ~ + non-existent \"~A\" in package ~A." + symbol-name package))) + (define-description intern (lambda (stream package symbol-name) + (format stream "Intern a symbol named \"~A\" in package ~A." + symbol-name package))) + (define-description use-anyway (lambda (stream package symbol-name) + (format stream "Use the unexported symbol named \"~A\" in ~ + package ~A anyway." + symbol-name package))) + + (define-description replace-invalid-digit "Use a suitable digit in place of the invalid digit.") + (define-description use-replacement-radix "Use a suitable radix in place of the invalid radix.") + (define-description use-replacement-float-format "Use a suitable float format in place of the invalid one.") + + (define-description ignore-quasiquote "Read the following form as if it were not quasiquoted.") + (define-description ignore-unquote "Read the following form as if it were not unquoted.") + (define-description ignore-missing-delimiter "Ignore the missing delimiter.") + (define-description use-partial-string "Return a string of the already read characters.") + (define-description inject-nil "Use NIL in place of the missing object.") + (define-description ignore-object "Ignore the object.") + (define-description use-partial-list "Return a list of the already read elements.") + (define-description ignore-trailing-right-paren "Ignore the trailing right parenthesis.") + + (define-description ignore-parameter "Ignore the invalid numeric parameter.") + (define-description use-replacement-parameter "Use a valid numeric parameter in place of the missing one.") + + (define-description use-replacement-character (lambda (stream replacement-character) + (format stream "Use the character ~:C in place of the invalid one." + replacement-character))) + (define-description use-partial-character-name "Use the already read part of the character name.") + + (define-description use-empty-vector "Return an empty vector.") + (define-description use-partial-vector "Return a vector of the already read elements.") + (define-description ignore-excess-elements "Use the already read elements and ignore the excess elements.") + + (define-description use-empty-array "Use an empty array in place of the invalid one.") + + (define-description use-replacement-part "Use a replacement part in place of the invalid part.") + (define-description use-partial-complex "Complete the complex number using default values for missing parts.") + (define-description ignore-excess-parts "Use the already read parts and ignore the excess parts.") + + (define-description use-partial-initargs "Use already read structure type name and initargs.") + (define-description skip-slot "Skip the invalid slot.") + + (define-description replace-namestring "Use a suitable namestring in place of the invalid one.") + + (define-description treat-as-false "Treat the feature expression as false.") + + (define-description ignore-label "Read the following object as is if there was no label.")) + +;;; Contexts and condition reporters + +(macrolet + ((define-reporter (((condition-var condition-specializer) stream-var + &optional (language-var 'language)) + &body body) + `(defmethod acclimation:report-condition + ((,condition-var ,condition-specializer) + ,stream-var + (,language-var acclimation:english)) + ,@body)) + (define-context (context name) + `(defmethod context-name ((context (eql ',context)) + (language acclimation:english)) + ,name))) + +;;; Type error + + (define-reporter ((condition read-object-type-error) stream) + (format stream "~@" + (type-error-datum condition) + (type-error-expected-type condition))) + +;;; Conditions related to symbols + + (define-reporter ((condition package-does-not-exist) stream) + (format stream "~@" + (desired-package-name condition))) + +;;; Conditions related to symbols + + (flet ((package-name* (package) + ;; PACKAGE may be a `cl:package' but could also be a + ;; client-defined representation of a package. + (typecase package + (package (package-name package)) + (t package)))) + + (define-reporter ((condition symbol-does-not-exist) stream) + (format stream "~@" + (desired-symbol-name condition) + (package-name* (desired-symbol-package condition)))) + + (define-reporter ((condition symbol-is-not-external) stream) + (format stream "~@" + (desired-symbol-name condition) + (package-name* (desired-symbol-package condition))))) + + (define-reporter ((condition invalid-constituent-character) stream) + (format stream "~@" + (aref (token condition) 0))) + + (define-reporter ((condition unterminated-single-escape-in-symbol) stream) + (format stream "~@" + (escape-char condition))) + + (define-reporter ((condition unterminated-multiple-escape-in-symbol) stream) + (format stream "~@" + (delimiter condition))) + + (define-reporter ((condition symbol-name-must-not-be-only-package-markers) stream) + (format stream "~@")) + + (define-reporter ((condition symbol-name-must-not-end-with-package-marker) stream) + (format stream "~@")) + + (define-reporter ((condition two-package-markers-must-be-adjacent) stream) + (format stream "~@")) + + (define-reporter ((condition two-package-markers-must-not-be-first) stream) + (format stream "~@")) + + (define-reporter ((condition symbol-can-have-at-most-two-package-markers) stream) + (format stream "~@")) + + (define-reporter ((condition uninterned-symbol-must-not-contain-package-marker) stream) + (format stream "~@")) + +;;; General reader macro conditions + + (define-reporter ((condition sharpsign-invalid) stream) + (format stream "~@" + (character-found condition))) + + (define-reporter ((condition numeric-parameter-supplied-but-ignored) stream) + (format stream "~@" + (macro-name condition))) + + (define-reporter ((condition numeric-parameter-not-supplied-but-required) stream) + (format stream "~@" + (macro-name condition))) + +;;; Conditions related to quotation + + (define-context sharpsign-single-quote "the function reader macro") + + (define-reporter ((condition end-of-input-after-quote) stream) + (format stream "~@")) + + (define-reporter ((condition object-must-follow-quote) stream) + (format stream "~@")) + +;;; Conditions related to strings + + (define-reporter ((condition unterminated-string) stream) + ;; Use the DELIMITER slot instead of a fixed character since the + ;; reader macro may have been installed on non-default character. + (format stream "~@" + (delimiter condition))) + + (define-reporter ((condition unterminated-single-escape-in-string) stream) + (format stream "~@" + (escape-char condition))) + +;;; Conditions related to quasiquotation + + (define-reporter ((condition backquote-in-invalid-context) stream) + (format stream "~@" + (context-name (context condition) language))) + + (define-reporter ((condition object-must-follow-backquote) stream) + (format stream "~@")) + + (define-reporter ((condition end-of-input-after-backquote) stream) + (format stream "~@")) + + (define-reporter ((condition unquote-not-inside-backquote) stream) + (format stream "~@<~:[Unquote~;Splicing unquote~] not inside backquote.~@:>" + (splicing-p condition))) + + (define-reporter ((condition unquote-in-invalid-context) stream) + (format stream "~@<~:[Unquote~;Splicing unquote~] is illegal in ~A.~@:>" + (splicing-p condition) + (context-name (context condition) language))) + + (define-reporter ((condition end-of-input-after-unquote) stream) + (format stream "~@" + (splicing-p condition))) + + (define-reporter ((condition object-must-follow-unquote) stream) + (format stream "~@" + (splicing-p condition))) + + (define-reporter ((condition unquote-splicing-in-dotted-list) stream) + (format stream "~@")) + + (define-reporter ((condition unquote-splicing-at-top) stream) + (format stream "~@")) + +;;; Conditions related to lists + + (define-reporter ((condition unterminated-list) stream) + ;; Use the DELIMITER slot instead of a fixed character since the + ;; reader macro may have been installed on a non-default + ;; character. + (format stream "~@" + (delimiter condition))) + + (define-reporter ((condition too-many-dots) stream) + (format stream "~@")) + + (define-reporter ((condition invalid-context-for-consing-dot) stream) + (format stream "~@")) + + (define-reporter ((condition end-of-input-after-consing-dot) stream) + (format stream "~@")) + + (define-reporter ((condition object-must-follow-consing-dot) stream) + (format stream "~@")) + + (define-reporter ((condition multiple-objects-following-consing-dot) stream) + (format stream "~@")) + + (define-reporter ((condition invalid-context-for-right-parenthesis) stream) + (format stream "~@" + (found-character condition) + (expected-character condition))) + +;;; Conditions related SHARPSIGN-SINGLE-QUOTE + + (define-reporter ((condition end-of-input-after-sharpsign-single-quote) stream) + (format stream "~@")) + + (define-reporter ((condition object-must-follow-sharpsign-single-quote) stream) + (format stream "~@")) + +;;; Conditions related to read-time evaluation + + (define-reporter ((condition end-of-input-after-sharpsign-dot) stream) + (format stream "~@")) + + (define-reporter ((condition object-must-follow-sharpsign-dot) stream) + (format stream "~@")) + + (define-reporter ((condition read-time-evaluation-inhibited) stream) + (format stream "~@" + '*read-eval*)) + + (define-reporter ((condition read-time-evaluation-error) stream) + (let ((expression (expression condition)) + (original-condition (original-condition condition))) + (format stream "~@" + expression (type-of original-condition) original-condition))) + +;;; Conditions related to characters + + (define-reporter ((condition end-of-input-after-backslash) stream) + (format stream "~@")) + + (define-reporter ((condition unterminated-single-escape-in-character-name) stream) + (format stream "~@" + (escape-char condition))) + + (define-reporter ((condition unterminated-multiple-escape-in-character-name) stream) + (format stream "~@" + (delimiter condition))) + + (define-reporter ((condition unknown-character-name) stream) + (format stream "~@" (name condition))) + +;;; Conditions related to rational numbers + + (define-reporter ((condition end-of-input-before-digit) stream) + (format stream "~@" + (base condition))) + + (define-reporter ((condition digit-expected) stream) + (format stream "~@" + (character-found condition) (base condition))) + + (define-reporter ((condition zero-denominator) stream) + (format stream "~@")) + + (define-reporter ((condition invalid-radix) stream) + (format stream "~@<~D is too ~:[big~;small~] to be a radix.~@:>" + (radix condition) (< (radix condition) 2))) + + (define-reporter ((condition invalid-default-float-format) stream) + (format stream "~@<~:[A floating-point number without exponent ~ + marker~;The exponent marker ~:*~A~] cannot be used ~ + since the value of ~A is ~A which is not valid.~@:>" + (exponent-marker condition) + 'cl:*read-default-float-format* + (float-format condition))) + +;;; Conditions related to block comments + + (define-reporter ((condition unterminated-block-comment) stream) + ;; Use the DELIMITER slot instead of a fixed character since the + ;; reader macro may have been installed on non-default (sub-) + ;; character. + (let ((delimiter-1 (delimiter condition)) + (delimiter-2 #\#)) + (format stream "~@" + (string delimiter-1) (string delimiter-2) + delimiter-1 delimiter-2))) + +;;; Conditions related to arrays + + (define-context sharpsign-a "the general array reader macro") + + (define-reporter ((condition end-of-input-after-sharpsign-a) stream) + (format stream "~@")) + + (define-reporter ((condition object-must-follow-sharpsign-a) stream) + (format stream "~@")) + + (define-reporter ((condition unterminated-vector) stream) + ;; Use the DELIMITER slot instead of a fixed character since the + ;; reader macro may have been installed on a non-default + ;; character. + (format stream "~@" + (delimiter condition))) + + (define-reporter ((condition too-many-elements) stream) + (format stream "~@<~a was specified to have length ~D, but ~D ~ + element~:P ~:*~[were~;was~:;were~] found.~@:>" + (array-type condition) + (expected-number condition) + (number-found condition))) + + (define-reporter ((condition no-elements-found) stream) + (format stream "~@<~A was specified to have length ~D, but no ~ + elements were found.~@:>" + (array-type condition) (expected-number condition))) + + (define-reporter ((condition incorrect-initialization-length) stream) + (format stream "~@<~A was specified to have length ~D along the ~:R ~ + axis, but provided initial-contents don't ~ + match:~%~A~@:>" + (array-type condition) + (expected-length condition) + (1+ (axis condition)) + (datum condition))) + +;;; Sharpsign C conditions + + (define-context sharpsign-c "the complex reader macro") + + (define-reporter ((condition end-of-input-after-sharpsign-c) stream) + (format stream "~@")) + + (define-reporter ((condition complex-parts-must-follow-sharpsign-c) stream) + (format stream "~@")) + + (define-reporter ((condition non-list-following-sharpsign-c) stream) + (format stream "~@")) + + (define-reporter ((condition end-of-input-before-complex-part) stream) + (format stream "~@" + (which condition))) + + (define-reporter ((condition complex-part-expected) stream) + (format stream "~@" + (which condition))) + + (define-reporter ((condition too-many-complex-parts) stream) + (format stream "~@")) + +;;; Sharpsign S conditions + + (define-context sharpsign-s "the structure literal reader macro") + (define-context sharpsign-s-type "the structure type name in the structure literal reader macro") + (define-context sharpsign-s-slot-name "a structure slot name in the structure literal reader macro") + (define-context sharpsign-s-slot-value "a structure slot value in the structure literal reader macro") + + (define-reporter ((condition end-of-input-after-sharpsign-s) stream) + (format stream "~@")) + + (define-reporter ((condition structure-constructor-must-follow-sharpsign-s) stream) + (format stream "~@")) + + (define-reporter ((condition non-list-following-sharpsign-s) stream) + (format stream "~@")) + + (define-reporter ((condition end-of-input-before-structure-type-name) stream) + (format stream "~@")) + + (define-reporter ((condition no-structure-type-name-found) stream) + (format stream "~@")) + + (define-reporter ((condition structure-type-name-is-not-a-symbol) stream) + (format stream "~@<~S should designate a structure type but is not a ~ + symbol.~@:>" + (type-error-datum condition))) + + (define-reporter ((condition end-of-input-before-slot-name) stream) + (format stream "~@")) + + (define-reporter ((condition slot-name-is-not-a-string-designator) stream) + (format stream "~@<~S should designate a structure slot but is ~ + neither a symbol, nor a string nor a character.~@:>" + (type-error-datum condition))) + + (define-reporter ((condition end-of-input-before-slot-value) stream) + (format stream "~@" + (slot-name condition))) + + (define-reporter ((condition no-slot-value-found) stream) + (format stream "~@" + (slot-name condition))) + +;;; Conditions related to pathnames + + (define-context sharpsign-p "the pathname reader macro") + + (define-reporter ((condition end-of-input-after-sharpsign-p) stream) + (format stream "~@")) + + (define-reporter ((condition namestring-must-follow-sharpsign-p) stream) + (format stream "~@")) + + (define-reporter ((condition non-string-following-sharpsign-p) stream) + (format stream "~@<~S should be a namestring but is not a ~S.~@:>" + (type-error-datum condition) + (type-error-expected-type condition))) + +;;; Conditions related to feature expressions + + (define-context :sharpsign-plus "the #+ conditionalization reader macro") + (define-context :sharpsign-minus "the #- conditionalization reader macro") + + (define-reporter ((condition end-of-input-after-sharpsign-plus-minus) + stream language) + (format stream "~@" + (context-name (context condition) language))) + + (define-reporter ((condition feature-expression-must-follow-sharpsign-plus-minus) + stream language) + (format stream "~@" + (context-name (context condition) language))) + + (define-reporter ((condition feature-expression-type-error) stream language) + (format stream "~@" + (type-error-datum condition) + (type-error-expected-type condition))) + + (define-reporter ((condition single-feature-expected) stream language) + (let ((features (features condition))) + (format stream "~@" + (length features) features))) + + (define-reporter ((condition end-of-input-after-feature-expression) + stream language) + (format stream "~@" + (context-name (context condition) language))) + + (define-reporter ((condition object-must-follow-feature-expression) + stream language) + (format stream "~@" + (context-name (context condition) language))) + +;;; SHARPSIGN-{EQUALS,SHARPSIGN} conditions + + (define-reporter ((condition end-of-input-after-sharpsign-equals) stream) + (format stream "~@")) + + (define-reporter ((condition object-must-follow-sharpsign-equals) stream) + (format stream "~@")) + + (define-reporter ((condition sharpsign-equals-label-defined-more-than-once) stream) + (format stream "~@