snail (empty) → 0.1.0.0

raw patch · 25 files changed

+1580/−0 lines, 25 filesdep +HUnitdep +QuickCheckdep +base

Dependencies added: HUnit, QuickCheck, base, containers, hspec, hspec-discover, megaparsec, mtl, raw-strings-qq, snail, text, text-display

Files

• LICENSE +21/−0
• README.md +90/−0
• snail-files/basic.snail +24/−0
• snail-files/fail-comment.snail +1/−0
• snail-files/fail-empty.snail +0/−0
• snail-files/fail-nil.snail +5/−0
• snail-files/fail-quotes-2.snail +1/−0
• snail-files/fail-quotes-3.snail +1/−0
• snail-files/fail-quotes.snail +1/−0
• snail-files/fail.snail +3/−0
• snail-files/nil.snail +1/−0
• snail.cabal +94/−0
• src/Snail.hs +8/−0
• src/Snail/Characters.hs +25/−0
• src/Snail/IO.hs +13/−0
• src/Snail/Lexer.hs +158/−0
• src/Snail/ToText.hs +15/−0
• test/Gen.hs +12/−0
• test/Snail/IOSpec.hs +53/−0
• test/Snail/LexerSpec.hs +146/−0
• test/Snail/ToTextSpec.hs +34/−0
• test/Spec.hs +3/−0
• test/files/fennel-reference.fnl +382/−0
• test/files/learnxyz.cl +129/−0
• test/files/r5rs_pitfalls.scm +360/−0

@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2023 Barry Moore II++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

@@ -0,0 +1,90 @@+# Snail++A no-semantics programming language for gastropods.++## Why?++My colleagues and I are going to start working through [Types and Progamming+Languages][tapl]. In the book you implement languages of varying feature sets.+The book implements these languages in OCaml, however I had this Lisp parser+essentially ready for awhile. There are a handful of "Write you a Scheme+Interpreters"-like tutorials and they all use a parser relatively similar to+this one. However, there are some pretty subtle issues with most of the ones I+have seen. For example, the two examples below parse as two lexemes in a lot of+examples. Even Haskell's parser has [this issue][haskell-parse-issue]!++```+(1a)+(1 a)+```++## Is this really a programming language?++From the ["Programming language" wikipedia page][pl-wikipedia],++> A programming language is a system of notation for writing computer programs.++> The description of a programming language is usually split into the two components of syntax (form) and semantics (meaning)++Snail is used for writing interpreters or compilers. However, it doesn't define+**any** semantics. So, maybe?++## Syntax (form)++Snail describes valid lexemes, text literals, and s-expressions. The valid+lexemes are approximately from R5RS Scheme but this may change in the future.+We also use Haskell's line and block comments. Here is a valid snail program,++```+-- Prints `hello "world"` to the console+(print "hello \"world\"")++-- Prints 3 to the console+(print (+ 1 2))++{-+  Defines a function to add two numbers+  Applies the function to generate 3+  Prints 3 to the console+-}+(let+  (f (lambda (x y) (+ x y)))+  (print (f 2 1)))++(quote hello)++(nil)++(print true)++(print false)++-- end comment+```++Reminder, this program has no semantics. It is your job to take Snail's+Abstract Syntax Tree (AST) and define the semantics of an interpreter or+compiler.++## Getting the AST++You can see some examples in `test/Snail/IOSpec.hs`, but you can put your snail+program into some file, let's say `hello.snail`. The following Haskell will print+the AST or print a failure,++```haskell+module Main where++import Snail++main :: IO ()+main = do+  eResults <- readSnailFile "./hello.snail"+  case eResults of+    Right ast -> print ast+    Left failureString -> print failureString+```++[tapl]: https://www.cis.upenn.edu/~bcpierce/tapl+[haskell-parse-issue]: https://twitter.com/chiroptical/status/1471568781906518018+[pl-wikipedia]: https://en.wikipedia.org/wiki/Programming_language

@@ -0,0 +1,24 @@+-- Prints `hello "world"` to the console+(print "hello \"world\"")++-- Prints 3 to the console+(print (+ 1 2))++{-+  Defines a function to add two numbers+  Applies the function to generate 3+  Prints 3 to the console+-}+(let+  (f (lambda (x y) (+ x y)))+  (print (f 2 1)))++(quote hello)++(nil)++(print true)++(print false)++-- end comment

@@ -0,0 +1,1 @@+{- ...

@@ -0,0 +1,5 @@+()++nil++()

@@ -0,0 +1,1 @@+(print "hello """)

@@ -0,0 +1,1 @@+(print """")

@@ -0,0 +1,1 @@+(print "hello "world"")

@@ -0,0 +1,3 @@+(let+  (f (lambda (x y) (+ x y)))+  (print (f 2 1))

@@ -0,0 +1,1 @@+nil

@@ -0,0 +1,94 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name:           snail+version:        0.1.0.0+synopsis:       A programming language with no semantics+description:    An s-expression parser and abstract syntax tree for a programming language with no semantics. If you wanted to write an interpreter or compiler you convert the AST into your own.+category:       Parsing+homepage:       https://github.com/chiroptical/snail#readme+bug-reports:    https://github.com/chiroptical/snail/issues+author:         Barry Moore II+maintainer:     chiroptical@gmail.com+copyright:      Barry Moore II+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+data-files:+    snail-files/basic.snail+    snail-files/fail-comment.snail+    snail-files/fail-empty.snail+    snail-files/fail-nil.snail+    snail-files/fail-quotes-2.snail+    snail-files/fail-quotes-3.snail+    snail-files/fail-quotes.snail+    snail-files/fail.snail+    snail-files/nil.snail+    test/files/fennel-reference.fnl+    test/files/learnxyz.cl+    test/files/r5rs_pitfalls.scm++source-repository head+  type: git+  location: https://github.com/chiroptical/snail++library+  exposed-modules:+      Snail+      Snail.Characters+      Snail.IO+      Snail.Lexer+      Snail.ToText+  other-modules:+      Paths_snail+  hs-source-dirs:+      src+  default-extensions:+      ImportQualifiedPost+      LambdaCase+      OverloadedStrings+  build-depends:+      QuickCheck >=2.14.3 && <2.15+    , base >=4.15 && <5+    , containers >=0.6.7 && <0.7+    , megaparsec >=9.3.1 && <9.4+    , mtl >=2.2.2 && <2.3+    , text >=2.0.2 && <2.1+    , text-display >=0.0.5 && <0.1+  default-language: Haskell2010++test-suite snail-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Gen+      Snail.IOSpec+      Snail.LexerSpec+      Snail.ToTextSpec+      Paths_snail+  hs-source-dirs:+      test+  default-extensions:+      ImportQualifiedPost+      LambdaCase+      OverloadedStrings+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      HUnit >=1.6.2 && <1.7+    , QuickCheck >=2.14.3 && <2.15+    , base >=4.15 && <5+    , containers >=0.6.7 && <0.7+    , hspec >=2.10.10 && <2.11+    , hspec-discover >=2.10.10 && <2.11+    , megaparsec >=9.3.1 && <9.4+    , mtl >=2.2.2 && <2.3+    , raw-strings-qq ==1.1.*+    , snail+    , text >=2.0.2 && <2.1+    , text-display >=0.0.5 && <0.1+  default-language: Haskell2010

@@ -0,0 +1,8 @@+module Snail (+    module X,+) where++import Snail.Characters as X+import Snail.IO as X+import Snail.Lexer as X+import Snail.ToText as X

@@ -0,0 +1,25 @@+module Snail.Characters where++-- | The initial character of any text+initialCharacter :: String+initialCharacter = ['a' .. 'z'] <> ['A' .. 'Z']++-- | ...+specialInitialCharacter :: String+specialInitialCharacter = "!$%&*/:<=>?^_~#,'"++-- | ...+peculiarCharacter :: String+peculiarCharacter = "+-."++-- | ...+digitCharacter :: String+digitCharacter = ['0' .. '9']++-- | ...+specialSubsequentCharacter :: String+specialSubsequentCharacter = "+-.@\\"++-- | ...+parenthesisStartingCharacter :: String+parenthesisStartingCharacter = "'`@#,"

@@ -0,0 +1,13 @@+module Snail.IO where++import Data.Text.IO qualified as Text+import Snail.Lexer+import Text.Megaparsec++-- | Given a 'FilePath', attempt to parse 'SnailAst' from a file.+readSnailFile :: FilePath -> IO (Either String [SnailAst])+readSnailFile fp = do+    contents <- Text.readFile fp+    pure $ case parse snailAst (show fp) contents of+        Left parseErrorBundle -> Left $ errorBundlePretty parseErrorBundle+        Right sexprs -> Right sexprs

@@ -0,0 +1,158 @@+{-+  Definitions++  * Lexer: `Text -> [Text]`+  * Token: The leaves in your AST, e.g. TextLiteral, Number, etc++  Here, we implement a structurally aware lexer that supports one token type+  (text literals) for convenience.+-}+module Snail.Lexer (+    -- * The parsers you should use+    SnailAst (..),+    sExpression,+    snailAst,++    -- * Exported for testing+    nonQuoteCharacter,+    textLiteral,+) where++import Data.Text (Text)+import Data.Text qualified as Text+import Data.Void+import Snail.Characters+import Text.Megaparsec hiding (token)+import Text.Megaparsec.Char+import Text.Megaparsec.Char.Lexer qualified as L++-- | TODO: 'Void' is the error type but we should use an explicit error type+type Parser = Parsec Void Text++{- | Megaparsec's 'skipLineComment' takes a prefix and skips lines that begin+ with that prefix+-}+skipLineComment :: Parser ()+skipLineComment = L.skipLineComment "--"++{- | Megaparsec's 'skipBlockComment' takes prefix and suffix and skips anything+ in between+-}+skipBlockComment :: Parser ()+skipBlockComment = L.skipBlockCommentNested "{-" "-}"++{- | Generate a parser for whitespace in a language with 'skipLineComment' and+ 'skipBlockComment'+-}+spaces :: Parser ()+spaces = L.space space1 skipLineComment skipBlockComment++-- | Parse a 'Text' verbatim+symbol :: Text -> Parser Text+symbol = L.symbol spaces++-- | Parse an S-Expression+parens :: Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++{- | The list of valid token characters, note that we allow invalid tokens at+ this point+-}+validCharacter :: Parser Char+validCharacter =+    oneOf+        ( initialCharacter+            <> specialInitialCharacter+            <> digitCharacter+            <> specialSubsequentCharacter+        )++{-+    A possibly empty tree of s-expressions++    Technically,+    @+    Token (SourcePos {..}, "hello")+    @++    isn't a valid s-expression. This is,++    @+    SExpression [Token (SourcePos {..}, "hello")]+    @++    and this is also valid,++    @+    SExpression []+    @++    The 'Data.Tree.Tree' type in containers is non-empty which isn't exactly what we are looking for+-}+data SnailAst+    = Lexeme (SourcePos, Text)+    | TextLiteral (SourcePos, Text)+    | SExpression (Maybe Char) [SnailAst]+    deriving (Eq, Show)++{- | Any 'Text' object that starts with an appropriately valid character. This+ could be an variable or function name. For example, `hello` is a valid+ lexeme in the s-expression below.++ @+ (hello)+ @+-}+lexeme :: Parser SnailAst+lexeme = do+    sourcePosition <- getSourcePos+    lexeme' <- some validCharacter+    pure $ Lexeme (sourcePosition, Text.pack lexeme')++-- | An escaped quote to support nesting `"` inside a 'textLiteral'+escapedQuote :: Parser Text+escapedQuote = string "\\\""++-- | Matches any non-quote character+nonQuoteCharacter :: Parser Text+nonQuoteCharacter = do+    character <- anySingleBut '\"'+    pure $ Text.singleton character++quote :: Parser Char+quote = char '\"'++quotes :: Parser a -> Parser a+quotes = between quote quote++{- | Matches a literal text and supports nested quotes, e.g.++ @+ ("hello\"")+ @+-}+textLiteral :: Parser SnailAst+textLiteral = do+    sourcePosition <- getSourcePos+    mText <- quotes . optional $ some $ escapedQuote <|> nonQuoteCharacter+    notFollowedBy (validCharacter <|> char '\"')+    pure $ case mText of+        Nothing -> TextLiteral (sourcePosition, "")+        Just text -> TextLiteral (sourcePosition, Text.concat text)++{- | Parse one of the possible structures in 'SnailAst'. These are parsed+ recursively separated by 'spaces' in 'sExpression'.+-}+leaves :: Parser SnailAst+leaves = lexeme <|> textLiteral <|> sExpression++-- | Parse an 'SExpression'+sExpression :: Parser SnailAst+sExpression =+    SExpression+        <$> optional (oneOf parenthesisStartingCharacter)+        <*> parens (leaves `sepEndBy` spaces)++-- | Parse a valid snail file+snailAst :: Parser [SnailAst]+snailAst = (spaces *> sExpression `sepEndBy1` spaces) <* eof

@@ -0,0 +1,15 @@+module Snail.ToText (toText) where++import Data.Text+import Snail.Lexer++toText :: SnailAst -> Text+toText = \case+    TextLiteral (_, txt) -> "\"" <> txt <> "\""+    Lexeme (_, lexeme) -> lexeme+    SExpression Nothing exprs ->+        let txt = Data.Text.unwords $ toText <$> exprs+         in "(" <> txt <> ")"+    SExpression (Just c) exprs ->+        let txt = Data.Text.unwords $ toText <$> exprs+         in singleton c <> "(" <> txt <> ")"

@@ -0,0 +1,12 @@+module Gen where++import Data.Text (Text)+import Data.Text qualified as T+import Test.QuickCheck++-- | TODO: Should define the list of characters allowed in symbols in Snail somewhere+genValidSymbolChar :: Gen Char+genValidSymbolChar = elements ['a' .. 'z']++genSymbol :: Gen Text+genSymbol = T.pack <$> listOf genValidSymbolChar

@@ -0,0 +1,53 @@+module Snail.IOSpec where++import Data.Either+import Snail+import Test.Hspec++spec :: Spec+spec = do+    describe "successfully lexes some basic snail files" $ do+        it "lex a basic snail file" $ do+            eResults <- readSnailFile "snail-files/basic.snail"+            eResults `shouldSatisfy` isRight++        it "lex an empty snail file" $ do+            eResults <- readSnailFile "snail-files/fail-empty.snail"+            eResults `shouldSatisfy` isLeft++        it "lex should fail with bad comment" $ do+            eResults <- readSnailFile "snail-files/fail-comment.snail"+            eResults `shouldSatisfy` isLeft++        it "lex should fail with non-terminated s-expression" $ do+            eResults <- readSnailFile "snail-files/fail.snail"+            eResults `shouldSatisfy` isLeft++        it "lex should fail with non-escaped quote" $ do+            eResults <- readSnailFile "snail-files/fail-quotes.snail"+            eResults `shouldSatisfy` isLeft++        it "lex should fail with non-escaped quote 2" $ do+            eResults <- readSnailFile "snail-files/fail-quotes-2.snail"+            eResults `shouldSatisfy` isLeft++        it "lex should fail with non-escaped quote 3" $ do+            eResults <- readSnailFile "snail-files/fail-quotes-3.snail"+            eResults `shouldSatisfy` isLeft++        it "lex should fail on naked nil" $ do+            eResults <- readSnailFile "snail-files/fail-nil.snail"+            eResults `shouldSatisfy` isLeft++    describe "successfully lexes some examples from other languages" $ do+        it "lexes a basic scheme file with converted comments" $ do+            eResults <- readSnailFile "./test/files/r5rs_pitfalls.scm"+            eResults `shouldSatisfy` isRight++        it "lexes a basic fennel file with converted comments" $ do+            eResults <- readSnailFile "./test/files/fennel-reference.fnl"+            eResults `shouldSatisfy` isRight++        it "lexes a basic common lisp file with converted comments" $ do+            eResults <- readSnailFile "./test/files/learnxyz.cl"+            eResults `shouldSatisfy` isRight

@@ -0,0 +1,146 @@+{-# LANGUAGE QuasiQuotes #-}++module Snail.LexerSpec (spec) where++import Data.Maybe (isJust, isNothing)+import Data.Text+import Snail+import Test.HUnit (assertBool)+import Test.Hspec+import Text.Megaparsec (parseMaybe)+import Text.RawString.QQ++foldLexemes :: SnailAst -> [Text]+foldLexemes = go []+  where+    go :: [Text] -> SnailAst -> [Text]+    go acc (Lexeme (_, t)) = acc ++ [t]+    go acc (TextLiteral (_, t)) = acc ++ [t]+    go acc (SExpression _ []) = acc+    go acc (SExpression _ (x : xs)) = lgo (go acc x) xs+    lgo :: [Text] -> [SnailAst] -> [Text]+    lgo acc [] = acc+    lgo acc (x : xs) = lgo (go acc x) xs++failAssertion :: String -> Expectation+failAssertion s = assertBool s False++sExpressionShouldBe :: Text -> [Text] -> Expectation+sExpressionShouldBe input output =+    case parseMaybe sExpression input of+        Nothing -> failAssertion "sExpressionShouldBe: Nothing"+        Just sExpr -> do+            let lexemes = foldLexemes sExpr+            lexemes `shouldBe` output++textLiteralShouldBe :: Text -> [Text] -> Expectation+textLiteralShouldBe input output =+    case parseMaybe textLiteral input of+        Nothing -> failAssertion "textLiteralShouldBe: Nothing"+        Just sExpr -> do+            let lexemes = foldLexemes sExpr+            lexemes `shouldBe` output++spec :: Spec+spec = do+    describe "non quote character" $ do+        it "handles spaces properly" $ do+            let mSExpr = parseMaybe nonQuoteCharacter " "+            mSExpr `shouldBe` Just " "++    describe "parse text literals" $ do+        it "successfully parses a basic text literal" $ do+            [r|"hello \"world"|] `textLiteralShouldBe` [[r|hello \"world|]]++        it "successfully parses a text literal with leading/trailing quotes" $ do+            [r|"\"hello \"world\""|] `textLiteralShouldBe` [[r|\"hello \"world\"|]]++        it "fails to lex text literal with unescaped quote" $ do+            let mSExpr = parseMaybe textLiteral [r|"hello "world"|]+            mSExpr `shouldSatisfy` isNothing++        it "can parse the empty string" $ do+            [r|""|] `textLiteralShouldBe` [""]++        it "can parse whitespace" $ do+            [r|" "|] `textLiteralShouldBe` [" "]++        it "can parse more whitespace" $ do+            [r|"    "|] `textLiteralShouldBe` ["    "]++    describe "parse sExpression" $ do+        it "successfully lex a basic list" $ do+            "(a b c)" `sExpressionShouldBe` ["a", "b", "c"]++        it "successfully parse nil inside parentheses" $ do+            "(nil)" `sExpressionShouldBe` ["nil"]++        it "fail to parse a standalone nil" $ do+            let mSExpr = parseMaybe sExpression "nil"+            mSExpr `shouldSatisfy` isNothing++        it "successfully lex a basic list" $ do+            "(1 a)" `sExpressionShouldBe` ["1", "a"]++        it "successfully lex a basic list with starting character" $ do+            "'(1 a)" `sExpressionShouldBe` ["1", "a"]++        it "successfully lex a single element list" $ do+            "(1a)" `sExpressionShouldBe` ["1a"]++        it "successfully lex a nested s-expression" $ do+            "((1a))" `sExpressionShouldBe` ["1a"]++        it "successfully lex nested s-expressions" $ do+            "(() ())" `sExpressionShouldBe` []++        it "successfully lex a nested s-expressions" $ do+            "((()) (()))" `sExpressionShouldBe` []++        it "successfully lex line comment" $ do+            "(-- ...\n)" `sExpressionShouldBe` []++        it "successfully lex line comment followed by token" $ do+            "(-- ...\nabc)" `sExpressionShouldBe` ["abc"]++        it "successfully lex line comment with \r\n followed by token" $ do+            "(-- ...\r\nabc)" `sExpressionShouldBe` ["abc"]++        it "successfully lex line comment with \t followed by token" $ do+            "(-- ...\n\tabc)" `sExpressionShouldBe` ["abc"]++        it "successfully lex line comment with \v followed by token" $ do+            "(-- ...\n\vabc)" `sExpressionShouldBe` ["abc"]++        it "successfully lex block comment" $ do+            "({- ... -})" `sExpressionShouldBe` []++        it "successfully lex block comment followed by token" $ do+            "({- ... -}abc)" `sExpressionShouldBe` ["abc"]++        it "successfully lex token followed by block comments" $ do+            "(abc{- ... -})" `sExpressionShouldBe` ["abc"]++        it "successfully lex block comments sorrounded by tokens" $ do+            "(abc{- ... -}def)" `sExpressionShouldBe` ["abc", "def"]++        it "successfully lex nested block comments" $ do+            "({- ... {- ... -} ... -})" `sExpressionShouldBe` []++        it "fail to lex nested block comments with missing internal start" $ do+            parseMaybe sExpression "({- ... -} ... -})" `shouldBe` Nothing++        it "fail to lex nested block comments with missing internal stop" $ do+            parseMaybe sExpression "({- ... {- ... -})" `shouldBe` Nothing++        it "fail to lex block comment with missing stop" $ do+            parseMaybe sExpression "({- ...)" `shouldBe` Nothing++        it "can handle subsequent s-expressions" $ do+            parseMaybe snailAst "()(nil)()" `shouldSatisfy` isJust++        it "fails to parse nested naked nil" $ do+            parseMaybe snailAst "()nil()" `shouldSatisfy` isNothing++        it "handles successive text literals" $ do+            [r|("hello" " " "world" "!!!")|] `sExpressionShouldBe` ["hello", " ", "world", "!!!"]

@@ -0,0 +1,34 @@+{-# LANGUAGE QuasiQuotes #-}++module Snail.ToTextSpec (spec) where++import Snail+import Test.Hspec+import Text.Megaparsec+import Text.RawString.QQ++spec :: Spec+spec = do+    describe "toText" $ do+        it "handles empty s-expression" $+            toText (SExpression Nothing []) `shouldBe` "()"+        it "handles basic text literal" $+            toText (SExpression Nothing [TextLiteral (sourcePos, "hello world")])+                `shouldBe` [r|("hello world")|]+        it "handles basic lexeme" $+            toText+                ( SExpression+                    Nothing+                    [ Lexeme (sourcePos, "hello")+                    , Lexeme (sourcePos, "world")+                    ]+                )+                `shouldBe` [r|(hello world)|]++sourcePos :: SourcePos+sourcePos =+    SourcePos+        { sourceName = "..."+        , sourceLine = mkPos 1+        , sourceColumn = mkPos 1+        }

@@ -0,0 +1,3 @@+-- Searches for files that end in Spec.hs that contain a 'spec' function and runs the tests+-- See https://hspec.github.io/hspec-discover.html for more information+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

@@ -0,0 +1,382 @@+(fn pxy (x y)+  (print (+ x y)))++(local functions ())++(fn functions.p (x y z)+  (print '(* x (+ y z))))++(lambda (x ?y z)+  (print (- x (* (or ?y 1) z))))++(fn pxy (x y)+  "Print the sum of x and y"+  (print (+ x y)))++(lambda pxyz (x ?y z)+  "Print the sum of x, y, and z. If y is not provided, defaults to 0."+  (print (+ x (or ?y 0) z)))++(fn add (...)+  (:fnl/docstring "Add arbitrary amount of numbers."+   :fnl/arglist (a b & more)(+  (match (values (select :# ...) ...)+    (0) 0+    (1 a) a+    (2 a b) (+ a b)+    (_ a b) (add (+ a b) (select 3 ...))))))++(fn (a b) (+ a b))++(hashfn (+ $1 $2))++(partial (fn (x y) (print (+ x y))) 2)++(let (x 89+      y 198)+  (print (+ x y 12))) -- => 299++(let ((x y z) (unpack (10 9 8)))+  (+ x y z)) -- => 27++(let ((a b c) (1 2 3))+  (+ a b c)) -- => 6++(let ((a b & c) (1 2 3 4 5 6))+  (table.concat c ",")) -- => "3,4,5,6"++(local t (1 2 3 4 5 6))++(local tau-approx 6.28318)++(match mytable+  59      :will-never-match-hopefully+  (9 q 5) (print :q q)+  (1 a b) @(+ a b))++(match mytable+  (:subtable (a b ?c) :depth depth( (* b depth)+  _ :unknown)))++(match (io.open "/some/file")+  (nil msg) (report-error msg)+  f (read-file f))++(let (x 95)+ (match (52 85 95)+   (b a a) :no -- because a=85 and a=95+   (x y z) :no -- because x=95 and x=52+   (a b x) :yes)) -- a and b are fresh values while x=95 and x=95++(match (91 12 53)+  (where (a b c) (= 5 a)) :will-not-match+  (where (a b c) (= 0 (math.fmod (+ a b c) 2)) (= 91 a)) c) -- -> 53++(match (5 1 2)+  (where `(or (a 3 9) (a 1 2)) (= 5 a)) "Either (5 3 9) or (5 1 2)"+  _ "anything else")++(match (5 1 2)+  (where (a 3 9) (= 5 a)) "Either (5 3 9) or (5 1 2)"+  (where (a 1 2) (= 5 a)) "Either (5 3 9) or (5 1 2)"+  _ "anything else")++-- bad+(match (1 2 3)+  (where (or (a 1 2) (a b 3)) (< a 0) (< b 1))+  :body)++-- ok+(match (1 2 3)+  (where (or (a b 2) (a b 3)) (< a 0) (<= b 1))+  :body)++(match (1 2 3)+  (where (a 2 3) (< 0 a)) "new guard syntax"+  ((a 2 3) ? (< 0 a)) "obsolete guard syntax")++(fn handle (conn)+  (match-try (conn:receive :*l)+    input (parse input)+    (command-name params) (commands.get command-name)+    command ,(pcall command (table.unpack params))+    (catch+     (_ :timeout) nil+     (_ :closed) (pcall disconnect conn "connection closed")+     (_ msg) (print "Error handling input" msg))))++(var x 83)++(set x (+ x 91))++(let (x (values 1 2 3))+  x) -- => 1++(let ((file-handle message code) (io.open "foo.blah"))+  message) -- => "foo.blah: No such file or directory"++(do (local (_ _ z) (unpack (:a :b :c :d :e))) z) -- => c++-- Basic usage+(with-open (fout (io.open :output.txt :w) fin (io.open :input.txt))+  (fout:write "Here is some text!\n")+  ((fin:lines))) -- => first line of input.txt++-- This demonstrates that the file will also be closed upon error.+(var fh nil)+(local (ok err)+  (pcall #(with-open (file (io.open :test.txt :w))+            (set fh file) -- you would normally never do this+            (error :whoops!))))+(io.type fh) -- => "closed file"+(ok err)     -- => (false "")++(pick-values 2 (func))++(let ((_0_ _1_) (func)) (values _0_ _1_))++(pick-values 0 :a :b :c :d :e) -- => nil+((pick-values 2 (table.unpack (:a :b :c)))) ---> ("a" "b")++(fn add (x y ...) (let (sum (+ (or x 0) (or y 0)))+                        (if (= (select :# ...) 0) sum (add sum ...))))++(add (pick-values 2 10 10 10 10)) -- => 20+(->> (1 2 3 4 5) (table.unpack) (pick-values 3) (add)) -- => 6++(select :# (pick-values 5 "one" "two")) -- => 5+((pick-values 5 "one" "two"))           -- => ("one" "two")++(let (x (math.random 64))+  (if (= 0 (% x 10))+      "multiple of ten"+      (= 0 (% x 2))+      "even"+      "I dunno, something else"))++(when launch-missiles?+  (power-on)+  (open-doors)+  (fire))++(each (key value (pairs mytbl))+  (print "executing key")+  (print (f value)))++(local out ())+(each (_ value (pairs tbl) &until (< max-len (length out)))+  (table.insert out value))++(for (i 1 10 2)+  (log-number i)+  (print i))++(var x 0)+(for (i 1 128 &until (maxed-out? x))+  (set x (+ x i)))++(var done? false)+(while (not done?)+  (print :not-done)+  (when (< 0.95 (math.random))+    (set done? true)))++(if launch-missiles?+    (do+      (power-on)+      (open-doors)+      (fire))+    false-alarm?+    (promote lt-petrov))++-- TODO: This should work...+-- (.. "Hello" " " "world" 7 "!!!") -- => "Hello world7!!!"++(+ (length (1 2 3 nil 8)) (length "abc")) -- => 6 or 8++(. mytbl myfield)++(let (t (:a (2 3 4)() (. t :a 2)))) -- => 3++(?. mytbl myfield)++(icollect (_ v (ipairs (1 2 3 4 5 6)))+  (if (> v 2) (* v v)))+-- -> (9 16 25 36)++-- equivalent to:+(let (tbl ())+  (each (_ v (ipairs (1 2 3 4 5 6)))+    (tset tbl (+ (length tbl) 1) (if (> v 2) (* v v))))+  tbl)++(collect (k v (pairs (:apple "red" :orange "orange" :lemon "yellow"())+  (if (not= k "yellow")+      (values (.. "color-" v) k)))))+-- -> (:color-orange "orange" :color-red "apple"(++-- equivalent to:+(let (tbl (()+  (each (k v (pairs (:apple "red" :orange "orange"())+    (if (not= k "yellow")+      (match (values (.. "color-" v) k)+        (key value) (tset tbl key value))))+  tbl)))))++(collect (k v (pairs (:a 85 :b 52 :c 621 :d 44())+  k (* v 5))))++(icollect (_ x (ipairs (2 3)) &into (9))+  (* x 11))+-- -> (9 22 33)++(accumulate (sum 0+             i n (ipairs (10 20 30 40)))+    (+ sum n)) -- -> 100++(faccumulate (n 0 i 1 5) (+ n i)) -- => 15++(#(faccumulate (n 1 i 1 $) (* n i)) 5) -- => 120 (factorial!)++(fcollect (i 0 10 2)+  (if (> i 2) (* i i)))+-- -> (16 36 64 100)++-- equivalent to:+(let (tbl (()+  (for (i 0 10 2)+    (if (> i 2)+        (table.insert tbl (* i i))))+  tbl)))++(fn (filename)+  (if (valid-file-name? filename)+      (open-file filename)+      (values nil (.. "Invalid filename: " filename))))++(let (f (assert (io.open "hello" "w")))+  (f:write "world")+  (f:close))++(let (f (assert (io.open "hello" "w"))+      method1 :write+      method2 :close)+  (: f method1 "world")+  (: f method2))++(let (f (assert (io.open "hello" "w")))+  (f.write f "world")+  (f.close f))++(fn t.enable (self)+  (set self.enabled? true))++(t:enable)++(-> 52+    (+ 91 2) -- (+ 52 91 2)+    (- 8)    -- (- (+ 52 91 2) 8)+    (print "is the answer")) -- (print (- (+ 52 91 2) 8) "is the answer")++(doto (io.open "/tmp/err.log")+  (: :write contents)+  (: :close))++-- equivalent to:+(let (x (io.open "/tmp/err.log"))+  (: x :write contents)+  (: x :close)+  x)++(include :my.embedded.module)++(fn when2 (condition body1 ...)+  (assert body1 "expected body")+  (if ,condition+     (do ,body1 ,...)))++(when2 (= 3 (+ 2 a))+  (print "yes")+  (finish-calculation))++(if (= 3 (+ 2 a))+  (do+    (print "yes")+    (finish-calculation)))++(import-macros mine :my-macros)++(mine.when2 (= 3 (+ 2 a))+  (print "yes")+  (finish-calculation))++(local (module-name file-name) ...)+(import-macros mymacros (.. module-name ".macros"))++(import-macros mymacros (.. ... ".macros"))++(local fennel (require :fennel))++(fn my-searcher (module-name)+  (let (filename (.. "src/" module-name ".fnl"))+    (match (find-in-archive filename)+      code (values (partial fennel.eval code (:env :_COMPILER()+                   filename))))))++(table.insert fennel.macro-searchers my-searcher)++(macros (:my-max (fn (x y)+                   (let (x# ,x y# ,y)+                      (if (< x# y#) y# x#)))))()++(print (my-max 10 20))+(print (my-max 20 10))+(print (my-max 20 20))++(macro my-max (x y)+  (let (x# ,x y# ,y)+     (if (< x# y#) y# x#)))++(macrodebug (-> abc+                (+ 99)+                (< 0)+                (when (os.exit))))+-- -> (if (< (+ abc 99) 0) (do (os.exit)))++(var v 1)+(macros (:my-max (fn (x y)+                   (if (< ,x ,y) ,y ,x))))()++(fn f () (set v (+ v 1)) v)++(print (my-max (f) 2)) -- -> 3 since (f) is called twice in the macro body above++(macros (:my-max (fn (x y)+                   (let (x2 ,x y2 ,y)+                      (if (< x2 y2) y2 x2)))))()++(print (my-max 10 20))+-- Compile error in 'x2' unknown:?: macro tried to bind x2 without gensym-- try x2# instead++(fn my-fn () (print "hi!"))++(macros (:my-max (fn (x y)+                   (my-fn)+                   (let (x# ,x y# ,y)+                      (if (< x# y#) y# x#)))))()++-- Compile error in 'my-max': attempt to call global '__fnl_global__my_2dfn' (a nil value)++(eval-compiler+  (each (name (pairs _G))+    (print name)))++(fn find (tbl pred)+  (each (key val (pairs tbl))+    (when (pred val)+      (lua "return key"))))++(let (foo-bar :hello)+  (lua "print(foo_bar .. \" world\")"))++(global prettyprint (fn (x) (print (fennel.view x))))

@@ -0,0 +1,129 @@+(defun meaning (life)+  "Return the computed meaning of LIFE"+  (let ((meh "abc"))+    -- Invoke krakaboom+    (loop :for x :across meh+       :collect x)))++(+ 1 1)                -- => 2+(- 8 1)                -- => 7+(* 10 2)               -- => 20+(expt 2 3)             -- => 8+(mod 5 2)              -- => 1+(/ 35 5)               -- => 7+(/ 1 3)                -- => 1/3+(+ (1 2) (6 -4))++(defstruct dog name breed age)+(defparameter *rover*+    (make-dog :name "rover"+              :breed "collie"+              :age 5))++(cons 'SUBJECT 'VERB)         -- => (SUBJECT . VERB)+(car (cons 'SUBJECT 'VERB))   -- => SUBJECT+(cdr (cons 'SUBJECT 'VERB))++(mapcar #'1+ (1 2 3))             -- => (2 3 4)+(mapcar #'+ (1 2 3) (10 20 30))  -- => (11 22 33)+(remove-if-not #'evenp (1 2 3 4)) -- => (2 4)+(every #'evenp (1 2 3 4))         -- => NIL+(some #'oddp (1 2 3 4))           -- => T+(butlast (subject verb object))++(defparameter *adjvec* (make-array (3) :initial-contents (1 2 3)+                                   :adjustable t :fill-pointer t))++(set-difference (1 2 3 4) (4 5 6 7))   -- => (3 2 1)+(intersection (1 2 3 4) (4 5 6 7))     -- => 4+(union (1 2 3 4) (4 5 6 7))            -- => (3 2 1 4 5 6 7)+(adjoin 4 (1 2 3 4))++(multiple-value-bind (x y)+    (values 1 2)+  (list y x))++(multiple-value-bind (a b)+    (gethash 'd *m*)+  (list a b))++(multiple-value-bind (a b)+    (gethash 'a *m*)+  (list a b))++(funcall (lambda () "Hello World"))   -- => "Hello World"+(funcall #'+ 1 2 3)++(defun hello (name) (format nil "Hello, ~A" name))+(hello "Steve")++(defun generalized-greeter (name &key (from "the world") (honorific "Mx"))+  (format t "Hello, ~A ~A, from ~A" honorific name from))++(equal (list 'a 'b) (list 'a 'b)) -- => T+(equal (list 'a 'b) (list 'b 'a))++(cond ((> 2 2) (error "wrong!"))+      ((< 2 2) (error "wrong again!"))+      (t 'ok))++(defun fact (n)+  (if (< n 2)+      1+    (* n (fact(- n 1)))))+++(defun fact (n)+  (loop :for result = 1 :then (* result i)+     :for i :from 2 :to n+     :finally (return result)))++(fact 5)++(loop :for x :across "abcd" :collect x)++(dolist (i (1 2 3 4))+  (format t "~A" i))++(defclass human-powered-conveyance ()+  ((velocity+    :accessor velocity+    :initarg :velocity)+   (average-efficiency+    :accessor average-efficiency+   :initarg :average-efficiency))+  (:documentation "A human powered conveyance"))++(defclass bicycle (human-powered-conveyance)+  ((wheel-size+    :accessor wheel-size+    :initarg :wheel-size+    :documentation "Diameter of the wheel.")+   (height+    :accessor height+    :initarg :height)))++(defclass recumbent (bicycle)+  ((chain-type+    :accessor chain-type+    :initarg :chain-type)))++(defclass unicycle (human-powered-conveyance) nil)++(defclass canoe (human-powered-conveyance)+  ((number-of-rowers+    :accessor number-of-rowers+    :initarg :number-of-rowers)))++(defmacro while (condition &body body)+    "While `condition` is true, `body` is executed.+`condition` is tested prior to each execution of `body`"+    (let ((block-name (gensym)) (done (gensym)))+        (tagbody+           ,block-name+           (unless ,condition+               (go ,done))+           (progn+           ,@body)+           (go ,block-name)+           ,done)))

@@ -0,0 +1,360 @@+{-+  r5rs_pitfalls.scm+ +  This program attempts to test a Scheme implementation's conformance+  to various subtle edge-cases and consequences of the R5RS Scheme standard.+  Code was collected from public forums, and is hereby placed in the public domain.++  Barry M. Oct 2022: Borrowed from http://code.call-cc.org and modified into a+  snail shell compliant format. Changed:+    - comments to `--` and `{- ... -}`. +    - '() to () because snail doesn't currently support this+    - `() to () because snail doesn't currently support this+-}+(define-syntax should-be+  (syntax-rules ()+    ((_ test-id value expression)+     (let ((return-value expression))+         (if (not (equal? return-value value))+           (for-each (lambda (v) (display v))+                     ("Failure: " test-id ", expected '"+                     value "', got '" ,return-value "'." #\newline))+           (for-each (lambda (v) (display v))+                     ("Passed: " test-id #\newline)))))))++(define call/cc call-with-current-continuation)++{-+  Section 1: Proper letrec implementation++  Credits to Al Petrofsky+  In thread:+  defines in letrec body +  http://groups.google.com/groups?selm=87bsoq0wfk.fsf%40app.dial.idiom.com+-}+(should-be 1.1 0+ (let ((cont #f))+   (letrec ((x (call-with-current-continuation (lambda (c) (set! cont c) 0)))+            (y (call-with-current-continuation (lambda (c) (set! cont c) 0))))+     (if cont+         (let ((c cont))+           (set! cont #f)+           (set! x 1)+           (set! y 1)+           (c 0))+         (+ x y)))))++{-+  Credits to Al Petrofsky++  In thread:+  Widespread bug (arguably) in letrec when an initializer returns twice+  http://groups.google.com/groups?selm=87d793aacz.fsf_-_%40app.dial.idiom.com+-}+(should-be 1.2 #t+  (letrec ((x (call/cc list)) (y (call/cc list)))+    (cond ((procedure? x) (x (pair? y)))+	  ((procedure? y) (y (pair? x))))+    (let ((x (car x)) (y (car y)))+      (and (call/cc x) (call/cc y) (call/cc x)))))++{-+  Credits to Alan Bawden+  In thread:+  LETREC + CALL/CC = SET! even in a limited setting +  http://groups.google.com/groups?selm=19890302162742.4.ALAN%40PIGPEN.AI.MIT.EDU+-}+(should-be 1.3 #t+  (letrec ((x (call-with-current-continuation+		  (lambda (c)+		    (list #T c)))))+      (if (car x)+	  ((cadr x) (list #F (lambda () x)))+	  (eq? x ((cadr x))))))++{-+  Section 2: Proper call/cc and procedure application++  Credits to Al Petrofsky, (and a wink to Matthias Blume)+  In thread:+  Widespread bug in handling (call/cc (lambda (c) (0 (c 1)))) => 1 +  http://groups.google.com/groups?selm=87g00y4b6l.fsf%40radish.petrofsky.org+-}+(should-be 2.1 1+ (call/cc (lambda (c) (0 (c 1)))))++{-+  Section 3: Hygienic macros++  Eli Barzilay +  In thread:+  R5RS macros...+  http://groups.google.com/groups?selm=skitsdqjq3.fsf%40tulare.cs.cornell.edu+-}+(should-be 3.1 4+  (let-syntax ((foo+                (syntax-rules ()+                  ((_ expr) (+ expr 1)))))+    (let ((+ *))+      (foo 3))))+++{-+  Al Petrofsky again+  In thread:+  Buggy use of begin in r5rs cond and case macros. +  http://groups.google.com/groups?selm=87bse3bznr.fsf%40radish.petrofsky.org+-}+(should-be 3.2 2+ (let-syntax ((foo (syntax-rules ()+                       ((_ var) (define var 1)))))+     (let ((x 2))+       (begin (define foo +))+       (cond (else (foo x))) +       x)))++{-+  Al Petrofsky+  In thread:+  An Advanced syntax-rules Primer for the Mildly Insane+  http://groups.google.com/groups?selm=87it8db0um.fsf@radish.petrofsky.org+-}+(should-be 3.3 1+  (let ((x 1))+    (let-syntax+        ((foo (syntax-rules ()+                ((_ y) (let-syntax+                             ((bar (syntax-rules ()+                                   ((_) (let ((x 2)) y)))))+                         (bar))))))+      (foo x))))++-- Al Petrofsky+-- Contributed directly+(should-be 3.4 1+  (let-syntax ((x (syntax-rules ()))) 1))++-- Setion 4: No identifiers are reserved++--(Brian M. Moore)+-- In thread:+-- shadowing syntatic keywords, bug in MIT Scheme?+-- http://groups.google.com/groups?selm=6e6n88%248qf%241%40news.cc.ukans.edu+(should-be 4.1 (x)+ ((lambda lambda lambda) 'x))++(should-be 4.2 (1 2 3)+ ((lambda (begin) (begin 1 2 3)) (lambda lambda lambda)))++(should-be 4.3 #f+ (let ((quote -)) (eqv? '1 1)))++-- Section 5: #f/() distinctness++-- Scott Miller+(should-be 5.1 #f+  (eq? #f '()))+(should-be 5.2 #f+  (eqv? #f '()))+(should-be 5.3 #f+  (equal? #f '()))++-- Section 6: string->symbol case sensitivity++-- Jens Axel S?gaard+-- In thread:+-- Symbols in DrScheme - bug? +-- http://groups.google.com/groups?selm=3be55b4f%240%24358%24edfadb0f%40dspool01.news.tele.dk+(should-be 6.1 #f+  (eq? (string->symbol "f") (string->symbol "F")))++-- Section 7: First class continuations++-- Scott Miller+-- No newsgroup posting associated.  The gist of this test and 7.2+-- is that once captured, a continuation should be unmodified by the +-- invocation of other continuations.  This test determines that this is +-- the case by capturing a continuation and setting it aside in a temporary+-- variable while it invokes that and another continuation, trying to +-- side effect the first continuation.  This test case was developed when+-- testing SISC 1.7's lazy CallFrame unzipping code.+(define r #f)+(define a #f)+(define b #f)+(define c #f)+(define i 0)+(should-be 7.1 28+  (let () +    (set! r (+ 1 (+ 2 (+ 3 (call/cc (lambda (k) (set! a k) 4))))+               (+ 5 (+ 6 (call/cc (lambda (k) (set! b k) 7))))))+    (if (not c) +        (set! c a))+    (set! i (+ i 1))+    (case i+      ((1) (a 5))+      ((2) (b 8))+      ((3) (a 6))+      ((4) (c 4)))+    r))++-- Same test, but in reverse order+(define r #f)+(define a #f)+(define b #f)+(define c #f)+(define i 0)+(should-be 7.2 28+  (let () +    (set! r (+ 1 (+ 2 (+ 3 (call/cc (lambda (k) (set! a k) 4))))+               (+ 5 (+ 6 (call/cc (lambda (k) (set! b k) 7))))))+    (if (not c) +        (set! c a))+    (set! i (+ i 1))+    (case i+      ((1) (b 8))+      ((2) (a 5))+      ((3) (b 7))+      ((4) (c 4)))+    r))++{-+  Credits to Matthias Radestock+  Another test case used to test SISC's lazy CallFrame routines.+-}+(should-be 7.3 '((-1 4 5 3)+                 (4 -1 5 3)+                 (-1 5 4 3)+                 (5 -1 4 3)+                 (4 5 -1 3)+                 (5 4 -1 3))+  (let ((k1 #f)+        (k2 #f)+        (k3 #f)+        (state 0))+    (define (identity x) x)+    (define (fn)+      ((identity (if (= state 0)+                     (call/cc (lambda (k) (set! k1 k) +))+                     +))+       (identity (if (= state 0)+                     (call/cc (lambda (k) (set! k2 k) 1))+                     1))+       (identity (if (= state 0)+                     (call/cc (lambda (k) (set! k3 k) 2))+                     2))))+    (define (check states)+      (set! state 0)+      (let* ((res '())+             (r (fn)))+        (set! res (cons r res))+        (if (null? states)+            res+            (begin (set! state (car states))+                   (set! states (cdr states))+                   (case state+                     ((1) (k3 4))+                     ((2) (k2 2))+                     ((3) (k1 -)))))))+    (map check '((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1)))))++{-+  Modification of the yin-yang puzzle so that it terminates and produces+  a value as a result. (Scott G. Miller)+-}+(should-be 7.4 '(10 9 8 7 6 5 4 3 2 1 0)+  (let ((x '())+        (y 0))+    (call/cc +     (lambda (escape)+       (let* ((yin ((lambda (foo) +                      (set! x (cons y x))+                      (if (= y 10)+                          (escape x)+                          (begin+                            (set! y 0)+                            foo)))+                    (call/cc (lambda (bar) bar))))+              (yang ((lambda (foo) +                       (set! y (+ y 1))+                       foo)+                     (call/cc (lambda (baz) baz)))))+         (yin yang))))))++{-+  Miscellaneous ++  Al Petrofsky+  In thread:+  R5RS Implementors Pitfalls+  http://groups.google.com/groups?selm=871zemtmd4.fsf@app.dial.idiom.com+-}+(should-be 8.1 -1+  (let - ((n (- 1))) n))++(should-be 8.2 '(1 2 3 4 1 2 3 4 5)+  (let ((ls (list 1 2 3 4)))+    (append ls ls '(5))))++{-+  This example actually illustrates a bug in R5RS.  If a Scheme system+  follows the letter of the standard, 1 should be returned, but+  the general agreement is that 2 should instead be returned.+  The reason is that in R5RS, let-syntax always introduces new scope, thus +  in the following test, the let-syntax breaks the definition section+  and begins the expression section of the let. ++  The general agreement by the implementors in 1998 was that the following +  should be possible, but isn't:++    (define ---)+    (let-syntax (---)+      (define ---)+      (define ---))+    (define ---)++  Scheme systems based on the Portable syntax-case expander by Dybvig+  and Waddell do allow the above, and thus often violate the letter of+  R5RS.  In such systems, the following will produce a local scope:++    (define ---)+    (let-syntax ((a ---))+      (let ()+        (define ---)+        (define ---)))+    (define ---)++  Credits to Matthias Radestock and thanks to R. Kent Dybvig for the+  explanation and background+-}+(should-be 8.3 1+  (let ((x 1))+    (let-syntax ((foo (syntax-rules () ((_) 2))))+      (define x (foo))+      3)+    x))++{-+  Not really an error to fail this (Matthias Radestock)+  If this returns (0 1 0), your map isn't call/cc safe, but is probably+  tail-recursive.  If its (0 0 0), the opposite is true.+-}+(let ((result +       (let ()+         (define executed-k #f)+         (define cont #f)+         (define res1 #f)+         (define res2 #f)+         (set! res1 (map (lambda (x)+                           (if (= x 0)+                               (call/cc (lambda (k) (set! cont k) 0))+                               0))+                         '(1 0 2)))+         (if (not executed-k)           +             (begin (set! executed-k #t) +                    (set! res2 res1)+                    (cont 1)))+         res2)))+  (if (equal? result '(0 0 0))+      (display "Map is call/cc safe, but probably not tail recursive or inefficient.")+      (display "Map is not call/cc safe, but probably tail recursive and efficient."))+  (newline))